home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a040 / 2.ddi / SHRWARE4.ARC / MSAPROC.INC < prev    next >
Encoding:
Text File  |  1988-06-03  |  19.1 KB  |  875 lines
  1. <<* MSAPROC.INC *>>
  2.  
  3.  
  4. <<* MODIFIED 5 May 1988 *>>
  5.  
  6. <<procedure GenProcStandard>>
  7. <<string alpha>>
  8. <<begin>>
  9.  
  10.  
  11. PROCEDURE {fileprefix}_Menu
  12. PARAMETER RS,CS,MN,MW
  13. SAVE SCREEN TO MENUSCRN
  14. DIME AMENU(MN)
  15. i = 1
  16. DO WHILE i <= MN
  17. STORE "MSG"+IIF(i >= 10,STR(i,2,0),STR(i,1,0)) TO MSG
  18. AMENU(i) = &MSG
  19. STORE i + 1 TO i
  20. ENDDO
  21. DO WHILE .T.
  22. <<GenColor( 0,'SCREEN')>>
  23. @ 23,0 SAY 'Press <Esc> to remove menu'
  24. @ RS,CS MENU AMENU,MN,MIN(MN,10)
  25. READ MENU TO menuchoice SAVE
  26. * ---CHECK FOR HELP KEY OR DELETE
  27. DO CASE
  28.  CASE readkey() = 36
  29.    DO SYS_HELP
  30.  CASE READKEY() = 12
  31.      RESTORE SCREEN FROM MENUSCRN
  32.      STORE INKEY(0) TO STOP
  33.  OTHERWISE
  34.    EXIT
  35. ENDCASE
  36. ENDDO
  37. RELEASE AMENU
  38. RESTORE SCREEN FROM MENUSCRN
  39. RETURN
  40.  
  41. PROCEDURE SYS_HELP
  42. SAVE SCREEN TO HELPSCRN
  43. <<GenColor( 0,'SCREEN')>>
  44. H = 0
  45. * ---HELP MENU
  46. DIME MHELP(3)
  47. MHELP(1) = 'Help'
  48. MHELP(2) = 'Calendar'
  49. MHELP(3) = 'Calculator'
  50. @ 1,60 MENU MHELP,3,3 TITLE ' Help '
  51. READ MENU TO H SAVE
  52. DO CASE
  53.  CASE H = 1
  54.   DO {fileprefix}_HELP WITH SYS(16,2)  
  55. CASE H = 2 
  56.   DO D_CAL WITH 1,25
  57. OTHERWISE
  58.   @ 24,0 CLEAR
  59.   @ 24,0 SAY 'Not implemented in current release.'
  60.   STORE INKEY(3) TO STOP
  61. ENDCASE
  62. RELEASE mhelp
  63. RESTORE SCREEN FROM HELPSCRN
  64. RETURN
  65.  
  66.  
  67. ******
  68. *   date1()
  69. *
  70. *   user defined PROCEDURE
  71. ******
  72. PROCEDURE date1
  73. * Syntax: date1( <date> )
  74. * Return: Character string of the date in mmm,dd,yyyy 
  75. *
  76. PARAMETERS cl_date1
  77. RETURN SUBSTR(CMONTH(cl_date1),1,3)+" "+LTRIM(STR(DAY(cl_date1)))+ ;
  78.          ", "+LTRIM(STR(YEAR(cl_date1)))
  79.  
  80. ******
  81. *   date2()
  82. *
  83. *   user defined PROCEDURE
  84. ******
  85. PROCEDURE date2
  86. * Syntax: date2( <date> )
  87. * Return: Character string of the date in mmm,yyyy 
  88. *
  89. PARAMETERS cl_date2
  90. RETURN SUBSTR(CMONTH(cl_date2),1,3)+" "+ ;
  91.          LTRIM(STR(YEAR(cl_date2)))
  92.  
  93. ******
  94. *   date3()
  95. *
  96. *   user defined PROCEDURE
  97. ******
  98. PROCEDURE date3
  99. * Syntax: date1( <date> )
  100. * Return: Character string of the date in mmm,dd 
  101. *
  102. PARAMETERS cl_date3
  103. RETURN SUBSTR(CMONTH(cl_date3),1,3)+" "+LTRIM(STR(DAY(cl_date3)))
  104.        
  105.  
  106. ******
  107. *   date4()
  108. *
  109. *   user defined PROCEDURE
  110. ******
  111. PROCEDURE date4
  112. * Syntax: date4( <date> )
  113. * Return: Character string of the date in Month dd,yyyy 
  114. *
  115. PARAMETERS cl_date4
  116. RETURN CMONTH(cl_date4)+" "+LTRIM(STR(DAY(cl_date4)))+ ;
  117.          ", "+LTRIM(STR(YEAR(cl_date4)))
  118.  
  119. ******
  120. *   firstday()
  121. *
  122. *   user defined PROCEDURE
  123. ******
  124. PROCEDURE firstday
  125. * Syntax: firstday( <date> )
  126. * Return: firstday of month 
  127. *
  128. PARAMETERS cl_firstday
  129.  
  130. RETURN ;
  131. CTOD(SUBSTR(DTOC(cl_firstday),1,3)+"01"+SUBSTR(DTOC(cl_firstday),6,3))
  132.  
  133.  
  134. ******
  135. *   lastday()
  136. *
  137. *   user defined PROCEDURE
  138. ******
  139. PROCEDURE lastday
  140. * Syntax: lastday( <date> )
  141. * Return: lastday of month 
  142. *
  143. PARAMETERS cl_lastday
  144. PRIVATE cl_lastday,lastday
  145. DO CASE
  146.  CASE MONTH(cl_lastday) <= 8
  147.     STORE CTOD("0"+ltrim(str(month(cl_lastday)+1))+;
  148.     "/01/"+ltrim(str(year(cl_lastday))))-1 TO lastday
  149.  CASE MONTH(cl_lastday) >= 9 .AND. MONTH(cl_lastday) < 12
  150.     STORE CTOD(ltrim(str(month(cl_lastday)+1)) + ;
  151.     "/01/"+ltrim(str(year(cl_lastday))))-1 TO lastday
  152.  CASE MONTH(cl_lastday) = 12
  153.     STORE CTOD("01/01/"+ltrim(str(year(cl_lastday)+1)))-1 TO lastday
  154.  ENDCASE
  155. RETURN lastday
  156.  
  157. ******
  158. *   months()
  159. *
  160. *   user defined PROCEDURE
  161. ******
  162. PROCEDURE MONTHS
  163. * Syntax: MONTHS( <expD>, <expN> )
  164. * Return: A date n months ahead or behind
  165. *
  166. PARAMETERS cl_date, cl_num
  167. STORE VAL(SUBSTR(DTOC(cl_date),1,2)) TO CUR_MNTH
  168. STORE CUR_MNTH+cl_num TO TARGET_NUM
  169. IF VAL(SUBSTR(DTOC(cl_date),4,2)) >= 29
  170.  * ---NEED TO CHECK OUT TARGET MONTH
  171.  * ---WHAT IS LAST DAY OF TARGET MONTH?
  172.  * ---IF IT IS NOT IN RANGE WE CHANGE cl_date
  173.  IF TARGET_NUM <= 0 .OR. TARGET_NUM > 12
  174.   STORE IIF(mod(TARGET_NUM,12)=0,12,mod(TARGET_NUM,12)) TO N_MONTH 
  175.  ELSE
  176.   STORE TARGET_NUM TO N_MONTH
  177.  ENDIF
  178.  * ---CREATE A DATE
  179.   IF N_MONTH <= 9
  180.    STORE CTOD("0"+STR(N_MONTH,1,0)+ "/"+;
  181.     "01/"+STR(YEAR(cl_date),4,0)) TO TEST_DT
  182.   ELSE
  183.    STORE CTOD(STR(N_MONTH,2,0)+ "/"+;
  184.     "01/"+STR(YEAR(cl_date),4,0)) TO TEST_DT
  185.   ENDIF
  186. IF VAL(SUBSTR(DTOC(cl_date),4,2)) <= ;
  187.          VAL(SUBSTR(DTOC(LASTDAY(TEST_DT)),4,2))
  188. * --- DATE IS OK
  189. ELSE
  190. * --- REPLACE DATE WITH LASTDAY OF TEST_DT
  191. STORE CTOD(SUBSTR(DTOC(cl_date),1,3)+SUBSTR(DTOC(LASTDAY(TEST_DT)),4,3)+;
  192.       SUBSTR(DTOC(cl_date),7,2)) TO cl_date
  193. ENDIF
  194.  
  195. ENDIF
  196.  * ---JUST ADD TO THE MONTHS AND CHECK THE YEAR
  197. DO CASE
  198.  
  199.  CASE TARGET_NUM <= 0
  200.   STORE YEAR(cl_date)-1-INT(-TARGET_NUM/12) TO N_YEAR
  201.   STORE IIF(mod(TARGET_NUM,12)=0,12,mod(TARGET_NUM,12)) TO N_MONTH 
  202.   * --- TEST N_YEAR FOR LEAP IF MONTH = 2 AND DAY = 29
  203.   IF N_MONTH = 2 .AND. DAY(cl_date) = 29 .AND. ;
  204.     mod(N_YEAR,4) <> 0
  205.     STORE cl_date-1 TO cl_date
  206.   ENDIF
  207.   IF N_MONTH <= 9
  208.    STORE CTOD("0"+STR(N_MONTH,1,0)+ "/"+;
  209.     SUBSTR(DTOC(cl_date),4,2)+"/"+STR(N_YEAR,4,0)) TO TARGET_DT
  210.   ELSE
  211.    STORE CTOD(STR(N_MONTH,2,0)+ "/"+;
  212.     SUBSTR(DTOC(cl_date),4,2)+"/"+STR(N_YEAR,4,0)) TO TARGET_DT
  213.   ENDIF
  214.  CASE TARGET_NUM <= 9 .AND. TARGET_NUM > 0
  215.   STORE CTOD("0"+STR(TARGET_NUM,1,0)+ "/"+;
  216.    SUBSTR(DTOC(cl_date),4,5)) TO TARGET_DT
  217.  CASE TARGET_NUM > 9 .AND. TARGET_NUM <= 12
  218.   STORE CTOD(STR(TARGET_NUM,2,0)+ "/"+;
  219.    SUBSTR(DTOC(cl_date),4,5)) TO TARGET_DT
  220.  CASE TARGET_NUM > 12
  221.   STORE YEAR(cl_date)+INT(TARGET_NUM/12) TO N_YEAR
  222.   STORE IIF(mod(TARGET_NUM,12)=0,12,mod(TARGET_NUM,12)) TO N_MONTH 
  223.   * --- TEST N_YEAR FOR LEAP IF MONTH = 2 AND DAY = 29
  224.   IF N_MONTH = 2 .AND. DAY(cl_date) = 29 .AND. ;
  225.     mod(N_YEAR,4) <> 0
  226.     STORE cl_date-1 TO cl_date
  227.   ENDIF
  228.   IF N_MONTH <= 9
  229.    STORE CTOD("0"+STR(N_MONTH,1,0)+ "/"+;
  230.     SUBSTR(DTOC(cl_date),4,2)+"/"+STR(N_YEAR,4,0)) TO TARGET_DT
  231.   ELSE
  232.    STORE CTOD(STR(N_MONTH,2,0)+ "/"+;
  233.     SUBSTR(DTOC(cl_date),4,2)+"/"+STR(N_YEAR,4,0)) TO TARGET_DT
  234.   ENDIF
  235.  
  236. ENDCASE
  237.  
  238. RETURN TARGET_DT
  239.  
  240. PROCEDURE D_CAL
  241.  
  242. PARAMETERS ROW,COL
  243. PRIVATE ROW,COL,CUR_MNTH,DAY_NUM,LDAY,FDAY,i,k
  244. SAVE SCREEN
  245. SET COLOR TO W/R,R/W
  246. DIME CALENDAR(37)
  247.  
  248. * --- THE FIRST CALENDAR WILL BE CURRENT MONTH
  249. STORE DATE() TO CUR_MNTH 
  250.  
  251. * ---WRITE TEMPLATE TO SCREEN
  252. * ---WRITE TEMPLATE TO SCREEN
  253. @ ROW+1,COL+1,ROW+15,COL+31 BOX '████████'
  254. @ ROW,COL CLEAR TO ROW+13,COL+30
  255. @ ROW,COL TO ROW+11,COL+30 DOUBLE
  256. @ ROW+10, COL+26 SAY ' µS '
  257. @ ROW+2,COL SAY '╟─────────────────────────────╢'
  258. @ ROW+3,COL+2 SAY 'Sun Mon Tue Wed Thu Fri Sat'
  259. @ ROW+11,COL SAY '╠═════════════════════════════╣'
  260. @ ROW+12,COL SAY '║  Use Arrow keys to navigate ║'
  261. @ ROW+13,COL SAY '║     Press <End> to Quit     ║'
  262. @ ROW+14,COL SAY '╚═════════════════════════════╝'
  263.  
  264. DO WHILE .T.
  265.  
  266. * --- DETERMINE THE FIRST AND LAST DAY OF THE MONTH 
  267. STORE LASTDAY(CUR_MNTH) TO LDAY
  268. STORE FIRSTDAY(CUR_MNTH) TO FDAY   
  269.  
  270. * ---REPLACE ARRAY WITH BLANKS
  271. i = 1
  272. DO WHILE i <= 37
  273. CALENDAR(i) = SPACE(2)
  274. i = i+1
  275. ENDDO
  276. * ---SET INDEX
  277. i = DOW(FDAY)
  278. * ---LOAD THE ARRAY
  279. STORE 1 TO DAY_NUM
  280. DO WHILE DAY_NUM <= DAY(LDAY)
  281. CALENDAR(i) = STR(DAY_NUM,2,0)
  282. DAY_NUM = DAY_NUM + 1 
  283. i = i + 1
  284. ENDDO
  285. * ---WRITE THE MONTH AND DAYS
  286. STORE DATE2(CUR_MNTH) TO SCRN_DT
  287. @ ROW+1,COL+11 SAY SCRN_DT
  288. STORE 5 TO RW
  289. STORE 2 TO CL
  290. STORE 1 TO i
  291. DO WHILE i <= 37
  292. @ ROW+RW,COL+CL SAY CALENDAR(i)
  293. i = i + 1
  294. CL = CL + 4
  295. IF MOD(i,7) = 1 
  296.  RW = RW + 1
  297.  CL = 2
  298. ENDIF
  299. ENDDO
  300. * ---CAPTURE THE KEY
  301. DO WHILE .T.
  302. k = 0
  303. DO WHILE k = 0
  304. k = INKEY()
  305. ENDDO
  306. DO CASE
  307.   CASE k = 6   && END DEPRESSED
  308.    RESTORE SCREEN
  309.    RELEASE CALENDAR
  310. <<GenColor( 4,'SCREEN')>>
  311. *   SET CURSOR ON
  312.    RETURN 
  313.   CASE k = 5   && ARROW UP DEPRESSED
  314.    STORE MONTHS(CUR_MNTH,12) TO CUR_MNTH
  315.    EXIT
  316.   CASE k = 24  && ARROW DOWN
  317.    STORE MONTHS(CUR_MNTH,-12) TO CUR_MNTH
  318.    EXIT
  319.   CASE k = 4   && RIGHT ARROW PRESSED
  320.    STORE MONTHS(CUR_MNTH,1) TO CUR_MNTH
  321.    EXIT
  322.   CASE k = 19  && LEFT ARROW PRESSED
  323.    STORE MONTHS(CUR_MNTH,-1) TO CUR_MNTH
  324.    EXIT
  325. ENDCASE
  326. ENDDO  &&KEY
  327.  
  328. ENDDO  MAIN LOOP
  329. RETURN
  330.  
  331.  
  332. PROCEDURE SayRec
  333.    * ---"SayRec" is used by the EDIT program and PROCEDURE DoCONT.
  334.    *
  335.    DO StatLine WITH RECNO(),DELETED()
  336.    DO {fileprefix}_SAYS
  337.    *
  338.    * ---If you are calling "SayRec" from more than one
  339.    * ---application, you may wish to replace the above
  340.    * ---line with a DO CASE structure, as follows:
  341.    *
  342.    *    * ---"appnum" is the application ID number.
  343.    *    DO CASE
  344.    *    CASE appnum = 1
  345.    *       DO AP1_SAYS
  346.    *    CASE appnum = 2
  347.    *       DO AP2_SAYS
  348.    *    ENDCASE
  349.    *
  350. RETURN
  351.  
  352. PROCEDURE GetKey
  353. PARAMETER choice,keychars
  354. PRIVATE keycode
  355.    choice = "*"
  356.    DO WHILE .NOT. (choice $ keychars)
  357.       keycode = INKEY()
  358.       IF keycode > 0
  359.          choice = UPPER(CHR(keycode))
  360.       ENDIF
  361.       * ---A keyfilter can be implemented here, as follows:
  362.       *
  363.       *    * ---FROM:  {{}F1}  ^leftarrow  ^rightarrow
  364.       *    * ---INTO:  "H"    leftarrow   rightarrow
  365.       *    fromkeys = CHR(28) + CHR(26) + CHR(2)
  366.       *    intokeys = "H" + CHR(19) + CHR(4)
  367.       *    choice = SUBSTR( "*"+intokeys,AT(choice,fromkeys) + 1,1 )
  368.    ENDDO
  369. RETURN
  370.  
  371. <<if ismultipage>>
  372.  
  373. PROCEDURE Page
  374. PARAMETER pageno,pagedir,PageMax
  375.    pageno = pageno + pagedir
  376.    DO CASE
  377.    CASE pageno < 1
  378.       * ---Circle to last page.
  379.       pageno = PageMax
  380.    CASE pageno > PageMax
  381.       * ---Circle to first page.
  382.       pageno = 1
  383.    ENDCASE
  384. RETURN
  385.  
  386. <<endif>>
  387.  
  388. PROCEDURE StatLine
  389. PARAMETER recnum,IsDeleted
  390.    <<GenColor( 1,'STATUS' )>>
  391.    @ 0,0 SAY STR( recnum,7,0 ) + "/"+LTRIM( STR(Reccount()) )
  392.    <<if ismultipage>>
  393.    @ 0,23 SAY STR( pageno,2 )
  394.    <<endif>>
  395.    <<if ismultials>>
  396.    @ 0,29 SAY "<        >"
  397.    @ 0,30 SAY SUBSTR( DBFname,1,AT( ".",DBFname )-1 )
  398.    <<endif>>
  399.    IF IsDeleted
  400.       @ 0,50 SAY "  <Del>  "
  401.    ELSE
  402.       @ 0,50 SAY "         "
  403.    ENDIF
  404. RETURN
  405.  
  406. PROCEDURE PromptBar
  407. <<GenColor( 0,'HILITE' )>>
  408. STORE DATE4(DATE()) TO SYSDATE
  409. @ 22,0 SAY SPACE(80)   &&CLEAR LINE
  410. @ 22,1 SAY INST_INC+SPACE(48-LEN(SYSDATE))+SYSDATE
  411. * ---Center the menu heading.
  412. col = (80 - LEN(menuhdg)) / 2
  413. @  22,col SAY menuhdg
  414. <<Gencolor( 0,'SCREEN' )>>
  415.  
  416. Return
  417.  
  418. PROCEDURE SayEOF
  419. PARAMETER row,oldrecnum
  420.    <<GenColor( 1,'PROMPT' )>>
  421.    @ row,0 CLEAR
  422.    IF EOF()
  423.       @ row,0 SAY "END-OF-FILE encountered"
  424.    ELSE
  425.       @ row,0 SAY "BEGINNING-OF-FILE encountered"
  426.    ENDIF
  427.    WAIT
  428.    @ row,0 CLEAR
  429.    IF oldrecnum > 0
  430.       GOTO oldrecnum
  431.    ENDIF
  432. RETURN
  433.  
  434.  
  435. PROCEDURE SayLine
  436. PARAMETER row,strg
  437.    <<GenColor( 1,'PROMPT' )>>
  438.    @ row,0 CLEAR
  439.    @ row,0 SAY strg
  440. RETURN
  441.  
  442.  
  443. PROCEDURE GotoRec
  444. PARAMETER row,recnum,lastrecnum
  445.    recnum = 0
  446.    SAVE SCREEN TO GOTOSCR
  447.    @ 1,15,4,50 BOX ''
  448.    @ 1,15,4,50 BOX "╒═╕│╛═╘│"
  449.    @ 2,17 SAY "{ 1 to "
  450.    @ 2,24 SAY SUBSTR( STR( lastrecnum + 1000000,7 ),2 ) + " } + {Return}"
  451.    ?? SYS(2002,1)
  452.    @ 3,17 SAY "Enter RECORD number" GET recnum;
  453.            PICTURE "@Z 9999999" RANGE 0,lastrecnum
  454.    READ
  455.    ?? SYS(2002)
  456.    RESTORE SCREEN FROM GOTOSCR
  457.    IF recnum > 0
  458.       GOTO recnum
  459.    ENDIF
  460. RETURN
  461.  
  462.  
  463. PROCEDURE DoGOTO
  464. PARAMETER row,recnum,lastrecnum
  465.    recnum = 0
  466.    <<GenColor( 1,'PROMPT' )>>
  467.    @ row,0 CLEAR
  468.    menuchoice = 0
  469.    MSG1 =  "Top"
  470.    MSG2 =  "Bottom"
  471.    MSG3 =  "Number"
  472.    MSG4 =  "Return"
  473.    DO {fileprefix}_MENU WITH 1,65,4,7
  474.    choice = SUBSTR( Returnkey+"TBR"+Returnkey,menuchoice + 1,1 )
  475.    @ row,0 CLEAR
  476.    DO CASE
  477.    CASE choice = Returnkey
  478.       RETURN
  479.    CASE choice = "T"
  480.       GOTO TOP
  481.       recnum = RECNO()
  482.    CASE choice = "B"
  483.       GOTO BOTTOM
  484.       recnum = RECNO()
  485.    CASE choice = "R"
  486.       DO GotoRec WITH row,recnum,lastrecnum
  487.    ENDCASE
  488. RETURN
  489.  
  490.  
  491. PROCEDURE DoLOCATE
  492. PARAMETER row,expr
  493. PRIVATE oldrecnum
  494.    oldrecnum = RECNO()
  495.    DO SayLine WITH row,"Locating..."
  496.    LOCATE FOR &expr
  497.    IF EOF()
  498.       DO SayEOF WITH row,oldrecnum
  499.    ELSE
  500.       @ row,0 CLEAR
  501.       @ row,0 SAY "LOCATE FOR" GET expr
  502.       CLEAR GETS
  503.       DO DoCONT WITH row
  504.    ENDIF
  505. RETURN
  506.  
  507.  
  508. PROCEDURE DoCONT
  509. PARAMETER row
  510. PRIVATE oldrecnum
  511.    choice = "Y"
  512.    DO WHILE choice = "Y" .AND. .NOT. EOF()
  513.       oldrecnum = RECNO()
  514.       DO SayRec
  515.       DO SayLine WITH row+1,"Continue? (y/n)"
  516.       DO GetKey WITH choice,"YN"+Returnkey
  517.       @ row+1,0 CLEAR
  518.       IF choice = "Y"
  519.          CONTINUE
  520.       ENDIF
  521.    ENDDO
  522.    IF EOF()
  523.       DO SayEOF WITH row,oldrecnum
  524.    ENDIF
  525. RETURN
  526.  
  527. <<end>> <<*GenProcStandard*>>
  528.  
  529.  
  530. <<#
  531. procedure GenFuncStandard
  532. begin
  533.   select all
  534.   select fields on ("VLU(" $ upper(fldval))
  535.   if (fldtotal > 0)
  536. #>>
  537.  
  538. PROCEDURE VLU
  539. PARAMETER lookals,lookexp,lookmsg
  540. PRIVATE origals,notvalid
  541.    origals = STR( SELECT(),2 )
  542.    SELECT &lookals
  543.    SEEK lookexp
  544.    notvalid = EOF()
  545.    IF notvalid
  546.       * ---Could not find <exp> in <LOOKUP> file.
  547.       DO SayLine WITH PromptRow,lookmsg
  548.       WAIT
  549.       @ PromptRow,0 CLEAR
  550.    ENDIF
  551.    SELECT &origals
  552. RETURN .NOT. notvalid
  553.  
  554.   <<endif>>
  555.   <<select all fields>>
  556. <<end GenFuncStandard>>
  557.  
  558.  
  559. <<procedure GenExecSeek>>
  560. <<string fixedkey>>
  561. <<begin>>
  562.   <<fixedkey := fixautomem(ndxkey)>>
  563.   <<if ndxtyp = 'C'>>
  564.       expr = TRIM( {fixedkey} )
  565.       IF "" <> expr
  566.          SEEK expr
  567.       ENDIF
  568.   <<elsif ndxtyp = 'N'>>
  569.       expr = {fixedkey}
  570.       IF expr <> 0
  571.          SEEK expr
  572.       ENDIF
  573.   <<else>>  <<*DATE type*>>
  574.       expr = {fixedkey}
  575.       IF DTOC(expr) <> "  /  /  "
  576.          SEEK expr
  577.       ENDIF
  578.   <<endif>>
  579. <<end GenExecSeek>>
  580.  
  581.  
  582. <<#
  583. procedure GenKeySeek
  584. string  pic,firstpart,keyfld
  585. integer count
  586. begin
  587.   select all fields
  588.   select fields on (fldtyp $ 'CDN') and (fldals <> 'M')
  589.   forall (upper(fldnam) $ upper(ndxkey)) and (forcount <= 2)
  590.     keyfld := fixfldnam
  591. #>>
  592.     <<if fldtyp = 'C'>>
  593.       {keyfld} = SPACE({fldwid})
  594.     <<elsif fldtyp = 'N'>>
  595.       {keyfld} = 0.0
  596.     <<else>>
  597.       {keyfld} = CTOD("  /  /  ")
  598.     <<endif>>
  599. <<#
  600.   endfor
  601.   count := 0
  602.   forall (upper(fldnam) $ upper(ndxkey)) and (forcount <= 2)
  603.     count := count + 1
  604.     keyfld := fixfldnam
  605.  
  606.     if forcount = 1
  607.       firstpart := '@ row,  0 SAY "Enter ' + fldnam + '"'
  608.     else
  609.       firstpart := '@ row+1,0 SAY "      ' + fldnam + '"'
  610.     endif
  611.  
  612.     <<*---PICTURE---*>>
  613.     pic := fldpic
  614.     if fldtyp = 'N'  <<*Force PICTURE on Numerics*>>
  615.       pic := replicate( '9',fldwid )
  616.       if flddec
  617.         pic[ fldwid-flddec ] := '.'
  618.       endif
  619.     endif
  620. #>>
  621.     <<if pic>>
  622.       {firstpart} GET {keyfld} PICTURE {"}{pic}{"}
  623.     <<else>>
  624.       {firstpart} GET {keyfld}
  625.     <<endif>>
  626.   <<endfor>>
  627.   <<if count = 0>>
  628.       * ---Key expression:  {ndxkey}
  629.       DO SayLine WITH row,"Key expression does not match database file."
  630.       WAIT
  631.       @ row,0 CLEAR
  632.   <<else>>
  633.       READ
  634.     <<GenExecSeek>>
  635.   <<endif>>
  636.   <<select all fields>>
  637. <<end GenKeySeek>>
  638.  
  639.  
  640. <<procedure GenSingleSEEK>>
  641. <<string alpha,fixedkey>>
  642. <<begin>>
  643.  
  644. <<alpha := chr( dbfcount + 64 )>>
  645. <<if ismultials>>
  646. PROCEDURE {fileprefix}_{alpha}SEE
  647. <<else>>
  648. PROCEDURE {fileprefix}_SEEK
  649. <<endif>>
  650. PARAMETER row
  651. PRIVATE expr
  652.   <<if not ismultials>>
  653.    IF NdxOrder = "0"
  654.       RETURN
  655.    ENDIF
  656.   <<endif>>
  657.   <<GenColor( 1,'PROMPT' )>>
  658.    @ row,0 CLEAR
  659.    DO CASE
  660.   <<forall indexes>>
  661.    CASE NdxOrder = {"}{ndxcount}{"}
  662.     <<GenKeySeek>>
  663.   <<endfor>>
  664.    ENDCASE
  665. RETURN
  666.  
  667. <<end GenSingleSEEK>>
  668.  
  669.  
  670. <<procedure GenMultiSEEK>>
  671. <<string alpha>>
  672. <<begin>>
  673.  
  674. PROCEDURE {fileprefix}_SEEK
  675. PARAMETER row
  676.    IF NdxOrder = "0"
  677.       RETURN
  678.    ENDIF
  679.    DO CASE
  680.   <<forall databases>>
  681.    CASE dbfarea = {"}{dbfcount}{"}
  682.     <<alpha := chr( dbfcount + 64 )>>
  683.     <<if ndxtotal > 0>>
  684.       DO {fileprefix}_{alpha}SEE WITH row
  685.     <<else>>
  686.       * ---<none>.
  687.     <<endif>>
  688.   <<endfor>>
  689.    ENDCASE
  690. RETURN
  691.  
  692. <<end>> <<*GenMultiSEEK*>>
  693.  
  694.  
  695. <<procedure GenSetIndex( procname : string )>>
  696. <<string keydisp,keyopts,ndxnames>>
  697. <<integer width>>
  698. <<begin>>
  699.  
  700. PROCEDURE {procname}
  701. PARAMETER row,ndxchoice
  702.    <<GenColor( 1,'PROMPT' )>>
  703.    @ row,0 CLEAR
  704. <<#
  705.    forall indexes
  706.      filespec( ndxnam,fpath,fname,fext )
  707.      keydisp := keydisp + ' ' + str( ndxcount ) + '-' + fname + ' '
  708.      genln('   MSG',str( ndxcount ),' = "',fname,'"' )
  709.      keyopts := keyopts + str( ndxcount )
  710.    endfor
  711. #>>
  712.    @ 24,0 CLEAR
  713.    @ 24,0 SAY 'Select index...'
  714.    DO {fileprefix}_menu WITH 1,50,{ ndxtotal },8
  715.    IF menuchoice = 0
  716.       RETURN
  717.    ENDIF
  718.    STORE STR(menuchoice,1,0) to ndxchoice, NdxOrder
  719.    SET ORDER TO &NdxOrder
  720. RETURN
  721.  
  722. <<end>> <<*GenSetIndex*>>
  723.  
  724.  
  725. <<procedure GenSetNdxs>>
  726. <<string alpha,keydisp,keyopts,ndxnames>>
  727. <<begin>>
  728.  
  729. PROCEDURE {fileprefix}_NDXS
  730. PARAMETER row,ndxchoice
  731.    DO CASE
  732.  <<forall databases>>
  733.    CASE dbfarea = {"}{dbfcount}{"}
  734.    <<alpha := chr( dbfcount + 64 )>>
  735.    <<if ndxtotal > 1>>
  736.       DO {fileprefix}_{alpha}NDX WITH row,ndxchoice
  737.    <<else>>
  738.       * ---Only one index.
  739.    <<endif>>
  740.  <<endfor>>
  741.    ENDCASE
  742. RETURN
  743.  
  744. <<end>> <<*GenSetNdxs*>>
  745.  
  746.  
  747. <<procedure GenSetFile>>
  748. <<string keydisp1,keyopts1,keydisp2,keyopts2,ndxnames>>
  749. <<integer width>>
  750. <<begin>>
  751.  
  752. PROCEDURE {fileprefix}_FILE
  753. PARAMETER row,dbfchoice
  754.    <<GenColor( 1,'PROMPT' )>>
  755.    @ row,0 CLEAR
  756. <<#
  757.    forall databases
  758.      filespec( dbfnam,fpath,fname,fext )
  759.      if forcount <= 5
  760.        keydisp1 := keydisp1 + ' ' + str( dbfcount ) + '-' + fname + ' '
  761.        keyopts1 := keyopts1 + str( dbfcount )
  762.      else
  763.        keydisp2 := keydisp2 + ' ' + str( dbfcount ) + '-' + fname + ' '
  764.        keyopts2 := keyopts2 + str( dbfcount )
  765.      endif
  766.    endfor
  767.    select all databases
  768. #>>
  769.  <<if dbftotal <= 5>>
  770.    @ row,0 SAY {"}SELECT: {keydisp1}{"}
  771.  <<else>>
  772.    @ row+1,0 SAY {"}        {keydisp2}{"}
  773.    @ row,0 SAY {"}SELECT: {keydisp1}{"}
  774.  <<endif>>
  775.    DO GetKey WITH dbfchoice,{"}{keyopts1}{keyopts2}{"}+Returnkey
  776.    IF dbfchoice = Returnkey
  777.       RETURN
  778.    ENDIF
  779.    dbfarea = dbfchoice
  780.    DO {fileprefix}_AREA
  781. RETURN
  782.  
  783. <<end>> <<*GenSetFile*>>
  784.  
  785.  
  786. <<procedure GenSetArea>>
  787. <<begin>>
  788.  
  789. PROCEDURE {fileprefix}_AREA
  790. PRIVATE oldrecnum
  791.    SELECT &dbfarea
  792.    oldrecnum = RECNO()
  793.   <<if ismultials>>
  794.    DO CASE
  795.   <<endif>>
  796. <<forall databases>>
  797.   <<if ismultials>>
  798.    CASE dbfarea = {"}{dbfcount}{"}
  799.     <<pushmargin( 2 )>>
  800.   <<else>>
  801.     <<pushmargin( 1 )>>
  802.   <<endif>>
  803. <<#
  804.    GenFileVars
  805.    if ndxtotal = 0
  806.      genln( '* ---<No indexes>.' )
  807.      genln( 'NdxOrder = "0"' )
  808.    else
  809.      GenIndexVars
  810.      genln( 'NdxOrder = "1"' )
  811.    endif
  812.    if ismultipage
  813.      select field 1
  814.      genln( 'pageno = ',fldpag )
  815.      genln( 'dbfpagemax = ',pagtotal )
  816.    endif
  817.    popmargin
  818.  endfor
  819. #>>
  820.   <<if ismultials>>
  821.    ENDCASE
  822.   <<endif>>
  823.    LastRec = RECCOUNT()
  824.    IF oldrecnum > 0 .AND. LastRec > 0
  825.       GOTO oldrecnum
  826.    ENDIF
  827. RETURN
  828.  
  829. <<end GenSetArea>>
  830.  
  831.  
  832. <<#
  833. procedure GenProcSecond
  834. begin
  835.   GenSetArea
  836.   if ismultials
  837.     GenSetFile
  838.   endif
  839.   GenFuncStandard
  840.   select all
  841.   if ndxtotal > 1
  842.     if ismultials
  843.       forall databases
  844.         if ndxtotal > 1
  845.           GenSetIndex( fileprefix + '_' + chr( 64 + dbfcount ) + 'NDX' )
  846.         endif
  847.       endfor
  848.       if ismultindx
  849.         GenSetNdxs
  850.       endif
  851.     else
  852.       select database 1
  853.       GenSetIndex( fileprefix + '_NDXS' )
  854.     endif
  855.   endif
  856.   select all
  857.   if ndxtotal > 0  <<*Total ndxs for entire system*>>
  858.     if ismultials
  859.       forall databases
  860.         if ndxtotal > 0  <<*Total ndxs for each dbf*>>
  861.           GenSingleSEEK
  862.         endif
  863.       endfor
  864.       GenMultiSEEK
  865.     else
  866.       select database 1
  867.       GenSingleSEEK
  868.     endif
  869.   endif
  870. end>> <<*GenProcSecond*>>
  871.  
  872. <<* EOF: MSAPROC.INC *>>
  873. #>>
  874.  
  875.