home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / mbug / mbug027.arc / DATE.INC < prev    next >
Text File  |  1979-12-31  |  6KB  |  155 lines
  1. PROCEDURE getdate(VAR dummy_date : str11; y : INTEGER);
  2. Label
  3.   escape;
  4. CONST
  5.   Term : CharSet  =  [^E,^I,^M,^X,^Z,#27];
  6.  
  7. VAR
  8.   K,R,yes     : INTEGER;
  9.   ddate,dyear : STRING[2];
  10.   dmonth      : str3;
  11.   tc          : CHAR;
  12.   OK          : BOOLEAN;
  13.  
  14. BEGIN
  15.   K := 1;
  16.   ddate  := copy(dummy_date,1,2);
  17.   dmonth := copy(dummy_date,4,3);
  18.   dyear  := copy(dummy_date,10,4);
  19.   ok := FALSE;
  20.   repeat
  21.   REPEAT
  22.     CASE K OF
  23.       1 : BEGIN
  24.             repeat
  25.               R := -1;
  26.               InputStr(ddate,2,22,y,term,tc);
  27.               val(ddate,R,yes);
  28.             until ((R in [1..31]) and (tc = ^X)) or (tc in [^M,^Z,^E,#27]);
  29.             case tc of
  30.               ^E : k := 3;
  31.               ^Z : goto escape;
  32.             end;
  33.           end;
  34.       2 : BEGIN
  35.             GotoXY(26,y+1);
  36.             REPEAT
  37.               Read(kbd,tc);
  38.               tc := UpCase(tc);
  39.             UNTIL tc IN ['A','D','F','J','M','N','O','S',^Z,^M,^E,^X,^I,#27];
  40.             IF tc = ^Z then goto escape;
  41.             if tc = ^E then k := 0;
  42.             if not(tc in [^M,^X,^E,#27])
  43.               THEN
  44.                 BEGIN
  45.                   Write(tc);
  46.                   CASE tc OF
  47.                     'A' : BEGIN
  48.                             REPEAT
  49.                               Read(kbd,tc);
  50.                               tc := UpCase(tc);
  51.                             UNTIL tc IN ['P','U'];
  52.                             CASE tc OF
  53.                               'P' : BEGIN
  54.                                       dmonth := 'APR';
  55.                                       Write('PR');
  56.                                     END;
  57.                               'U' : BEGIN
  58.                                       dmonth := 'AUG';
  59.                                       Write('UG');
  60.                                     END;
  61.                             END;
  62.                           END;{case A}
  63.                     'D' : BEGIN
  64.                             dmonth := 'DEC';
  65.                             Write('EC');
  66.                           END;
  67.                     'F' : BEGIN
  68.                             dmonth := 'FEB';
  69.                             Write('EB');
  70.                           END;
  71.                     'S' : BEGIN
  72.                             dmonth := 'SEP';
  73.                             Write('EP');
  74.                           END;
  75.                     'N' : BEGIN
  76.                             dmonth := 'NOV';
  77.                             Write('OV');
  78.                           END;
  79.                     'M' : BEGIN
  80.                             Write('A');
  81.                             REPEAT
  82.                               Read(kbd,tc);
  83.                               tc := UpCase(tc);
  84.                             UNTIL tc IN ['R','Y'];
  85.                             CASE tc OF
  86.                               'R' : BEGIN
  87.                                       dmonth := 'MAR';
  88.                                       Write('R');
  89.                                     END;
  90.                               'Y' : BEGIN
  91.                                       dmonth := 'MAY';
  92.                                       Write('Y');
  93.                                     END;
  94.                             END; {case}
  95.                           END; {case M}
  96.                     'O' : BEGIN
  97.                             dmonth := 'OCT';
  98.                             Write('CT');
  99.                           END;
  100.                     'J' : BEGIN
  101.                             REPEAT
  102.                               Read(kbd,tc);
  103.                               tc := UpCase(tc);
  104.                             UNTIL tc IN ['A','U'];
  105.                             CASE tc OF
  106.                               'A' : BEGIN
  107.                                       dmonth := 'JAN';
  108.                                       Write('AN');
  109.                                     END;
  110.                               'U' : BEGIN
  111.                                       Write('U');
  112.                                       REPEAT
  113.                                         Read(kbd,tc);
  114.                                         tc := UpCase(tc);
  115.                                       UNTIL tc IN ['L','N'];
  116.                                       CASE tc OF
  117.                                         'L' : BEGIN
  118.                                                 dmonth := 'JUL';
  119.                                                 Write('L');
  120.                                               END;
  121.                                         'N' : BEGIN
  122.                                                 dmonth := 'JUN';
  123.                                                 Write('N');
  124.                                               END;
  125.                                       END;{case}
  126.                                     END;{Case U}
  127.                             END;{case  ['A','U']}
  128.                           END;{Case J}
  129.                   END;{case  ['A','D','F','J','M','N','O','S']}
  130.                 END;
  131.            END;{case 2}
  132.       3 : begin
  133.           repeat
  134.             InputStr(dyear,2,31,y,term,tc);
  135.           until ((dyear >= '00') and (dyear <= '99')) or (tc in [^M,^Z,^X,^E,#27]);
  136.           case tc of
  137.             ^E : k := 0;
  138.             ^Z : goto escape;
  139.           end;
  140.          end;
  141.     END; {Case}
  142.     K := K + 1;
  143.   UNTIL (K=4) or (TC in [^Z,#13,#27]) or ((TC=^E) and (K=2)) or ((TC=^X) and (K=4));
  144.   IF  (tc in [^E,^X]) THEN
  145.        else
  146.        begin
  147.         dummy_date := ddate + ' ' + dmonth + ' 19' + dyear;
  148.         verify_date(dummy_date,ok);
  149.         if (not ok) then k := 1;
  150.         if Dummy_Date = '__ ___ 19__' then ok := true;
  151.        end;
  152.   until ok or (tc in [^E,^X]);
  153.   escape:
  154. END;
  155.