home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Basic / Samples / DBFM2 / DBFM2.ZIP / MYLIB.BAS < prev    next >
Encoding:
BASIC Source File  |  1994-02-06  |  23.0 KB  |  681 lines
  1. Declare SUB IM (xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  2.  
  3. 'COLOR 14, 1
  4. 'CALL SaveScrn(a$)
  5. 'CLS : FILES
  6. 'CALL SaveScrn(b$)
  7. 'CLS : SHELL "DIR"
  8. 'CALL SaveScrn(c$)
  9. 'CLS
  10. 'PRINT "Press a key...";
  11. 'DO: LOOP WHILE INKEY$ = ""
  12. 'CALL RestoreScrn(c$)
  13. 'CALL PopWindow(10, 10, 20, 70, 78)
  14. 'LOCATE 25, 1
  15. 'PRINT "Press a key...";
  16. 'DO: LOOP WHILE INKEY$ = ""
  17. 'CALL RestoreScrn(b$)
  18. 'LOCATE 25, 1
  19. 'PRINT "Press a key...";
  20. 'DO: LOOP WHILE INKEY$ = ""
  21. 'CALL RestoreScrn(a$)
  22. 'LOCATE 25, 1
  23. 'PRINT "Press a key...";
  24. 'CLS
  25. 'END
  26.  
  27. SUB AddKeyRec (krs%, ky$, Rec$, rn&, status%) public
  28.   CALL Info(krs%, xn%, kl%, Rfn%, Rfl%)
  29.   if Rfl%>0 then rn& = (LOF(Rfn%) \ Rfl%) + 1
  30.   fc$ = "A": CALL im(xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  31.   status% = rc%    ' rc% = 109 is duplicate key
  32.   IF rc% <> 0 THEN
  33.     CALL IndexError(rc%)
  34.   ELSE
  35.     IF LEN(Rec$) < Rfl% THEN Rec$ = Rec$ + SPACE$(Rfl% - LEN(Rec$))
  36.     if len(Rec$)>0 and rn&>0 then PUT #Rfn%, rn&, Rec$
  37.   END IF
  38. END SUB
  39.  
  40. SUB Cdate (dt$) public
  41.   ' Format Date$ converted to YYMMDD  dt$ passed as ""
  42.   ' Format YYMMDDD converted to MM-DD-YY
  43.   IF LEN(dt$) = 6 THEN
  44.     dt$ = MID$(dt$, 3, 2) + "-" + MID$(dt$, 5, 2) + "-" + MID$(dt$, 1, 2)
  45.   END IF
  46.   IF LEN(dt$) = 0 THEN
  47.     dt$ = MID$(DATE$, 9, 2) + MID$(DATE$, 1, 2) + MID$(DATE$, 4, 2)
  48.   END IF
  49. END SUB
  50.  
  51. FUNCTION ColorAttribute% (row%, col%)  public
  52.   DEF SEG = GetVideoSegment
  53.   '*** Determine the background color of the cel at row%, col% ****
  54.   step1% = (PEEK(((row% - 1) * 160) + ((col% - 1) * 2) + 1) AND &HFF)
  55.   ColorAttribute% = step1%
  56.   DEF SEG   '**** Restore BASIC's default data segment ****
  57. END FUNCTION
  58.  
  59. SUB DateEdit (row%, col%, colr%, vk$, dt$, xk%) public
  60.  ' Typ% =1  Edit MM/DD/YYYY  returns YYYYMMDD
  61.  ' Typ% =2  Edit MM/DD/YYYY  returns YYYDDD        YYY= YYYY-1700
  62.  ' Typ% =3  Edit MM/DD/YYYY  returns YYYYDDD
  63.   st$ = dt$: fld% = 10: Typ% = xk%
  64.   FOR xk% = 48 TO 57: vk$ = vk$ + CHR$(xk%): NEXT
  65.   IF colr% = -1 THEN colr% = ColorAttribute%(row%, col%)
  66.   SELECT CASE Typ%
  67.     CASE 1
  68.      st$ = MID$(dt$, 5, 2) + "-" + MID$(dt$, 7, 2) + "-" + MID$(dt$, 1, 4)
  69.     CASE 2
  70.      CALL Julian(st$)          ' get back  MM-DD-YYYY
  71.     CASE 3
  72.      CALL Julian(st$)          ' get back MM-DD-YYYY
  73.   END SELECT
  74.   DO
  75.     CALL FastPrint(row%, col%, st$, colr%)
  76.     IF c% <= 0 THEN c% = 0
  77.     IF c% = 2 THEN c% = 3
  78.     IF c% = 5 THEN c% = 6
  79.     IF c% >= fld% THEN c% = fld% - 1
  80.     LOCATE row%, (col% + c%), 1, 6, 7
  81.     xk% = KeyIn%
  82.     IF xk% > 0 AND xk% < 255 THEN
  83.       IF INSTR(vk$, CHR$(xk%)) AND c% < fld% THEN
  84.          c% = c% + 1: MID$(st$, c%, 1) = CHR$(xk%)
  85.       END IF
  86.     END IF
  87.     SELECT CASE xk%
  88.      CASE 13
  89.       SELECT CASE Typ%
  90.         CASE 1
  91.          dt$ = MID$(st$, 7, 4) + MID$(st$, 1, 2) + MID$(st$, 4, 2)
  92.         CASE 2
  93.          CALL Julian(st$)
  94.          Year% = VAL(MID$(st$, 1, 4)) - 1300
  95.          dt$ = MID$(STR$(Year%), 2) + MID$(st$, 5, 3)
  96.         CASE 3
  97.          CALL Julian(st$): dt$ = st$       ' get back YYYYDDD
  98.       END SELECT
  99.      CASE 8                         ' Backspace Key
  100.        MID$(st$, (c% + 1), 1) = " ": c% = c% - 1
  101.        IF c% = 2 THEN c% = 1
  102.        IF c% = 5 THEN c% = 4
  103.      CASE -46                          ' Alt C to clear field
  104.        st$ = "  -  -    ": c% = 0
  105.      CASE -71
  106.        c% = 0: xk% = 0                  ' Home Key  start of field
  107.      CASE -79
  108.        c% = fld% - 1: xk% = 0           ' End Key  end of field
  109.      CASE -75
  110.        c% = c% - 1: xk% = 0             ' Left Arrow Key
  111.        IF c% = 2 THEN c% = 1
  112.        IF c% = 5 THEN c% = 4
  113.      CASE -77
  114.        c% = c% + 1: xk% = 0             ' Right Arrow Key
  115.        IF c% = 2 THEN c% = 3
  116.        IF c% = 5 THEN c% = 6
  117.     END SELECT
  118.     IF xk% = -77 OR xk% = -75 OR xk% = -83 OR xk% = -82 OR xk% = -46 THEN xk% = 0
  119.     IF xk% < 0 OR xk% = 13 OR xk% = 27 THEN EXIT SUB    ' Exit keys
  120.   LOOP
  121. END SUB
  122.  
  123. FUNCTION DayOfWeek$  public
  124.   IF VAL(dt$) < 1991001 THEN
  125.     ndays& = NumDays("1991003", dt$)
  126.   ELSE
  127.     ndays& = NumDays(dt$, "1991003")
  128.   END IF
  129.   day% = 1 + (ndays& MOD 7)
  130.   SELECT CASE day%
  131.     CASE 1
  132.       DayOfWeek = "Sunday"
  133.     CASE 2
  134.       DayOfWeek = "Monday"
  135.     CASE 3
  136.       DayOfWeek = "Tuesday"
  137.     CASE 4
  138.       DayOfWeek = "Wednesday"
  139.     CASE 5
  140.       DayOfWeek = "Thursday"
  141.     CASE 6
  142.       DayOfWeek = "Friday"
  143.     CASE 7
  144.       DayOfWeek = "Saturday"
  145.     CASE ELSE
  146.       DayOfWeek = "Error"
  147.   END SELECT
  148. END FUNCTION
  149.  
  150. SUB DeleteKeyRec (krs%, ky$, Rec$, status%) public
  151.   ' Deletes Current Key & Data Record or Just Key
  152.   CALL Info(krs%, xn%, kl%, Rfn%, Rfl%)
  153.   fc$ = "R": CALL im(xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  154.   IF rc% <> 0 THEN CALL IndexError(rc%): EXIT SUB
  155.   fc$ = "D": CALL im(xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  156.   IF rc% <> 0 THEN
  157.     CALL IndexError(rc%): status% = rc%
  158.   ELSE
  159.     ' Delete Rec$ if Rec$ not a nul
  160.     IF Rec$ <> "" AND Rfn% <> 0 AND rn& > 0 THEN
  161.        Rec$ = SPACE$(Rfl%): PUT #Rfn%, rn&, Rec$
  162.     END IF
  163.   END IF
  164. END SUB
  165.  
  166. SUB EditField (row%, col%, colr%, vk$, st$, xk%) public
  167.   fld% = LEN(st$)
  168.   IF colr% = -1 THEN colr% = ColorAttribute%(row%, col%)
  169.   IF xk% > 10 THEN cap% = 1: xk% = xk% - 10
  170.   SELECT CASE xk%
  171.    CASE 1    ' All keys accepted
  172.      FOR xk% = 32 TO 126: vk$ = vk$ + CHR$(xk%): NEXT
  173.    CASE 2    ' Numeric ONLY
  174.      FOR xk% = 48 TO 57: vk$ = vk$ + CHR$(xk%): NEXT
  175.    CASE 3    ' Numeric DECIMAL
  176.      FOR xk% = 42 TO 57: vk$ = vk$ + CHR$(xk%): NEXT
  177.    CASE 4    ' Alpha ONLY
  178.      FOR xk% = 65 TO 90: vk$ = vk$ + CHR$(xk%): NEXT
  179.      FOR xk% = 97 TO 122: vk$ = vk$ + CHR$(xk%): NEXT
  180.   END SELECT
  181.   DO
  182.     IF cap% = 1 THEN st$ = UCASE$(st$)
  183.     CALL FastPrint(row%, col%, st$, colr%)
  184.     IF c% >= fld% THEN c% = fld% - 1
  185.     IF c% < 0 THEN c% = 0
  186.     LOCATE row%, (col% + c%), 1, 6, 7
  187.     xk% = KeyIn%
  188.     IF xk% > 0 AND xk% < 255 THEN
  189.       IF INSTR(vk$, CHR$(xk%)) AND c% < fld% THEN
  190.         c% = c% + 1:   MID$(st$, c%, 1) = CHR$(xk%)
  191.       END IF
  192.     END IF
  193.     SELECT CASE xk%
  194.      CASE 8                          ' Backspace Key
  195.        MID$(st$, (c% + 1), 1) = " ": c% = c% - 1
  196.      CASE -83                         ' Del Key
  197.        new$ = MID$(st$, 1, c%) + MID$(st$, (c% + 2), fld%) + " "
  198.        st$ = new$: new$ = ""
  199.      CASE -82                           ' Insert Key
  200.        new$ = MID$(st$, 1, c%) + " " + MID$(st$, (c% + 1), (fld% - 1))
  201.        st$ = new$: new$ = ""
  202.      CASE -46                           ' Alt C to clear field
  203.        st$ = SPACE$(fld%): c% = 0
  204.      CASE -71
  205.        c% = 0: xk% = 0                  ' Home Key  start of field
  206.      CASE -79
  207.        c% = fld% - 1: xk% = 0           ' End Key  end of field
  208.      CASE -75
  209.        c% = c% - 1: xk% = 0  ' Left Arrow Key
  210.      CASE -77
  211.        c% = c% + 1: xk% = 0   ' Right Arrow Key
  212.     END SELECT
  213.     IF xk% = -77 OR xk% = -75 OR xk% = -83 OR xk% = -82 OR xk% = -46 THEN xk% = 0
  214.     IF xk% < 0 OR xk% = 13 OR xk% = 27 THEN EXIT SUB    ' Exit keys
  215.   LOOP
  216. END SUB
  217.  
  218. SUB FastPrint (row%, col%, st$, colr%) public
  219.   '**** Get Current screen color if colr% set to -1 *****
  220.   IF colr% = -1 THEN colr% = ColorAttribute%(row%, col%)
  221.   '**** Calculate video memory offset, where display will begin ****
  222.   offset% = 160 * (row% - 1) + 2 * (col% - 1)
  223.   DEF SEG = GetVideoSegment  '** Set default data segment to screen memory  **
  224.   '**** Place the string into video memory, along with the color ****
  225.   stPos% = 1
  226.   FOR x% = 0 TO ((LEN(st$) - 1) * 2) STEP 2
  227.     POKE x% + offset%, ASC(MID$(st$, stPos%, 1))
  228.     POKE x% + offset% + 1, colr%
  229.     stPos% = stPos% + 1
  230.   NEXT x%
  231.   DEF SEG  '**** Restore BASIC's default data segment ****
  232. END SUB
  233.  
  234.  
  235. SUB GetEqual (krs%, ky$, Rec$, rn&, status%) public
  236.   ' to get first record make ky$ < first possible record
  237.   ' to get last record make k$ > last possible record
  238.   CALL Info(krs%, xn%, kl%, Rfn%, Rfl%)
  239.   fc$ = "Q": CALL im(xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  240.   status% = rc%: Rec$ = SPACE$(Rfl%)
  241.   IF rc% <> 0 THEN
  242.     If rc%> 114 and rc%<117 then
  243.         fc$ = "L" :CALL im(xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  244.     else
  245.       CALL IndexError(rc%): exit sub
  246.     end if
  247.   end if
  248.     ' Get the associated data record if the data file exists
  249.   IF Rfl% > 0 AND rn& <= LOF(Rfn%) \ Rfl% AND rn& > 0 THEN
  250.     GET #Rfn%, rn&, Rec$
  251.   END IF
  252. END SUB
  253.  
  254. SUB GetNext (krs%, ky$, Rec$, status%) public
  255.   CALL Info(krs%, xn%, kl%, Rfn%, Rfl%)
  256.   ky$ = SPACE$(kl%)
  257.   fc$ = "N": CALL im(xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  258.   status% = rc%: Rec$ = SPACE$(Rfl%)
  259.   IF rc% <> 0 THEN
  260.     IF rc% = 116 THEN
  261.       fc$ = "L":CALL im(xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  262.     ELSE
  263.       CALL IndexError(rc%): exit sub
  264.     END IF
  265.   END IF
  266.   ' Get the associated data record if the data file exists
  267.   IF Rfl% > 0 AND rn& <= LOF(Rfn%) \ Rfl% AND rn& > 0 THEN
  268.     GET #Rfn%, rn&, Rec$
  269.   END IF
  270. END SUB
  271.  
  272. SUB GetPrev (krs%, ky$, Rec$, status%) public
  273.   CALL Info(krs%, xn%, kl%, Rfn%, Rfl%)
  274.   ky$ = SPACE$(kl%)
  275.   fc$ = "L": CALL im(xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  276.   status% = rc%: Rec$ = SPACE$(Rfl%)
  277.   IF rc% <> 0 THEN
  278.     IF rc% = 116 THEN
  279.       ky$=space$(kl%): fc$ = "Q"
  280.       CALL im(xn%, fc$, ifn$, kl%, ky$, rn&, rc%)
  281.     ELSE
  282.       CALL IndexError(rc%): exit sub
  283.     END IF
  284.     'ky$= space$(kl%)
  285.   END IF
  286.   ' Get the associated data record if the data file exists
  287.   IF Rfl% > 0 AND rn& <= LOF(Rfn%) \ Rfl% AND rn& > 0 THEN
  288.     GET #Rfn%, rn&, Rec$
  289.   END IF
  290. END SUB
  291.  
  292. FUNCTION GetVideoSegment& public
  293.   DEF SEG = 0   '**** Set default segment to 0 ****
  294.   adapter = PEEK(&H463)  '** PEEK at value stored at video adapter address.**
  295.   '**** Set function equal to proper segment value. ****
  296.   IF adapter = &HB4 THEN
  297.     GetVideoSegment& = &HB000  '**** Monochrom Monitor was reported
  298.   ELSE
  299.     GetVideoSegment& = &HB800  '**** Color Monitor was reported
  300.   END IF
  301. END FUNCTION
  302.  
  303. SUB IndexError (rc%) public
  304.   CALL SaveScrn(Scrn$)
  305.   CALL PopWindow(3, 23, 6, 57, 78)
  306.   st$ = "Index Manager Failed Code:"+str$(rc%)
  307.   CALL FastPrint(4, 25, st$, 78)
  308.   gosub GetRC : CALL FastPrint(5, 30, st$, 78)
  309.   xk%=KeyIn%
  310.   CALL RestoreScrn(Scrn$)
  311.   exit sub
  312. GetRC:
  313.   select case rc%
  314.    case 1
  315.      st$="Function Number Invalid"
  316.    case 2
  317.       st$= "File Name Invalid"
  318.    case 3
  319.      st$="File/Path Not Found"
  320.    case 4
  321.      st$= "Handle Not Available"
  322.    case 5
  323.      st$="File Name Access Denied"
  324.    case 6
  325.      st$= "Handle Invalid or Not Opened"
  326.    case 101
  327.      st$="Invalid Index Number"
  328.    case 102
  329.      st$= "Invalid Function Code"
  330.    case 103
  331.      st$="Invalid File Name"
  332.    case 104
  333.      st$= "Invalid Key Lenghth"
  334.    case 105, 108
  335.      st$="Invalid Key"
  336.    case 106
  337.      st$= "Invalid Record Number"
  338.    case 107
  339.      st$="Index Not Opened"
  340.    case 109
  341.      st$= "Duplicate Key"
  342.    case 110
  343.      st$="Disk Full/Write Error"
  344.    case 111
  345.      st$= "Invalid Index Block Size"
  346.    case 112
  347.      st$="Index Already In Use"
  348.    case 113, 114
  349.      st$= "Invalid Block/Record Read"
  350.    case 115
  351.      st$="Key Not Found"
  352.    case 116
  353.      st$= "End Of File"
  354.    case else
  355.      st$= "Unknown Error"
  356.   end select
  357.  return
  358. END SUB
  359.  
  360. SUB Info (krs%, xn%, kl%, Rfn%, Rfl%) public
  361.   STATIC xn1%, kl1%, Rfn1%, Rfl1%
  362.   STATIC xn2%, kl2%, Rfn2%, Rfl2%
  363.   STATIC xn3%, kl3%, Rfn3%, Rfl3%
  364.   STATIC xn4%, kl4%, Rfn4%, Rfl1%
  365.   STATIC xn5%, kl5%, Rfn5%, Rfl2%
  366.   STATIC xn6%, kl6%, Rfn6%, Rfl3%
  367.   STATIC xn7%, kl7%, Rfn7%, Rfl1%
  368.   STATIC xn8%, kl8%, Rfn8%, Rfl2%
  369.   STATIC xn9%, kl9%, Rfn9%, Rfl3%
  370.   STATIC xn10%, kl10%, Rfn10%, Rfl10%
  371.   STATIC xn11%, kl11%, Rfn11%, Rfl11%
  372.   STATIC xn12%, kl12%, Rfn12%, Rfl12%
  373.   SELECT CASE krs%
  374.     CASE -1  ' store information about key-record-set (krs%)
  375.        xn1% = xn%: kl1% = kl%: Rfn1% = Rfn%: Rfl1% = Rfl%
  376.     CASE 1   ' retrieve information about key-record-set (krs%)
  377.        xn% = xn1%: kl% = kl1%: Rfn% = Rfn1%: Rfl% = Rfl1%
  378.     CASE -2
  379.        xn2% = xn%: kl2% = kl%: Rfn2% = Rfn%: Rfl2% = Rfl%
  380.     CASE 2
  381.        xn% = xn2%: kl% = kl2%: Rfn% = Rfn2%: Rfl% = Rfl2%
  382.     CASE -3
  383.        xn3% = xn%: kl3% = kl%: Rfn3% = Rfn%: Rfl3% = Rfl%
  384.     CASE 3
  385.        xn% = xn3%: kl% = kl3%: Rfn% = Rfn3%: Rfl% = Rfl3%
  386.     CASE -4
  387.        xn4% = xn%: kl4% = kl%: Rfn4% = Rfn%: Rfl4% = Rfl%
  388.     CASE 4
  389.        xn% = xn4%: kl% = kl4%: Rfn% = Rfn4%: Rfl% = Rfl4%
  390.     CASE -5
  391.        xn5% = xn%: kl5% = kl%: Rfn5% = Rfn%: Rfl5% = Rfl%
  392.     CASE 5
  393.        xn% = xn5%: kl% = kl5%: Rfn% = Rfn5%: Rfl% = Rfl5%
  394.     CASE -6
  395.        xn6% = xn%: kl6% = kl%: Rfn6% = Rfn%: Rfl6% = Rfl%
  396.     CASE 6
  397.        xn% = xn6%: kl% = kl6%: Rfn% = Rfn6%: Rfl% = Rfl6%
  398.     CASE -7
  399.        xn7% = xn%: kl7% = kl%: Rfn7% = Rfn%: Rfl7% = Rfl%
  400.     CASE 7
  401.        xn% = xn7%: kl% = kl7%: Rfn% = Rfn7%: Rfl% = Rfl7%
  402.     CASE -8
  403.        xn8% = xn%: kl8% = kl%: Rfn8% = Rfn%: Rfl8% = Rfl%
  404.     CASE 8
  405.        xn% = xn8%: kl% = kl8%: Rfn% = Rfn8%: Rfl% = Rfl8%
  406.     CASE -9
  407.        xn9% = xn%: kl9% = kl%: Rfn9% = Rfn%: Rfl9% = Rfl%
  408.     CASE 9
  409.        xn% = xn9%: kl% = kl9%: Rfn% = Rfn9%: Rfl% = Rfl9%
  410.     CASE -10
  411.        xn10% = xn%: kl10% = kl%: Rfn10% = Rfn%: Rfl10% = Rfl%
  412.     CASE 10
  413.        xn% = xn10%: kl% = kl10%: Rfn% = Rfn10%: Rfl% = Rfl10%
  414.     CASE -11
  415.        xn11% = xn%: kl11% = kl%: Rfn11% = Rfn%: Rfl11% = Rfl%
  416.     CASE 11
  417.        xn% = xn11%: kl% = kl11%: Rfn% = Rfn11%: Rfl% = Rfl11%
  418.     CASE -12
  419.        xn12% = xn%: kl12% = kl%: Rfn12% = Rfn%: Rfl12% = Rfl%
  420.     CASE 12
  421.        xn% = xn12%: kl% = kl12%: Rfn% = Rfn12%: Rfl% = Rfl12%
  422.     CASE -13
  423.        xn13% = xn%: kl13% = kl%: Rfn13% = Rfn%: Rfl13% = Rfl%
  424.     CASE 13
  425.        xn% = xn13%: kl% = kl13%: Rfn% = Rfn13%: Rfl% = Rfl13%
  426.    END SELECT
  427. END SUB
  428.  
  429. FUNCTION IntgrToDollar$ (Intgr&, L%) public
  430.   st$ = STR$(Intgr&)
  431.   IF LEN(st$) < 3 THEN EXIT Function
  432.   t$ = SPACE$(L%) + MID$(st$, 1, (LEN(st$) - 2)) + "." + MID$(st$, (LEN(st$) - 2), 2)
  433.   IntgrToDollar$ = RIGHT$(t$, L%)
  434. END FUNCTION
  435.  
  436. SUB Julian (dt$) public
  437.   ' Format MM-DD-YYYY converted to YYYYDDD
  438.   ' Format YYYYDDD converted to MM-DD-YYYY
  439.   ' Format YYYDDD converted to MM-DD-YYYY
  440.   IF LEN(dt$) = 6 THEN
  441.     Year% = 1300 + VAL(MID$(dt$, 1, 3)): st$ = STR$(Year%) + MID$(dt$, 4, 3)
  442.     dt$ = MID$(st$, 2)
  443.   END IF
  444.   IF LEN(dt$) = 10 THEN
  445.     Year% = VAL(MID$(dt$, 7, 4)): Month% = VAL(MID$(dt$, 1, 2))
  446.     day% = VAL(MID$(dt$, 4, 2))
  447.     ddd% = INT((Month% * 30.5) + (day% - 29.5) + .5 * (Month% < 8) + (Month% > 2) * (2 + ((Year% MOD 4) = 0)))
  448.     jd$ = STR$((ddd% + 1000))
  449.     st$ = MID$(dt$, 7, 4) + RIGHT$(jd$, 3): dt$ = st$
  450.     EXIT SUB
  451.   END IF
  452.   IF LEN(dt$) = 7 THEN
  453.     Year% = VAL(MID$(dt$, 1, 4)): ddd% = VAL(MID$(dt$, 5, 3))
  454.     IF Year% MOD 4 = 0 THEN
  455.       M% = 13 + (ddd% < 367) + (ddd% < 336) + (ddd% < 306) + (ddd% < 275) + (ddd% < 245) + (ddd% < 214) + (ddd% < 183) + (ddd% < 153) + (ddd% < 122) + (ddd% < 92) + (ddd% < 61) + (ddd% < 32)
  456.       day% = ddd% + (M% = 12) * 335 + (M% = 11) * 305 + (M% = 10) * 274 + (M% = 9) * 244 + (M% = 8) * 213 + (M% = 7) * 182 + (M% = 6) * 152 + (M% = 5) * 121 + (M% = 4) * 91 + (M% = 3) * 60 + (M% = 2) * 31
  457.     ELSE
  458.       M% = 13 + (ddd% < 366) + (ddd% < 335) + (ddd% < 305) + (ddd% < 274) + (ddd% < 244) + (ddd% < 213) + (ddd% < 182) + (ddd% < 152) + (ddd% < 121) + (ddd% < 91) + (ddd% < 60) + (ddd% < 32)
  459.       day% = ddd% + (M% = 12) * 334 + (M% = 11) * 304 + (M% = 10) * 273 + (M% = 9) * 243 + (M% = 8) * 212 + (M% = 7) * 181 + (M% = 6) * 151 + (M% = 5) * 120 + (M% = 4) * 90 + (M% = 3) * 59 + (M% = 2) * 31
  460.     END IF
  461.     M$ = RIGHT$(STR$(100 + M%), 2): d$ = RIGHT$(STR$(100 + day%), 2)
  462.     st$ = M$ + "-" + d$ + "-" + MID$(dt$, 1, 4): dt$ = st$
  463.   END IF
  464. END SUB
  465.  
  466. FUNCTION KeyIn% public
  467.   DO: ky$ = INKEY$: LOOP UNTIL LEN(ky$)   ' wait for a key press
  468.   KeyIn% = (ASC(ky$) * -(LEN(ky$) = 1)) + (ASC(RIGHT$(ky$, 1)) * (LEN(ky$) <> 1))
  469. END FUNCTION
  470.  
  471. FUNCTION NumDays& (dt1$, dt2$)  public
  472.   ' dt1$= Most resent date YYMMDD
  473.   ' dt2$= Oldest date YYMMDD
  474.   ' nd&= Value returned... number of days between dates
  475.   yr% = VAL(MID$(dt1$, 1, 2))
  476.   yr1% = (-(1900 + yr%) * (yr% > 80)) - ((2000 + yr%) * (yr% <= 80))
  477.   mo1% = VAL(MID$(dt1$, 3, 2))
  478.   da1% = VAL(MID$(dt1$, 5, 2))
  479.   days1& = (yr1% MOD 1900) * 365.25 + .75    ' # of days since 1900
  480.   ddd% = INT((mo1% * 30.5) + (da1% - 29.5) + .5 * (mo1% < 8) + (mo1% > 2) * (2 + ((yr1% MOD 4) = 0)))
  481.   days1& = days1& + ddd%
  482.   yr% = VAL(MID$(dt2$, 1, 2))
  483.   yr2% = (-(1900 + yr%) * (yr% > 80)) - ((2000 + yr%) * (yr% <= 80))
  484.   mo2% = VAL(MID$(dt2$, 3, 2))
  485.   da2% = VAL(MID$(dt2$, 5, 2))
  486.   days2& = (yr2% MOD 1900) * 365.25 + .75    ' # of days since 1900
  487.   ddd% = INT((mo2% * 30.5) + (da2% - 29.5) + .5 * (mo2% < 8) + (mo2% > 2) * (2 + ((yr2% MOD 4) = 0)))
  488.   days2& = days2& + ddd%
  489.   NumDays& = days1& - days2&
  490. END FUNCTION
  491.  
  492. FUNCTION NumToString$ (n#, dp%, Ln%) public
  493.   L% = Ln%
  494.   IF L% = 0 THEN EXIT Function
  495.   IF dp% <= 0 THEN
  496.    t& = n#: NumToString$ = RIGHT$((SPACE$(L%) + STR$(t&)), L%)
  497.   ELSE
  498.    t& = (n# * (10 ^ dp%)): st$ = RIGHT$((SPACE$(L%) + STR$(t&)), L%)
  499.    r$ = STRING$((dp% - 1), "0") + MID$((STR$(t& MOD (10 ^ dp%))), 2, dp%)
  500.    t$ = SPACE$(L%) + STR$(t& \ (10 ^ dp%)) + "." + RIGHT$(r$, dp%)
  501.    NumToString$ = RIGHT$(t$, L%)
  502.   END IF
  503. END FUNCTION
  504.  
  505. SUB PhoneEdit (row%, col%, colr%, vk$, pn$, xk%) public
  506.   ' Typ% =1  Edit (AAA)XXX-NNNN  returns AAAXXXNNNN
  507.   st$ = pn$: fld% = 14: Typ% = xk%: c% = 1
  508.   FOR xk% = 48 TO 57: vk$ = vk$ + CHR$(xk%): NEXT
  509.   IF colr% = -1 THEN colr% = ColorAttribute%(row%, col%)
  510.   st$ = "(" + MID$(pn$, 1, 3) + ") " + MID$(pn$, 4, 3) + "-" + MID$(pn$, 7, 4)
  511.   REDIM S$(fld%): FOR a% = 1 TO fld%: S$(a%) = MID$(st$, a%, 1): NEXT
  512.   DO
  513.     CALL FastPrint(row%, col%, st$, colr%)
  514.     IF c% = 0 THEN c% = 1
  515.     IF c% = 4 THEN c% = 6
  516.     IF c% = 5 THEN c% = 6
  517.     IF c% = 9 THEN c% = 10
  518.     IF c% >= fld% THEN c% = fld% - 1
  519.     LOCATE row%, (col% + c%), 1, 6, 7
  520.     xk% = KeyIn%
  521.     IF xk% > 0 AND xk% < 255 THEN
  522.       IF INSTR(vk$, CHR$(xk%)) AND c% < fld% THEN
  523.         c% = c% + 1
  524.         S$(c%) = CHR$(xk%)
  525.         st$ = "": FOR a% = 1 TO fld%: st$ = st$ + S$(a%): NEXT
  526.       END IF
  527.     END IF
  528.     SELECT CASE xk%
  529.       CASE 13
  530.         pn$ = MID$(st$, 2, 3) + MID$(st$, 7, 3) + MID$(st$, 11, 4)
  531.       CASE 8                         ' Backspace Key
  532.         S$(c% + 1) = " ": c% = c% - 1
  533.         IF c% = 4 THEN c% = 3
  534.         IF c% = 5 THEN c% = 3
  535.         IF c% = 9 THEN c% = 8
  536.         st$ = "": FOR a% = 1 TO fld%: st$ = st$ + S$(a%): NEXT
  537.       CASE -46                        ' Alt C to clear field
  538.         st$ = "(" + SPACE$(3) + ") " + SPACE$(3) + "-" + SPACE$(4)
  539.         FOR a% = 1 TO fld%: S$(a%) = MID$(st$, a%, 1): NEXT
  540.         c% = 1
  541.       CASE -71
  542.         c% = 1: xk% = 0                  ' Home Key  start of field
  543.       CASE -79
  544.         c% = fld% - 1: xk% = 0           ' End Key  end of field
  545.       CASE -75
  546.         c% = c% - 1: xk% = 0             ' Left Arrow Key
  547.         IF c% = 4 THEN c% = 3
  548.         IF c% = 5 THEN c% = 3
  549.         IF c% = 9 THEN c% = 8
  550.       CASE -77
  551.         c% = c% + 1: xk% = 0             ' Right Arrow Key
  552.         IF c% = 4 THEN c% = 6
  553.         IF c% = 5 THEN c% = 6
  554.         IF c% = 9 THEN c% = 10
  555.     END SELECT
  556.     IF xk% = -77 OR xk% = -75 OR xk% = -83 OR xk% = -82 OR xk% = -46 THEN xk% = 0
  557.     IF xk% < 0 OR xk% = 13 OR xk% = 27 THEN EXIT SUB    ' Exit keys
  558.   LOOP
  559. END SUB
  560.  
  561. SUB PutScreen (file$) public
  562.   '**** Set the memory segment to the address of screen memory ****
  563.   DEF SEG = GetVideoSegment
  564.   '**** Use the BASIC BLOAD statement to load the saved screen to video RAM **
  565.   LOCATE 1, 1, 0: BLOAD file$, 0
  566.   DEF SEG  '**** Restore BASIC's default data segment ****
  567. END SUB
  568.  
  569. SUB Wipe (top%, lft%, bottom%, rght%, colr%) public
  570.   '  colr% - combined fg & bg color  colr% = fg% + (bg% * 16)                                                                   │
  571.   '  top% - The top-most row to clear.  Allowable range is 1 to 25.
  572.   '  bottom% - The bottom-most row to clear.  Allowable range is 1 to 25.                                                │
  573.   '  lft% - The left-most column to clear.  Allowable range is 1 to 80.                                                        │
  574.   '  rght% - The right-most column to clear.  Allowable range is 1 to 80.                                                  │
  575.   ' Clear the selected portion of the screen by overwriting with spaces
  576.  
  577.   FOR x% = top% + 1 TO bottom% - 1
  578.     st$ = SPACE$(rght% - lft% - 1)
  579.     CALL FastPrint(x%, (lft% + 1), st$, colr%)
  580.   NEXT x%
  581. END SUB
  582.  
  583. SUB RestoreScrn (Scrn$) Public
  584.   DEF SEG = GetVideoSegment&
  585.   POKE$ 0, Scrn$
  586.   DEF SEG
  587. END SUB
  588.  
  589. SUB SaveScrn (Scrn$) Public
  590.   DEF SEG = GetVideoSegment&
  591.   'bRow% = (bRow% - 1) * 80: eRow% = (eRow% - 1) * 80
  592.   Scrn$ = PEEK$(0, 4000)
  593.   DEF SEG
  594. END SUB
  595.  
  596. SUB PopWindow (Wa%, Wb%, Wc%, Wd%, colr%) Public
  597.   '
  598.   '  Wa% = TopRow%   Wb% = LeftCol%   Wc% = BottomRow%  Wd% = RightCol%
  599.  
  600.   a$ = STRING$((Wd% - Wb%) - 1, 196)
  601.   st$ = CHR$(218) + a$ + CHR$(191)
  602.   CALL FastPrint(Wa%, Wb%, st$, colr%)
  603.   st$ = CHR$(192) + a$ + CHR$(217)
  604.   CALL FastPrint(Wc%, Wb%, st$, colr%)
  605.  
  606.   'Side shadow
  607.   segment& = GetVideoSegment&
  608.   FOR x% = Wa% TO Wc% - 1
  609.     offset% = (160 * x%) + (Wd% * 2) + 1
  610.     sf% = GetForeground%(x% + 1, INT(Wd% + 1))
  611.     IF sf% > 15 THEN blink% = 128 ELSE blink% = 0
  612.     IF sf% > 7 THEN sf% = (sf% MOD 8) + blink%
  613.     DEF SEG = segment&: POKE offset%, sf%: DEF SEG
  614.     sf% = GetForeground%(x% + 1, INT(Wd% + 2))
  615.     IF sf% > 15 THEN blink% = 128 ELSE blink% = 0
  616.     IF sf% > 7 THEN sf% = (sf% MOD 8) + blink%
  617.     DEF SEG = segment&: POKE offset% + 2, sf%: DEF SEG
  618.   NEXT x%
  619.  
  620.   ' Main Body Of Window
  621.   x% = Wc% - Wa% - 1    ' Limit
  622.   FOR xyz% = 1 TO x%
  623.     st$ = CHR$(179) + SPACE$((Wd% - Wb%) - 1) + CHR$(179)
  624.     CALL FastPrint((Wa% + xyz%), Wb%, st$, colr%)
  625.   NEXT xyz%
  626.  
  627.   ' Bottom shadow
  628.   offset% = (Wc% * 160): col% = INT(Wb% + 2)
  629.   FOR x% = ((Wb% + 1) * 2) TO ((Wd% + 1) * 2) STEP 2
  630.     sf% = GetForeground%(INT(Wc%) + 1, col%)
  631.     col% = col% + 1
  632.     IF sf% > 15 THEN blink% = 128 ELSE blink% = 0
  633.     IF sf% > 7 THEN sf% = (sf% MOD 8) + blink%
  634.     DEF SEG = segment&: POKE offset% + x% + 1, sf%: DEF SEG
  635.   NEXT x%
  636. END SUB
  637.  
  638. FUNCTION GetBackground% (row%, col%) Public
  639.   DEF SEG = GetVideoSegment&
  640.   ' Get color attribute byte
  641.   attr% = PEEK(((row% - 1) * 160) + ((col% - 1) * 2) + 1)
  642.   ' Calculate background
  643.   step1% = (attr% AND &HFF) \ 16
  644.   IF step1% > 7 THEN          ' Foreground is blinking
  645.     GetBackground% = step1% - 8
  646.   ELSE        ' Foreground is NOT blinking
  647.     GetBackground% = step1%
  648.   END IF
  649.   DEF SEG
  650. END FUNCTION
  651.  
  652. FUNCTION GetForeground% (row%, col%) Public
  653.   DEF SEG = GetVideoSegment&
  654.   ' Calculate color attribute byte
  655.   attr% = PEEK(((row% - 1) * 160) + ((col% - 1) * 2) + 1)
  656.   ' Calculate foreground color
  657.   step1% = attr% AND &HFF
  658.   IF step1% > 127 THEN        ' Color is blinking
  659.     GetForeground% = ((step1% - 128) MOD 16) + 16
  660.   ELSE        ' Color is NOT blinking
  661.     GetForeground% = step1% MOD 16
  662.   END IF
  663.   DEF SEG
  664. END FUNCTION
  665.  
  666. FUNCTION FILEXISTS% (FILNAM$) public
  667.   %FLAGS=0 : %AX=1 : %CX=3 : %DX=4 : %DS=8 : %ES=9
  668.  
  669.   FILEXISTS% = -1 : DTA$=STRING$(44,0) : SPEC$=FILNAM$ + CHR$(0)
  670.  
  671.   REG %DS,STRSEG(DTA$) : REG %DX,STRPTR(DTA$) : REG %AX,&H1A00
  672.   CALL INTERRUPT &H21
  673.  
  674.   REG %DS,STRSEG(SPEC$) : REG %DX,STRPTR(SPEC$)
  675.   REG %CX,&H1F00 : REG %AX,&H4E00
  676.   CALL INTERRUPT &H21
  677.  
  678.   IF (REG(%FLAGS) AND 1) THEN FILEXISTS% = 0
  679. END FUNCTION
  680.  
  681.