home *** CD-ROM | disk | FTP | other *** search
/ Share Gallery 1 / share_gal_1.zip / share_gal_1 / DB / DB004A.ZIP / BASEPROG.EXE / lha / DBMANAGE.SRC < prev    next >
Text File  |  1990-03-10  |  15KB  |  174 lines
  1. |2010 DIM TITLE$(4),TITLEHORIZ%(4):BLINKNORMAL%=|28:BLINKINSERT%=|29:BLINK2%=|30 'For CGA or EGA adapter, BLINKNORMAL%=6, BLINKINSERT%=4 and BLINK2%=7. For Monochrome adapter, BLINKNORMAL%=13, BLINKINSERT%=9 and BLINK2%=14.
  2. 2020 TITLEHORIZ%(1)=2:TITLE$(1)=" Add Record ":TITLEHORIZ%(2)=14:TITLE$(2)=" Modify/Look At Record ":TITLEHORIZ%(3)=37:TITLE$(3)=" Delete Record "
  3. *32 2030 TITLEHORIZ%(4)=52:TITLE$(4)=" Select With "+CHR$(26)+" "+CHR$(27)+" Then Enter"
  4. *33 2030 TITLEHORIZ%(4)=52:TITLE$(4)=" Select With "+CHR$(26)+CHR$(27)+CHR$(24)+CHR$(25)+" Then Enter"
  5. 2040 NEWTITLE%=1:LASTTITLE%=1:NEWFILE%=1:LASTFILE%=1:FILEINCREMENT%=2:IF ZQ>6 THEN FILEINCREMENT%=1
  6. 2050 CLS:COLOR COLA%(2),0:PRINT TAB(29);"PDS*BASE File Work Menu For":PRINT:Z2=LEN(ZB$):PRINT TAB(INT((75-Z2)/2));ZB$;" Data Base":COLOR 7,0:PRINT:LOCATE ,,1
  7. 2060 COLOR COLA%(3),0:FOR J=1 TO 3:LOCATE 5,TITLEHORIZ%(J),0:PRINT TITLE$(J);:NEXT:LOCATE 5,TITLEHORIZ%(LASTTITLE%),0:COLOR 0,COLA%(3):PRINT TITLE$(LASTTITLE%);:COLOR 7,0
  8. 2070 LOCATE 5,TITLEHORIZ%(4),0:COLOR 15,0:PRINT TITLE$(4);:COLOR 7,0
  9. 2080 ' *** The following titles are from the file names. You may wish to change them to more people frendly menu titles and remove this REM line. ***
  10. 2090 LOCATE 7,1,0:COLOR COLA%(14),0
  11. *34
  12. 2300 LOCATE 24,33,0:COLOR 15,0:PRINT "Esc = End Program";:COLOR 7,0
  13. *33 2310 LOCATE 6+(LASTFILE%*FILEINCREMENT%),60,0:COLOR 0,COLA%(3):PRINT "Selected File";:COLOR 7,0
  14. 2320 A$="":WHILE A$="":A$=INKEY$:WEND:IF ASC(A$)=27 THEN LOCATE 23,38:GOTO 400 ELSE IF ASC(A$)=13 THEN GOTO 2400
  15. *32 2330 IF LEN(A$)=1 THEN SOUND 400,1:GOTO 2320 ELSE A%=ASC(RIGHT$(A$,1)):IF A%<>75 AND A%<>77 THEN SOUND 400,1:GOTO 2320
  16. *33 2330 IF LEN(A$)=1 THEN SOUND 400,1:GOTO 2320 ELSE A%=ASC(RIGHT$(A$,1)):IF A%<>72 AND A%<>75 AND A%<>77 AND A%<>80 THEN SOUND 400,1:GOTO 2320
  17. 2340 IF A%=75 THEN NEWTITLE%=LASTTITLE%-1:IF NEWTITLE%=0 THEN NEWTITLE%=3
  18. 2350 IF A%=77 THEN NEWTITLE%=LASTTITLE%+1:IF NEWTITLE%=4 THEN NEWTITLE%=1
  19. 2360 IF A%=75 OR A%=77 THEN LOCATE 5,TITLEHORIZ%(LASTTITLE%),0:COLOR COLA%(3),0:PRINT TITLE$(LASTTITLE%);:LOCATE 5,TITLEHORIZ%(NEWTITLE%),0:COLOR 0,COLA%(3):PRINT TITLE$(NEWTITLE%);:COLOR 7,0:LASTTITLE%=NEWTITLE%:GOTO 2320
  20. *33 2370 IF A%=72 THEN NEWFILE%=LASTFILE%-1:IF NEWFILE%=0 THEN NEWFILE%=ZQ
  21. *33 2380 IF A%=80 THEN NEWFILE%=LASTFILE%+1:IF NEWFILE%>ZQ THEN NEWFILE%=1
  22. *33 2390 IF A%=72 OR A%=80 THEN LOCATE 6+(LASTFILE%*FILEINCREMENT%),60,0:PRINT SPC(15):LOCATE 6+(NEWFILE%*FILEINCREMENT%),60,0:COLOR 0,COLA%(3):PRINT "Selected File";:COLOR 7,0:LASTFILE%=NEWFILE%:GOTO 2320
  23. *32 2400 ZA=1:ZM=1
  24. *33 2400 ZA=NEWFILE%:ZM=ZA
  25. 2410 CLS:ON NEWTITLE% GOSUB 2500,2800,2800:GOTO 2050
  26. 2500 ' Add New Data Records
  27. *23 2510 IF ZS%(ZA,1)=1 GOTO 2560
  28. *23 2520 ZS=ZA:Y11=0:FOR ZI=1 TO ZQ:IF ZS$(ZA,2)=ZS$(ZI,1) THEN Y11=ZI:ZM=ZI:ZI=ZQ
  29. *23 2530 NEXT:IF Y11=0 THEN BEEP:PRINT "NO MASTER SET FOUND FOR '";ZS$(ZA,1);".":FOR ZI=1 TO 5000:NEXT:RETURN
  30. *23 2540 COLOR COLA%(2),0:PRINT "First Enter ";ZN$(ZM,1,1);" ";:COLOR 7,0:INPUT YC$:IF YC$="" THEN RETURN ELSE ZR$=STRING$(ZSIZE%(ZM,1),32):LSET ZR$=YC$
  31. *23 2550 ZA=ZM:GOSUB 500:GOSUB 600:YM=ZR:ZA=ZS:ZMASTER$=ZN$(ZM,1,1)+"="+YC$:IF ZV>0 THEN ZA=NEWFILE%:PRINT "Strike any key to continue":YQ$=INPUT$(1):RETURN
  32. 2560 'Add New Record
  33. 2570 PROGLOOP%=1
  34. 2580 WHILE PROGLOOP%=1
  35. 2590    GOSUB 5000:IF (ZI=1 AND (ZI$(ZS%(ZA,10),ZA)=STRING$(ZSIZE%(ZA,ZS%(ZA,10)),32) OR (FLDTYPE%=4 AND ZI$(ZS%(ZA,10),ZA)="  -  -  ")) ) OR ESCFLAG%=1 THEN RETURN  'do not create the present record
  36. 2600    IF ZS%(ZA,1)=1 THEN ZR$=ZI$(ZS%(ZA,10),ZA):GOSUB 800:ZA=NEWFILE%
  37. *23 2610    IF ZS%(ZA,1)=2 THEN GOSUB 1000:ZA=NEWFILE%
  38. 2620 WEND 
  39. 2800 ' Modify Data Set
  40. 2810 Y5=0
  41. *23 2820 IF ZS%(ZA,1)=1 THEN ZM=ZA:GOTO 2850
  42. *23 2830 ZS=ZA:Y11=0:FOR ZI=1 TO ZQ:IF ZS$(ZA,2)=ZS$(ZI,1) THEN Y11=ZI:ZM=Y11:ZI=ZQ
  43. *23 2840 NEXT:IF Y11=0 THEN BEEP:PRINT "NO MASTER SET FOUND FOR '";ZS$(ZA,1);".":FOR ZI=1 TO 5000:NEXT:RETURN
  44. 2850 CLS:LOCATE 15,23,0:COLOR 15,0:PRINT "Enter=Return To Menu, \=Same As Last";:COLOR COLA%(2),0:LOCATE 1,1,1:IF ZS%(ZA,1)=1 THEN PRINT "Enter Existing ";ZN$(ZM,1,1); ELSE PRINT "Enter Existing Master ";ZN$(ZM,1,1);
  45. 2860 COLOR 7,0:INPUT YC$:IF YC$="" THEN RETURN ELSE IF YC$<>"\" THEN ZR$=STRING$(ZSIZE%(ZM,1),32):LSET ZR$=YC$
  46. *23 2870 IF ZS%(NEWFILE%,1)=2 THEN ZA=ZM
  47. 2880 GOSUB 500:GOSUB 600
  48. *23 2890 IF ZS%(NEWFILE%,1)=2 THEN YM=ZR
  49. 2900 IF ZV>0 THEN ZA=NEWFILE%:PRINT "Strike any key to continue":YQ$=INPUT$(1):GOTO 2800
  50. 2910 IF ZS%(NEWFILE%,1)=1 THEN GOSUB 1500:IF NEWTITLE%=3 THEN GOSUB 3200:GOTO 2850 ELSE ALTM%=1:GOSUB 5000:IF ESCFLAG%=0 THEN GOSUB 750:GOTO 2850 ELSE GOTO 2850
  51. *23 |2920 ZA=ZS:Y2=0:FOR ZI=2 TO |09
  52. *23 |2930 IF ZS$(ZM,ZI)=ZS$(ZS,1) THEN Y2=ZI-1:ZI=|09
  53. *23 2940 NEXT
  54. *23 2950 ZR=ZH(Y2):Y3=0:IF ZR=0 THEN BEEP:PRINT "NO DETAIL DATA FOR THIS MASTER":PRINT "Strike any key to continue";:ZQ$=INPUT$(1):GOTO 2800 'we now have the chain head in the Detail set
  55. *23 2960 ZA=ZS:GOSUB 600:GOSUB 1500:Y3=Y3+1
  56. *23 2970 CURRENTFIRST=1:GOSUB 7000:IF ZR=ZH(Y2) THEN Y3=1
  57. *23 2980 LOCATE 24,16:COLOR COLA%(2),0:PRINT "PgDn=Next, PgUp=Previous Record,";:LOCATE 24,1,0:PRINT "Detail #";:IF Y3>0 THEN PRINT Y3; ELSE IF Y3<>-31999 THEN PRINT "L";(Y3+31999);
  58. *23 2990 IF NEWTITLE%=2 THEN LOCATE 24,49:PRINT " Alt/M=Modify Record";SPC(11);
  59. *23 3000 IF NEWTITLE%=3 THEN LOCATE 24,49:PRINT " Alt/D=Delete Record";SPC(11);
  60. *23 3010 IF ZR=ZE(Y2) THEN LOCATE 24,72,0:SOUND 400,1:COLOR 23,0:PRINT "Last Rec";:COLOR 7,0
  61. *23 3020 COLOR 7,0:YQ$="":WHILE YQ$="":YQ$=INKEY$:WEND:IF ASC(YQ$)=27 OR ASC(YQ$)=13 THEN GOTO 2800
  62. *23 3030 IF LEN(YQ$)=2 THEN PGUP%=0:PGDN%=0:YC%=ASC(RIGHT$(YQ$,1)):GOSUB 5600
  63. *23 3040 IF PGUP%=1 THEN IF Y3<>1 THEN Y3=Y3-2:ZR=ZB:GOTO 2960 ELSE ZR=ZE(Y2):Y3=-32000:GOTO 2960
  64. *23 3050 IF PGDN%=1 THEN IF ZF>0 THEN ZR=ZF:GOTO 2960 ELSE ZR=ZH(Y2):Y3=0:GOTO 2960
  65. *23 3060 IF NEWTITLE%=2 AND ALTM%=1 THEN LOCATE 24,1,0: PRINT "  Alt/S or Ctrl/End = Save Modification  -  Esc = Escape Without Modification  ";:GOSUB 5020:PGDN%=1:IF ESCFLAG%=0 THEN GOSUB 750:GOTO 3050 ELSE GOTO 2800
  66. *23 3070 IF NEWTITLE%=3 AND ALTD%=1 THEN GOSUB 3200:PGDN%=1:ALTD%=0:GOTO 3050
  67. *23 3080 GOTO 2800
  68. 3200 'Delete Data Record
  69. 3210 LOCATE 24,1,0:PRINT SPC(79):LOCATE 24,20,0:SOUND 400,1:COLOR 0,COLA%(2):PRINT "Do You Wish To Delete The Above ";:COLOR 0,COLA%(3):PRINT "N";:LOCATE ,POS(0)-1,1:YQ$="":WHILE YQ$="":YQ$=INKEY$:WEND:PRINT YQ$;:COLOR 7,0
  70. 3220 IF YQ$<>"Y" AND YQ$<>"y" THEN RETURN
  71. 3230 IF ZS%(ZA,1)=1 THEN GOSUB 1200:RETURN
  72. *23 3240 IF ZS%(ZA,1)=2 THEN YS=ZR:GOSUB 1300
  73. *23 3250 ZA=NEWFILE%:RETURN
  74. 5000 ' ** Subroutine to input data **
  75. 5010 CURRENTFIRST=1:GOSUB 7000
  76. 5020 FOR ZI=CURRENTFIRST TO CURRENTLAST
  77. 5030    IF ZS%(ZA,1)=1 AND NEWTITLE%=2 THEN IF ZI=1 AND ZI=ZS%(ZA,10) THEN ZI=ZI+1 'can't modify search value
  78. 5040    EFLAG%=1:ESCFLAG%=0:CFLAG%=0:FLDUP%=0:FLDDOWN%=0:PGUP%=0:PGDN%=0:HOMEFLAG%=0:ENDFLAG%=0:ALTM%=0:ALTD%=0:ZENDSAVE%=0:INSERT%=0:FLDTYPE%=INSTR("CIRD",MID$(ZN$(ZA,ZI,2),2,1)):NOMSG%=0
  79. 5050    WHILE EFLAG%=1 'loop on this field until EFLAG% set to zero
  80. 5060       LOCATE ZFLDPOSVERT%(ZA,ZI),ZFLDPOSHORIZ%(ZA,ZI),0:COLOR 0,COLA%(3):PRINT ZI$(ZI,ZA):COLOR 7,0:LOCATE ZFLDPOSVERT%(ZA,ZI),ZFLDPOSHORIZ%(ZA,ZI),1:Z2=ZSIZE%(ZA,ZI)
  81. 5070       FOR ZJ=1 TO Z2
  82. 5080          YC$="":WHILE YC$="":YC$=INKEY$:WEND:POSX%=CSRLIN:POSY%=POS(0) 'strobe keyboard for next character
  83. 5090          IF CFLAG%=1 THEN LOCATE 25,1,0:PRINT SPC(79):LOCATE POSX%,POSY%,1:CFLAG%=0
  84. 5100          IF LEN(YC$)=2 THEN YC%=ASC(RIGHT$(YC$,1)):GOSUB 5600:GOTO 5190
  85. 5110          YC%=ASC(YC$)
  86. 5120          IF YC%=27 THEN ZJ=Z2:ESCFLAG%=1:GOTO 5190
  87. 5130          IF YC%=8 THEN GOSUB 5500:GOTO 5080
  88. 5140          IF YC%=13 THEN ZJ=Z2:GOTO 5190
  89. 5150          POSY%=POS(0):ON FLDTYPE% GOSUB 5800,5850,6000,5800:IF CFLAG%=1 THEN LOCATE POSX%,POSY%,1:GOTO 5080
  90. 5160          IF INSERT%=1 THEN GOSUB 6200 
  91. 5170          COLOR 0,COLA%(3):PRINT YC$;:COLOR 7,0:MID$(ZI$(ZI,ZA),ZJ,1)=YC$
  92. 5180          IF FLDTYPE%=4 AND (ZJ=2 OR ZJ=5) THEN ZJ=ZJ+1:LOCATE ,POS(0)+1 'skip dash on Date field
  93. 5190       NEXT 'ZJ
  94. 5200       LOCATE ,,,BLINKNORMAL%,BLINK2%:INSERT%=0:IF ZI=1 THEN IF YC%=13 AND (ZI$(ZI,ZA)=STRING$(Z2,32) OR (FLDTYPE%=4 AND ZI$(ZI,ZA)="  -  -  ")) THEN RETURN 'finished adding records
  95. 5210       IF ESCFLAG%=1 THEN RETURN 'abort from this record
  96. 5220       EFLAG%=0
  97. 5230       IF MID$(ZN$(ZA,ZI,2),1,1)="R" THEN IF ZI$(ZI,ZA)=STRING$(Z2,32) THEN LOCATE 25,5,0:COLOR 15,0:SOUND 400,1:PRINT "Entry for this item required - Press 'Esc' to cancel the entire entry.";:COLOR 7,0:CFLAG%=1:EFLAG%=1:FLDUP%=0:FLDDOWN%=0
  98. 5240       IF FLDTYPE%=4 THEN CFLAG%=1:EFLAG%=1:GOSUB 6100:IF CFLAG%=0 THEN EFLAG%=0
  99. 5250    WEND 'EFLAG%
  100. 5260    IF ZENDSAVE%=1 AND NEWTITLE%=2 THEN RETURN
  101. 5270    LOCATE ZFLDPOSVERT%(ZA,ZI),ZFLDPOSHORIZ%(ZA,ZI),0:COLOR COLA%(3),0:PRINT ZI$(ZI,ZA);:COLOR 7,0:IF FLDUP%=1 THEN IF ZI>1 THEN ZI=ZI-2 ELSE ZI=CURRENTLAST-1
  102. 5280    IF HOMEFLAG%=1 THEN ZI=CURRENTFIRST-1
  103. 5290    IF ENDFLAG%=1 THEN ZI=CURRENTLAST-1
  104. 5293    IF ZS%(ZA,1)=1 AND NEWTITLE%=1 AND ZI=ZS%(ZA,10) THEN ZR$=ZI$(ZS%(ZA,10),ZA):NOMSG%=1:GOSUB 500:GOSUB 600:IF ZV=0 THEN NEWTITLE%=2:GOSUB 1500:GOSUB 7000:NEWTITLE%=1:GOSUB 7000:NOMSG%=0:GOTO 5040
  105. 5295    IF PGUP%=1 OR PGDN%=1 THEN ZI=CURRENTLAST
  106. 5300 NEXT 'ZI
  107. 5310 IF CURRENTLAST < ZS%(ZA,7) THEN CURRENTFIRST=CURRENTLAST+1:GOSUB 7000:GOTO 5020
  108. 5315 IF CURRENTFIRST > 1 THEN IF PGUP%=1 THEN CURRENTFIRST=1:GOSUB 7000:GOTO 5020
  109. 5320 IF NEWTITLE%=2 THEN GOTO 5020
  110. 5330 RETURN
  111. 5500 'Subroutine for backspace
  112. 5520 IF ZJ=1 THEN RETURN
  113. 5530 IF FLDTYPE%=4 AND EFLAG%=0 THEN IF ZJ=3 OR ZJ=7 THEN LOCATE ,POS(0)-2:ZJ=ZJ-2:RETURN 'skip spaces on Date field
  114. 5540 LOCATE ,POS(0)-1,1:COLOR 0,COLA%(3):PRINT " ";:COLOR 7,0:LOCATE ,POS(0)-1,1:MID$(ZI$(ZI,ZA),ZJ-1,1)=" ":ZJ=ZJ-1
  115. 5550 RETURN
  116. 5600 'Extended code key pressed
  117. 5610 IF YC%=72 THEN FLDUP%=1:ZJ=Z2:RETURN
  118. 5620 IF YC%=80 THEN FLDDOWN%=1:ZJ=Z2:RETURN
  119. 5630 IF (YC%=73 AND CURRENTFIRST%>1) OR (YC%=73 AND NEWTITLE%>1) THEN PGUP%=1:ZJ=Z2:RETURN ELSE IF YC%=81 AND NEWTITLE%>1 THEN PGDN%=1:ZJ=Z2:RETURN
  120. 5640 IF YC%=75 THEN ZJ=ZJ-1:IF ZJ>0 THEN ZJ=ZJ-1:LOCATE ,POS(0)-1:IF FLDTYPE%=4 AND (ZJ=3 OR ZJ=6) THEN ZJ=ZJ-1:LOCATE ,POS(0)-1:RETURN ELSE RETURN 'left arrow
  121. 5650 IF YC%=77 AND ZJ<Z2 THEN LOCATE ,POS(0)+1:IF FLDTYPE%=4 AND (ZJ=3 OR ZJ=6) THEN LOCATE ,POS(0)+1:ZJ=ZJ+1:RETURN ELSE RETURN 'right arrow
  122. 5660 IF YC%=71 THEN HOMEFLAG%=1:ZJ=Z2:RETURN 'home key
  123. 5670 IF YC%=79 THEN ENDFLAG%=1:ZJ=Z2:RETURN 'end key
  124. 5680 IF YC%=117 OR YC%=31 THEN ZJ=Z2:ZENDSAVE%=1:RETURN 'Ctrl/Home or Alt/S to save and exit
  125. 5690 IF YC%=50 THEN ALTM%=1:RETURN
  126. 5700 IF YC%=32 THEN ALTD%=1:RETURN
  127. 5710 IF YC%=82 THEN ZJ=ZJ-1:IF INSERT%=0 AND ZJ<Z2 THEN INSERT%=1:LOCATE ,,,BLINKINSERT%,BLINK2%:RETURN ELSE INSERT%=0:LOCATE ,,,BLINKNORMAL%,BLINK2%:RETURN ' insert key
  128. 5720 IF YC%=83 THEN IF ZJ<Z2 THEN FLD$=MID$(ZI$(ZI,ZA),ZJ+1)+" " ELSE FLD$=" " 'delete key
  129. 5730 IF YC%=83 THEN COLOR 0,COLA%(3):LOCATE ,,0:PRINT FLD$:COLOR 7,0:LOCATE ZFLDPOSVERT%(ZA,ZI),POSY%,1:MID$(ZI$(ZI,ZA),ZJ)=FLD$:ZJ=ZJ-1:RETURN 'delete key
  130. 5740 SOUND 400,1:RETURN 'key not used
  131. 5800 'Character type field
  132. 5810 IF YC%>31 AND YC%<127 THEN RETURN
  133. 5820 SOUND 400,1:CFLAG%=1
  134. 5830 LOCATE 25,31,0:COLOR 15,0:PRINT "Illegal key stroke";:COLOR 7,0
  135. 5840 RETURN
  136. 5850 'Integer type field
  137. 5860 IF (YC%>47 AND YC%<58) OR YC%=32 OR YC%=43 OR YC%=45 THEN RETURN
  138. 5870 SOUND 400,1:CFLAG%=1
  139. 5880 LOCATE 25,30,0:COLOR 15,0:PRINT "Must be whole number";:COLOR 7,0
  140. 5890 RETURN
  141. 6000 'Real number type field
  142. 6010 IF (YC%>42 AND YC%<58 AND YC%<>44 AND YC%<>47) OR YC%=32 THEN RETURN
  143. 6020 SOUND 400,1:CFLAG%=1
  144. 6030 LOCATE 25,32,0:COLOR 15,0:PRINT "Must be a number";:COLOR 7,0
  145. 6040 RETURN
  146. 6100 'Date type field
  147. 6110 ZMTH%=VAL(MID$(ZI$(ZI,ZA),1,2)):ZDAY%=VAL(MID$(ZI$(ZI,ZA),4,2)):ZYR=VAL(MID$(ZI$(ZI,ZA),7,2)):IF MID$(ZI$(ZI,ZA),7,2)="00" THEN ZYR=2000 ELSE IF ZYR=0 THEN SOUND 400,1:LOCATE 25,29,0:COLOR 15,0:PRINT "Year must have a value";:COLOR 7,0:RETURN
  148. 6120 IF ZMTH%<10 THEN IF MID$(ZI$(ZI,ZA),1,1)<>"0" THEN MID$(ZI$(ZI,ZA),1,2)=MID$(STR$(ZMTH%),2):LOCATE ZFLDPOSVERT%(ZA,ZI),ZFLDPOSHORIZ%(ZA,ZI),0:COLOR 0,7:PRINT MID$(ZI$(ZI,ZA),1,2);:COLOR 7,0
  149. 6130 IF ZDAY%<10 THEN IF MID$(ZI$(ZI,ZA),4,1)<>"0" THEN MID$(ZI$(ZI,ZA),4,2)=MID$(STR$(ZDAY%),2):LOCATE ZFLDPOSVERT%(ZA,ZI),ZFLDPOSHORIZ%(ZA,ZI),0:COLOR 0,7:PRINT MID$(ZI$(ZI,ZA),4,2);:COLOR 7,0
  150. 6140 IF ZMTH%<1 OR ZMTH%>12 THEN SOUND 400,1:LOCATE 25,26,0:COLOR 15,0:PRINT "Month must be 01 through 12";:COLOR 7,0:RETURN
  151. 6150 IF ZMTH%=2 AND ZDAY%=29 AND ((ZTEST/4)=INT(ZTEST/4)) AND ZTEST<>2000 THEN CFLAG%=0:RETURN
  152. 6160 IF ZMTH%=2 AND ZDAY%<=28 THEN CFLAG%=0:RETURN
  153. 6170 IF (ZMTH%=1 OR ZMTH%=3 OR ZMTH%=5 OR ZMTH%=7 OR ZMTH%=8 OR ZMTH%=10 OR ZMTH%=12) AND ZDAY% <= 31 THEN CFLAG%=0:RETURN 
  154. 6180 IF (ZMTH%=4 OR ZMTH%=6 OR ZMTH%=9 OR ZMTH%=11) AND ZDAY%<=30 THEN CFLAG%=0:RETURN 
  155. 6190 SOUND 400,1:LOCATE 25,25,0:COLOR 15,0:PRINT "Day out of range for the month";:COLOR 7,0:RETURN
  156. 6200 'Handle Inserted Character
  157. 6210 IF FLDTYPE%=4 OR ZJ=Z2 THEN RETURN 'no insert on Date field or if at end of field
  158. 6220 FLD$=MID$(ZI$(ZI,ZA),ZJ,Z2-ZJ)
  159. 6230 MID$(ZI$(ZI,ZA),ZJ+1,Z2-ZJ-1)=FLD$:COLOR 0,COLA%(3):LOCATE ,POSY%+1,0:PRINT FLD$;:COLOR 7,0:LOCATE ,POSY%,1
  160. 6240 RETURN
  161. 7000 'Display current screen
  162. 7010 CLS:FOR J=CURRENTFIRST TO ZS%(ZA,7)
  163. 7020 CURRENTLAST=J:IF J>CURRENTFIRST AND ZNAMEPOSVERT%(ZA,J)=1 THEN CURRENTLAST=J-1:J=ZS%(ZA,7):GOTO 7070
  164. 7030 IF NEWTITLE%=1 THEN ZI$(J,ZA)=STRING$(ZSIZE%(ZA,J),32):IF MID$(ZN$(ZA,J,2),2,1)="D" THEN LSET ZI$(J,ZA)="  -  -  "
  165. 7040 LOCATE ZNAMEPOSVERT%(ZA,J),1:COLOR COLA%(2),0:PRINT ZN$(ZA,J,1);"=";:LOCATE ZFLDPOSVERT%(ZA,J),ZFLDPOSHORIZ%(ZA,J),0
  166. 7050 COLOR COLA%(3),0:PRINT ZI$(J,ZA);:COLOR 7,0
  167. 7060 NEXT 'J
  168. 7070 IF NEWTITLE%=1 AND ZS%(NEWFILE%,1)=1 THEN LOCATE 24,1:COLOR COLA%(2),0:PRINT "Esc=Abort";:LOCATE 24,60:PRINT CHR$(17)+CHR$(217)+" On 1st Field=Done";:COLOR 7,0
  169. 7075 IF NEWTITLE%=2 AND ZS%(NEWFILE%,1)=1 AND NOMSG%=1 THEN SOUND 400,1:LOCATE 24,12:COLOR COLA%(2),0:PRINT "This Master already exists - Strike any key to continue";: COLOR 7,0:ZQ$=INPUT$(1)
  170. 7080 IF NEWTITLE%=1 AND ZS%(NEWFILE%,1)=2 THEN LOCATE 24,1,0:COLOR COLA%(2),0:PRINT "Adding ";ZS$(NEWFILE%,1);" Detail for ";ZMASTER$;:LOCATE 25,1:PRINT "Esc=Abort";:LOCATE 25,73:PRINT CHR$(17)+CHR$(217)+"=Done";:COLOR 7,0
  171. 7090 IF NEWTITLE%=2 AND ZS%(NEWFILE%,1)=1 AND NOMSG%=0 THEN LOCATE 24,3,0:COLOR COLA%(2),0:PRINT "Alt/S or Ctrl/End = Save Modification  -  Esc = Escape Without Modification";:COLOR 7,0
  172. 7100 RETURN
  173. *31 Copyright 1987 by PRO DEV Software
  174.