100 lines
7.8 KiB
COBOL
100 lines
7.8 KiB
COBOL
00001 IDENTIFICATION DIVISION. 10/06/99
|
|
00002 PROGRAM-ID. DTSCU007 DTSCU007
|
|
00003 AUTHOR. TRICOASTAL CONSULTING LTD. LV005
|
|
00004 DATE-WRITTEN NOVEMBER 1991. DTSCU007
|
|
00005 DATE-COMPILED. DTSCU007
|
|
00006 SKIP3 DTSCU007
|
|
00007 ***** DTSCU007
|
|
00008 * DTSCU007
|
|
00009 * FUNCTION: AUDIT YEAR / EDIT CONVERSION DTSCU007
|
|
00010 * DTSCU007
|
|
00011 * DTSCU007
|
|
00012 * MODIFICATION LOG: DTSCU007
|
|
00013 * DTSCU007
|
|
00014 * 08/03/98 INITIAL DEVELOPMENT. MODIFIED FROM MACCU007. CL**2
|
|
00015 * WORK ORDER: PROGRAMMER: ZL1. CL**2
|
|
00016 * DTSCU007
|
|
00017 * DTSCU007
|
|
00018 * XX/XX/XX XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSCU007
|
|
00019 * XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSCU007
|
|
00020 * WORK ORDER: PROGRAMMER: DTSCU007
|
|
00021 * DTSCU007
|
|
00022 * DTSCU007
|
|
00023 * DESCRIPTION: DTSCU007
|
|
00024 * DTSCU007
|
|
00025 ***** DTSCU007
|
|
00026 SKIP3 DTSCU007
|
|
00027 ENVIRONMENT DIVISION. DTSCU007
|
|
00028 DATA DIVISION. DTSCU007
|
|
00029 SKIP3 DTSCU007
|
|
00030 WORKING-STORAGE SECTION. DTSCU007
|
|
000305 77 PAN-VALET PICTURE X(24) VALUE '005DTSCU007 10/06/99'. DTSCU007
|
|
00031 01 WRK-AREA. DTSCU007
|
|
00032 05 WS-ABEND-CODE PIC X(04) DTSCU007
|
|
00033 VALUE 'U007'. DTSCU007
|
|
00034 05 WS-YEAR-APART. CL**3
|
|
00035 10 WS-CENTURY PIC 9(02). DTSCU007
|
|
00036 10 WS-YR PIC 9(02). DTSCU007
|
|
00037 05 WS-START-YRQ-X. DTSCU007
|
|
00038 10 WS-START-YR PIC 9(04). DTSCU007
|
|
00039 10 WS-START-Q PIC 9(01) DTSCU007
|
|
00040 VALUE 1. DTSCU007
|
|
00041 05 WS-START-YRQ-9 REDEFINES WS-START-YRQ-X DTSCU007
|
|
00042 PIC 9(05). DTSCU007
|
|
00043 05 WS-END-YRQ-X. DTSCU007
|
|
00044 10 WS-END-YR PIC 9(04). DTSCU007
|
|
00045 10 WS-END-Q PIC 9(01) DTSCU007
|
|
00046 VALUE 4. DTSCU007
|
|
00047 05 WS-END-YRQ-9 REDEFINES WS-END-YRQ-X DTSCU007
|
|
00048 PIC 9(05). DTSCU007
|
|
00049 LINKAGE SECTION. DTSCU007
|
|
00050 01 DFHCOMMAREA. DTSCU007
|
|
00051 ++INCLUDE DTSIL007 CL**2
|
|
00052 PROCEDURE DIVISION. DTSCU007
|
|
00053 SKIP2 DTSCU007
|
|
00054 SET L007-VALID-YR TO TRUE. CL**5
|
|
00055 SKIP2 CL**5
|
|
00056 IF L007-FROM-YR-4 DTSCU007
|
|
00057 PERFORM PROC100-FROM-YR-4 THRU CL**3
|
|
00058 PROC100-FROM-YR-4-EXIT CL**3
|
|
00059 ELSE DTSCU007
|
|
00060 IF L007-FROM-YR-2 DTSCU007
|
|
00061 PERFORM PROC200-FROM-YR-2 THRU CL**3
|
|
00062 PROC200-FROM-YR-2-EXIT CL**3
|
|
00063 ELSE DTSCU007
|
|
00064 EXEC CICS ABEND ABCODE (WS-ABEND-CODE) END-EXEC. CL**3
|
|
00065 CL**4
|
|
00066 IF L007-NOT-VALID-YR CL**4
|
|
00067 GO TO INIT0199-GOBACK. CL**4
|
|
00068 CL**4
|
|
00069 MOVE L007-YR-4-9 TO CL**4
|
|
00070 WS-START-YR CL**4
|
|
00071 WS-END-YR CL**4
|
|
00072 MOVE WS-START-YRQ-9 TO L007-START-YRQ CL**4
|
|
00073 MOVE WS-END-YRQ-9 TO L007-END-YRQ CL**4
|
|
00074 SET L007-VALID-YR TO TRUE. CL**4
|
|
00075 INIT0199-GOBACK. DTSCU007
|
|
00076 EXEC CICS DTSCU007
|
|
00077 RETURN DTSCU007
|
|
00078 END-EXEC. DTSCU007
|
|
00079 PROC100-FROM-YR-4. DTSCU007
|
|
00080 IF L007-YR-4-9 NOT NUMERIC OR CL**3
|
|
00081 L007-YR-4-9 < 1930 OR CL**3
|
|
00082 L007-YR-4-9 > 2029 CL**3
|
|
00083 SET L007-NOT-VALID-YR TO TRUE CL**3
|
|
00084 GO TO PROC100-FROM-YR-4-EXIT. CL**3
|
|
00085 SKIP2 DTSCU007
|
|
00086 MOVE L007-YR-4-9 TO WS-YEAR-APART. DTSCU007
|
|
00087 MOVE WS-YR TO L007-YR-2-9. DTSCU007
|
|
00088 PROC100-FROM-YR-4-EXIT. EXIT. CL**3
|
|
00089 SKIP2 DTSCU007
|
|
00090 PROC200-FROM-YR-2. DTSCU007
|
|
00091 IF L007-YR-2-9 NOT NUMERIC DTSCU007
|
|
00092 SET L007-NOT-VALID-YR TO TRUE CL**3
|
|
00093 GO TO PROC200-FROM-YR-2-EXIT. CL**3
|
|
00094 IF L007-YR-2-9 < 30 DTSCU007
|
|
00095 ADD L007-YR-2-9 2000 GIVING L007-YR-4-9 DTSCU007
|
|
00096 ELSE DTSCU007
|
|
00097 ADD L007-YR-2-9 1900 GIVING L007-YR-4-9. DTSCU007
|
|
00098 PROC200-FROM-YR-2-EXIT. EXIT. CL**3
|