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