1060 lines
84 KiB
COBOL
1060 lines
84 KiB
COBOL
00001 IDENTIFICATION DIVISION. 07/30/98
|
|
00002 PROGRAM-ID. MACCU351. DTSCU351
|
|
00003 AUTHOR. TRICOASTAL CONSULTING LTD. LV001
|
|
00004 DATE-WRITTEN. DECEMBER 1991. DTSCU351
|
|
00005 DATE-COMPILED. DTSCU351
|
|
00006 DTSCU351
|
|
00007 ***** DTSCU351
|
|
00008 * DTSCU351
|
|
00009 * FUNCTION: FIELD ASSIGNMENT MEMORANDUM PRINT. DTSCU351
|
|
00010 * DTSCU351
|
|
00011 * DTSCU351
|
|
00012 * MODIFICATION LOG: DTSCU351
|
|
00013 * DTSCU351
|
|
00014 * 12/08/91 INITIAL DEVELOPMENT. DTSCU351
|
|
00015 * WORK ORDER: PROGRAMMER: TCL DTSCU351
|
|
00016 * DTSCU351
|
|
00017 * 11/07/97 MODIFICATIONS TO REFLECT TRANSFER OF UI TAX DTSCU351
|
|
00018 * FUNCTIONS FROM DLI TO DOR. DTSCU351
|
|
00019 * WORK ORDER: TCL 208 PROGRAMMER: EHH DTSCU351
|
|
00020 * DTSCU351
|
|
00021 * 03/24/92 DTSCU351
|
|
00022 * WORK ORDER: PROGRAMMER: JME DTSCU351
|
|
00023 * DTSCU351
|
|
00024 * DTSCU351
|
|
00025 * DESCRIPTION: DTSCU351
|
|
00026 * DTSCU351
|
|
00027 * MACCU351 IS PASSED L351-EMP-NO, L351-ASSGN-NO, DTSCU351
|
|
00028 * L351-PRINTER-ID, L351-COPY-CNT, L351-TASK-START-DISP-DATE, DTSCU351
|
|
00029 * AND L351-TASK-START-DISP-TIME. DTSCU351
|
|
00030 * DTSCU351
|
|
00031 * SEE \RAP\RPT\601R1 FOR FIELD ASSIGNMENT MEMORANDUM DESCRIPTIODTSCU351
|
|
00032 * DESCRIPTION AND FORMAT. DTSCU351
|
|
00033 * DTSCU351
|
|
00034 * USE TS Q 'P' TO COMMUNICATE PRINT LINES TO MACIL357. DTSCU351
|
|
00035 * DTSCU351
|
|
00036 * DTSCU351
|
|
00037 * RECORDS READ: DTSCU351
|
|
00038 * DTSCU351
|
|
00039 * MASTER: DTSCU351
|
|
00040 * DTSCU351
|
|
00041 * MPRF DTSCU351
|
|
00042 * MFAS DTSCU351
|
|
00043 * MTAD DTSCU351
|
|
00044 * MOPO DTSCU351
|
|
00045 * DTSCU351
|
|
00046 * DTSCU351
|
|
00047 * MODULES LINKED TO: DTSCU351
|
|
00048 * DTSCU351
|
|
00049 * MACCU036 FIELD SUPPORT CODES EDIT/DESCRIPTION. DTSCU351
|
|
00050 * MACCU062 FIELD REP ID EDIT/DESCRIPTION. DTSCU351
|
|
00051 * MACCU063 FIELD ASSIGNMENT TYPE EDIT/DESCRIPTION. DTSCU351
|
|
00052 * MACCU071 NAME EDIT/CONVERSION. DTSCU351
|
|
00053 * MACCU112 FORMAT ADDRESS FOR MAILING. DTSCU351
|
|
00054 * MACCU119 AGENCY FACTS. DTSCU351
|
|
00055 * MACCU357 ON-LINE PRINTING. DTSCU351
|
|
00056 * MACCU810 MASTER FILE INPUT/OUTPUT. DTSCU351
|
|
00057 * MACCU829 TEMPORARY STORAGE INPUT/OUTPUT. DTSCU351
|
|
00058 * DTSCU351
|
|
00059 * DTSCU351
|
|
00060 * VERMONT REFERENCE: DTSCU351
|
|
00061 * DTSCU351
|
|
00062 * TXCU351. DTSCU351
|
|
00063 * DTSCU351
|
|
00064 * DTSCU351
|
|
00065 * NOTES TO JEFF: DTSCU351
|
|
00066 * DTSCU351
|
|
00067 * . SEE RPT601R1.* IN RPT.ZIP FOR DEFINITIONS AND LAYOUT OF DTSCU351
|
|
00068 * THE REPORT. DTSCU351
|
|
00069 * DTSCU351
|
|
00070 * . DON'T GET TOO CUTE FLOATING PRINT LINES UP AND DOWN THE DTSCU351
|
|
00071 * PAGE. JUST SO THE PRINT LOOKS REASONABLE. DTSCU351
|
|
00072 * DTSCU351
|
|
00073 * . YOU WON'T BE ABLE TO TEST THE MOPO RELATED LOGIC UNTIL DTSCU351
|
|
00074 * WE GET MACCS15 WRITTEN. I WILL SEND YOU MACCS15 IN A DTSCU351
|
|
00075 * WEEK OR TWO. DTSCU351
|
|
00076 * DTSCU351
|
|
00077 * DTSCU351
|
|
00078 ***** DTSCU351
|
|
00079 DTSCU351
|
|
00080 ENVIRONMENT DIVISION. DTSCU351
|
|
00081 DTSCU351
|
|
00082 DATA DIVISION. DTSCU351
|
|
00083 DTSCU351
|
|
00084 WORKING-STORAGE SECTION. DTSCU351
|
|
000845 77 PAN-VALET PICTURE X(24) VALUE '001DTSCU351 07/30/98'. DTSCU351
|
|
00085 DTSCU351
|
|
00086 01 WRK-AREA. DTSCU351
|
|
00087 05 WRK-ABEND-CODE PIC X(04) VALUE 'U351'. DTSCU351
|
|
00088 DTSCU351
|
|
00089 05 LINE-CNT PIC S9(04) COMP. DTSCU351
|
|
00090 DTSCU351
|
|
00091 05 WRK-OCC PIC S9(04) COMP. DTSCU351
|
|
00092 DTSCU351
|
|
00093 05 WRK-OCC1 PIC S9(04) COMP. DTSCU351
|
|
00094 DTSCU351
|
|
00095 05 WRK-OCC2 PIC S9(04) COMP. DTSCU351
|
|
00096 DTSCU351
|
|
00097 05 WRK-COPY-CNT PIC S9(01) COMP-3. DTSCU351
|
|
00098 DTSCU351
|
|
00099 05 WRK-BLANK-LINE-IND PIC X(01). DTSCU351
|
|
00100 88 WRK-BLANK-LINE-YES-88 VALUE 'Y'. DTSCU351
|
|
00101 88 WRK-BLANK-LINE-NO-88 VALUE 'N'. DTSCU351
|
|
00102 DTSCU351
|
|
00103 05 WRK-CC PIC X(01). DTSCU351
|
|
00104 88 WRK-CC-NONE VALUE ' '. DTSCU351
|
|
00105 88 WRK-CC-SKIP-LINE VALUE '0'. DTSCU351
|
|
00106 DTSCU351
|
|
00107 01 WRK-ASSIGN-DESC. DTSCU351
|
|
00108 05 WRK-ASSIGN-DESC1 PIC X(20). DTSCU351
|
|
00109 05 WRK-ASSIGN-DESC2 PIC X(20). DTSCU351
|
|
00110 DTSCU351
|
|
00111 01 TS-AREA. DTSCU351
|
|
00112 05 TS-LINE-CNT PIC S9(04) COMP. DTSCU351
|
|
00113 05 TS-LINE OCCURS 66 TIMES DTSCU351
|
|
00114 INDEXED BY TS-LINE-IDX. DTSCU351
|
|
00115 10 TS-CC PIC X(01). DTSCU351
|
|
00116 88 TS-CC-NEW-PAGE VALUE '1'. DTSCU351
|
|
00117 88 TS-CC-SKIP-LINE VALUE '0'. DTSCU351
|
|
00118 88 TS-CC-NONE VALUE ' '. DTSCU351
|
|
00119 10 TS-TEXT PIC X(78). DTSCU351
|
|
00120 DTSCU351
|
|
00121 01 WRK-ADDRESSES. DTSCU351
|
|
00122 05 WRK-ADDRESS OCCURS 6 TIMES. DTSCU351
|
|
00123 10 WRK-MAILING-LINE OCCURS 6 TIMES PIC X(40). DTSCU351
|
|
00124 DTSCU351
|
|
00125 01 WRK-TELEPHONES. DTSCU351
|
|
00126 * 05 WRK-PHONES OCCURS 6 TIMES. DTSCU351
|
|
00127 10 WRK-TELEPHONE. DTSCU351
|
|
00128 15 WRK-TELEPHONE-LEFT PIC X(01). DTSCU351
|
|
00129 15 WRK-TELEPHONE-AREA-CD PIC X(03). DTSCU351
|
|
00130 15 WRK-TELEPHONE-RIGHT PIC X(02). DTSCU351
|
|
00131 15 WRK-TELEPHONE-PREFIX PIC X(03). DTSCU351
|
|
00132 15 WRK-TELPHONE-DASH PIC X(01). DTSCU351
|
|
00133 15 WRK-TELEPHONE-SUFFIX PIC X(04). DTSCU351
|
|
00134 15 WRK-TELEPHONE-EXT-LBL PIC X(06). DTSCU351
|
|
00135 15 WRK-TELEPHONE-EXT PIC X(04). DTSCU351
|
|
00136 DTSCU351
|
|
00137 01 WRK-HEADING-1. DTSCU351
|
|
00138 05 WRK-PROGRAM PIC X(05) VALUE '601R1'. DTSCU351
|
|
00139 05 FILLER PIC X(19) VALUE SPACES. DTSCU351
|
|
00140 05 WRK-AGY-NAMEA-CNTR PIC X(40). DTSCU351
|
|
00141 05 FILLER PIC X(06) VALUE SPACES. DTSCU351
|
|
00142 05 WRK-SYS-DATE PIC X(08). DTSCU351
|
|
00143 DTSCU351
|
|
00144 01 WRK-HEADING-2. DTSCU351
|
|
00145 05 FILLER PIC X(25) VALUE SPACES. DTSCU351
|
|
00146 05 FILLER PIC X(27) VALUE DTSCU351
|
|
00147 'FIELD ASSIGNMENT MEMORANDUM'. DTSCU351
|
|
00148 05 FILLER PIC X(18) VALUE SPACES. DTSCU351
|
|
00149 05 WRK-SYS-TIME PIC X(08). DTSCU351
|
|
00150 DTSCU351
|
|
00151 01 WRK-LINE-TO. DTSCU351
|
|
00152 05 FILLER PIC X(13) VALUE ' TO: '. DTSCU351
|
|
00153 05 WRK-FIELD-REP-NAME PIC X(32). DTSCU351
|
|
00154 05 FILLER PIC X(13) VALUE ' ASSIGN NO: '. DTSCU351
|
|
00155 05 WRK-ASSIGN-NO PIC 99B99999. DTSCU351
|
|
00156 DTSCU351
|
|
00157 01 WRK-LINE-FROM. DTSCU351
|
|
00158 05 FILLER PIC X(13) DTSCU351
|
|
00159 VALUE ' FROM: '. DTSCU351
|
|
00160 05 WRK-ORIGINATOR PIC X(32). DTSCU351
|
|
00161 05 FILLER PIC X(13) VALUE ' DUE DATE: '. DTSCU351
|
|
00162 05 WRK-DUE-DATE PIC X(08). DTSCU351
|
|
00163 DTSCU351
|
|
00164 01 WRK-LINE-EMP-NO. DTSCU351
|
|
00165 05 FILLER PIC X(13) VALUE ' EMP NO: '. DTSCU351
|
|
00166 05 WRK-EMP-NO PIC 999B999. DTSCU351
|
|
00167 05 FILLER PIC X(25) VALUE SPACES. DTSCU351
|
|
00168 05 FILLER PIC X(13) VALUE 'ASSIGN TYPE: '. DTSCU351
|
|
00169 05 WRK-ASSIGN-TYPE PIC X(02). DTSCU351
|
|
00170 DTSCU351
|
|
00171 01 WRK-LINE-ASSIGN-1. DTSCU351
|
|
00172 05 FILLER PIC X(58) VALUE SPACES. DTSCU351
|
|
00173 05 WRK-ASSIGN-TYPE-DESC1 PIC X(20). DTSCU351
|
|
00174 DTSCU351
|
|
00175 01 WRK-LINE-ASSIGN-2. DTSCU351
|
|
00176 05 FILLER PIC X(13) VALUE ' SIC: '. DTSCU351
|
|
00177 05 WRK-SIC-CD PIC X(07). DTSCU351
|
|
00178 05 FILLER PIC X(01) VALUE SPACES. DTSCU351
|
|
00179 05 WRK-OWN-CD PIC X(02). DTSCU351
|
|
00180 05 FILLER PIC X(35) VALUE SPACES. DTSCU351
|
|
00181 05 WRK-ASSIGN-TYPE-DESC2 PIC X(20). DTSCU351
|
|
00182 DTSCU351
|
|
00183 01 WRK-LINE-FEIN. DTSCU351
|
|
00184 05 FILLER PIC X(13) VALUE ' FEIN: '. DTSCU351
|
|
00185 05 WRK-FEIN-X PIC X(11). DTSCU351
|
|
00186 05 WRK-FEIN REDEFINES WRK-FEIN-X DTSCU351
|
|
00187 PIC 99B9999999B. DTSCU351
|
|
00188 05 FILLER PIC X(20) VALUE SPACES. DTSCU351
|
|
00189 05 FILLER PIC X(14) VALUE 'AUDIT PERIOD: '. DTSCU351
|
|
00190 05 WRK-AUDIT-YRQ-START PIC X(04). DTSCU351
|
|
00191 05 FILLER PIC X(03) VALUE ' - '. DTSCU351
|
|
00192 05 WRK-AUDIT-YRQ-END PIC X(04). DTSCU351
|
|
00193 DTSCU351
|
|
00194 01 WRK-EMP-SIZE-LINE. DTSCU351
|
|
00195 05 FILLER PIC X(43) VALUE SPACES. DTSCU351
|
|
00196 05 FILLER PIC X(15) VALUE 'EMPLOYER SIZE: '.DTSCU351
|
|
00197 05 WRK-EMP-SIZE PIC X(05). DTSCU351
|
|
00198 DTSCU351
|
|
00199 01 WRK-LINE-ADDRESS. DTSCU351
|
|
00200 05 WRK-TAD-ADDRESS PIC X(40). DTSCU351
|
|
00201 05 FILLER PIC X(01) VALUE SPACES. DTSCU351
|
|
00202 05 WRK-OPO-ADDRESS PIC X(37). DTSCU351
|
|
00203 DTSCU351
|
|
00204 01 WRK-LINE-RE. DTSCU351
|
|
00205 05 FILLER PIC X(13) VALUE 'RE CLAIMANT: '. DTSCU351
|
|
00206 05 WRK-CLAIMANT-SSN PIC 999B99B9999. DTSCU351
|
|
00207 05 FILLER PIC X(04) VALUE SPACES. DTSCU351
|
|
00208 05 WRK-CLAIMANT-NAME PIC X(32). DTSCU351
|
|
00209 DTSCU351
|
|
00210 01 WRK-LINE-RELATED-EMP. DTSCU351
|
|
00211 05 FILLER PIC X(13) VALUE 'RELATED EMP: '. DTSCU351
|
|
00212 05 WRK-RELATED-EMP-NO PIC 999B999. DTSCU351
|
|
00213 05 FILLER PIC X(04) VALUE SPACES. DTSCU351
|
|
00214 05 WRK-RELATED-EMP-NAME PIC X(40). DTSCU351
|
|
00215 DTSCU351
|
|
00216 01 WRK-LINE-TEXT. DTSCU351
|
|
00217 05 WRK-TEXT PIC X(72) VALUE SPACES. DTSCU351
|
|
00218 DTSCU351
|
|
00219 01 WRK-LINE-COPY. DTSCU351
|
|
00220 05 FILLER PIC X(25) VALUE SPACES. DTSCU351
|
|
00221 05 WRK-COPY-LIT PIC X(20). DTSCU351
|
|
00222 EJECT DTSCU351
|
|
00223 01 L001-COMM-AREA. DTSCU351
|
|
00224 COPY MACIL001. DTSCU351
|
|
00225 EJECT DTSCU351
|
|
00226 01 L004-COMM-AREA. DTSCU351
|
|
00227 COPY MACIL004. DTSCU351
|
|
00228 EJECT DTSCU351
|
|
00229 01 L056-COMM-AREA. DTSCU351
|
|
00230 COPY MACIL056. DTSCU351
|
|
00231 EJECT DTSCU351
|
|
00232 01 L062-COMM-AREA. DTSCU351
|
|
00233 COPY MACIL062. DTSCU351
|
|
00234 EJECT DTSCU351
|
|
00235 01 L063-COMM-AREA. DTSCU351
|
|
00236 COPY MACIL063. DTSCU351
|
|
00237 EJECT DTSCU351
|
|
00238 01 L071-COMM-AREA. DTSCU351
|
|
00239 COPY MACIL071. DTSCU351
|
|
00240 EJECT DTSCU351
|
|
00241 01 L082-COMM-AREA. DTSCU351
|
|
00242 COPY MACIL082. DTSCU351
|
|
00243 EJECT DTSCU351
|
|
00244 01 L112-COMM-AREA. DTSCU351
|
|
00245 COPY MACIL112. DTSCU351
|
|
00246 EJECT DTSCU351
|
|
00247 01 L119-COMM-AREA. DTSCU351
|
|
00248 COPY MACIL119. DTSCU351
|
|
00249 EJECT DTSCU351
|
|
00250 01 L357-COMM-AREA. DTSCU351
|
|
00251 COPY MACIL357. DTSCU351
|
|
00252 EJECT DTSCU351
|
|
00253 01 L829-COMM-AREA. DTSCU351
|
|
00254 05 L829-CONTROL-BLOCK. DTSCU351
|
|
00255 COPY MACIL829. DTSCU351
|
|
00256 DTSCU351
|
|
00257 05 L829-REC. DTSCU351
|
|
00258 COPY MACIXPTS. DTSCU351
|
|
00259 EJECT DTSCU351
|
|
00260 01 L810-COMM-AREA. DTSCU351
|
|
00261 05 L810-CONTROL-BLOCK. DTSCU351
|
|
00262 COPY MACIL810. DTSCU351
|
|
00263 DTSCU351
|
|
00264 05 MSKL-REC. DTSCU351
|
|
00265 COPY MACIMSKL. DTSCU351
|
|
00266 EJECT DTSCU351
|
|
00267 01 MPRF-REC. DTSCU351
|
|
00268 COPY MACIMPRF. DTSCU351
|
|
00269 EJECT DTSCU351
|
|
00270 01 MTAD-REC. DTSCU351
|
|
00271 COPY MACIMTAD. DTSCU351
|
|
00272 EJECT DTSCU351
|
|
00273 01 MFAS-REC. DTSCU351
|
|
00274 COPY MACIMFAS. DTSCU351
|
|
00275 EJECT DTSCU351
|
|
00276 01 MOPO-REC. DTSCU351
|
|
00277 COPY MACIMOPO. DTSCU351
|
|
00278 EJECT DTSCU351
|
|
00279 LINKAGE SECTION. DTSCU351
|
|
00280 DTSCU351
|
|
00281 01 DFHCOMMAREA. DTSCU351
|
|
00282 COPY MACIL351. DTSCU351
|
|
00283 DTSCU351
|
|
00284 /*****************************************************************DTSCU351
|
|
00285 * DTSCU351
|
|
00286 ******************************************************************DTSCU351
|
|
00287 PROCEDURE DIVISION. DTSCU351
|
|
00288 *-----------------------------------------------------------------DTSCU351
|
|
00289 * CLEAN UP AND INITIALIZE TS QUEUE AREA. DTSCU351
|
|
00290 *-----------------------------------------------------------------DTSCU351
|
|
00291 MOVE 0 TO L829-ITEM-NO. DTSCU351
|
|
00292 DTSCU351
|
|
00293 MOVE XPTS-LENGTH TO L829-REC-LENGTH. DTSCU351
|
|
00294 DTSCU351
|
|
00295 SET L829-DEFAULT-STORAGE-88 TO TRUE. DTSCU351
|
|
00296 DTSCU351
|
|
00297 MOVE L351-TS-NAME-PREFIX TO L829-QUEUE-NAME-PREFIX. DTSCU351
|
|
00298 DTSCU351
|
|
00299 MOVE 'P' TO L829-QUEUE-NAME-SUFFIX. DTSCU351
|
|
00300 DTSCU351
|
|
00301 COMPUTE L829-COMM-AREA-LENGTH DTSCU351
|
|
00302 = L829-CONTROL-BLOCK-LENGTH + L829-REC-LENGTH. DTSCU351
|
|
00303 DTSCU351
|
|
00304 PERFORM S829-DELETE-QUEUE THRU S829-EXIT. DTSCU351
|
|
00305 DTSCU351
|
|
00306 MOVE L351-PRINTER-ID TO L357-PRINTER-ID. DTSCU351
|
|
00307 DTSCU351
|
|
00308 MOVE L829-QUEUE-NAME TO L357-QUEUE-NAME DTSCU351
|
|
00309 DTSCU351
|
|
00310 DTSCU351
|
|
00311 *-----------------------------------------------------------------DTSCU351
|
|
00312 * SET RESULT TO OK AND AND START PROCESS DTSCU351
|
|
00313 *-----------------------------------------------------------------DTSCU351
|
|
00314 SET L351-PRINT-OK TO TRUE. DTSCU351
|
|
00315 DTSCU351
|
|
00316 IF L351-COPY-CNT = 0 DTSCU351
|
|
00317 SET L351-PRINT-FAILED TO TRUE DTSCU351
|
|
00318 ELSE DTSCU351
|
|
00319 PERFORM P1000-PROCESS THRU P1000-EXIT DTSCU351
|
|
00320 IF L351-PRINT-FAILED DTSCU351
|
|
00321 PERFORM S829-DELETE-QUEUE THRU S829-EXIT DTSCU351
|
|
00322 ELSE DTSCU351
|
|
00323 PERFORM S357-LINK-PRINT THRU S357-EXIT DTSCU351
|
|
00324 IF L357-FAILED-88 DTSCU351
|
|
00325 SET L351-PRINT-FAILED TO TRUE DTSCU351
|
|
00326 END-IF. DTSCU351
|
|
00327 DTSCU351
|
|
00328 EXEC CICS DTSCU351
|
|
00329 RETURN DTSCU351
|
|
00330 END-EXEC. DTSCU351
|
|
00331 DTSCU351
|
|
00332 GOBACK. DTSCU351
|
|
00333 /*****************************************************************DTSCU351
|
|
00334 * DTSCU351
|
|
00335 ******************************************************************DTSCU351
|
|
00336 P1000-PROCESS. DTSCU351
|
|
00337 PERFORM P1010-READ-PRF THRU P1010-EXIT DTSCU351
|
|
00338 IF L351-PRINT-FAILED DTSCU351
|
|
00339 GO TO P1000-EXIT DTSCU351
|
|
00340 END-IF. DTSCU351
|
|
00341 DTSCU351
|
|
00342 PERFORM P1020-READ-FAS THRU P1020-EXIT. DTSCU351
|
|
00343 IF L351-PRINT-FAILED DTSCU351
|
|
00344 GO TO P1000-EXIT DTSCU351
|
|
00345 END-IF. DTSCU351
|
|
00346 DTSCU351
|
|
00347 PERFORM P1100-HEADING THRU P1100-EXIT. DTSCU351
|
|
00348 DTSCU351
|
|
00349 PERFORM P1200-FAS-AREA THRU P1200-EXIT. DTSCU351
|
|
00350 DTSCU351
|
|
00351 PERFORM P1300-ADDRESSES THRU P1300-EXIT. DTSCU351
|
|
00352 DTSCU351
|
|
00353 PERFORM P1400-CLAIMANT THRU P1400-EXIT. DTSCU351
|
|
00354 DTSCU351
|
|
00355 PERFORM P1500-REL-EMP THRU P1500-EXIT. DTSCU351
|
|
00356 DTSCU351
|
|
00357 ADD +1 TO TS-LINE-CNT DTSCU351
|
|
00358 MOVE ' ' TO TS-CC(TS-LINE-CNT) DTSCU351
|
|
00359 MOVE SPACES TO TS-TEXT(TS-LINE-CNT). DTSCU351
|
|
00360 ADD +1 TO LINE-CNT. DTSCU351
|
|
00361 DTSCU351
|
|
00362 IF MFAS-TEXT-CNT NOT EQUAL 0 DTSCU351
|
|
00363 PERFORM P1600-FAS-TEXT THRU P1600-EXIT DTSCU351
|
|
00364 VARYING MFAS-TEXT-IDX DTSCU351
|
|
00365 FROM 1 BY 1 DTSCU351
|
|
00366 UNTIL MFAS-TEXT-IDX > MFAS-TEXT-CNT. DTSCU351
|
|
00367 DTSCU351
|
|
00368 PERFORM P7000-COPY-LINE THRU P7000-EXIT. DTSCU351
|
|
00369 DTSCU351
|
|
00370 MOVE '(FIELD REP COPY)' TO WRK-COPY-LIT. DTSCU351
|
|
00371 PERFORM P8000-TS-WRITE THRU P8000-EXIT. DTSCU351
|
|
00372 DTSCU351
|
|
00373 IF L351-PRINT-FAILED DTSCU351
|
|
00374 GO TO P1000-EXIT DTSCU351
|
|
00375 END-IF. DTSCU351
|
|
00376 DTSCU351
|
|
00377 MOVE +0 TO WRK-COPY-CNT. DTSCU351
|
|
00378 PERFORM P2000-COPY-IND THRU P2000-EXIT. DTSCU351
|
|
00379 DTSCU351
|
|
00380 IF L351-COPY-CNT > 1 DTSCU351
|
|
00381 MOVE '(EMPLOYER FILE COPY)' TO WRK-COPY-LIT DTSCU351
|
|
00382 PERFORM P8000-TS-WRITE THRU P8000-EXIT DTSCU351
|
|
00383 PERFORM P2000-COPY-IND THRU P2000-EXIT DTSCU351
|
|
00384 END-IF. DTSCU351
|
|
00385 DTSCU351
|
|
00386 IF L351-PRINT-FAILED DTSCU351
|
|
00387 GO TO P1000-EXIT DTSCU351
|
|
00388 END-IF. DTSCU351
|
|
00389 DTSCU351
|
|
00390 IF L351-COPY-CNT > 2 DTSCU351
|
|
00391 MOVE SPACES TO WRK-COPY-LIT DTSCU351
|
|
00392 PERFORM P8000-TS-WRITE THRU P8000-EXIT DTSCU351
|
|
00393 PERFORM P2000-COPY-IND THRU P2000-EXIT DTSCU351
|
|
00394 END-IF. DTSCU351
|
|
00395 DTSCU351
|
|
00396 IF L351-PRINT-FAILED DTSCU351
|
|
00397 GO TO P1000-EXIT DTSCU351
|
|
00398 END-IF. DTSCU351
|
|
00399 DTSCU351
|
|
00400 IF L351-COPY-CNT > 3 DTSCU351
|
|
00401 IF MFAS-RELATED-EMP-NO NOT = 0 DTSCU351
|
|
00402 MOVE SPACES TO WRK-COPY-LIT DTSCU351
|
|
00403 ELSE DTSCU351
|
|
00404 MOVE SPACES TO WRK-COPY-LIT DTSCU351
|
|
00405 END-IF DTSCU351
|
|
00406 PERFORM P8000-TS-WRITE THRU P8000-EXIT DTSCU351
|
|
00407 PERFORM P2000-COPY-IND THRU P2000-EXIT DTSCU351
|
|
00408 END-IF DTSCU351
|
|
00409 DTSCU351
|
|
00410 IF L351-PRINT-FAILED DTSCU351
|
|
00411 GO TO P1000-EXIT. DTSCU351
|
|
00412 DTSCU351
|
|
00413 PERFORM P1001-ADDL-COPIES THRU P1001-EXIT DTSCU351
|
|
00414 UNTIL (WRK-COPY-CNT NOT < L351-COPY-CNT) DTSCU351
|
|
00415 OR DTSCU351
|
|
00416 (L351-PRINT-FAILED). DTSCU351
|
|
00417 DTSCU351
|
|
00418 P1000-EXIT. DTSCU351
|
|
00419 EXIT. DTSCU351
|
|
00420 DTSCU351
|
|
00421 P1001-ADDL-COPIES. DTSCU351
|
|
00422 MOVE SPACES TO WRK-COPY-LIT. DTSCU351
|
|
00423 PERFORM P8000-TS-WRITE THRU P8000-EXIT. DTSCU351
|
|
00424 PERFORM P2000-COPY-IND THRU P2000-EXIT. DTSCU351
|
|
00425 P1001-EXIT. DTSCU351
|
|
00426 EXIT. DTSCU351
|
|
00427 /*****************************************************************DTSCU351
|
|
00428 * READ EMPLOYER PROFILE DTSCU351
|
|
00429 ******************************************************************DTSCU351
|
|
00430 P1010-READ-PRF. DTSCU351
|
|
00431 MOVE LOW-VALUES TO MPRF-KEY-AREA. DTSCU351
|
|
00432 MOVE L351-EMP-NO TO MPRF-EMP-NO. DTSCU351
|
|
00433 SET MPRF-PRF-88 TO TRUE. DTSCU351
|
|
00434 MOVE MPRF-KEY-AREA TO MSKL-KEY-AREA. DTSCU351
|
|
00435 PERFORM S810-READ THRU S810-EXIT. DTSCU351
|
|
00436 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351
|
|
00437 SET L351-PRINT-FAILED TO TRUE DTSCU351
|
|
00438 ELSE DTSCU351
|
|
00439 MOVE MSKL-REC TO MPRF-REC DTSCU351
|
|
00440 END-IF. DTSCU351
|
|
00441 P1010-EXIT. DTSCU351
|
|
00442 EXIT. DTSCU351
|
|
00443 DTSCU351
|
|
00444 /*****************************************************************DTSCU351
|
|
00445 * READ FIELD ASSIGNMENT DTSCU351
|
|
00446 ******************************************************************DTSCU351
|
|
00447 P1020-READ-FAS. DTSCU351
|
|
00448 MOVE LOW-VALUES TO MFAS-KEY-AREA. DTSCU351
|
|
00449 MOVE L351-EMP-NO TO MFAS-EMP-NO. DTSCU351
|
|
00450 MOVE L351-ASSIGN-NO TO MFAS-ASSIGN-NO. DTSCU351
|
|
00451 SET MFAS-FAS-88 TO TRUE. DTSCU351
|
|
00452 MOVE MFAS-KEY-AREA TO MSKL-KEY-AREA. DTSCU351
|
|
00453 PERFORM S810-READ THRU S810-EXIT. DTSCU351
|
|
00454 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351
|
|
00455 SET L351-PRINT-FAILED TO TRUE DTSCU351
|
|
00456 ELSE DTSCU351
|
|
00457 MOVE MSKL-REC TO MFAS-REC DTSCU351
|
|
00458 END-IF. DTSCU351
|
|
00459 P1020-EXIT. DTSCU351
|
|
00460 EXIT. DTSCU351
|
|
00461 DTSCU351
|
|
00462 /*****************************************************************DTSCU351
|
|
00463 * BUILD FIELD ASSIGNMENT MEMO HEADING (FIRST 3 LINES) DTSCU351
|
|
00464 ******************************************************************DTSCU351
|
|
00465 P1100-HEADING. DTSCU351
|
|
00466 MOVE L351-TASK-START-DISP-DATE TO WRK-SYS-DATE. DTSCU351
|
|
00467 MOVE L351-TASK-START-DISP-TIME TO WRK-SYS-TIME. DTSCU351
|
|
00468 DTSCU351
|
|
00469 PERFORM S119-AGENCY-FACTS THRU S119-EXIT. DTSCU351
|
|
00470 DTSCU351
|
|
00471 MOVE L119-AGY-NAMEA TO WRK-AGY-NAMEA-CNTR. DTSCU351
|
|
00472 SET TS-CC-NEW-PAGE(1) TO TRUE. DTSCU351
|
|
00473 MOVE WRK-HEADING-1 TO TS-TEXT(1). DTSCU351
|
|
00474 SET TS-CC-NONE(2) TO TRUE. DTSCU351
|
|
00475 MOVE WRK-HEADING-2 TO TS-TEXT(2). DTSCU351
|
|
00476 MOVE +02 TO TS-LINE-CNT. DTSCU351
|
|
00477 MOVE +02 TO LINE-CNT. DTSCU351
|
|
00478 P1100-EXIT. EXIT. DTSCU351
|
|
00479 DTSCU351
|
|
00480 /*****************************************************************DTSCU351
|
|
00481 * BUILD FIELD ASSIGNMENT SPECIFIC INFORMATION DTSCU351
|
|
00482 ******************************************************************DTSCU351
|
|
00483 P1200-FAS-AREA. DTSCU351
|
|
00484 SET TS-CC-SKIP-LINE(3) TO TRUE. DTSCU351
|
|
00485 MOVE MFAS-FLD-REP-ID TO L062-FLD-REP-ID. DTSCU351
|
|
00486 PERFORM S062-AUDIT-EDIT THRU S062-EXIT. DTSCU351
|
|
00487 MOVE L062-NAME TO WRK-FIELD-REP-NAME. DTSCU351
|
|
00488 MOVE MFAS-ASSIGN-NO TO WRK-ASSIGN-NO. DTSCU351
|
|
00489 MOVE WRK-LINE-TO TO TS-TEXT(3). DTSCU351
|
|
00490 DTSCU351
|
|
00491 SET TS-CC-SKIP-LINE(4) TO TRUE. DTSCU351
|
|
00492 MOVE MFAS-SOURCE-OP-ID TO L082-OP-ID. DTSCU351
|
|
00493 PERFORM S082-OP-ID THRU S082-EXIT. DTSCU351
|
|
00494 MOVE L082-NAME TO WRK-ORIGINATOR. DTSCU351
|
|
00495 MOVE MFAS-DUE-DATE TO L001-FED-8-DATE-9. DTSCU351
|
|
00496 PERFORM S001-FROM-FED-8 THRU S001-EXIT. DTSCU351
|
|
00497 MOVE L001-SLASH-DATE TO WRK-DUE-DATE. DTSCU351
|
|
00498 MOVE WRK-LINE-FROM TO TS-TEXT(4). DTSCU351
|
|
00499 DTSCU351
|
|
00500 SET TS-CC-SKIP-LINE(5) TO TRUE. DTSCU351
|
|
00501 MOVE MFAS-ASSIGN-TYPE TO L063-TYPE. DTSCU351
|
|
00502 PERFORM S063-ASSIGN-TYPE THRU S063-EXIT. DTSCU351
|
|
00503 MOVE L063-TYPE TO WRK-ASSIGN-TYPE. DTSCU351
|
|
00504 MOVE MFAS-EMP-NO TO WRK-EMP-NO. DTSCU351
|
|
00505 MOVE WRK-LINE-EMP-NO TO TS-TEXT(5). DTSCU351
|
|
00506 DTSCU351
|
|
00507 SET TS-CC-NONE(6) TO TRUE. DTSCU351
|
|
00508 MOVE L063-DESCRIPTION TO WRK-ASSIGN-DESC. DTSCU351
|
|
00509 MOVE WRK-ASSIGN-DESC1 TO WRK-ASSIGN-TYPE-DESC1. DTSCU351
|
|
00510 MOVE WRK-LINE-ASSIGN-1 TO TS-TEXT(6). DTSCU351
|
|
00511 DTSCU351
|
|
00512 SET TS-CC-NONE(7) TO TRUE. DTSCU351
|
|
00513 MOVE MFAS-SIC-CD TO WRK-SIC-CD. DTSCU351
|
|
00514 MOVE MFAS-OWN-CD TO WRK-OWN-CD. DTSCU351
|
|
00515 DTSCU351
|
|
00516 MOVE WRK-ASSIGN-DESC2 TO WRK-ASSIGN-TYPE-DESC2. DTSCU351
|
|
00517 MOVE WRK-LINE-ASSIGN-2 TO TS-TEXT(7). DTSCU351
|
|
00518 DTSCU351
|
|
00519 SET TS-CC-NONE(8) TO TRUE. DTSCU351
|
|
00520 IF MPRF-FEIN > 0 DTSCU351
|
|
00521 MOVE MPRF-FEIN TO WRK-FEIN DTSCU351
|
|
00522 ELSE DTSCU351
|
|
00523 MOVE SPACES TO WRK-FEIN-X DTSCU351
|
|
00524 END-IF. DTSCU351
|
|
00525 DTSCU351
|
|
00526 MOVE MFAS-AUDIT-START-YRQ TO L004-QTR-5-9. DTSCU351
|
|
00527 PERFORM S004-FROM-5 THRU S004-EXIT. DTSCU351
|
|
00528 MOVE L004-SLASH-QTR TO WRK-AUDIT-YRQ-START. DTSCU351
|
|
00529 MOVE MFAS-AUDIT-END-YRQ TO L004-QTR-5-9. DTSCU351
|
|
00530 PERFORM S004-FROM-5 THRU S004-EXIT. DTSCU351
|
|
00531 MOVE L004-SLASH-QTR TO WRK-AUDIT-YRQ-END. DTSCU351
|
|
00532 MOVE WRK-LINE-FEIN TO TS-TEXT(8). DTSCU351
|
|
00533 DTSCU351
|
|
00534 SET TS-CC-NONE(9) TO TRUE. DTSCU351
|
|
00535 IF MFAS-AUDIT-88 DTSCU351
|
|
00536 IF MFAS-EMP-LARGE-88 DTSCU351
|
|
00537 MOVE 'LARGE' TO WRK-EMP-SIZE DTSCU351
|
|
00538 ELSE DTSCU351
|
|
00539 MOVE 'SMALL' TO WRK-EMP-SIZE DTSCU351
|
|
00540 END-IF DTSCU351
|
|
00541 ELSE DTSCU351
|
|
00542 MOVE SPACES TO WRK-EMP-SIZE DTSCU351
|
|
00543 END-IF. DTSCU351
|
|
00544 MOVE WRK-EMP-SIZE-LINE TO TS-TEXT(9). DTSCU351
|
|
00545 DTSCU351
|
|
00546 MOVE +09 TO TS-LINE-CNT. DTSCU351
|
|
00547 MOVE +12 TO LINE-CNT. DTSCU351
|
|
00548 P1200-EXIT. DTSCU351
|
|
00549 EXIT. DTSCU351
|
|
00550 /*****************************************************************DTSCU351
|
|
00551 * OBTAIN ADDRESS INFORMATION FROM FILE AND STORE IN TABLE DTSCU351
|
|
00552 ******************************************************************DTSCU351
|
|
00553 P1300-ADDRESSES. DTSCU351
|
|
00554 MOVE SPACES TO WRK-ADDRESSES. DTSCU351
|
|
00555 DTSCU351
|
|
00556 PERFORM P1310-FORMAT-TAX-ADDR THRU P1310-EXIT. DTSCU351
|
|
00557 DTSCU351
|
|
00558 PERFORM P1320-FORMAT-OPO-ADDR THRU P1320-EXIT. DTSCU351
|
|
00559 DTSCU351
|
|
00560 MOVE SPACE TO WRK-TAD-ADDRESS. DTSCU351
|
|
00561 DTSCU351
|
|
00562 MOVE SPACE TO WRK-OPO-ADDRESS. DTSCU351
|
|
00563 DTSCU351
|
|
00564 PERFORM VARYING WRK-OCC FROM 1 BY 1 DTSCU351
|
|
00565 UNTIL WRK-OCC > 3 DTSCU351
|
|
00566 DTSCU351
|
|
00567 SET WRK-CC-SKIP-LINE TO TRUE DTSCU351
|
|
00568 DTSCU351
|
|
00569 ADD 3 TO WRK-OCC GIVING WRK-OCC2 DTSCU351
|
|
00570 PERFORM VARYING WRK-OCC1 FROM 1 BY 1 DTSCU351
|
|
00571 UNTIL WRK-OCC1 > 6 DTSCU351
|
|
00572 IF WRK-MAILING-LINE (WRK-OCC, WRK-OCC1) = SPACES DTSCU351
|
|
00573 AND WRK-MAILING-LINE (WRK-OCC2, WRK-OCC1) = SPACES DTSCU351
|
|
00574 CONTINUE DTSCU351
|
|
00575 ELSE DTSCU351
|
|
00576 MOVE WRK-MAILING-LINE (WRK-OCC, WRK-OCC1) DTSCU351
|
|
00577 TO WRK-TAD-ADDRESS DTSCU351
|
|
00578 MOVE WRK-MAILING-LINE (WRK-OCC2, WRK-OCC1) DTSCU351
|
|
00579 TO WRK-OPO-ADDRESS DTSCU351
|
|
00580 ADD 1 TO TS-LINE-CNT DTSCU351
|
|
00581 MOVE WRK-CC TO TS-CC (TS-LINE-CNT) DTSCU351
|
|
00582 SET WRK-CC-NONE TO TRUE DTSCU351
|
|
00583 MOVE WRK-LINE-ADDRESS TO TS-TEXT (TS-LINE-CNT) DTSCU351
|
|
00584 PERFORM P1301-LINE-CNT THRU P1301-EXIT DTSCU351
|
|
00585 END-IF DTSCU351
|
|
00586 END-PERFORM DTSCU351
|
|
00587 END-PERFORM. DTSCU351
|
|
00588 P1300-EXIT. EXIT. DTSCU351
|
|
00589 DTSCU351
|
|
00590 P1301-LINE-CNT. DTSCU351
|
|
00591 IF TS-CC-SKIP-LINE (TS-LINE-CNT) DTSCU351
|
|
00592 ADD +2 TO LINE-CNT DTSCU351
|
|
00593 ELSE DTSCU351
|
|
00594 ADD +1 TO LINE-CNT. DTSCU351
|
|
00595 P1301-EXIT. DTSCU351
|
|
00596 EXIT. DTSCU351
|
|
00597 /*****************************************************************DTSCU351
|
|
00598 * READ AND FORMAT FROM TAD (REPETITIVE CODE USED FOR READABLILITY)DTSCU351
|
|
00599 ******************************************************************DTSCU351
|
|
00600 P1310-FORMAT-TAX-ADDR. DTSCU351
|
|
00601 MOVE LOW-VALUES TO MTAD-KEY-AREA. DTSCU351
|
|
00602 MOVE MPRF-EMP-NO TO MTAD-EMP-NO. DTSCU351
|
|
00603 SET MTAD-TAD-88 TO TRUE. DTSCU351
|
|
00604 MOVE MTAD-KEY-AREA TO MSKL-KEY-AREA. DTSCU351
|
|
00605 PERFORM S810-START-BROWSE THRU S810-EXIT. DTSCU351
|
|
00606 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351
|
|
00607 GO TO P1310-EXIT DTSCU351
|
|
00608 END-IF. DTSCU351
|
|
00609 MOVE +0 TO WRK-OCC. DTSCU351
|
|
00610 PERFORM P1315-FORMAT THRU P1315-EXIT. DTSCU351
|
|
00611 DTSCU351
|
|
00612 PERFORM S810-READ-NEXT THRU S810-EXIT. DTSCU351
|
|
00613 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351
|
|
00614 GO TO P1310-EXIT DTSCU351
|
|
00615 END-IF. DTSCU351
|
|
00616 PERFORM P1315-FORMAT THRU P1315-EXIT. DTSCU351
|
|
00617 DTSCU351
|
|
00618 PERFORM S810-READ-NEXT THRU S810-EXIT. DTSCU351
|
|
00619 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351
|
|
00620 GO TO P1310-EXIT DTSCU351
|
|
00621 END-IF. DTSCU351
|
|
00622 PERFORM P1315-FORMAT THRU P1315-EXIT. DTSCU351
|
|
00623 DTSCU351
|
|
00624 PERFORM S810-END-BROWSE THRU S810-EXIT. DTSCU351
|
|
00625 DTSCU351
|
|
00626 P1310-EXIT. DTSCU351
|
|
00627 EXIT. DTSCU351
|
|
00628 EJECT DTSCU351
|
|
00629 DTSCU351
|
|
00630 /*****************************************************************DTSCU351
|
|
00631 * DTSCU351
|
|
00632 ******************************************************************DTSCU351
|
|
00633 P1315-FORMAT. DTSCU351
|
|
00634 ADD +1 TO WRK-OCC. DTSCU351
|
|
00635 MOVE MSKL-REC TO MTAD-REC. DTSCU351
|
|
00636 PERFORM S112-FORMAT-TAD THRU S112-EXIT. DTSCU351
|
|
00637 DTSCU351
|
|
00638 IF MTAD-VOICE = SPACES DTSCU351
|
|
00639 MOVE SPACES TO WRK-TELEPHONE DTSCU351
|
|
00640 ELSE DTSCU351
|
|
00641 MOVE '(' TO WRK-TELEPHONE-LEFT DTSCU351
|
|
00642 MOVE MTAD-VOICE-AREA-CD TO WRK-TELEPHONE-AREA-CD DTSCU351
|
|
00643 MOVE ') ' TO WRK-TELEPHONE-RIGHT DTSCU351
|
|
00644 MOVE MTAD-VOICE-PREFIX TO WRK-TELEPHONE-PREFIX DTSCU351
|
|
00645 MOVE '-' TO WRK-TELPHONE-DASH DTSCU351
|
|
00646 MOVE MTAD-VOICE-SUFFIX TO WRK-TELEPHONE-SUFFIX DTSCU351
|
|
00647 IF MTAD-VOICE-EXT NOT = SPACES DTSCU351
|
|
00648 MOVE ' EXT. ' TO WRK-TELEPHONE-EXT-LBL DTSCU351
|
|
00649 MOVE MTAD-VOICE-EXT TO WRK-TELEPHONE-EXT DTSCU351
|
|
00650 ELSE DTSCU351
|
|
00651 MOVE SPACES TO WRK-TELEPHONE-EXT-LBL DTSCU351
|
|
00652 MOVE SPACES TO WRK-TELEPHONE-EXT DTSCU351
|
|
00653 END-IF. DTSCU351
|
|
00654 MOVE L112-MAILING-ADDRESS TO WRK-ADDRESS(WRK-OCC). DTSCU351
|
|
00655 MOVE WRK-TELEPHONE TO WRK-MAILING-LINE(WRK-OCC, 6).DTSCU351
|
|
00656 PERFORM P1330-SCRUNCH THRU P1330-EXIT. DTSCU351
|
|
00657 P1315-EXIT. DTSCU351
|
|
00658 EXIT. DTSCU351
|
|
00659 DTSCU351
|
|
00660 /*****************************************************************DTSCU351
|
|
00661 * READ AND FORMAT FROM OPO (REPETITIVE CODE USED FOR READABLILITY)DTSCU351
|
|
00662 ******************************************************************DTSCU351
|
|
00663 P1320-FORMAT-OPO-ADDR. DTSCU351
|
|
00664 MOVE LOW-VALUES TO MOPO-KEY-AREA. DTSCU351
|
|
00665 MOVE MPRF-EMP-NO TO MOPO-EMP-NO. DTSCU351
|
|
00666 SET MOPO-OPO-88 TO TRUE. DTSCU351
|
|
00667 MOVE MOPO-KEY-AREA TO MSKL-KEY-AREA. DTSCU351
|
|
00668 PERFORM S810-START-BROWSE THRU S810-EXIT. DTSCU351
|
|
00669 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351
|
|
00670 GO TO P1320-EXIT DTSCU351
|
|
00671 END-IF. DTSCU351
|
|
00672 DTSCU351
|
|
00673 MOVE +3 TO WRK-OCC. DTSCU351
|
|
00674 PERFORM P1325-FORMAT THRU P1325-EXIT. DTSCU351
|
|
00675 DTSCU351
|
|
00676 PERFORM S810-READ-NEXT THRU S810-EXIT. DTSCU351
|
|
00677 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351
|
|
00678 GO TO P1320-EXIT DTSCU351
|
|
00679 END-IF. DTSCU351
|
|
00680 PERFORM P1325-FORMAT THRU P1325-EXIT. DTSCU351
|
|
00681 DTSCU351
|
|
00682 PERFORM S810-READ-NEXT THRU S810-EXIT. DTSCU351
|
|
00683 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351
|
|
00684 GO TO P1320-EXIT DTSCU351
|
|
00685 END-IF. DTSCU351
|
|
00686 PERFORM P1325-FORMAT THRU P1325-EXIT. DTSCU351
|
|
00687 DTSCU351
|
|
00688 PERFORM S810-END-BROWSE THRU S810-EXIT. DTSCU351
|
|
00689 DTSCU351
|
|
00690 P1320-EXIT. DTSCU351
|
|
00691 EXIT. DTSCU351
|
|
00692 EJECT DTSCU351
|
|
00693 /*****************************************************************DTSCU351
|
|
00694 * DTSCU351
|
|
00695 ******************************************************************DTSCU351
|
|
00696 P1325-FORMAT. DTSCU351
|
|
00697 ADD +1 TO WRK-OCC. DTSCU351
|
|
00698 MOVE MSKL-REC TO MOPO-REC. DTSCU351
|
|
00699 IF MOPO-VOICE = SPACES DTSCU351
|
|
00700 MOVE SPACES TO WRK-TELEPHONE DTSCU351
|
|
00701 ELSE DTSCU351
|
|
00702 MOVE '(' TO WRK-TELEPHONE-LEFT DTSCU351
|
|
00703 MOVE MOPO-VOICE-AREA-CD TO WRK-TELEPHONE-AREA-CD DTSCU351
|
|
00704 MOVE ') ' TO WRK-TELEPHONE-RIGHT DTSCU351
|
|
00705 MOVE MOPO-VOICE-PREFIX TO WRK-TELEPHONE-PREFIX DTSCU351
|
|
00706 MOVE '-' TO WRK-TELPHONE-DASH DTSCU351
|
|
00707 MOVE MOPO-VOICE-SUFFIX TO WRK-TELEPHONE-SUFFIX DTSCU351
|
|
00708 IF MOPO-VOICE-EXT NOT = SPACES DTSCU351
|
|
00709 MOVE ' EXT. ' TO WRK-TELEPHONE-EXT-LBL DTSCU351
|
|
00710 MOVE MOPO-VOICE-EXT TO WRK-TELEPHONE-EXT DTSCU351
|
|
00711 ELSE DTSCU351
|
|
00712 MOVE SPACES TO WRK-TELEPHONE-EXT-LBL DTSCU351
|
|
00713 MOVE SPACES TO WRK-TELEPHONE-EXT DTSCU351
|
|
00714 END-IF. DTSCU351
|
|
00715 DTSCU351
|
|
00716 IF MOPO-ADDRESS = SPACES DTSCU351
|
|
00717 MOVE MOPO-NAME TO L071-NAM DTSCU351
|
|
00718 PERFORM S071-FROM-LAST-NAME-FIRST THRU S071-EXIT DTSCU351
|
|
00719 MOVE SPACE TO WRK-ADDRESS (WRK-OCC) DTSCU351
|
|
00720 IF MOPO-TITLE = SPACES DTSCU351
|
|
00721 MOVE L071-NAM TO WRK-MAILING-LINE (WRK-OCC 1) DTSCU351
|
|
00722 ELSE DTSCU351
|
|
00723 STRING L071-NAM DELIMITED BY ' ' DTSCU351
|
|
00724 ', ' DELIMITED BY SIZE DTSCU351
|
|
00725 MOPO-TITLE DELIMITED BY ' ' DTSCU351
|
|
00726 INTO DTSCU351
|
|
00727 WRK-MAILING-LINE (WRK-OCC 1) DTSCU351
|
|
00728 ELSE DTSCU351
|
|
00729 PERFORM S112-FORMAT-OPO THRU S112-EXIT DTSCU351
|
|
00730 MOVE L112-MAILING-ADDRESS TO WRK-ADDRESS (WRK-OCC). DTSCU351
|
|
00731 DTSCU351
|
|
00732 MOVE WRK-TELEPHONE TO WRK-MAILING-LINE(WRK-OCC, 6).DTSCU351
|
|
00733 PERFORM P1330-SCRUNCH THRU P1330-EXIT. DTSCU351
|
|
00734 P1325-EXIT. DTSCU351
|
|
00735 EXIT. DTSCU351
|
|
00736 DTSCU351
|
|
00737 /*****************************************************************DTSCU351
|
|
00738 * BUBBLE SORT THE BLANK LINES TO THE BOTTOM OF EACH GROUP DTSCU351
|
|
00739 ******************************************************************DTSCU351
|
|
00740 P1330-SCRUNCH. DTSCU351
|
|
00741 SET WRK-BLANK-LINE-YES-88 TO TRUE. DTSCU351
|
|
00742 DTSCU351
|
|
00743 PERFORM DTSCU351
|
|
00744 UNTIL WRK-BLANK-LINE-NO-88 DTSCU351
|
|
00745 SET WRK-BLANK-LINE-NO-88 TO TRUE DTSCU351
|
|
00746 DTSCU351
|
|
00747 PERFORM VARYING WRK-OCC1 FROM 1 BY 1 DTSCU351
|
|
00748 UNTIL WRK-OCC1 > 5 DTSCU351
|
|
00749 DTSCU351
|
|
00750 COMPUTE WRK-OCC2 = WRK-OCC1 + 1 DTSCU351
|
|
00751 DTSCU351
|
|
00752 IF WRK-MAILING-LINE(WRK-OCC, WRK-OCC1) = SPACES DTSCU351
|
|
00753 AND WRK-MAILING-LINE(WRK-OCC, WRK-OCC2) NOT = SPACES DTSCU351
|
|
00754 SET WRK-BLANK-LINE-YES-88 TO TRUE DTSCU351
|
|
00755 MOVE WRK-MAILING-LINE(WRK-OCC, WRK-OCC2) DTSCU351
|
|
00756 TO WRK-MAILING-LINE(WRK-OCC, WRK-OCC1) DTSCU351
|
|
00757 MOVE SPACES TO WRK-MAILING-LINE(WRK-OCC, WRK-OCC2) DTSCU351
|
|
00758 END-IF DTSCU351
|
|
00759 DTSCU351
|
|
00760 END-PERFORM DTSCU351
|
|
00761 DTSCU351
|
|
00762 END-PERFORM. DTSCU351
|
|
00763 P1330-EXIT. DTSCU351
|
|
00764 EXIT. DTSCU351
|
|
00765 /*****************************************************************DTSCU351
|
|
00766 * DTSCU351
|
|
00767 ******************************************************************DTSCU351
|
|
00768 P1400-CLAIMANT. DTSCU351
|
|
00769 IF MFAS-CLAIMANT-SSN IS NOT EQUAL TO ZERO DTSCU351
|
|
00770 ADD +1 TO TS-LINE-CNT DTSCU351
|
|
00771 SET TS-CC-SKIP-LINE(TS-LINE-CNT) TO TRUE DTSCU351
|
|
00772 MOVE MFAS-CLAIMANT-SSN TO WRK-CLAIMANT-SSN DTSCU351
|
|
00773 MOVE MFAS-CLAIMANT-NAME TO WRK-CLAIMANT-NAME DTSCU351
|
|
00774 MOVE WRK-LINE-RE TO TS-TEXT(TS-LINE-CNT) DTSCU351
|
|
00775 ADD +2 TO LINE-CNT. DTSCU351
|
|
00776 P1400-EXIT. DTSCU351
|
|
00777 EXIT. DTSCU351
|
|
00778 /*****************************************************************DTSCU351
|
|
00779 * DTSCU351
|
|
00780 ******************************************************************DTSCU351
|
|
00781 P1500-REL-EMP. DTSCU351
|
|
00782 IF MFAS-RELATED-EMP-NO NOT EQUAL TO ZERO DTSCU351
|
|
00783 MOVE LOW-VALUES TO MPRF-KEY-AREA DTSCU351
|
|
00784 MOVE MFAS-RELATED-EMP-NO TO MPRF-EMP-NO DTSCU351
|
|
00785 SET MPRF-PRF-88 TO TRUE DTSCU351
|
|
00786 MOVE MPRF-KEY-AREA TO MSKL-KEY-AREA DTSCU351
|
|
00787 PERFORM S810-READ THRU S810-EXIT DTSCU351
|
|
00788 ADD +1 TO TS-LINE-CNT DTSCU351
|
|
00789 SET TS-CC-SKIP-LINE(TS-LINE-CNT) TO TRUE DTSCU351
|
|
00790 MOVE MFAS-RELATED-EMP-NO TO WRK-RELATED-EMP-NO DTSCU351
|
|
00791 IF L810-NO-REC-88 OR L810-FILE-CLOSED-88 DTSCU351
|
|
00792 MOVE '--NAME NO LONGER ON FILE--' DTSCU351
|
|
00793 TO WRK-RELATED-EMP-NAME DTSCU351
|
|
00794 ELSE DTSCU351
|
|
00795 MOVE MSKL-REC TO MPRF-REC DTSCU351
|
|
00796 MOVE MPRF-BUSINESS-NAME TO WRK-RELATED-EMP-NAME DTSCU351
|
|
00797 END-IF DTSCU351
|
|
00798 MOVE WRK-LINE-RELATED-EMP TO TS-TEXT(TS-LINE-CNT) DTSCU351
|
|
00799 ADD +2 TO LINE-CNT. DTSCU351
|
|
00800 P1500-EXIT. DTSCU351
|
|
00801 EXIT. DTSCU351
|
|
00802 /*****************************************************************DTSCU351
|
|
00803 * DTSCU351
|
|
00804 ******************************************************************DTSCU351
|
|
00805 P1600-FAS-TEXT. DTSCU351
|
|
00806 DTSCU351
|
|
00807 ADD +1 TO TS-LINE-CNT. DTSCU351
|
|
00808 MOVE ' ' TO TS-CC(TS-LINE-CNT). DTSCU351
|
|
00809 MOVE MFAS-TEXT(MFAS-TEXT-IDX) TO WRK-TEXT. DTSCU351
|
|
00810 MOVE WRK-LINE-TEXT TO TS-TEXT(TS-LINE-CNT). DTSCU351
|
|
00811 ADD +1 TO LINE-CNT. DTSCU351
|
|
00812 DTSCU351
|
|
00813 P1600-EXIT. DTSCU351
|
|
00814 EXIT. DTSCU351
|
|
00815 DTSCU351
|
|
00816 /*****************************************************************DTSCU351
|
|
00817 * DTSCU351
|
|
00818 ******************************************************************DTSCU351
|
|
00819 P2000-COPY-IND. DTSCU351
|
|
00820 DTSCU351
|
|
00821 ADD +1 TO WRK-COPY-CNT. DTSCU351
|
|
00822 DTSCU351
|
|
00823 P2000-EXIT. DTSCU351
|
|
00824 EXIT. DTSCU351
|
|
00825 DTSCU351
|
|
00826 /*****************************************************************DTSCU351
|
|
00827 * GETS THE POINTER TO THE END OF THE PAGE DTSCU351
|
|
00828 ******************************************************************DTSCU351
|
|
00829 P7000-COPY-LINE. DTSCU351
|
|
00830 PERFORM P7100-LOOP THRU P7100-EXIT DTSCU351
|
|
00831 UNTIL LINE-CNT >= 60. DTSCU351
|
|
00832 P7000-EXIT. DTSCU351
|
|
00833 EXIT. DTSCU351
|
|
00834 DTSCU351
|
|
00835 P7100-LOOP. DTSCU351
|
|
00836 ADD +1 TO LINE-CNT. DTSCU351
|
|
00837 ADD +1 TO TS-LINE-CNT. DTSCU351
|
|
00838 MOVE SPACE TO TS-CC(TS-LINE-CNT) DTSCU351
|
|
00839 TS-TEXT(TS-LINE-CNT). DTSCU351
|
|
00840 P7100-EXIT. DTSCU351
|
|
00841 EXIT. DTSCU351
|
|
00842 DTSCU351
|
|
00843 P8000-TS-WRITE. DTSCU351
|
|
00844 MOVE WRK-LINE-COPY TO TS-TEXT(TS-LINE-CNT). DTSCU351
|
|
00845 PERFORM P8100-TS-LOOP THRU P8100-EXIT DTSCU351
|
|
00846 VARYING WRK-OCC FROM 1 BY 1 DTSCU351
|
|
00847 UNTIL WRK-OCC > TS-LINE-CNT DTSCU351
|
|
00848 OR L351-PRINT-FAILED. DTSCU351
|
|
00849 P8000-EXIT. DTSCU351
|
|
00850 EXIT. DTSCU351
|
|
00851 EJECT DTSCU351
|
|
00852 /*****************************************************************DTSCU351
|
|
00853 * DTSCU351
|
|
00854 ******************************************************************DTSCU351
|
|
00855 P8100-TS-LOOP. DTSCU351
|
|
00856 MOVE TS-CC(WRK-OCC) TO XPTS-CC. DTSCU351
|
|
00857 MOVE TS-TEXT(WRK-OCC) TO XPTS-DATA. DTSCU351
|
|
00858 MOVE WRK-OCC TO L829-ITEM-NO. DTSCU351
|
|
00859 PERFORM S829-WRITE-ITEM THRU S829-EXIT. DTSCU351
|
|
00860 IF NOT L829-OK-88 DTSCU351
|
|
00861 SET L351-PRINT-FAILED TO TRUE. DTSCU351
|
|
00862 DTSCU351
|
|
00863 P8100-EXIT. DTSCU351
|
|
00864 EXIT. DTSCU351
|
|
00865 /*****************************************************************DTSCU351
|
|
00866 * SERVICE UTILITIES DTSCU351
|
|
00867 ******************************************************************DTSCU351
|
|
00868 S001-FROM-FED-8. DTSCU351
|
|
00869 SET L001-FROM-FED-8 TO TRUE. DTSCU351
|
|
00870 GO TO S001-DATE-EDIT. DTSCU351
|
|
00871 DTSCU351
|
|
00872 S001-DATE-EDIT. DTSCU351
|
|
00873 EXEC CICS DTSCU351
|
|
00874 LINK DTSCU351
|
|
00875 PROGRAM ('MACCU001') DTSCU351
|
|
00876 COMMAREA (L001-COMM-AREA) DTSCU351
|
|
00877 LENGTH (L001-LENGTH) DTSCU351
|
|
00878 END-EXEC. DTSCU351
|
|
00879 S001-EXIT. DTSCU351
|
|
00880 EXIT. DTSCU351
|
|
00881 DTSCU351
|
|
00882 S004-FROM-5. DTSCU351
|
|
00883 SET L004-FROM-5 TO TRUE. DTSCU351
|
|
00884 GO TO S004-QTR-EDIT. DTSCU351
|
|
00885 DTSCU351
|
|
00886 S004-QTR-EDIT. DTSCU351
|
|
00887 EXEC CICS DTSCU351
|
|
00888 LINK DTSCU351
|
|
00889 PROGRAM ('MACCU004') DTSCU351
|
|
00890 COMMAREA (L004-COMM-AREA) DTSCU351
|
|
00891 LENGTH (L004-LENGTH) DTSCU351
|
|
00892 END-EXEC. DTSCU351
|
|
00893 S004-EXIT. DTSCU351
|
|
00894 EXIT. DTSCU351
|
|
00895 DTSCU351
|
|
00896 S056-RATE. DTSCU351
|
|
00897 EXEC CICS DTSCU351
|
|
00898 LINK DTSCU351
|
|
00899 PROGRAM ('MACCU056') DTSCU351
|
|
00900 COMMAREA (L056-COMM-AREA) DTSCU351
|
|
00901 LENGTH (L056-LENGTH) DTSCU351
|
|
00902 END-EXEC. DTSCU351
|
|
00903 S056-EXIT. DTSCU351
|
|
00904 EXIT. DTSCU351
|
|
00905 DTSCU351
|
|
00906 S062-AUDIT-EDIT. DTSCU351
|
|
00907 EXEC CICS DTSCU351
|
|
00908 LINK DTSCU351
|
|
00909 PROGRAM ('MACCU062') DTSCU351
|
|
00910 COMMAREA (L062-COMM-AREA) DTSCU351
|
|
00911 LENGTH (L062-LENGTH) DTSCU351
|
|
00912 END-EXEC. DTSCU351
|
|
00913 S062-EXIT. DTSCU351
|
|
00914 EXIT. DTSCU351
|
|
00915 DTSCU351
|
|
00916 S063-ASSIGN-TYPE. DTSCU351
|
|
00917 EXEC CICS DTSCU351
|
|
00918 LINK DTSCU351
|
|
00919 PROGRAM ('MACCU063') DTSCU351
|
|
00920 COMMAREA (L063-COMM-AREA) DTSCU351
|
|
00921 LENGTH (L063-LENGTH) DTSCU351
|
|
00922 END-EXEC. DTSCU351
|
|
00923 S063-EXIT. DTSCU351
|
|
00924 EXIT. DTSCU351
|
|
00925 DTSCU351
|
|
00926 S071-FROM-LAST-NAME-FIRST. DTSCU351
|
|
00927 SET L071-FROM-LAST-NAME-FIRST TO TRUE. DTSCU351
|
|
00928 GO TO S071-FORMAT-NAME. DTSCU351
|
|
00929 DTSCU351
|
|
00930 S071-FORMAT-NAME. DTSCU351
|
|
00931 EXEC CICS DTSCU351
|
|
00932 LINK DTSCU351
|
|
00933 PROGRAM ('MACCU071') DTSCU351
|
|
00934 COMMAREA (L071-COMM-AREA) DTSCU351
|
|
00935 LENGTH (L071-LENGTH) DTSCU351
|
|
00936 END-EXEC. DTSCU351
|
|
00937 S071-EXIT. DTSCU351
|
|
00938 EXIT. DTSCU351
|
|
00939 DTSCU351
|
|
00940 S082-OP-ID. DTSCU351
|
|
00941 EXEC CICS DTSCU351
|
|
00942 LINK DTSCU351
|
|
00943 PROGRAM ('MACCU082') DTSCU351
|
|
00944 COMMAREA (L082-COMM-AREA) DTSCU351
|
|
00945 LENGTH (L082-LENGTH) DTSCU351
|
|
00946 END-EXEC. DTSCU351
|
|
00947 S082-EXIT. DTSCU351
|
|
00948 EXIT. DTSCU351
|
|
00949 DTSCU351
|
|
00950 S112-FORMAT-TAD. DTSCU351
|
|
00951 SET L112-TAD-ADDR-88 TO TRUE. DTSCU351
|
|
00952 SET L112-ANCHOR-FIRST-88 TO TRUE. DTSCU351
|
|
00953 IF MTAD-ID-NO = +1 DTSCU351
|
|
00954 MOVE MPRF-BUSINESS-NAME TO L112-BUSINESS-NAME DTSCU351
|
|
00955 ELSE DTSCU351
|
|
00956 MOVE SPACES TO L112-BUSINESS-NAME. DTSCU351
|
|
00957 MOVE MTAD-MAIL-DELIV-IND TO L112-MAIL-DELIV-IND. DTSCU351
|
|
00958 MOVE SPACES TO L112-NAME DTSCU351
|
|
00959 L112-TITLE. DTSCU351
|
|
00960 MOVE MTAD-ADDRESS TO L112-ADDRESS. DTSCU351
|
|
00961 GO TO S112-FORMAT-ADDRESS. DTSCU351
|
|
00962 DTSCU351
|
|
00963 S112-FORMAT-OPO. DTSCU351
|
|
00964 SET L112-OPO-ADDR-88 TO TRUE. DTSCU351
|
|
00965 SET L112-ANCHOR-FIRST-88 TO TRUE. DTSCU351
|
|
00966 MOVE SPACES TO L112-BUSINESS-NAME. DTSCU351
|
|
00967 MOVE MOPO-MAIL-DELIV-IND TO L112-MAIL-DELIV-IND. DTSCU351
|
|
00968 MOVE MOPO-NAME TO L112-NAME. DTSCU351
|
|
00969 MOVE MOPO-TITLE TO L112-TITLE. DTSCU351
|
|
00970 MOVE MOPO-ADDRESS TO L112-ADDRESS. DTSCU351
|
|
00971 GO TO S112-FORMAT-ADDRESS. DTSCU351
|
|
00972 DTSCU351
|
|
00973 S112-FORMAT-ADDRESS. DTSCU351
|
|
00974 EXEC CICS DTSCU351
|
|
00975 LINK DTSCU351
|
|
00976 PROGRAM ('MACCU112') DTSCU351
|
|
00977 COMMAREA (L112-COMM-AREA) DTSCU351
|
|
00978 LENGTH (L112-LENGTH) DTSCU351
|
|
00979 END-EXEC. DTSCU351
|
|
00980 S112-EXIT. DTSCU351
|
|
00981 EXIT. DTSCU351
|
|
00982 DTSCU351
|
|
00983 S119-AGENCY-FACTS. DTSCU351
|
|
00984 SET L119-REQ-CAPS-88 TO TRUE. DTSCU351
|
|
00985 SET L119-REQ-NO-UNIT-88 TO TRUE. DTSCU351
|
|
00986 EXEC CICS DTSCU351
|
|
00987 LINK DTSCU351
|
|
00988 PROGRAM ('MACCU119') DTSCU351
|
|
00989 COMMAREA (L119-COMM-AREA) DTSCU351
|
|
00990 LENGTH (L119-LENGTH) DTSCU351
|
|
00991 END-EXEC. DTSCU351
|
|
00992 S119-EXIT. DTSCU351
|
|
00993 EXIT. DTSCU351
|
|
00994 DTSCU351
|
|
00995 S357-LINK-PRINT. DTSCU351
|
|
00996 SET L357-EJECT-PAGE-88 TO TRUE. DTSCU351
|
|
00997 DTSCU351
|
|
00998 EXEC CICS DTSCU351
|
|
00999 LINK DTSCU351
|
|
01000 PROGRAM ('MACCU357') DTSCU351
|
|
01001 COMMAREA (L357-COMM-AREA) DTSCU351
|
|
01002 LENGTH (L357-LENGTH) DTSCU351
|
|
01003 END-EXEC. DTSCU351
|
|
01004 S357-EXIT. DTSCU351
|
|
01005 EXIT. DTSCU351
|
|
01006 DTSCU351
|
|
01007 S810-START-BROWSE. DTSCU351
|
|
01008 SET L810-START-BROWSE-88 TO TRUE DTSCU351
|
|
01009 GO TO S810-MSTR-IO. DTSCU351
|
|
01010 DTSCU351
|
|
01011 S810-END-BROWSE. DTSCU351
|
|
01012 SET L810-END-BROWSE-88 TO TRUE DTSCU351
|
|
01013 GO TO S810-MSTR-IO. DTSCU351
|
|
01014 DTSCU351
|
|
01015 S810-READ-NEXT. DTSCU351
|
|
01016 SET L810-READ-NEXT-88 TO TRUE DTSCU351
|
|
01017 GO TO S810-MSTR-IO. DTSCU351
|
|
01018 DTSCU351
|
|
01019 S810-READ. DTSCU351
|
|
01020 SET L810-READ-88 TO TRUE DTSCU351
|
|
01021 GO TO S810-MSTR-IO. DTSCU351
|
|
01022 DTSCU351
|
|
01023 S810-MSTR-IO. DTSCU351
|
|
01024 EXEC CICS DTSCU351
|
|
01025 LINK DTSCU351
|
|
01026 PROGRAM ('MACCU810') DTSCU351
|
|
01027 COMMAREA (L810-COMM-AREA) DTSCU351
|
|
01028 LENGTH (L810-LENGTH) DTSCU351
|
|
01029 END-EXEC. DTSCU351
|
|
01030 S810-EXIT. DTSCU351
|
|
01031 EXIT. DTSCU351
|
|
01032 DTSCU351
|
|
01033 S829-DELETE-QUEUE. DTSCU351
|
|
01034 DTSCU351
|
|
01035 SET L829-DELETE-QUEUE-88 TO TRUE. DTSCU351
|
|
01036 GO TO S829-TS-IO. DTSCU351
|
|
01037 DTSCU351
|
|
01038 S829-WRITE-ITEM. DTSCU351
|
|
01039 SET L829-WRITE-88 TO TRUE. DTSCU351
|
|
01040 GO TO S829-TS-IO. DTSCU351
|
|
01041 DTSCU351
|
|
01042 S829-TS-IO. DTSCU351
|
|
01043 EXEC CICS DTSCU351
|
|
01044 LINK DTSCU351
|
|
01045 PROGRAM ('MACCU829') DTSCU351
|
|
01046 COMMAREA (L829-COMM-AREA) DTSCU351
|
|
01047 LENGTH (L829-COMM-AREA-LENGTH) DTSCU351
|
|
01048 END-EXEC. DTSCU351
|
|
01049 S829-EXIT. DTSCU351
|
|
01050 EXIT. DTSCU351
|
|
01051 DTSCU351
|
|
01052 S899-ABEND. DTSCU351
|
|
01053 EXEC CICS DTSCU351
|
|
01054 ABEND DTSCU351
|
|
01055 ABCODE (WRK-ABEND-CODE) DTSCU351
|
|
01056 END-EXEC. DTSCU351
|
|
01057 S899-EXIT. DTSCU351
|
|
01058 EXIT. DTSCU351
|