217 lines
17 KiB
COBOL
217 lines
17 KiB
COBOL
00001 IDENTIFICATION DIVISION. 08/13/04
|
|
00002 PROGRAM-ID. DTSBU083. DTSBU083
|
|
00003 AUTHOR. TRW. LV003
|
|
00004 DATE-WRITTEN. JUNE 2001. DTSBU083
|
|
00005 DATE-COMPILED. DTSBU083
|
|
00006 SKIP3 DTSBU083
|
|
00007 ***** DTSBU083
|
|
00008 * DTSBU083
|
|
00009 * FUNCTION: CLAIMANT NAME LOOKUP FROM IB6 FILE. DTSBU083
|
|
00010 * DTSBU083
|
|
00011 * DTSBU083
|
|
00012 * MODIFICATION LOG: DTSBU083
|
|
00013 * DTSBU083
|
|
00014 * 07/22/2002 INITIAL DEVELOPMENT. DTSBU083
|
|
00015 * WORK ORDER: PROGRAMMER: GD DTSBU083
|
|
00016 * DTSBU083
|
|
00017 * 07/22/2004 CORRECTED PROBLEM WITH L081-CLAIMANT-SSN. DTSBU083
|
|
00018 * THE BATCH PROGRAM WAS NOT CONSISTENT WITH DTSBU083
|
|
00019 * THE CICS PROGRAM. DTSBU083
|
|
00020 * THE PROGRAM WAS MOVING THIS 9 DIGIT FIELD TO DTSBU083
|
|
00021 * THE 10 DIGIT VSAM-KEY (SSN PLUS SEQUENCE NUMBER).DTSBU083
|
|
00022 * THE PROGRAM NOW BUILDS THE KEY IN WORKING-STORAGEDTSBU083
|
|
00023 * AND MOVE THE FULL 10 DIGIT KEY. THE SEQUENCE DTSBU083
|
|
00024 * NUMBER IS ALWAYS SET TO ZERO. DTSBU083
|
|
00025 * REFERENCE: PROGRAMMER: GD DTSBU083
|
|
00026 * DTSBU083
|
|
00027 * MM/DD/YYYY XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSBU083
|
|
00028 * XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSBU083
|
|
00029 * REFERENCE: XXXXXXXXXXXXXXX PROGRAMMER: XXX DTSBU083
|
|
00030 * DTSBU083
|
|
00031 * DTSBU083
|
|
00032 * DESCRIPTION: DTSBU083
|
|
00033 * DTSBU083
|
|
00034 * DTSBU083 IS PASSED L081-CLAIMANT-SSN. DTSBU083 READS THE DTSBU083
|
|
00035 * IB6 MASTER FILE. DTSBU083
|
|
00036 * DTSBU083
|
|
00037 * IF THE CLAIMANT IS FOUND, THEN L081-CLAIMANT-NAME IS RETURNED DTSBU083
|
|
00038 ***** DTSBU083
|
|
00039 SKIP3 DTSBU083
|
|
00040 ENVIRONMENT DIVISION. DTSBU083
|
|
00041 SKIP3 DTSBU083
|
|
00042 DATA DIVISION. DTSBU083
|
|
00043 SKIP3 DTSBU083
|
|
00044 WORKING-STORAGE SECTION. DTSBU083
|
|
000445 77 PAN-VALET PICTURE X(24) VALUE '003DTSBU083 08/13/04'. DTSBU083
|
|
00045 SKIP3 DTSBU083
|
|
00046 01 WRK-AREA. DTSBU083
|
|
00047 05 WRK-ABEND-CODE PIC X(04) VALUE 'U083'. DTSBU083
|
|
00048 DTSBU083
|
|
00049 05 WRK-FIRST-TIME-IND PIC X(01) VALUE 'Y'. DTSBU083
|
|
00050 88 WRK-FIRST-TIME-YES-88 VALUE 'Y'. DTSBU083
|
|
00051 88 WRK-FIRST-TIME-NO-88 VALUE 'N'. DTSBU083
|
|
00052 DTSBU083
|
|
00053 05 WRK-KEY PIC 9(10). DTSBU083
|
|
00054 05 FILLER REDEFINES WRK-KEY. DTSBU083
|
|
00055 10 WRK-SSN PIC 9(09). DTSBU083
|
|
00056 10 WRK-SSN-SEQ PIC 9(01). DTSBU083
|
|
00057 DTSBU083
|
|
00058 05 WRK-SPACE-NEEDED-IND PIC X(01). DTSBU083
|
|
00059 88 WRK-SPACE-NEEDED-YES-88 VALUE 'Y'. DTSBU083
|
|
00060 88 WRK-SPACE-NEEDED-NO-88 VALUE 'N'. DTSBU083
|
|
00061 DTSBU083
|
|
00062 05 WRK-LEN PIC S9(04) COMP DTSBU083
|
|
00063 VALUE +31. DTSBU083
|
|
00064 05 SUB1 PIC S9(04) COMP. DTSBU083
|
|
00065 05 SUB2 PIC S9(04) COMP. DTSBU083
|
|
00066 DTSBU083
|
|
00067 05 WRK-NAME. DTSBU083
|
|
00068 10 WRK-FIRST-NAME PIC X(12). DTSBU083
|
|
00069 10 WRK-MIDDLE-NAME PIC X(01). DTSBU083
|
|
00070 10 WRK-LAST-NAME PIC X(18). DTSBU083
|
|
00071 DTSBU083
|
|
00072 05 WRK-NAME-OUT PIC X(32). DTSBU083
|
|
00073 DTSBU083
|
|
00074 01 EMSG-LITERALS. DTSBU083
|
|
00075 05 EMSG-NO-REC. DTSBU083
|
|
00076 10 FILLER PIC X(31) DTSBU083
|
|
00077 VALUE 'NO BENEFITS RECORD FOUND '. DTSBU083
|
|
00078 10 FILLER PIC X(16) DTSBU083
|
|
00079 VALUE SPACES. DTSBU083
|
|
00080 05 EMSG-EOF. DTSBU083
|
|
00081 10 FILLER PIC X(31) DTSBU083
|
|
00082 VALUE 'END OF FILE '. DTSBU083
|
|
00083 10 FILLER PIC X(16) DTSBU083
|
|
00084 VALUE SPACES. DTSBU083
|
|
00085 EJECT DTSBU083
|
|
00086 01 IB6-LINKAGE-SECTION. DTSBU083
|
|
00087 ++INCLUDE IB6VSMCB DTSBU083
|
|
00088 EJECT DTSBU083
|
|
00089 ++INCLUDE ESPDATEW DTSBU083
|
|
00090 EJECT DTSBU083
|
|
00091 ++INCLUDE IB6SCCD DTSBU083
|
|
00092 EJECT DTSBU083
|
|
00093 ++INCLUDE ESPSTRER DTSBU083
|
|
00094 EJECT DTSBU083
|
|
00095 ++INCLUDE IB6SCSWA DTSBU083
|
|
00096 EJECT DTSBU083
|
|
00097 ++INCLUDE IB6SCTWA DTSBU083
|
|
00098 EJECT DTSBU083
|
|
00099 ++INCLUDE IB6SEG01 DTSBU083
|
|
00100 EJECT DTSBU083
|
|
00101 ++INCLUDE IB6SEG02 DTSBU083
|
|
00102 EJECT DTSBU083
|
|
00103 ++INCLUDE IB6SEG03 DTSBU083
|
|
00104 EJECT DTSBU083
|
|
00105 ++INCLUDE IB6TRAND DTSBU083
|
|
00106 EJECT DTSBU083
|
|
00107 ++INCLUDE IB6HEADR DTSBU083
|
|
00108 EJECT DTSBU083
|
|
00109 LINKAGE SECTION. DTSBU083
|
|
00110 SKIP3 DTSBU083
|
|
00111 01 BU081-LINK-AREA. DTSBU083
|
|
00112 ++INCLUDE DTSIL081 DTSBU083
|
|
00113 EJECT DTSBU083
|
|
00114 PROCEDURE DIVISION USING BU081-LINK-AREA. DTSBU083
|
|
00115 SKIP2 DTSBU083
|
|
00116 IF WRK-FIRST-TIME-YES-88 DTSBU083
|
|
00117 PERFORM I0000-INIT THRU I0000-EXIT DTSBU083
|
|
00118 SET WRK-FIRST-TIME-NO-88 TO TRUE DTSBU083
|
|
00119 PERFORM P0000-FIND-NAME THRU P0000-EXIT DTSBU083
|
|
00120 ELSE DTSBU083
|
|
00121 PERFORM P0000-FIND-NAME THRU P0000-EXIT. DTSBU083
|
|
00122 DTSBU083
|
|
00123 GOBACK. DTSBU083
|
|
00124 EJECT DTSBU083
|
|
00125 I0000-INIT. DTSBU083
|
|
00126 MOVE 'DTSBU083' TO DB-PROGRAM-NAME. DTSBU083
|
|
00127 SET DB-HEADER-RECORD TO TRUE. DTSBU083
|
|
00128 SET DB-RANDOM-PROCESSING TO TRUE. DTSBU083
|
|
00129 SET DB-OPEN-INPUT TO TRUE. DTSBU083
|
|
00130 MOVE ZEROS TO DB-KEY. DTSBU083
|
|
00131 DTSBU083
|
|
00132 CALL 'IB6960D' USING IB6-LINKAGE-SECTION. DTSBU083
|
|
00133 IF DB-SUCCESSFUL-COMPLETION DTSBU083
|
|
00134 NEXT SENTENCE DTSBU083
|
|
00135 ELSE DTSBU083
|
|
00136 DISPLAY 'CANNOT OPEN IB6 FILE' DTSBU083
|
|
00137 PERFORM S9999-ABEND THRU S9999-EXIT. DTSBU083
|
|
00138 DTSBU083
|
|
00139 I0000-EXIT. DTSBU083
|
|
00140 EXIT. DTSBU083
|
|
00141 P0000-FIND-NAME. DTSBU083
|
|
00142 SET L081-NAME-NOT-FOUND TO TRUE. DTSBU083
|
|
00143 DTSBU083
|
|
00144 MOVE SPACES TO L081-CLAIMANT-NAME DTSBU083
|
|
00145 L081-MSG-AREA. DTSBU083
|
|
00146 DTSBU083
|
|
00147 SET DB-RANDOM-PROCESSING TO TRUE. DTSBU083
|
|
00148 SET DB-IB6-PROFILE TO TRUE. DTSBU083
|
|
00149 SET DB-READ-SEGMENT TO TRUE. DTSBU083
|
|
00150 MOVE L081-CLAIMANT-SSN TO WRK-SSN. DTSBU083
|
|
00151 MOVE ZERO TO WRK-SSN-SEQ. DTSBU083
|
|
00152 MOVE WRK-KEY TO VSAM-KEY. DTSBU083
|
|
00153 DTSBU083
|
|
00154 CALL 'IB6960D' USING IB6-LINKAGE-SECTION. DTSBU083
|
|
00155 IF DB-SUCCESSFUL-COMPLETION DTSBU083
|
|
00156 SET L081-NAME-FOUND TO TRUE DTSBU083
|
|
00157 PERFORM P1000-FORMAT-NAME THRU P1000-EXIT DTSBU083
|
|
00158 MOVE WRK-NAME-OUT TO L081-CLAIMANT-NAME DTSBU083
|
|
00159 ELSE DTSBU083
|
|
00160 IF DB-NO-RECORD-FOUND DTSBU083
|
|
00161 SET L081-NAME-NOT-FOUND TO TRUE DTSBU083
|
|
00162 MOVE EMSG-NO-REC TO L081-MSG-TEXT DTSBU083
|
|
00163 ELSE DTSBU083
|
|
00164 PERFORM S9999-ABEND THRU S9999-EXIT. DTSBU083
|
|
00165 DTSBU083
|
|
00166 P0000-EXIT. DTSBU083
|
|
00167 EXIT. DTSBU083
|
|
00168 DTSBU083
|
|
00169 P1000-FORMAT-NAME. DTSBU083
|
|
00170 MOVE SPACES TO WRK-NAME DTSBU083
|
|
00171 WRK-NAME-OUT. DTSBU083
|
|
00172 DTSBU083
|
|
00173 MOVE IN1-CLAIM-FIRST-NAME TO WRK-FIRST-NAME. DTSBU083
|
|
00174 MOVE IN1-CLAIM-MIDDLE-NAME TO WRK-MIDDLE-NAME DTSBU083
|
|
00175 MOVE IN1-CLAIM-LAST-NAME TO WRK-LAST-NAME DTSBU083
|
|
00176 DTSBU083
|
|
00177 SET WRK-SPACE-NEEDED-YES-88 TO TRUE. DTSBU083
|
|
00178 MOVE +0 TO SUB2. DTSBU083
|
|
00179 PERFORM P1100-PARSE THRU P1100-EXIT. DTSBU083
|
|
00180 DTSBU083
|
|
00181 MOVE WRK-NAME-OUT TO L081-CLAIMANT-NAME. DTSBU083
|
|
00182 DTSBU083
|
|
00183 P1000-EXIT. DTSBU083
|
|
00184 EXIT. DTSBU083
|
|
00185 DTSBU083
|
|
00186 P1100-PARSE. DTSBU083
|
|
00187 PERFORM DTSBU083
|
|
00188 VARYING SUB1 FROM +1 BY +1 DTSBU083
|
|
00189 UNTIL SUB1 > WRK-LEN DTSBU083
|
|
00190 IF WRK-NAME (SUB1:1) NOT = SPACE DTSBU083
|
|
00191 SET WRK-SPACE-NEEDED-YES-88 TO TRUE DTSBU083
|
|
00192 ADD +1 TO SUB2 DTSBU083
|
|
00193 MOVE WRK-NAME (SUB1:1) TO WRK-NAME-OUT (SUB2:1) DTSBU083
|
|
00194 IF SUB1 = +13 DTSBU083
|
|
00195 ADD +1 TO SUB2 DTSBU083
|
|
00196 MOVE SPACE TO WRK-NAME-OUT (SUB2:1) DTSBU083
|
|
00197 END-IF DTSBU083
|
|
00198 ELSE DTSBU083
|
|
00199 IF WRK-SPACE-NEEDED-YES-88 DTSBU083
|
|
00200 ADD +1 TO SUB2 DTSBU083
|
|
00201 MOVE SPACE TO WRK-NAME-OUT (SUB2:1) DTSBU083
|
|
00202 SET WRK-SPACE-NEEDED-NO-88 TO TRUE DTSBU083
|
|
00203 END-IF DTSBU083
|
|
00204 END-IF DTSBU083
|
|
00205 END-PERFORM. DTSBU083
|
|
00206 DTSBU083
|
|
00207 P1100-EXIT. DTSBU083
|
|
00208 EXIT. DTSBU083
|
|
00209 DTSBU083
|
|
00210 S9999-ABEND. DTSBU083
|
|
00211 SKIP1 DTSBU083
|
|
00212 CALL 'DTSBU999' USING WRK-ABEND-CODE. DTSBU083
|
|
00213 SKIP1 DTSBU083
|
|
00214 S9999-EXIT. DTSBU083
|
|
00215 EXIT. DTSBU083
|