home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Du Jour
/
SoftwareDuJour.iso
/
BUSINESS
/
DBASE
/
DBAPG.ARC
/
VARIOUS.ALG
< prev
next >
Wrap
Text File
|
1985-01-10
|
27KB
|
857 lines
* Program..: VARIOUS.ALG
* Notice...: Copyright 1983 & 1984, Ashton-Tate, All Rights Reserved
* Notes....: These are six of the longer algorithms in the book.
*
* THIS FILE WILL NOT EXECUTE PROPERLY AS IT STANDS
* BECAUSE EACH ALGORITHM IS A SEPARATE ENTITY WRITTEN
* TO RUN UNDER A PARTICULAR VERSION OF dBASE.
*
* THESE ALGORITHMS MAY NEED REVISION TO RUN PROPERLY
* BECAUSE SOME USE METAVARIABLES THAT MUST BE REPLACED
* WITH VALUES APPROPRIATE TO YOUR APPLICATION.
*
* The algorithms included are:
*
* 1. Binary Locate, chapter 19, page 335
* 2. Check for Duplicates, chapter 19, page 337
* 3. Color Demo, chapter 18, page 273
* 4. Datetest, chapter 22, page 395
* 5. Multiple Screens, chapter 19, page 348
* 6. Prompt Pad, chapter 18, page 288
* 7. Page Counter, chapter 21, page 384
* 8. Periodic Files, chapter 19, page 302
* 9. Pseudo Arrays, chapter 17, page 239
* 10. Quick Date Trap, chapter 16, page 215
**********************************************************************
* Binary Locate:
*
* LOCATING.PRG [II]
*
* A binary search to replace the LOCATE command
* when the key is in sequential order...
*
* is:found ::= .T. if a match occurs, current record is match.
* is:found ::= .F. if no match, current record varies.
*
* Establish working environment...
ERASE
SET TALK OFF
STORE F TO is:found
*
* Prompt operator for details of the search...
ACCEPT "Enter file name -->" TO file:name
ACCEPT "Enter field name -->" TO field:name
INPUT "Enter data to find -->" TO search:key
* Note that the INPUT command requires character type data to be delimited.
*
* Open the file...
USE &file:name
*
* Branch for first or last records...
IF &field:name = search:key
*
* Found: it's the first record.
STORE T TO is:found
ELSE
* Maybe it's the last record...
GO BOTTOM
IF &field:name = search:key
*
* Found: it's the last record.
STORE T TO is:found
ELSE
* Not there either, so let's search.
* Set the top, middle, and bottom markers...
STORE # TO high
STORE 0 TO mid
STORE 1 TO low
*
* Establish a loop for repitition...
DO WHILE .NOT. is:found
*
* Branch to end search if record does not exist...
IF mid = low + INT((high-low)/2)
SET TALK ON
RELEASE file:name, search:key, field:name, low, mid, high
RETURN
ELSE
*
* Set new middle marker; see where to go next...
STORE low + INT((high-low)/2) TO mid
GO mid
DO CASE
CASE &field:name > search:key
*
* Field value is high, so set next block
* to lower half of existing block...
STORE mid TO high
CASE &field:name < search:key
*
* Field value is low, so set next block
* to upper half of existing block...
STORE mid TO low
OTHERWISE
*
* Found it...
STORE T TO is:found
ENDCASE
ENDIF [record does not exist]
ENDDO [WHILE .NOT. found]
ENDIF [last record]
ENDIF [first record]
RELEASE file:name, search:key, field:name, low, mid, high
RETURN
* EOF: Locating.prg
**********************************************************************
* Check for Duplicates:
*
* dBASE III...
*
memvar = SPACE(6)
DO WHILE .T.
* Prompt for an entry from the operator...
@ <coordinates> GET memvar PICTURE [AA9999]
READ
CLEAR GETS
@ <coordinates> SAY "Please be patient while I check for duplicates."
*
* Save the current record number in order to return after searching...
record_no = RECNO()
*
* Search for the entry, and test for a find...
SEEK memvar
IF .NOT. EOF()
? "This already exists, please re-enter..."
ELSE
*
* Restore record pointer to previous position, and exit the loop...
GO record_no
EXIT
ENDIF
*
* Restore record pointer to previous position...
GO record_no
ENDDO
* dBASE II...
*
STORE " " TO memvar
STORE T TO condition
DO WHILE condition
* Prompt for an entry from the operator...
@ <coordinates> GET memvar PICTURE [AA9999]
READ
CLEAR GETS
@ <coordinates> SAY "Please be patient while I check for duplicates."
*
* Save the current record number in order to return after searching...
STORE # TO record:no
*
* Search for the entry, and test for a find...
FIND &memvar
IF # > 0
? "This already exists, please re-enter..."
ELSE
* Change the <condition> to exit the loop...
STORE F TO condition
ENDIF
*
* Restore record pointer to previous position...
GO record:no
ENDDO
**********************************************************************
* Color Demo:
*
* COLORS.PRG [II]
*
SET TALK OFF
ERASE
*
STORE ' VIDEO FOR "SAYS" =' TO text1
STORE ' VIDEO FOR "GETS" =' TO text2
STORE 0 TO line
STORE 1 TO n1
*
DO WHILE n1 < 255
STORE text1 + STR(n1,3) + ' ' TO text1
STORE 1 TO n2
DO WHILE n2 < 255
STORE $(text2,1,19) + STR(n2,3) + ' ' TO text2
SET COLOR TO n2,n1
IF line > 22
ERASE
STORE 0 TO line
ENDIF
@ line,12 SAY text1
@ line,38 GET text2
STORE line + 1 TO line
STORE n2 + 1 TO n2
ENDDO
STORE n1 + 1 TO n1
ENDDO
SET TALK ON
RETURN
* EOF: Colors.prg
**********************************************************************
* Datetest:
; DATETEST.A86
; Date test subroutine for use in dBASE-II/86 2.4
;
; Assemble with ASM86 under CP/M-86.
; The DATETEST.H86 file can be LOADed from dBASE II.
; POKE the decimal date values to be checked before calling:
; POKE month at 57501
; POKE day at 57502, and
; POKE year at 57503
; SET CALL TO 57504
; Then CALL to execute this routine
;
;
ORG 57501
MONTH DB 0 ; MONTH PARAMETER.
DAY DB 0 ; DAY
YEAR DB 0 ; YEAR
ORG 57504 ; 4 BYTES ABOVE 'TOP' OF
; dBASE II 2.4 (57500d) THIS
; KEEPS CODE ABOVE MM/DD/YY BUFFERS
START:
;
; CHECK FOR 0 <= YEAR <= 99.
;
MOV AL,BYTE PTR YEAR ; YEAR TO AL REGISTER
OR AL,AL ; IS IT < 1 ?
JZ ERROR ; YES, ERROR
CMP AL,100 ; IS IT >= 99 ?
JGE ERROR ; YES, ERROR
;
; CHECK FOR 1 <= MONTH <= 12.
;
MOV AH,0
MOV AL,BYTE PTR MONTH ; MONTH TO AL REGISTER
OR AL,AL ; IS IT < 1 ?
JZ ERROR ; YES, ERROR
CMP AL,12 ; IS IT >= 12 ?
JGE ERROR ; YES, ERROR
;
; TEST DAYS IN MONTH.
;
MOV BX,OFFSET DTABLE-1 ; POINT BX TO DAY-IN-MONTH
; TABLE
ADD BX,AX ; POINT TO NUMBER OF DAYS FOR
; MONTH
MOV AH,BYTE PTR [BX] ; ... FETCH VALUE
MOV AL,BYTE PTR DAY ; PICK UP DAY
OR AL,AL ; 0 < DAY <= [DTABLE-1+MONTH]
JE ERROR
CMP AH,28 ; FEBRUARY?
JNE NOTLEAP ; JUMP IF NOT FEBRUARY.
PUSH AX
MOV AL,BYTE PTR YEAR ;
AND AL,3 ; CHECK IF YEAR IS DIVISIBLE
; BY 4
POP AX
JNE NOTLEAP ; JUMP IF NOT LEAP YEAR.
INC AH ; LEAP YEAR; SET DAYS/MONTH
; TO 29
NOTLEAP:
CMP AL,AH ; EXCEEDS DAYS/MONTH?
JG ERROR ; IF SO, ERROR
RET ; OTHERWISE, IT IS A GOOD DATE
;
; SET MONTH, DAY, AND YEAR TO NULLS IF ERROR IN DATE.
;
ERROR: MOV BYTE PTR MONTH,0 ; ZERO OUT MONTH
MOV WORD PTR DAY,0 ; ZERO OUT DAY AND YEAR
RET ; RETURN TO dBASE II
;;; Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
DTABLE DB 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31
END
* DATETEST.PRG
* Demonstrates the use of DATETEST.H86
* If the date is not valid the memory locations 57501,
* 57502, and 57503 will contain zeros.
*
SET TALK OFF
STORE 0 TO mmonth,mday,myear
*
LOAD DATETEST.H86
SET CALL TO 57504
*
ERASE
@ 10,10 SAY 'ENTER MONTH' GET mmonth PICTURE '99'
@ 12,10 SAY 'ENTER DAY' GET mday PICTURE '99'
@ 14,10 SAY 'ENTER YEAR' GET myear PICTURE '99'
READ
*
POKE 57501, mmonth, mday, myear
*
* ---Display the values before and after the CALL.
? PEEK( 57501 ), PEEK( 57502 ), PEEK( 57503 )
CALL
? PEEK( 57501 ), PEEK( 57502 ), PEEK( 57503 )
*
IF PEEK( 57501 ) = 0
? "INVALID DATE"
ENDIF
*
CLEAR
SET TALK ON
RETURN
* EOF: DATETEST.PRG
**********************************************************************
* Multiple Screens:
*
* Multiple screen routine [II, 2.4x]
*
DO WHILE T
*
* Prompt the operator for a key expression to find...
<Do a subroutine for this entry>
*
* Find the first occurrence of a particular key...
FIND &m:key
*
* Branch for no find...
IF # = 0
STORE ' ' TO t:waiting
@ 22,23 SAY "There are no records for this key."
@ 23,24 SAY "Press any key to continue..." GET t:waiting
READ NOUPDATE
CLEAR GETS
RETURN
ELSE
STORE T TO t:is:found
ENDIF
*
* Display headings for the output...
@ 6, 8 SAY "Key:"
@ 6,30 SAY "Address:"
@ 6,60 SAY "Phone Number:"
*
* Initialize memvars to control screens...
* String of possible menu items (12 per screen)...
STORE 'ABCDEFGHIJKL' TO t:menu:str
* Line counter initialized for first item...
STORE 8 TO t:line
* Used as parameter in substring function to get
* menu item from string of possibilities...
STORE 1 TO t:menu:num
* Possible choices in operator entry trapping routine...
STORE ' ?' + $(t:menu:str,t:menu:num,1) TO t:selectns
* Screen number used as macro in memvar array of record numbers...
STORE '11' TO t:scrn:no
* Number of the first record on this screen is used to
* reposition record pointer when changing screens...
STORE # TO t:record&t:scrn:no
*
* A loop for each record on the screen...
DO WHILE t:is:found
* Save the menu letter for this record...
STORE $(t:menu:str,t:menu:num,1) TO t:menu:ltr
* Save current record number in a memvar using the
* current menu letter in the memvar name. This is used
* to postion the record pointer to a record selected by
* menu letter.
STORE # TO t:menu:&t:menu:ltr
*
* Display the menu letter and pointer...
@ t:line, 2 SAY t:menu:ltr
@ t:line, 4 SAY "-->"
*
* Display data from the current record...
@ t:line, 8 SAY Key
@ t:line,30 SAY Address
@ t:line,60 SAY Telephone
*
* Next record, and increment display line...
SKIP
STORE t:line + 1 TO t:line
*
* Branch for another menu item...
IF .NOT. ( t:menu:num = 12 .OR. EOF .OR. (.NOT. m:key = Key) )
STORE t:menu:num + 1 TO t:menu:num
STORE t:selectns + $(t:menu:str,t:menu:num,1) TO t:selectns
LOOP
*
ELSE
* Branch for another screen, eof, or end of this key data...
DO CASE
*
CASE t:scrn:no = '11' .AND. ( (m:key # Key) .OR. EOF )
* No more records, only one screen...
@ 21, 0 SAY "There are NO more records for this key."
@ 22, 0 SAY "Select a record by letter,"
*
CASE m:key = Key .AND. t:scrn:no = '11' .AND. (.NOT. EOF)
* More records, still on first screen...
@ 21, 0 SAY "MORE records for this key on the NEXT screen."
@ 22, 0 SAY "Select a record by letter, N = NEXT screen,"
STORE t:selectns + 'N' TO t:selectns
*
CASE VAL(t:scrn:no) > 11 .AND. ( (m:key # Key) .OR. EOF )
* No more records, more than one screen...
@ 21, 0 SAY "MORE records for this key on the PREVIOUS screen."
@ 22, 0 SAY "Select a record by letter, P = PREVIOUS screen,"
STORE t:selectns + 'P' TO t:selectns
*
CASE m:key = Key .AND. VAL(t:scrn:no) > 11 .AND. (.NOT. EOF)
* More records, more than one screen...
@ 21, 0 SAY "MORE records for this key " +;
"on both the PREVIOUS and NEXT screens."
@ 22, 0 SAY "Select a record by letter, "+;
"N = NEXT screen, P = PREVIOUS screen,"
STORE t:selectns + 'NP' TO t:selectns
ENDCASE
*
* Display the last line in the prompt...
@ 23, 0 SAY "SPACE = another customer, RETURN = Main Menu..."
*
* Get the operator's selection...
STORE '\' TO t:select
DO WHILE .NOT. t:select $ t:selectns
STORE '?' TO t:select
@ 23,47 GET t:select PICTURE '!'
READ NOUPDATE
CLEAR GETS
ENDDO
*
* Branch for selection...
DO CASE
CASE t:select = '?'
* Restore environment and exit...
RELEASE ALL LIKE t:*
USE
RETURN
CASE t:select = ' '
* Loop around to enter another customer...
STORE F TO t:is:found
LOOP
CASE t:select $ 'ABCDEFGHIJKL'
* View or edit a displayed record...
*
* Position record pointer to selected record...
GO t:menu:&t:select
*
* Clear some room in memory, and do editing routine...
RELEASE ALL LIKE t:menu:*
<Do a subroutine to edit the record>
*
* Exit the inner loop to enter another key expression...
* (This is a good example of where the EXIT command
* in dBASE III really speeds things up!)
STORE F TO t:is:found
LOOP
CASE t:select = 'N'
* Next screen...
* Reset screen line counter...
STORE 8 TO t:line
* Increment screen number...
STORE STR( VAL(t:scrn:no)+1 ,2) TO t:scrn:no
* Save first record of this screen...
STORE # TO t:record&t:scrn:no
CASE t:select = 'P'
* Previous screen...
* Reset screen line counter...
STORE 8 TO t:line
* Decrement screen number...
STORE STR( VAL(t:scrn:no)-1 ,2) TO t:scrn:no
* Position to first record of previous screen...
GO t:record&t:scrn:no
ENDCASE
*
* Reset memvars for the next screen's menu...
STORE ' ?A' TO t:selectns
STORE 1 TO t:menu:num
*
* Clear the current screen leaving the header...
@ 8,0
@ 9,0
@ 10,0
@ 11,0
@ 12,0
@ 13,0
@ 14,0
@ 15,0
@ 16,0
@ 17,0
@ 18,0
@ 19,0
@ 21,0
@ 22,0
@ 23,0
*
ENDIF
ENDDO [WHILE t:is:found]
*
* Clear the header...
@ 6,0
ENDDO [WHILE T]
*
* End of multiple screen routine
**********************************************************************
* Prompt Pad:
*
* Prompt-Pad Algorithm [III]
*
* Initialize prompts in memvar array...
STORE '<prompt-1>' TO prompt_001
STORE '<prompt-2>' TO prompt_002
STORE '<prompt-3>' TO prompt_003
STORE '<prompt-4>' TO prompt_004
STORE '<prompt-5>' TO prompt_005
STORE '<prompt-6>' TO prompt_006
STORE '<prompt-7>' TO prompt_007
STORE '<prompt-8>' TO prompt_008
*
* Can have as many prompts as there are available memvars.
* (60 in II, 252 in III because this algorithm uses 4 memvars)
*
* Initialize controlling memvars with first and last numbers...
STORE '001' TO first, counter
STORE '008' TO last
*
* Display instructions to operator...
@ 23,17 SAY "Press SPACE or B to change, RETURN to enter..."
*
* Set up loop to redisplay <prompts> until one is chosen...
SET BELL OFF
STORE " " TO switch
DO WHILE switch # "?"
*
* Blank the previous display if there is one...
@ 20,23
*
<set screen to attribute or color that highlights the prompt>
*
@ 20,23 SAY prompt_&counter
STORE "?" TO switch
*
<set screen to invisible in order to conceal the GET>
*
@ 23,77 GET switch PICTURE "!"
READ
CLEAR GETS
*
* Branch to increment counter and switch selection...
DO CASE
CASE switch = " " .AND. counter < last
STORE SUBSTR( STR( &counter+1001,4 ) ,2,3) TO counter
CASE switch = " " .AND. counter = last
STORE first TO counter
CASE switch = "B" .AND. counter > first
STORE SUBSTR( STR( &counter+ 999,4 ) ,2,3) TO counter
CASE switch = "B" .AND. counter = first
STORE last TO counter
ENDCASE
ENDDO
*
* Restore the environment before moving on...
<set screen back to normal>
SET BELL ON
@ 20, 0 SAY [ ]
@ 23,17
*
* Branch to execute selection...
DO CASE
CASE counter = '001'
<commands>
CASE counter = '002'
<commands>
CASE counter = '003'
<commands>
CASE counter = '004'
<commands>
CASE counter = '005'
<commands>
CASE counter = '006'
<commands>
CASE counter = '007'
<commands>
CASE counter = '008'
<commands>
ENDCASE
*
* EOA: Prompt-Pad
**********************************************************************
* Page Counter:
*
* Page counter algorithm, one file.
*
* Initialize counters to starting values.
* Start t:line high enough to take the branch for a
* new heading just inside the DO loop...
STORE 61 TO t:line
STORE 5 TO t:col
STORE 0 TO t:pagectr
*
* Look at each record in the file sequentially...
GO TOP
DO WHILE .NOT. EOF
*
* Branch for new page...
IF t:line > 60
STORE 1 TO t:line
STORE t:pagectr + 1 TO t:pagectr
*
* This next line causes a form-feed to be sent to the printer
* because it is now a lower value than the last one sent...
@ t:line ,t:col+66 SAY 'Page' + STR(t:pagectr,3)
@ t:line+1,t:col+66 SAY DATE()
@ t:line+4,t:col+25 SAY <heading>
ENDIF
*
@ t:line, t:col SAY <data from this record>
*
* Next record, and increment the line counter...
SKIP
STORE t:line + 1 TO t:line
ENDDO
*
* EOA
**********************************************************************
* Periodic Files:
*
* dBASE II...
*
* Prompt for the file to use...
STORE T TO select
DO WHILE select
STORE " " TO t:month,t:year
@ 5, 9 SAY "Enter the month and year of the data you want to enter."
@ 7,17 SAY "Month " GET t:month PICTURE [##]
@ 7,31 SAY "<Ctrl-C> to return to main menu."
@ 8,17 SAY "Year " GET t:year PICTURE [##]
READ
CLEAR GETS
@ 10,0
*
DO CASE
*
CASE t:month = " " .AND. t:year = " "
* Branch to exit to main menu if there is no entry...
RELEASE ALL LIKE t:*
RETURN
*
CASE VAL(t:month) < 1 .OR. VAL(t:month) > 12 .OR.;
VAL(t:year) < 83 .OR. VAL(t:year) > 98
* Branch to trap invalid entries...
@ 10,22 SAY "Invalid entry -- please re-enter..."
LOOP
*
CASE VAL(t:month) < 10
* Branch to format leading zero in month...
STORE "0" + STR(VAL(t:month),1) TO t:month
ENDCASE
*
* Set up filename in the format PL_<mm>-<yy>
* where <mm> ::= month, and <yy> ::= year...
STORE "PL_" + t:month + "-" + t:year TO t:use:file
*
* Verify existence of file, exit loop if file exists...
IF FILE("&t:use:file")
STORE F TO select
ELSE
* Prompt to create new file or re-enter the date...
@ 10,20 SAY "I cannot find the file " + t:use:file + ".DBF."
@ 12, 7 SAY "Press <C> to Create this file, " +;
"or any other key to re-enter..."
STORE "?" TO t:waiting
@ 12,69 GET t:waiting
READ
CLEAR GETS
@ 10, 0
@ 12, 0
*
* Branch to create a new placement file...
IF !(t:waiting) = "C"
@ 7,31
@ 10,15 SAY "Just a moment please, while I prepare the files..."
USE PL_place
COPY STRUCTURE TO &t:use:file
STORE F TO select
ENDIF
ENDIF
*
ENDDO [WHILE select]
*
* Clear the used part of the screen...
@ 5,0
@ 7,0
@ 8,0
@ 10,0
@ 12,0
*
* Open the file...
USE &t:use:file
*
* EOA
**********************************************************************
* Pseudo Arrays:
*
* AR_DEMO.PRG [III]
*
* Initialize a memvar to use as a counter...
* A character type is used because it will be concatenated
* to a memvar name to give us programming access to the array.
STORE '000' TO counter
*
* Set up a loop for the size of the array, twelve in this
* example. (Remember the limit of active memory variables)
DO WHILE counter < '012'
*
* Increment counter by 1...
STORE SUBSTR( STR( &counter+1001,4 ) ,2,3) TO counter
* [In II, substitute $ for SUBSTR]
*
* Assign values to the array elements...
STORE VAL(counter) TO number&counter
STORE 'EXAMPLE ' + counter TO alpha&counter
ENDDO
* EOF: AR_DEMO.PRG
* ARRAY.CMD [II]
*
* Initialize the array(s) with values...
STORE "101275031020680710321417104210001051971510622000"+;
"107117081081275610915281110122631111528411211763"+;
"113095171140025011500575116015821170182611802929"+;
"1190427612005326" TO prodtable1
STORE "121305721227086012371412124000211255179112600022"+;
"127807111286572112918251130362211314825113236711"+;
"133715901340520013557500136285101376281013892920"+;
"1396724014062350" TO prodtable2
*
* Initialize a variable for entry...
STORE " " TO prod:nmbr
*
* Set up a loop for repetition...
DO WHILE T
*
* Prompt for the product number...
@ 5,20 SAY "Enter the product number (Return to Quit)";
GET prod:nmbr PICTURE "999"
READ
CLEAR GETS
*
* Depending on the contents of prod:nmbr, either
* RETURN out of this program, LOOP back to DO WHILE T,
* or select the proper table and execute the rest of
* this program...
DO CASE
CASE prod:nmbr = " "
SET TALK ON
RETURN
CASE prod:nmbr < "101" .OR. prod:nmbr > "140"
@ 10,25 SAY "Incorrect product number "
LOOP
CASE prod:nmbr > "100" .AND. prod:nmbr < "121"
STORE "prodtable1" TO array
CASE prod:nmbr > "120" .AND. prod:nmbr < "141"
STORE "prodtable2" TO array
ENDCASE
*
* Search for the prod:nmbr...
* Notice the use of the macro function to specify the array.
STORE 1 TO pointer
* (The macro cannot be used in a DO loop in dBASE III.)
DO WHILE prod:nmbr # $(&array,pointer,3) .AND. pointer < 160
STORE pointer + 8 TO pointer
ENDDO
*
* Display the results...
STORE VAL($(&array,pointer+3,5)) / 100.00 TO prod:price
@ 10,25 SAY " The price is: $" + STR(prod:price,6,2)
*
* Housekeeping...
STORE " " TO prod:nmbr
ENDDO
* EOF: Array.cmd
**********************************************************************
* Quick Date Trap: [II]
*
* Start of date entry routine...
*
@ <entry coordinates> GET m:date PICTURE [##/##/##]
READ NOUPDATE
CLEAR GETS
STORE VAL($(m:date,1,2)) TO t:month
STORE VAL($(m:date,4,2)) TO t:day
STORE VAL($(m:date,7,2)) TO t:year
DO WHILE (m:date # [ / / ]) .AND. (t:month<1 .OR. t:month>12 .OR.;
t:day<1 .OR. t:day>VAL($("312931303130313130313031",(t:month-13* INT(t:month/;
13))*2-1,2)) .OR. (t:month=2 .AND. t:day>28 .AND. t:year/4.0>INT(t:year/4.0)))
@ <message coordinates> SAY "Not a valid date, please re-enter..."
@ <entry coordinates> GET m:date PICTURE [##/##/##]
READ NOUPDATE
CLEAR GETS
STORE VAL($(m:date,1,2)) TO t:month
STORE VAL($(m:date,4,2)) TO t:day
STORE VAL($(m:date,7,2)) TO t:year
@ <message coordinates>
ENDDO
*
* Format the string if it contains a date with blank spaces...
IF " " $ m:date .AND. (.NOT. m:date = [ / / ])
*
* Right justify the characters in each subvariable...
STORE STR(t:month,2) +"/"+ STR(t:day,2) +"/"+ STR(t:year,2) TO m:date
*
* Use the date function to add leading zeros...
* Save the system date...
STORE DATE() TO t:date
* Set system date to entered date...
SET DATE TO &m:date
* Replace entered date with formatted system date...
STORE DATE() TO m:date
* Restore original system date...
SET DATE TO &t:date
*
* Redisplay the formatted date...
@ <entry coordinates> GET m:date PICTURE [##/##/##]
CLEAR GETS
ENDIF
*
* End of date entry routine.
**********************************************************************
* EOF: Various.alg
up a loop for the size of the array, twelve in this
* example. (Remember the limit of active memory variables)
DO WHILE counter < '012'
*
* Increment counter by 1...
STORE SUBSTR( STR( &counter+1001,4 ) ,2,3) TO counter
* [In II, substitute $ for SUBSTR]
*
* Assign values to the array elements...
STORE VAL(counter) TO number&counter
STORE 'EXAMPLE ' + coun