CP/M/CPM_CDROM.iso/mbug/mbug027.arc/AGE.INC

Text File | 1979-12-31 | 5KB | 187 lines

PROCEDURE Load_Months;
BEGIN
  Month[1]  := 'JAN';
  Month[2]  := 'FEB';
  Month[3]  := 'MAR';
  Month[4]  := 'APR';
  Month[5]  := 'MAY';
  Month[6]  := 'JUN';
  Month[7]  := 'JUL';
  Month[8]  := 'AUG';
  Month[9]  := 'SEP';
  Month[10] := 'OCT';
  Month[11] := 'NOV';
  Month[12] := 'DEC';
END;

FUNCTION Leapyear (YearX : INTEGER) :  BOOLEAN;
BEGIN
    Leapyear := (( YearX MOD 4 = 0) AND ( YearX MOD 100 <> 0))
                OR ( YearX MOD 400 = 0)
END (* Leapyear  *)  ;

PROCEDURE No_Of_Days(mm ,yy : INTEGER; VAR MonthLength : INTEGER);
BEGIN
  CASE mm OF
    4,6,9,11        : MonthLength := 30;

    1,3,5,7,8,10,12 : MonthLength := 31;

    2               : BEGIN
                        IF Leapyear(yy)
                          THEN Monthlength := 29
                          ELSE Monthlength := 28;
                      END;
  END;{Case mm}
END;

PROCEDURE verify_date(x : str11; VAR OK : BOOLEAN);

VAR
  Work_Day     : STRING[2];
  Work_month   : STRING[3];
  Work_year    : STRING[4];
  yes,i        : INTEGER;
  MonthLength  : INTEGER;
BEGIN
  IF x = '__ ___ 19__'
    THEN ok := FALSE
    ELSE
      BEGIN
        Work_Day   := copy(x,1,2);
        Work_month := copy(x,4,3);
        Work_year  := copy(x,8,4);
        i      := 0;
        Iday   := 0;
        Imonth := 0;
        Iyear  := 0;
        ok     := FALSE;
        REPEAT
          i := i + 1;
        UNTIL (work_month = month[i]) OR (i = 12);
        IF Work_month = month[i]
          THEN
            BEGIN
              Imonth := i;
              val(Work_year,Iyear,yes);
              IF yes = 0
                THEN ok := TRUE
                    ELSE ok := FALSE;
              IF (Work_Day  <> '  ') AND OK
                THEN
                  BEGIN
                    val(Work_Day ,Iday,yes);
                    IF yes = 0
                      THEN ok := TRUE
                          ELSE ok := FALSE;
                    IF ok
                      THEN
                        BEGIN
                          No_Of_Days(i,iyear,MonthLength);
                          IF (Iday > MonthLength) OR (Iday < 1)
                            THEN OK := FALSE
                            ELSE OK := TRUE;
                        END;
                  END;
            END;
      END;
END;

PROCEDURE age(date1,date2 : str11; VAR yy,ww,dd : INTEGER);

{Accepts two dates as strings and returns how many days between them.
 The date MUST be in the form '01 SEP 1986' There MUST be two digets
 for the day, three UPPER case letters for the month and four digets
 for the year.}

VAR
  Monthlength  : INTEGER;
  Quite,ok     : BOOLEAN;
  total_date   : str11;
  dev          : CHAR;
  yearsgone,
  weeks,
  daysleft,
  i,
  tdays,
  dd1,dd2,
  mm1,mm2,
  yy1,yy2      : INTEGER;

BEGIN
  tdays := 0;
  verify_date(date1,ok);
  IF OK
    THEN BEGIN
           yy1 := Iyear;
           mm1 := Imonth;
           dd1 := Iday;
           tdays := monthlength - dd1;
           verify_date(date2,ok);
      END;
  IF OK
    THEN BEGIN
           yy2 := Iyear;
           mm2 := Imonth;
           dd2 := Iday;
           tdays := tdays + dd2;
           IF yy1 = yy2
             THEN
               BEGIN
                 IF mm1 = mm2
                   THEN tdays := dd2 - dd1
                   ELSE
                     FOR i := mm1 + 1 TO mm2 - 1 DO
                       BEGIN
                         No_Of_Days(i,yy1,MonthLength);
                         tdays := tdays + monthlength;
                       END;
               END;
           IF yy1 < yy2
             THEN
               BEGIN
                 FOR i := mm1 + 1 TO 12 DO
                   BEGIN
                     No_Of_Days(i,yy1,MonthLength);
                     tdays := tdays + monthlength;
                   END;
                 FOR i := 1 TO mm2 - 1 DO
                   BEGIN
                     No_Of_Days(i,yy1,MonthLength);
                     tdays := tdays + monthlength;
                   END;
                 IF yy2 - yy1 > 1
                   THEN
                     BEGIN
                       FOR i := YY1+1 TO yy2 - 1  DO
                         BEGIN
                           IF leapyear(i)
                             THEN tdays := tdays + 366
                             ELSE tdays := tdays + 365 ;
                         END;
                     END;
               END;
           yearsgone := 0;
           weeks     := 0;
           daysleft  := 0;
           yy        := 0;
           ww        := 0;
           dd        := 0;
           weeks := tdays DIV 7;
           yearsgone := weeks DIV 52;
           IF yearsgone > 0
             THEN
               BEGIN
                 FOR i := 1 TO yearsgone DO
                   weeks := weeks - 52;
               END;
           daysleft := tdays mod 7;
      END;
    IF OK
      THEN
        yy := yearsgone;
    ww := weeks;
    dd := daysleft;
END;
eft :=