home *** CD-ROM | disk | FTP | other *** search
/ Software Du Jour / SoftwareDuJour.iso / BUSINESS / DBASE / DBAPG.ARC / VARIOUS.ALG < prev    next >
Text File  |  1985-01-10  |  27KB  |  857 lines

  1. * Program..: VARIOUS.ALG
  2. * Notice...: Copyright 1983 & 1984, Ashton-Tate, All Rights Reserved
  3. * Notes....: These are six of the longer algorithms in the book.
  4. *
  5. *            THIS FILE WILL NOT EXECUTE PROPERLY AS IT STANDS
  6. *            BECAUSE EACH ALGORITHM IS A SEPARATE ENTITY WRITTEN
  7. *            TO RUN UNDER A PARTICULAR VERSION OF dBASE.
  8. *
  9. *            THESE ALGORITHMS MAY NEED REVISION TO RUN PROPERLY
  10. *            BECAUSE SOME USE METAVARIABLES THAT MUST BE REPLACED
  11. *            WITH VALUES APPROPRIATE TO YOUR APPLICATION.
  12. *
  13. * The algorithms included are:
  14. *
  15. *     1.  Binary Locate, chapter 19, page 335
  16. *     2.  Check for Duplicates, chapter 19, page 337
  17. *     3.  Color Demo, chapter 18, page 273
  18. *     4.  Datetest, chapter 22, page 395 
  19. *     5.  Multiple Screens, chapter 19, page 348
  20. *     6.  Prompt Pad, chapter 18, page 288
  21. *     7.  Page Counter, chapter 21, page 384
  22. *     8.  Periodic Files, chapter 19, page 302
  23. *     9.  Pseudo Arrays, chapter 17, page 239
  24. *    10.  Quick Date Trap, chapter 16, page 215
  25.  
  26. **********************************************************************
  27.  
  28. * Binary Locate:
  29. *
  30. * LOCATING.PRG [II]
  31. *
  32. * A binary search to replace the LOCATE command
  33. * when the key is in sequential order...
  34. *
  35. * is:found  ::=  .T. if a match occurs, current record is match.
  36. * is:found  ::=  .F. if no match, current record varies.
  37. *
  38. * Establish working environment...
  39. ERASE
  40. SET TALK OFF
  41. STORE F TO is:found
  42. *
  43. * Prompt operator for details of the search...
  44. ACCEPT "Enter file name    -->" TO file:name
  45. ACCEPT "Enter field name   -->" TO field:name
  46. INPUT  "Enter data to find -->" TO search:key
  47. * Note that the INPUT command requires character type data to be delimited.
  48. *
  49. * Open the file...
  50. USE &file:name
  51. *
  52. * Branch for first or last records...
  53. IF &field:name = search:key
  54.    *
  55.    * Found: it's the first record.
  56.    STORE T TO is:found
  57. ELSE
  58.    * Maybe it's the last record...
  59.    GO BOTTOM
  60.    IF &field:name = search:key
  61.       *
  62.       * Found: it's the last record.
  63.       STORE T TO is:found
  64.    ELSE
  65.       * Not there either, so let's search.
  66.       * Set the top, middle, and bottom markers...
  67.       STORE # TO high
  68.       STORE 0 TO mid
  69.       STORE 1 TO low
  70.       *
  71.       * Establish a loop for repitition...
  72.       DO WHILE .NOT. is:found
  73.          *
  74.          * Branch to end search if record does not exist...
  75.          IF mid = low + INT((high-low)/2)
  76.             SET TALK ON
  77.             RELEASE file:name, search:key, field:name, low, mid, high
  78.             RETURN
  79.          ELSE
  80.             * 
  81.             * Set new middle marker; see where to go next...
  82.             STORE low + INT((high-low)/2) TO mid
  83.             GO mid
  84.             DO CASE
  85.                CASE &field:name > search:key
  86.                   *
  87.                   * Field value is high, so set next block
  88.                   * to lower half of existing block...
  89.                   STORE mid TO high
  90.                CASE &field:name < search:key
  91.                   *
  92.                   * Field value is low, so set next block
  93.                   * to upper half of existing block...
  94.                   STORE mid TO low
  95.                OTHERWISE
  96.                   *
  97.                   * Found it...
  98.                   STORE T TO is:found
  99.             ENDCASE 
  100.          ENDIF [record does not exist]
  101.       ENDDO [WHILE .NOT. found]
  102.    ENDIF [last record]
  103. ENDIF [first record]
  104. RELEASE file:name, search:key, field:name, low, mid, high
  105. RETURN
  106. * EOF: Locating.prg
  107.  
  108. **********************************************************************
  109.  
  110. * Check for Duplicates:
  111. *
  112. * dBASE III...
  113. *
  114. memvar = SPACE(6)
  115. DO WHILE .T.
  116.    * Prompt for an entry from the operator...
  117.    @ <coordinates> GET memvar PICTURE [AA9999]
  118.    READ
  119.    CLEAR GETS
  120.    @ <coordinates> SAY "Please be patient while I check for duplicates."
  121.    *
  122.    * Save the current record number in order to return after searching...
  123.    record_no = RECNO()
  124.    *
  125.    * Search for the entry, and test for a find...
  126.    SEEK memvar
  127.    IF .NOT. EOF()
  128.       ? "This already exists, please re-enter..."
  129.    ELSE
  130.       *
  131.       * Restore record pointer to previous position, and exit the loop...
  132.       GO record_no
  133.       EXIT
  134.    ENDIF
  135.    *
  136.    * Restore record pointer to previous position...
  137.    GO record_no
  138. ENDDO
  139.  
  140.  
  141. * dBASE II...
  142. *
  143. STORE "      " TO memvar
  144. STORE T TO condition
  145. DO WHILE condition
  146.    * Prompt for an entry from the operator...
  147.    @ <coordinates> GET memvar PICTURE [AA9999]
  148.    READ
  149.    CLEAR GETS
  150.    @ <coordinates> SAY "Please be patient while I check for duplicates."
  151.    *
  152.    * Save the current record number in order to return after searching...
  153.    STORE # TO record:no
  154.    *
  155.    * Search for the entry, and test for a find...
  156.    FIND &memvar
  157.    IF # > 0 
  158.       ? "This already exists, please re-enter..."
  159.    ELSE
  160.       * Change the <condition> to exit the loop...
  161.       STORE F TO condition
  162.    ENDIF
  163.    *
  164.    * Restore record pointer to previous position...
  165.    GO record:no
  166. ENDDO
  167.  
  168. **********************************************************************
  169.  
  170. * Color Demo:
  171. *
  172. * COLORS.PRG [II]
  173. *
  174. SET TALK OFF
  175. ERASE
  176. *
  177. STORE ' VIDEO FOR "SAYS" =' TO text1
  178. STORE ' VIDEO FOR "GETS" =' TO text2
  179. STORE 0 TO line
  180. STORE 1 TO n1
  181. *
  182. DO WHILE n1 < 255
  183.    STORE text1 + STR(n1,3) + ' ' TO text1
  184.    STORE 1 TO n2
  185.    DO WHILE n2 < 255
  186.       STORE $(text2,1,19) + STR(n2,3) + ' ' TO text2
  187.       SET COLOR TO n2,n1
  188.       IF line > 22
  189.          ERASE
  190.          STORE 0 TO line
  191.       ENDIF
  192.       @ line,12 SAY text1
  193.       @ line,38 GET text2
  194.       STORE line + 1 TO line
  195.       STORE n2 + 1 TO n2
  196.    ENDDO
  197.    STORE n1 + 1 TO n1
  198. ENDDO
  199. SET TALK ON
  200. RETURN
  201. * EOF: Colors.prg
  202.  
  203. **********************************************************************
  204.  
  205. * Datetest:
  206.  
  207. ; DATETEST.A86
  208. ; Date test subroutine for use in dBASE-II/86  2.4
  209. ;
  210. ;   Assemble with ASM86 under CP/M-86.
  211. ;   The DATETEST.H86 file can be LOADed from dBASE II.
  212. ;   POKE the decimal date values to be checked before calling: 
  213. ;       POKE month at 57501
  214. ;       POKE day at 57502, and 
  215. ;       POKE year at 57503
  216. ;   SET CALL TO 57504 
  217. ;   Then CALL to execute this routine
  218. ;
  219. ;
  220.         ORG     57501
  221. MONTH   DB      0         ; MONTH PARAMETER.
  222. DAY     DB      0         ; DAY
  223. YEAR    DB      0         ; YEAR
  224.         ORG     57504     ; 4 BYTES ABOVE 'TOP' OF
  225.                           ; dBASE II 2.4 (57500d) THIS 
  226.                           ; KEEPS CODE ABOVE MM/DD/YY BUFFERS
  227. START:  
  228. ;
  229. ; CHECK FOR 0 <= YEAR <= 99.
  230. ;
  231.         MOV     AL,BYTE PTR YEAR        ; YEAR TO AL REGISTER
  232.         OR      AL,AL                   ; IS IT < 1 ?   
  233.         JZ      ERROR                   ; YES, ERROR
  234.         
  235.         CMP     AL,100                  ; IS IT >= 99 ?
  236.         JGE     ERROR                   ; YES, ERROR  
  237. ;
  238. ; CHECK FOR 1 <= MONTH <= 12.
  239. ;
  240.         MOV     AH,0
  241.         MOV     AL,BYTE PTR MONTH       ; MONTH TO AL REGISTER
  242.         OR      AL,AL                   ; IS IT < 1 ?   
  243.         JZ      ERROR                   ; YES, ERROR
  244.         
  245.         CMP     AL,12                   ; IS IT >= 12 ?
  246.         JGE     ERROR                   ; YES, ERROR
  247. ;
  248. ; TEST DAYS IN MONTH.
  249. ;
  250.         MOV     BX,OFFSET DTABLE-1 ; POINT BX TO DAY-IN-MONTH 
  251.                                    ; TABLE      
  252.         ADD     BX,AX              ; POINT TO NUMBER OF DAYS FOR
  253.                                    ; MONTH
  254.         MOV     AH,BYTE PTR [BX]   ;   ... FETCH VALUE
  255.         MOV     AL,BYTE PTR DAY    ; PICK UP DAY
  256.         OR      AL,AL              ; 0 < DAY <= [DTABLE-1+MONTH]
  257.         JE      ERROR
  258.         CMP     AH,28              ; FEBRUARY?
  259.         JNE     NOTLEAP            ; JUMP IF NOT FEBRUARY.
  260.         PUSH    AX
  261.         MOV     AL,BYTE PTR YEAR   ; 
  262.         AND     AL,3               ; CHECK IF YEAR IS DIVISIBLE
  263.                                    ; BY 4
  264.         POP     AX
  265.         JNE     NOTLEAP            ; JUMP IF NOT LEAP YEAR.
  266.         INC     AH                 ; LEAP YEAR; SET DAYS/MONTH
  267.                                    ; TO 29
  268. NOTLEAP:
  269.         CMP     AL,AH              ; EXCEEDS DAYS/MONTH?
  270.         JG      ERROR              ; IF SO, ERROR
  271.         RET                        ; OTHERWISE, IT IS A GOOD DATE
  272.  
  273. ;
  274. ; SET MONTH, DAY, AND YEAR TO NULLS IF ERROR IN DATE.
  275. ERROR:  MOV     BYTE PTR MONTH,0   ; ZERO OUT MONTH 
  276.         MOV     WORD PTR DAY,0     ; ZERO OUT DAY AND YEAR
  277.         RET                        ; RETURN TO dBASE II
  278.  
  279. ;;;             Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
  280. DTABLE  DB      31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31
  281.         END
  282.  
  283.  
  284. * DATETEST.PRG
  285. * Demonstrates the use of DATETEST.H86
  286. * If the date is not valid the memory locations 57501, 
  287. * 57502, and 57503 will contain zeros.
  288. *
  289. SET TALK OFF
  290. STORE 0 TO mmonth,mday,myear
  291. *
  292. LOAD DATETEST.H86
  293. SET CALL TO 57504
  294. *
  295. ERASE
  296. @ 10,10 SAY 'ENTER MONTH' GET mmonth PICTURE '99'
  297. @ 12,10 SAY 'ENTER DAY'   GET mday   PICTURE '99'
  298. @ 14,10 SAY 'ENTER YEAR'  GET myear  PICTURE '99'
  299. READ
  300. *
  301. POKE 57501, mmonth, mday, myear
  302. *
  303. * ---Display the values before and after the CALL.
  304. ? PEEK( 57501 ), PEEK( 57502 ), PEEK( 57503 )
  305. CALL
  306. ? PEEK( 57501 ), PEEK( 57502 ), PEEK( 57503 )
  307. *
  308. IF PEEK( 57501 ) = 0
  309.    ? "INVALID DATE"
  310. ENDIF
  311. *
  312. CLEAR
  313. SET TALK ON
  314. RETURN
  315. * EOF: DATETEST.PRG
  316.  
  317. **********************************************************************
  318.  
  319. * Multiple Screens:
  320. *
  321. * Multiple screen routine [II, 2.4x]
  322. *
  323. DO WHILE T
  324.    *
  325.    * Prompt the operator for a key expression to find...
  326.    <Do a subroutine for this entry>
  327.    *
  328.    * Find the first occurrence of a particular key...
  329.    FIND &m:key
  330.    *
  331.    * Branch for no find...
  332.    IF # = 0
  333.       STORE ' ' TO t:waiting
  334.       @ 22,23 SAY "There are no records for this key."
  335.       @ 23,24 SAY "Press any key to continue..." GET t:waiting
  336.       READ NOUPDATE
  337.       CLEAR GETS
  338.       RETURN
  339.    ELSE
  340.       STORE T TO t:is:found
  341.    ENDIF
  342.    *
  343.    * Display headings for the output...
  344.    @ 6, 8 SAY "Key:"
  345.    @ 6,30 SAY "Address:"
  346.    @ 6,60 SAY "Phone Number:"
  347.    *
  348.    * Initialize memvars to control screens...
  349.       * String of possible menu items (12 per screen)...
  350.    STORE 'ABCDEFGHIJKL' TO t:menu:str
  351.       * Line counter initialized for first item...
  352.    STORE 8 TO t:line
  353.       * Used as parameter in substring function to get 
  354.       * menu item from string of possibilities...
  355.    STORE 1 TO t:menu:num
  356.       * Possible choices in operator entry trapping routine...
  357.    STORE ' ?' + $(t:menu:str,t:menu:num,1) TO t:selectns
  358.       * Screen number used as macro in memvar array of record numbers...
  359.    STORE '11' TO t:scrn:no
  360.       * Number of the first record on this screen is used to 
  361.       * reposition record pointer when changing screens...
  362.    STORE # TO t:record&t:scrn:no
  363.    *
  364.    * A loop for each record on the screen...
  365.    DO WHILE t:is:found
  366.         * Save the menu letter for this record...
  367.       STORE $(t:menu:str,t:menu:num,1) TO t:menu:ltr
  368.         * Save current record number in a memvar using the
  369.         * current menu letter in the memvar name.  This is used 
  370.         * to postion the record pointer to a record selected by 
  371.         * menu letter.
  372.       STORE # TO t:menu:&t:menu:ltr
  373.       *
  374.       * Display the menu letter and pointer...
  375.       @ t:line, 2 SAY t:menu:ltr
  376.       @ t:line, 4 SAY "-->"
  377.       *
  378.       * Display data from the current record...
  379.       @ t:line, 8 SAY Key
  380.       @ t:line,30 SAY Address
  381.       @ t:line,60 SAY Telephone
  382.       *
  383.       * Next record, and increment display line...
  384.       SKIP
  385.       STORE t:line + 1 TO t:line
  386.       *
  387.       * Branch for another menu item...
  388.       IF .NOT. ( t:menu:num = 12 .OR. EOF .OR. (.NOT. m:key = Key) )
  389.          STORE t:menu:num + 1 TO t:menu:num
  390.          STORE t:selectns + $(t:menu:str,t:menu:num,1) TO t:selectns
  391.          LOOP
  392.          *
  393.       ELSE
  394.       * Branch for another screen, eof, or end of this key data...
  395.          DO CASE
  396.             *
  397.             CASE t:scrn:no = '11' .AND. ( (m:key # Key)  .OR. EOF )
  398.              * No more records, only one screen...
  399.                @ 21, 0 SAY "There are NO more records for this key."
  400.                @ 22, 0 SAY "Select a record by letter,"
  401.                *
  402.             CASE m:key = Key .AND. t:scrn:no = '11' .AND. (.NOT. EOF) 
  403.              * More records, still on first screen...
  404.                @ 21, 0 SAY "MORE records for this key on the NEXT screen."
  405.                @ 22, 0 SAY "Select a record by letter, N = NEXT screen,"
  406.                STORE t:selectns + 'N' TO t:selectns
  407.                *
  408.             CASE VAL(t:scrn:no) > 11 .AND. ( (m:key # Key) .OR. EOF )
  409.              * No more records, more than one screen...
  410.                @ 21, 0 SAY "MORE records for this key on the PREVIOUS screen."
  411.                @ 22, 0 SAY "Select a record by letter, P = PREVIOUS screen,"
  412.                STORE t:selectns + 'P' TO t:selectns
  413.                *
  414.             CASE m:key = Key .AND. VAL(t:scrn:no) > 11 .AND. (.NOT. EOF)
  415.              * More records, more than one screen...
  416.                @ 21, 0 SAY "MORE records for this key " +;
  417.                            "on both the PREVIOUS and NEXT screens."
  418.                @ 22, 0 SAY "Select a record by letter, "+;
  419.                            "N = NEXT screen, P = PREVIOUS screen,"
  420.                STORE t:selectns + 'NP' TO t:selectns
  421.          ENDCASE
  422.          *
  423.          * Display the last line in the prompt...
  424.          @ 23, 0 SAY "SPACE = another customer, RETURN = Main Menu..."
  425.          *
  426.          * Get the operator's selection...
  427.          STORE '\' TO t:select
  428.          DO WHILE .NOT. t:select $ t:selectns
  429.             STORE '?' TO t:select
  430.             @ 23,47 GET t:select PICTURE '!'
  431.             READ NOUPDATE
  432.             CLEAR GETS
  433.          ENDDO
  434.          *
  435.          * Branch for selection...
  436.          DO CASE
  437.             CASE t:select = '?'
  438.             * Restore environment and exit...
  439.                RELEASE ALL LIKE t:*
  440.                USE
  441.                RETURN
  442.             CASE t:select = ' '
  443.             * Loop around to enter another customer...
  444.                STORE F TO t:is:found
  445.                LOOP
  446.             CASE t:select $ 'ABCDEFGHIJKL'
  447.             * View or edit a displayed record...
  448.                *
  449.                * Position record pointer to selected record...
  450.                GO t:menu:&t:select
  451.                *
  452.                * Clear some room in memory, and do editing routine...
  453.                RELEASE ALL LIKE t:menu:*
  454.                <Do a subroutine to edit the record>
  455.                *
  456.                * Exit the inner loop to enter another key expression...
  457.                * (This is a good example of where the EXIT command 
  458.                *  in dBASE III really speeds things up!)
  459.                STORE F TO t:is:found
  460.                LOOP
  461.             CASE t:select = 'N'
  462.             * Next screen...
  463.                * Reset screen line counter...
  464.                STORE  8 TO t:line
  465.                * Increment screen number...
  466.                STORE STR( VAL(t:scrn:no)+1 ,2) TO t:scrn:no
  467.                * Save first record of this screen...
  468.                STORE # TO t:record&t:scrn:no
  469.             CASE t:select = 'P'
  470.             * Previous screen...
  471.                * Reset screen line counter...
  472.                STORE  8 TO t:line
  473.                * Decrement screen number...
  474.                STORE STR( VAL(t:scrn:no)-1 ,2) TO t:scrn:no
  475.                * Position to first record of previous screen...
  476.                GO t:record&t:scrn:no
  477.          ENDCASE
  478.          *
  479.          * Reset memvars for the next screen's menu...
  480.          STORE ' ?A' TO t:selectns
  481.          STORE 1 TO t:menu:num
  482.          *
  483.          * Clear the current screen leaving the header...
  484.          @  8,0
  485.          @  9,0
  486.          @ 10,0
  487.          @ 11,0
  488.          @ 12,0
  489.          @ 13,0
  490.          @ 14,0
  491.          @ 15,0
  492.          @ 16,0
  493.          @ 17,0
  494.          @ 18,0
  495.          @ 19,0
  496.          @ 21,0
  497.          @ 22,0
  498.          @ 23,0
  499.          *
  500.       ENDIF 
  501.    ENDDO [WHILE t:is:found]
  502.      *
  503.      * Clear the header...
  504.      @  6,0
  505. ENDDO [WHILE T]
  506. *
  507. * End of multiple screen routine
  508.  
  509. **********************************************************************
  510.  
  511. * Prompt Pad:
  512. *
  513. * Prompt-Pad Algorithm  [III]
  514. *
  515. * Initialize prompts in memvar array...
  516. STORE '<prompt-1>' TO prompt_001
  517. STORE '<prompt-2>' TO prompt_002
  518. STORE '<prompt-3>' TO prompt_003
  519. STORE '<prompt-4>' TO prompt_004
  520. STORE '<prompt-5>' TO prompt_005
  521. STORE '<prompt-6>' TO prompt_006
  522. STORE '<prompt-7>' TO prompt_007
  523. STORE '<prompt-8>' TO prompt_008
  524. *
  525. * Can have as many prompts as there are available memvars.
  526. * (60 in II, 252 in III because this algorithm uses 4 memvars)
  527. *
  528. * Initialize controlling memvars with first and last numbers...
  529. STORE '001' TO first, counter
  530. STORE '008' TO last
  531. *
  532. * Display instructions to operator...
  533. @ 23,17 SAY "Press SPACE or B to change, RETURN to enter..."
  534. *
  535. * Set up loop to redisplay <prompts> until one is chosen...
  536. SET BELL OFF
  537. STORE " " TO switch
  538. DO WHILE switch # "?"
  539.    *
  540.    * Blank the previous display if there is one...
  541.    @ 20,23
  542.    *
  543.    <set screen to attribute or color that highlights the prompt>
  544.    *
  545.    @ 20,23 SAY prompt_&counter
  546.    STORE "?" TO switch
  547.    *
  548.    <set screen to invisible in order to conceal the GET>
  549.    *
  550.    @ 23,77 GET switch PICTURE "!"
  551.    READ
  552.    CLEAR GETS
  553.    *
  554.    * Branch to increment counter and switch selection...
  555.    DO CASE
  556.       CASE switch = " " .AND. counter < last
  557.          STORE SUBSTR( STR( &counter+1001,4 ) ,2,3) TO counter
  558.       CASE switch = " " .AND. counter = last
  559.          STORE first TO counter
  560.       CASE switch = "B" .AND. counter > first
  561.          STORE SUBSTR( STR( &counter+ 999,4 ) ,2,3) TO counter
  562.       CASE switch = "B" .AND. counter = first
  563.          STORE last TO counter
  564.    ENDCASE
  565. ENDDO
  566. *
  567. * Restore the environment before moving on...
  568. <set screen back to normal>
  569. SET BELL ON
  570. @ 20, 0 SAY [                      ]
  571. @ 23,17
  572. *
  573. * Branch to execute selection...
  574. DO CASE
  575.    CASE counter = '001'
  576.       <commands>
  577.    CASE counter = '002'
  578.       <commands>
  579.    CASE counter = '003'
  580.       <commands>
  581.    CASE counter = '004'
  582.       <commands>
  583.    CASE counter = '005'
  584.       <commands>
  585.    CASE counter = '006'
  586.       <commands>
  587.    CASE counter = '007'
  588.       <commands>
  589.    CASE counter = '008'
  590.       <commands>
  591. ENDCASE
  592. *
  593. * EOA: Prompt-Pad
  594.  
  595. **********************************************************************
  596.  
  597. * Page Counter:
  598. *
  599. * Page counter algorithm, one file.
  600. *
  601. * Initialize counters to starting values.
  602. * Start t:line high enough to take the branch for a 
  603. * new heading just inside the DO loop...
  604. STORE 61 TO t:line
  605. STORE  5 TO t:col
  606. STORE  0 TO t:pagectr
  607. *
  608. * Look at each record in the file sequentially...
  609. GO TOP
  610. DO WHILE .NOT. EOF
  611.    *
  612.    * Branch for new page...
  613.    IF t:line > 60
  614.       STORE 1 TO t:line
  615.       STORE t:pagectr + 1 TO t:pagectr    
  616.       *
  617.       * This next line causes a form-feed to be sent to the printer
  618.       * because it is now a lower value than the last one sent...
  619.       @ t:line  ,t:col+66 SAY 'Page' + STR(t:pagectr,3)
  620.       @ t:line+1,t:col+66 SAY DATE()
  621.       @ t:line+4,t:col+25 SAY <heading>
  622.    ENDIF
  623.    *
  624.    @ t:line, t:col SAY <data from this record>
  625.    *
  626.    * Next record, and increment the line counter...
  627.    SKIP
  628.    STORE t:line + 1 TO t:line
  629. ENDDO
  630. *
  631. * EOA
  632.  
  633. **********************************************************************
  634.  
  635. * Periodic Files:
  636. *
  637. * dBASE II...
  638. *
  639. * Prompt for the file to use...
  640. STORE T TO select
  641. DO WHILE select    
  642.    STORE "  " TO t:month,t:year
  643.    @  5, 9 SAY "Enter the month and year of the data you want to enter."
  644.    @  7,17 SAY "Month " GET t:month PICTURE [##]
  645.    @  7,31 SAY "<Ctrl-C> to return to main menu."
  646.    @  8,17 SAY "Year  " GET t:year  PICTURE [##]
  647.    READ
  648.    CLEAR GETS
  649.    @ 10,0
  650.    *
  651.    DO CASE
  652.       *
  653.       CASE t:month = "  " .AND. t:year = "  "
  654.       * Branch to exit to main menu if there is no entry...
  655.          RELEASE ALL LIKE t:*
  656.          RETURN
  657.       *
  658.       CASE VAL(t:month) < 1  .OR. VAL(t:month) > 12 .OR.;
  659.            VAL(t:year)  < 83 .OR. VAL(t:year)  > 98
  660.       * Branch to trap invalid entries...
  661.          @ 10,22 SAY "Invalid entry -- please re-enter..."
  662.          LOOP
  663.       *
  664.       CASE VAL(t:month) < 10
  665.       * Branch to format leading zero in month...
  666.          STORE "0" + STR(VAL(t:month),1) TO t:month
  667.    ENDCASE
  668.    *
  669.    * Set up filename in the format PL_<mm>-<yy>
  670.    * where <mm> ::= month, and <yy> ::= year...
  671.    STORE "PL_" + t:month + "-" + t:year TO t:use:file
  672.    *
  673.    * Verify existence of file, exit loop if file exists...
  674.    IF FILE("&t:use:file")      
  675.       STORE F TO select
  676.    ELSE
  677.       * Prompt to create new file or re-enter the date...
  678.       @ 10,20 SAY "I cannot find the file " + t:use:file + ".DBF."
  679.       @ 12, 7 SAY "Press <C> to Create this file, " +;
  680.                   "or any other key to re-enter..."
  681.       STORE "?" TO t:waiting
  682.       @ 12,69 GET t:waiting 
  683.       READ
  684.       CLEAR GETS
  685.       @ 10, 0
  686.       @ 12, 0
  687.       *
  688.       * Branch to create a new placement file...
  689.       IF !(t:waiting) = "C"
  690.          @  7,31
  691.          @ 10,15 SAY "Just a moment please, while I prepare the files..."
  692.          USE PL_place
  693.          COPY STRUCTURE TO &t:use:file
  694.          STORE F TO select
  695.       ENDIF
  696.    ENDIF
  697.    *
  698. ENDDO [WHILE select]
  699. *
  700. * Clear the used part of the screen...
  701. @  5,0
  702. @  7,0
  703. @  8,0
  704. @ 10,0
  705. @ 12,0
  706. *
  707. * Open the file...
  708. USE &t:use:file
  709. *
  710. * EOA
  711.  
  712. **********************************************************************
  713.  
  714. * Pseudo Arrays:
  715. *
  716. * AR_DEMO.PRG [III]
  717. *
  718. * Initialize a memvar to use as a counter...
  719. * A character type is used because it will be concatenated
  720. * to a memvar name to give us programming access to the array.
  721. STORE '000' TO counter
  722. *
  723. * Set up a loop for the size of the array, twelve in this 
  724. * example.  (Remember the limit of active memory variables)
  725. DO WHILE counter < '012'
  726.    *
  727.    * Increment counter by 1... 
  728.    STORE SUBSTR( STR( &counter+1001,4 ) ,2,3) TO counter
  729.    * [In II, substitute $ for SUBSTR]
  730.    *
  731.    * Assign values to the array elements...   
  732.    STORE VAL(counter) TO number&counter
  733.    STORE 'EXAMPLE ' + counter TO alpha&counter
  734. ENDDO
  735. * EOF: AR_DEMO.PRG
  736.  
  737. * ARRAY.CMD [II]
  738. *
  739. * Initialize the array(s) with values...
  740. STORE "101275031020680710321417104210001051971510622000"+;
  741.       "107117081081275610915281110122631111528411211763"+;
  742.       "113095171140025011500575116015821170182611802929"+;
  743.       "1190427612005326" TO prodtable1
  744. STORE "121305721227086012371412124000211255179112600022"+;
  745.       "127807111286572112918251130362211314825113236711"+;
  746.       "133715901340520013557500136285101376281013892920"+;
  747.       "1396724014062350" TO prodtable2
  748. *
  749. * Initialize a variable for entry...
  750. STORE "   " TO prod:nmbr
  751. *
  752. * Set up a loop for repetition...
  753. DO WHILE T
  754.    *
  755.    * Prompt for the product number...
  756.    @ 5,20 SAY "Enter the product number (Return to Quit)";
  757.           GET prod:nmbr PICTURE "999"
  758.    READ
  759.    CLEAR GETS
  760.    *
  761.    * Depending on the contents of prod:nmbr, either
  762.    * RETURN out of this program, LOOP back to DO WHILE T, 
  763.    * or select the proper table and execute the rest of 
  764.    * this program...
  765.    DO CASE
  766.       CASE prod:nmbr = " "
  767.          SET TALK ON
  768.          RETURN 
  769.       CASE prod:nmbr < "101" .OR. prod:nmbr > "140"
  770.          @ 10,25 SAY "Incorrect product number "
  771.          LOOP
  772.       CASE prod:nmbr > "100" .AND. prod:nmbr < "121"
  773.          STORE "prodtable1" TO array
  774.       CASE prod:nmbr > "120" .AND. prod:nmbr < "141"
  775.          STORE "prodtable2" TO array
  776.    ENDCASE
  777.    *
  778.    * Search for the prod:nmbr...
  779.    * Notice the use of the macro function to specify the array. 
  780.    STORE 1 TO pointer
  781.    * (The macro cannot be used in a DO loop in dBASE III.)
  782.    DO WHILE prod:nmbr # $(&array,pointer,3) .AND. pointer < 160
  783.       STORE pointer + 8 TO pointer
  784.    ENDDO
  785.    *
  786.    * Display the results...
  787.    STORE VAL($(&array,pointer+3,5)) / 100.00 TO prod:price
  788.    @ 10,25 SAY "   The price is:  $" + STR(prod:price,6,2)
  789.    *
  790.    * Housekeeping...
  791.    STORE "   " TO prod:nmbr
  792. ENDDO
  793. * EOF: Array.cmd
  794.  
  795. **********************************************************************
  796.  
  797. * Quick Date Trap: [II]
  798. *
  799. * Start of date entry routine...
  800. @ <entry coordinates> GET m:date PICTURE [##/##/##]
  801. READ NOUPDATE
  802. CLEAR GETS
  803. STORE VAL($(m:date,1,2)) TO t:month
  804. STORE VAL($(m:date,4,2)) TO t:day
  805. STORE VAL($(m:date,7,2)) TO t:year
  806. DO WHILE (m:date # [  /  /  ]) .AND. (t:month<1 .OR. t:month>12 .OR.;
  807. t:day<1 .OR. t:day>VAL($("312931303130313130313031",(t:month-13* INT(t:month/;
  808. 13))*2-1,2)) .OR. (t:month=2 .AND. t:day>28 .AND. t:year/4.0>INT(t:year/4.0)))
  809.    @ <message coordinates> SAY "Not a valid date, please re-enter..."
  810.    @ <entry coordinates> GET m:date PICTURE [##/##/##]
  811.    READ NOUPDATE
  812.    CLEAR GETS
  813.    STORE VAL($(m:date,1,2)) TO t:month
  814.    STORE VAL($(m:date,4,2)) TO t:day
  815.    STORE VAL($(m:date,7,2)) TO t:year
  816.    @ <message coordinates> 
  817. ENDDO
  818. *
  819. * Format the string if it contains a date with blank spaces...
  820. IF " " $ m:date .AND. (.NOT. m:date = [  /  /  ])
  821.    *
  822.    * Right justify the characters in each subvariable...
  823.    STORE STR(t:month,2) +"/"+ STR(t:day,2) +"/"+ STR(t:year,2) TO m:date
  824.    *
  825.    * Use the date function to add leading zeros...
  826.      * Save the system date...
  827.    STORE DATE() TO t:date
  828.      * Set system date to entered date...
  829.    SET DATE TO &m:date
  830.      * Replace entered date with formatted system date...
  831.    STORE DATE() TO m:date
  832.      * Restore original system date...
  833.    SET DATE TO &t:date
  834.    *
  835.    * Redisplay the formatted date...
  836.    @ <entry coordinates> GET m:date PICTURE [##/##/##]
  837.    CLEAR GETS
  838. ENDIF
  839. *           
  840. * End of date entry routine.
  841.  
  842. **********************************************************************
  843.  
  844. * EOF: Various.alg
  845.  up a loop for the size of the array, twelve in this 
  846. * example.  (Remember the limit of active memory variables)
  847. DO WHILE counter < '012'
  848.    *
  849.    * Increment counter by 1... 
  850.    STORE SUBSTR( STR( &counter+1001,4 ) ,2,3) TO counter
  851.    * [In II, substitute $ for SUBSTR]
  852.    *
  853.    * Assign values to the array elements...   
  854.    STORE VAL(counter) TO number&counter
  855.    STORE 'EXAMPLE ' + coun