IDENTIFICATION DIVISION.
PROGRAM-ID. DATETEST.
AUTHOR. MARTIN O SULLIVAN
INSTALLATION. MOYLISH.
DATE-WRITTEN. SEPTEMBER 1998.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBMAS400.
OBJECT-COMPUTER. IBMAS400.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT SCREEN-FILE
ASSIGN TO WORKSTATION-DATETEST
ORGANIZATION IS TRANSACTION
FILE STATUS IS WA-SCREEN-STAT WA-RETURN-CODE
CONTROL-AREA IS WA-CONTROL-AREA.
DATA DIVISION.
FILE SECTION.
FD SCREEN-FILE
LABEL RECORDS ARE OMITTED.
01 SCREEN-REC PIC X(500).
01 FIRST-SPACE.
03 DD PIC 9(2).
03 DILM1 PIC A(1).
03 MM PIC 9(2).
03 DILM2 PIC A(1).
03 CCYY PIC 9(4).
WORKING-STORAGE SECTION.
01 WA-SCREEN-CONTROL.
03 WA-SCREEN-STAT PIC X(2).
88 SUCCESSFUL-READ VALUE "00".
03 WA-RETURN-CODE PIC X(4).
03 WA-CONTROL-AREA.
05 WA-AID-BYTE PIC S99 VALUE ZEROES.
88 END-OF-JOB VALUE 3.
88 ENTER-KEY VALUE 0.
88 ESCAPE VALUE 12.
05 WA-SESSION-ID PIC X(2).
05 FILLER PIC X(8).
01 NUMERIC-DATE-IN.
03 N-DAY PIC 9(2).
03 DELIM-1 PIC X.
03 N-MONTH PIC 9(2).
03 DELIM-2 PIC X.
03 N-YEAR.
05 N-CENTURY PIC 9(2).
05 N-TENS-PART PIC 9(2).
88 CENTURY-YEAR VALUE 0.
01 SCRATCH-PAD.
03 QUOTIENT PIC 9(3).
03 LEAP PIC 9.
88 LEAP-YEAR VALUE 0.
03 MONTH-SUB PIC 9(2).
01 TABLES-FOR-CALC.
03 MONTH-DAY-VALUES.
05 FILLER PIC X(24)
VALUE "312831303130313130313031".
03 FILLER REDEFINES MONTH-DAY-VALUES.
05 DAYS-IN-MONTH PIC 9(2) OCCURS 12 TIMES.
01 FLAGS-ETC.
02 DATE-VALID-FLAG PIC X.
88 DATE-VALID VALUE "Y".
88 DATE-NOT-VALID VALUE "N".
02 OTHER-FLAGS.
03 DELIM-FLAG PIC X.
88 DELIMS-VALID VALUE "Y".
88 DELIMS-NOT-VALID VALUE "N".
03 DAY-FLAG PIC X.
88 DAY-VALID VALUE "Y".
88 DAY-NOT-VALID VALUE "N".
PROCEDURE DIVISION.
DECLARATIVES.
SCREEN-ERROR SECTION.
USE AFTER STANDARD EXCEPTION PROCEDURE ON I-O.
SCREEN-ERROR-PARA.
DISPLAY "ATTENTION !!!!! ERROR IN I-O ", WA-SCREEN-CONTROL.
END DECLARATIVES.
MAIN-PROCESSING SECTION.
TOP-LEVEL-PARA.
PERFORM START-UP.
PERFORM ASK-GO.
PERFORM WORK-1-ASK-MORE UNTIL END-OF-JOB.
PERFORM CLOSE-DOWN.
STOP RUN.
START-UP.
OPEN I-O SCREEN-FILE.
ASK-GO.
WRITE SCREEN-REC FORMAT IS "WELCOME".
READ SCREEN-FILE.
CLOSE-DOWN.
CLOSE SCREEN-FILE.
WORK-1-ASK-MORE.
PERFORM INITIALISE-LOOP.
PERFORM WORK-1.
PERFORM ASK-GO.
INITIALISE-LOOP.
MOVE 28 TO DAYS-IN-MONTH(2).
SET DATE-VALID TO TRUE.
MOVE SPACES TO OTHER-FLAGS.
WORK-1.
PERFORM GET-DATE.
PERFORM POSS-ESCAPE.
GET-DATE.
MOVE SPACES TO FIRST-SPACE.
WRITE SCREEN-REC FROM FIRST-SPACE FORMAT IS "ENTRY".
READ SCREEN-FILE INTO FIRST-SPACE.
MOVE DD TO N-DAY.
MOVE DILM1 TO DELIM-1.
MOVE MM TO N-MONTH.
MOVE DILM2 TO DELIM-2.
MOVE CCYY TO N-YEAR.
POSS-ESCAPE.
IF ESCAPE THEN WRITE SCREEN-REC FORMAT IS "ESCAPE"
READ SCREEN-FILE
ELSE
PERFORM VALIDATE-DATE
PERFORM DISPLAY-OUTCOME.
VALIDATE-DATE.
PERFORM VALIDATE-DELIMITERS.
PERFORM POSS-VALIDATE-DAY.
DISPLAY-OUTCOME.
IF DATE-VALID
WRITE SCREEN-REC FORMAT IS "VALID"
READ SCREEN-FILE
ELSE
WRITE SCREEN-REC FORMAT IS "NOTVALID"
READ SCREEN-FILE.
VALIDATE-DELIMITERS.
IF DELIM-1 = DELIM-2
SET DELIMS-VALID TO TRUE
ELSE
SET DELIMS-NOT-VALID TO TRUE.
POSS-VALIDATE-DAY.
IF DELIMS-VALID
PERFORM CHECK-LEAP-VALIDATE-DAY
ELSE
SET DATE-NOT-VALID TO TRUE
WRITE SCREEN-REC FORMAT IS "DILMERR"
READ SCREEN-FILE.
CHECK-LEAP-VALIDATE-DAY.
PERFORM LEAP-YEAR-CALCS.
PERFORM POSS-LEAP-YEAR.
PERFORM VALIDATE-DAY.
PERFORM POSS-VALID-DATE.
LEAP-YEAR-CALCS.
IF CENTURY-YEAR
PERFORM CENTURY-LEAP-CALCS
ELSE
PERFORM YEAR-LEAP-CALCS.
CENTURY-LEAP-CALCS.
DIVIDE N-CENTURY BY 4
GIVING QUOTIENT REMAINDER LEAP.
YEAR-LEAP-CALCS.
DIVIDE N-TENS-PART BY 4
GIVING QUOTIENT REMAINDER LEAP.
POSS-LEAP-YEAR.
IF LEAP-YEAR
MOVE 29 TO DAYS-IN-MONTH(2).
VALIDATE-DAY.
IF N-DAY > DAYS-IN-MONTH(N-MONTH)
SET DAY-NOT-VALID TO TRUE
WRITE SCREEN-REC FORMAT IS "DAYERROR"
READ SCREEN-FILE
ELSE
SET DAY-VALID TO TRUE.
POSS-VALID-DATE.
IF DAY-VALID
SET DATE-VALID TO TRUE
ELSE
SET DATE-NOT-VALID TO TRUE.
Link back to cobol page