194 lines
15 KiB
COBOL
194 lines
15 KiB
COBOL
00001 IDENTIFICATION DIVISION. 08/05/98
|
|
00002 PROGRAM-ID. DTSBU002. DTSBU002
|
|
00003 AUTHOR. TRICOASTAL CONSULTING LTD. LV003
|
|
00004 DATE-WRITTEN. NOVEMBER 1991. DTSBU002
|
|
00005 DATE-COMPILED. DTSBU002
|
|
00006 SKIP3 DTSBU002
|
|
00007 ***** DTSBU002
|
|
00008 * DTSBU002
|
|
00009 * FUNCTION: DISPLAY DATE IN TEXT FORMAT. DTSBU002
|
|
00010 * DTSBU002
|
|
00011 * DTSBU002
|
|
00012 * MODIFICATION LOG: DTSBU002
|
|
00013 * DTSBU002
|
|
00014 * 08/04/98 CLONED FROM MACCU002. CL**2
|
|
00015 * WORK ORDER: PROGRAMMER: ZL1 CL**2
|
|
00016 * DTSBU002
|
|
00017 * XX/XX/XX XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSBU002
|
|
00018 * XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSBU002
|
|
00019 * WORK ORDER: PROGRAMMER: DTSBU002
|
|
00020 * DTSBU002
|
|
00021 * DTSBU002
|
|
00022 * DESCRIPTION: DTSBU002
|
|
00023 * DTSBU002
|
|
00024 * DTSBU002 IS PASSED L002-OPTION, AND L002-DATE. DTSBU002 CL**2
|
|
00025 * RETURNS L002-LONG-TEXT-CNT, L002-LONG-TEXT-AREA, DTSBU002
|
|
00026 * L002-SHORT-TEXT-CNT, AND L002-SHORT-TEXT-AREA. DTSBU002
|
|
00027 * DTSBU002
|
|
00028 * IF L002-OPTION IS NOT A VALID OPTION OR L002-DATE IS NOT A DTSBU002
|
|
00029 * VALID DATE, THEN ABEND DTSBU002 WITH ABEND CODE +002. CL**2
|
|
00030 * DTSBU002
|
|
00031 * EXAMPLE OF USE: DTSBU002
|
|
00032 * DTSBU002
|
|
00033 * IF L002-UPPER-CASE AND L002-DATE = 19911203, THEN DTSBU002
|
|
00034 * RETURN L002-LONG-TEXT-CNT = 16 AND L002-LONG-TEXT-AREA = DTSBU002
|
|
00035 * 'DECEMBER 3, 1991' AND L002-SHORT-TEXT-CNT = 11 AND DTSBU002
|
|
00036 * L002-SHORT-TEXT-AREA = 'DEC 3, 1991' DTSBU002
|
|
00037 * DTSBU002
|
|
00038 * SET THE SPF EDITOR TO "CAPS OFF" AND THE SCREEN DISPLAY TO DTSBU002
|
|
00039 * MIXED MODE ("Aa") WHEN EDITING THIS MODULE. DTSBU002
|
|
00040 ***** DTSBU002
|
|
00041 SKIP3 DTSBU002
|
|
00042 ENVIRONMENT DIVISION. DTSBU002
|
|
00043 SKIP3 DTSBU002
|
|
00044 DATA DIVISION. DTSBU002
|
|
00045 SKIP3 DTSBU002
|
|
00046 WORKING-STORAGE SECTION. DTSBU002
|
|
000465 77 PAN-VALET PICTURE X(24) VALUE '003DTSBU002 08/05/98'. DTSBU002
|
|
00047 SKIP3 DTSBU002
|
|
00048 01 WRK-AREA. DTSBU002
|
|
00049 05 WRK-ABEND-CD PIC S9(04) COMP VALUE +002. DTSBU002
|
|
00050 05 LONG-SUB PIC S9(04) COMP. DTSBU002
|
|
00051 05 SHORT-SUB PIC S9(04) COMP. DTSBU002
|
|
00052 05 WRK-DAY. DTSBU002
|
|
00053 10 WRK-DAY-1 PIC X(01). DTSBU002
|
|
00054 10 WRK-DAY-2 PIC X(01). DTSBU002
|
|
00055 01 LONG-DATE PIC X(18). DTSBU002
|
|
00056 01 SHORT-DATE PIC X(12). DTSBU002
|
|
00057 SKIP1 DTSBU002
|
|
00058 01 MONTH-TABLE-1. DTSBU002
|
|
00059 05 FILLER PIC X(09) VALUE 'JANUARY '. DTSBU002
|
|
00060 05 FILLER PIC X(09) VALUE 'FEBRUARY '. DTSBU002
|
|
00061 05 FILLER PIC X(09) VALUE 'MARCH '. DTSBU002
|
|
00062 05 FILLER PIC X(09) VALUE 'APRIL '. DTSBU002
|
|
00063 05 FILLER PIC X(09) VALUE 'MAY '. DTSBU002
|
|
00064 05 FILLER PIC X(09) VALUE 'JUNE '. DTSBU002
|
|
00065 05 FILLER PIC X(09) VALUE 'JULY '. DTSBU002
|
|
00066 05 FILLER PIC X(09) VALUE 'AUGUST '. DTSBU002
|
|
00067 05 FILLER PIC X(09) VALUE 'SEPTEMBER'. DTSBU002
|
|
00068 05 FILLER PIC X(09) VALUE 'OCTOBER '. DTSBU002
|
|
00069 05 FILLER PIC X(09) VALUE 'NOVEMBER '. DTSBU002
|
|
00070 05 FILLER PIC X(09) VALUE 'DECEMBER '. DTSBU002
|
|
00071 01 FILLER REDEFINES MONTH-TABLE-1. DTSBU002
|
|
00072 05 FILLER OCCURS 12. DTSBU002
|
|
00073 10 MONTH-NAME-1. DTSBU002
|
|
00074 15 MONTH-NAME-1-SHORT PIC X(03). DTSBU002
|
|
00075 15 FILLER PIC X(06). DTSBU002
|
|
00076 SKIP1 DTSBU002
|
|
00077 01 MONTH-TABLE-2. DTSBU002
|
|
00078 05 FILLER PIC X(09) VALUE 'January '. DTSBU002
|
|
00079 05 FILLER PIC X(09) VALUE 'February '. DTSBU002
|
|
00080 05 FILLER PIC X(09) VALUE 'March '. DTSBU002
|
|
00081 05 FILLER PIC X(09) VALUE 'April '. DTSBU002
|
|
00082 05 FILLER PIC X(09) VALUE 'May '. DTSBU002
|
|
00083 05 FILLER PIC X(09) VALUE 'June '. DTSBU002
|
|
00084 05 FILLER PIC X(09) VALUE 'July '. DTSBU002
|
|
00085 05 FILLER PIC X(09) VALUE 'August '. DTSBU002
|
|
00086 05 FILLER PIC X(09) VALUE 'September'. DTSBU002
|
|
00087 05 FILLER PIC X(09) VALUE 'October '. DTSBU002
|
|
00088 05 FILLER PIC X(09) VALUE 'November '. DTSBU002
|
|
00089 05 FILLER PIC X(09) VALUE 'December '. DTSBU002
|
|
00090 01 FILLER REDEFINES MONTH-TABLE-2. DTSBU002
|
|
00091 05 FILLER OCCURS 12. DTSBU002
|
|
00092 10 MONTH-NAME-2. DTSBU002
|
|
00093 15 MONTH-NAME-2-SHORT PIC X(03). DTSBU002
|
|
00094 15 FILLER PIC X(06). DTSBU002
|
|
00095 SKIP1 DTSBU002
|
|
00096 01 MONTH-TABLE-LENGTH. DTSBU002
|
|
00097 05 LENGTH-JANUARY PIC S9(04) COMP VALUE +7. DTSBU002
|
|
00098 05 LENGTH-FEBRUARY PIC S9(04) COMP VALUE +8. DTSBU002
|
|
00099 05 LENGTH-MARCH PIC S9(04) COMP VALUE +5. DTSBU002
|
|
00100 05 LENGTH-APRIL PIC S9(04) COMP VALUE +5. DTSBU002
|
|
00101 05 LENGTH-MAY PIC S9(04) COMP VALUE +3. DTSBU002
|
|
00102 05 LENGTH-JUNE PIC S9(04) COMP VALUE +4. DTSBU002
|
|
00103 05 LENGTH-JULY PIC S9(04) COMP VALUE +4. DTSBU002
|
|
00104 05 LENGTH-AUGUST PIC S9(04) COMP VALUE +6. DTSBU002
|
|
00105 05 LENGTH-SEPTEMBER PIC S9(04) COMP VALUE +9. DTSBU002
|
|
00106 05 LENGTH-OCTOBER PIC S9(04) COMP VALUE +7. DTSBU002
|
|
00107 05 LENGTH-NOVEMBER PIC S9(04) COMP VALUE +8. DTSBU002
|
|
00108 05 LENGTH-DECEMBER PIC S9(04) COMP VALUE +8. DTSBU002
|
|
00109 01 FILLER REDEFINES MONTH-TABLE-LENGTH. DTSBU002
|
|
00110 05 MONTH-NAME-LENGTH OCCURS 12 TIMES PIC S9(04) COMP. DTSBU002
|
|
00111 EJECT DTSBU002
|
|
00112 01 L001-LINK-AREA. DTSBU002
|
|
00113 ++INCLUDE DTSIL001 CL**3
|
|
00114 EJECT DTSBU002
|
|
00115 LINKAGE SECTION. DTSBU002
|
|
00116 SKIP3 DTSBU002
|
|
00117 01 L002-LINK-AREA. DTSBU002
|
|
00118 ++INCLUDE DTSIL002 CL**3
|
|
00119 EJECT DTSBU002
|
|
00120 PROCEDURE DIVISION DTSBU002
|
|
00121 USING L002-LINK-AREA. DTSBU002
|
|
00122 SKIP2 DTSBU002
|
|
00123 PERFORM P1000-PROCESS THRU CL**2
|
|
00124 P1000-PROCESS-EXIT. CL**2
|
|
00125 SKIP2 DTSBU002
|
|
00126 GOBACK. DTSBU002
|
|
00127 EJECT DTSBU002
|
|
00128 P1000-PROCESS. DTSBU002
|
|
00129 SKIP1 DTSBU002
|
|
00130 MOVE '1' TO L001-OPTION. DTSBU002
|
|
00131 MOVE L002-DATE TO L001-FED-8-DATE-9. DTSBU002
|
|
00132 PERFORM S001-LINK-DATE THRU CL**2
|
|
00133 S001-LINK-DATE-EXIT. CL**2
|
|
00134 IF L001-INVALID-DATE DTSBU002
|
|
00135 PERFORM S999-ABEND THRU S999-ABEND-EXIT. CL**2
|
|
00136 SKIP1 DTSBU002
|
|
00137 IF L002-UPPER-CASE DTSBU002
|
|
00138 MOVE MONTH-NAME-1 (L001-FED-8-MO) TO LONG-DATE DTSBU002
|
|
00139 MOVE MONTH-NAME-1-SHORT (L001-FED-8-MO) TO SHORT-DATE DTSBU002
|
|
00140 ELSE DTSBU002
|
|
00141 IF L002-MIXED-CASE DTSBU002
|
|
00142 MOVE MONTH-NAME-2 (L001-FED-8-MO) TO LONG-DATE DTSBU002
|
|
00143 MOVE MONTH-NAME-2-SHORT (L001-FED-8-MO) TO SHORT-DATE DTSBU002
|
|
00144 ELSE DTSBU002
|
|
00145 PERFORM S999-ABEND THRU S999-ABEND-EXIT. CL**2
|
|
00146 SKIP1 DTSBU002
|
|
00147 PERFORM P1100-DAY-AND-YEAR THRU CL**2
|
|
00148 P1100-DAY-AND-YEAR-EXIT. CL**2
|
|
00149 SKIP1 DTSBU002
|
|
00150 MOVE LONG-DATE TO L002-LONG-TEXT-AREA. DTSBU002
|
|
00151 ADD LONG-SUB, 5 GIVING L002-LONG-TEXT-CNT. DTSBU002
|
|
00152 MOVE SHORT-DATE TO L002-SHORT-TEXT-AREA. DTSBU002
|
|
00153 ADD SHORT-SUB, 5 GIVING L002-SHORT-TEXT-CNT. DTSBU002
|
|
00154 SKIP1 DTSBU002
|
|
00155 P1000-PROCESS-EXIT. CL**2
|
|
00156 EXIT. DTSBU002
|
|
00157 EJECT DTSBU002
|
|
00158 P1100-DAY-AND-YEAR. DTSBU002
|
|
00159 ADD MONTH-NAME-LENGTH (L001-FED-8-MO), 2 GIVING LONG-SUB. DTSBU002
|
|
00160 MOVE +5 TO SHORT-SUB. DTSBU002
|
|
00161 SKIP1 DTSBU002
|
|
00162 MOVE L001-FED-8-DA TO WRK-DAY. DTSBU002
|
|
00163 IF WRK-DAY-1 NOT = '0' DTSBU002
|
|
00164 MOVE WRK-DAY-1 TO LONG-DATE (LONG-SUB : 1) DTSBU002
|
|
00165 SHORT-DATE (SHORT-SUB : 1) DTSBU002
|
|
00166 ADD +1 TO LONG-SUB DTSBU002
|
|
00167 SHORT-SUB. DTSBU002
|
|
00168 MOVE WRK-DAY-2 TO LONG-DATE (LONG-SUB : 1) DTSBU002
|
|
00169 SHORT-DATE (SHORT-SUB : 1) DTSBU002
|
|
00170 SKIP1 DTSBU002
|
|
00171 ADD +1 TO LONG-SUB DTSBU002
|
|
00172 SHORT-SUB. DTSBU002
|
|
00173 MOVE ',' TO LONG-DATE (LONG-SUB : 1) DTSBU002
|
|
00174 SHORT-DATE (SHORT-SUB : 1). DTSBU002
|
|
00175 MOVE L001-FED-8-YR TO LONG-DATE (LONG-SUB + 2 : 4) DTSBU002
|
|
00176 SHORT-DATE (SHORT-SUB + 2 : 4). DTSBU002
|
|
00177 SKIP1 DTSBU002
|
|
00178 P1100-DAY-AND-YEAR-EXIT. EXIT. CL**2
|
|
00179 EJECT DTSBU002
|
|
00180 S001-LINK-DATE. DTSBU002
|
|
00181 SKIP1 DTSBU002
|
|
00182 CALL 'DTSBU001' CL**2
|
|
00183 USING L001-LINK-AREA. DTSBU002
|
|
00184 SKIP1 DTSBU002
|
|
00185 S001-LINK-DATE-EXIT. EXIT. CL**2
|
|
00186 EJECT DTSBU002
|
|
00187 S999-ABEND. DTSBU002
|
|
00188 SKIP1 DTSBU002
|
|
00189 CALL 'DTSBU999' CL**2
|
|
00190 USING WRK-ABEND-CD. DTSBU002
|
|
00191 SKIP1 DTSBU002
|
|
00192 S999-ABEND-EXIT. EXIT. CL**2
|