00001  IDENTIFICATION DIVISION.                                         05/17/00
00002  PROGRAM-ID.             DTSBU600.                                DTSBU600
00003  AUTHOR.                 TRICOASTAL CONSULTING LTD.                  LV017
00004  DATE-WRITTEN.           FEBRUARY 1999.                           DTSBU600
00005  DATE-COMPILED.                                                   DTSBU600
00006      SKIP3                                                        DTSBU600
00007 *****                                                             DTSBU600
00008 *                                                                 DTSBU600
00009 *    FUNCTION:  FIND ULTIMATE SUCCESSOR ACCOUNT.                  DTSBU600
00010 *                                                                 DTSBU600
00011 *                                                                 DTSBU600
00012 *    MODIFICATION LOG:                                            DTSBU600
00013 *                                                                 DTSBU600
00014 *    02/11/1999  INITIAL DEVELOPMENT.                             DTSBU600
00015 *                WORK ORDER:                      PROGRAMMER: GD  DTSBU600
00016 *                                                                 DTSBU600
00017 *    05/15/2000  ADDED PROCESSING FOR EXPERIENCE TRANSFER         DTSBU600
00018 *                EFFECTIVE DATE. SEE DESCRIPTION BELOW            DTSBU600
00019 *                FOR DETAILS.                                     DTSBU600
00020 *                WORK ORDER:                      PROGRAMMER: GD  DTSBU600
00021 *                                                                 DTSBU600
00022 *    XX/XX/XXXX  XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSBU600
00023 *                XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX DTSBU600
00024 *                WORK ORDER:                      PROGRAMMER: XXX DTSBU600
00025 *                                                                 DTSBU600
00026 *                                                                 DTSBU600
00027 *    DESCRIPTION:                                                 DTSBU600
00028 *                                                                 DTSBU600
00029 *    SCAN THE IPES RECORDS LOOKING FOR THE ULTIMATE SUCCESSOR     DTSBU600
00030 *    ACCOUNT RELATED TO THE EMPLOYER NUMBER PASSED.               DTSBU600
00031 *                                                                 DTSBU600
00032 *    FIRST LOOK FOR AN IPES RECORD FOR THE EMPLOYER.  IF ONE      DTSBU600
00033 *    EXISTS, AND THE EXPERIENCE HAS BEEN TRANSFERRED TO A         DTSBU600
00034 *    SUCCESSOR, READ THE IPES RECORDS LOOKING FOR THE NEXT        DTSBU600
00035 *    SUCCESSOR.                                                   DTSBU600
00036 *                                                                 DTSBU600
00037 *    IF THE SEARCH FINDS MORE THAN 100 SUCCESSORS, IT RETURNS     DTSBU600
00038 *    WITH AN ERROR CODE.                                          DTSBU600
00039 *                                                                 DTSBU600
00040 *    IF L600-EXP-TRN-EFF-DATE CONTAINS A VALID DATE, THE PROGRAM  DTSBU600
00041 *    WILL IGNORE CHANGES OF OWNERSHIP THAT OCCURRED AFTER THIS    DTSBU600
00042 *    DATE.  THE PARAMETER IS NORMALLY SET TO ALL NINES, AND       DTSBU600
00043 *    IGNORED.  IT IS ONLY USED IN SPECIAL SITUATIONS WHERE IT IS  DTSBU600
00044 *    NECESSARY TO RECREATE THE CHARGE HISTORY REPORTED FOR A      DTSBU600
00045 *    PRIOR RATING YEAR.                                           DTSBU600
00046 *                                                                 DTSBU600
00047 *****                                                             DTSBU600
00048      SKIP3                                                        DTSBU600
00049  ENVIRONMENT DIVISION.                                            DTSBU600
00050      SKIP3                                                        DTSBU600
00051  DATA DIVISION.                                                   DTSBU600
00052      SKIP3                                                        DTSBU600
00053  WORKING-STORAGE SECTION.                                         DTSBU600
000535 77  PAN-VALET PICTURE X(24) VALUE '017DTSBU600  05/17/00'.       DTSBU600
00054      SKIP3                                                        DTSBU600
00055  01  WRK-AREA.                                                    DTSBU600
00056      05  WRK-ABEND-CODE              PIC S9(04)  COMP             DTSBU600
00057                                                  VALUE +600.      DTSBU600
00058                                                                   DTSBU600
00059      05  WRK-MAX-CNT                 PIC S9(04)  COMP             DTSBU600
00060                                                  VALUE +100.      DTSBU600
00061                                                                   DTSBU600
00062      05  WRK-EMP-NO                  PIC S9(07)  COMP-3.          DTSBU600
00063      05  WRK-SUCCESSOR               PIC S9(07)  COMP-3.          DTSBU600
00064      05  WRK-EFF-DATE                PIC S9(09)  COMP-3.          DTSBU600
00065                                                                   DTSBU600
00066 *  THE FOLLOWING FIELD USED FOR SPECIAL RUNS THAT EXCLUDE         DTSBU600
00067 *  EXPERIENCE TRANSFERS PAST A CERTAIN DATE.                      DTSBU600
00068      05  WRK-END-DATE                PIC S9(09)  COMP-3.          DTSBU600
00069                                                                   DTSBU600
00070      05  WRK-SEARCH-IND              PIC  X(01).                  DTSBU600
00071          88  WRK-START-SEARCH-88  VALUE '0'.                      DTSBU600
00072          88  WRK-SEARCH-ENDED-88  VALUE '1'.                      DTSBU600
00073                                                                   DTSBU600
00074      05  WRK-SUCCESSOR-IND           PIC  X(01).                  DTSBU600
00075          88  WRK-SUCCESSOR-YES-88 VALUE 'Y'.                      DTSBU600
00076          88  WRK-SUCCESSOR-NO-88  VALUE 'N'.                      DTSBU600
00077                                                                   DTSBU600
00078      05  WRK-ERROR-IND               PIC  X(01).                  DTSBU600
00079          88  WRK-ERROR-YES-88     VALUE 'Y'.                      DTSBU600
00080          88  WRK-ERROR-NO-88      VALUE 'N'.                      DTSBU600
00081                                                                   DTSBU600
00082      05  WRK-IPES-CNT                PIC S9(04)  COMP.            DTSBU600
00083                                                                   DTSBU600
00084      EJECT                                                        DTSBU600
00085  01  L001-LINK-AREA.                                              DTSBU600
00086  ++INCLUDE DTSIL001                                               DTSBU600
00087      SKIP3                                                        DTSBU600
00088  01  L921-LINK-AREA.                                              DTSBU600
00089  ++INCLUDE DTSIL921                                               DTSBU600
00090      SKIP3                                                        DTSBU600
00091  01  ISKL-REC.                                                    DTSBU600
00092  ++INCLUDE DTSIISKL                                               DTSBU600
00093      SKIP3                                                        DTSBU600
00094  01  IPES-REC.                                                    DTSBU600
00095  ++INCLUDE DTSIIPES                                               DTSBU600
00096      EJECT                                                        DTSBU600
00097  LINKAGE SECTION.                                                 DTSBU600
00098      SKIP3                                                        DTSBU600
00099  01  L600-LINK-AREA.                                              DTSBU600
00100  ++INCLUDE DTSIL600                                               DTSBU600
00101      EJECT                                                        DTSBU600
00102  PROCEDURE DIVISION                                               DTSBU600
00103      USING L600-LINK-AREA.                                        DTSBU600
00104                                                                   DTSBU600
00105  DTSBU600-MAIN.                                                   DTSBU600
00106      MOVE ZERO      TO L600-ULTIMATE-SUCCESSOR                    DTSBU600
00107                        WRK-SUCCESSOR                              DTSBU600
00108                        WRK-EFF-DATE                               DTSBU600
00109                        WRK-IPES-CNT.                              DTSBU600
00110                                                                   DTSBU600
00111      SET WRK-START-SEARCH-88  TO TRUE.                            DTSBU600
00112                                                                   DTSBU600
00113      MOVE L600-EMP-NO         TO WRK-EMP-NO.                      DTSBU600
00114                                                                   DTSBU600
00115      PERFORM I1000-END-DATE   THRU I1000-EXIT.                    DTSBU600
00116                                                                   DTSBU600
00117      PERFORM P1000-FIND-SUCCESSOR THRU P1000-EXIT                 DTSBU600
00118         UNTIL WRK-SEARCH-ENDED-88.                                DTSBU600
00119                                                                   DTSBU600
00120      IF WRK-ERROR-YES-88                                          DTSBU600
00121         SET L600-ERROR-88 TO TRUE                                 DTSBU600
00122      ELSE                                                         DTSBU600
00123      IF WRK-SUCCESSOR = ZERO                                      DTSBU600
00124         SET L600-NO-SUCCESSOR-88 TO TRUE                          DTSBU600
00125      ELSE                                                         DTSBU600
00126         MOVE WRK-SUCCESSOR TO L600-ULTIMATE-SUCCESSOR             DTSBU600
00127         SET L600-SUCCESSOR-FOUND-88 TO TRUE.                      DTSBU600
00128                                                                   DTSBU600
00129  DTSBU600-MAIN-EXIT.                                              DTSBU600
00130      GOBACK.                                                      DTSBU600
00131      EJECT                                                        DTSBU600
00132  I1000-END-DATE.                                                  DTSBU600
00133      IF L600-EXP-TRN-EFF-DATE NOT NUMERIC                         DTSBU600
00134         MOVE 99999999                 TO WRK-END-DATE             DTSBU600
00135      ELSE                                                         DTSBU600
00136         MOVE L600-EXP-TRN-EFF-DATE    TO L001-FED-8-DATE-9        DTSBU600
00137         PERFORM S001-FROM-FED-8       THRU S001-EXIT              DTSBU600
00138         IF L001-VALID-DATE                                        DTSBU600
00139            MOVE L600-EXP-TRN-EFF-DATE TO WRK-END-DATE             DTSBU600
00140         ELSE                                                      DTSBU600
00141            MOVE 99999999              TO WRK-END-DATE.            DTSBU600
00142                                                                   DTSBU600
00143  I1000-EXIT. EXIT.                                                DTSBU600
00144                                                                   DTSBU600
00145  P1000-FIND-SUCCESSOR.                                            DTSBU600
00146      MOVE LOW-VALUE         TO IPES-KEY-AREA.                     DTSBU600
00147      MOVE WRK-EMP-NO        TO IPES-PRED-EMP-NO.                  DTSBU600
00148      SET IPES-PES-88        TO TRUE.                              DTSBU600
00149      MOVE IPES-KEY-AREA     TO ISKL-KEY-AREA.                     DTSBU600
00150                                                                   DTSBU600
00151      PERFORM S921-START-BROWSE THRU S921-EXIT.                    DTSBU600
00152      IF L921-NO-REC-88                                            DTSBU600
00153         SET WRK-SEARCH-ENDED-88 TO TRUE                           DTSBU600
00154         GO TO P1000-EXIT.                                         DTSBU600
00155                                                                   DTSBU600
00156      ADD +1 TO WRK-IPES-CNT.                                      DTSBU600
00157      IF WRK-IPES-CNT > WRK-MAX-CNT                                DTSBU600
00158         SET WRK-ERROR-YES-88    TO TRUE                           DTSBU600
00159         SET WRK-SEARCH-ENDED-88 TO TRUE                           DTSBU600
00160         GO TO P1000-EXIT.                                         DTSBU600
00161                                                                   DTSBU600
00162      MOVE ISKL-REC               TO IPES-REC.                     DTSBU600
00163                                                                   DTSBU600
00164      IF IPES-PRED-EMP-NO NOT =   WRK-EMP-NO                       DTSBU600
00165         SET WRK-SEARCH-ENDED-88  TO TRUE                          DTSBU600
00166         GO TO P1000-EXIT.                                         DTSBU600
00167                                                                   DTSBU600
00168      IF IPES-EXP-TRNSF-YES-88                                     DTSBU600
00169         IF IPES-EFF-DATE > WRK-END-DATE                           DTSBU600
00170            SET WRK-SEARCH-ENDED-88 TO TRUE                        DTSBU600
00171            GO TO P1000-EXIT                                       DTSBU600
00172         ELSE                                                      DTSBU600
00173            IF IPES-EFF-DATE NOT < WRK-EFF-DATE                    DTSBU600
00174               MOVE IPES-EFF-DATE TO WRK-EFF-DATE                  DTSBU600
00175               MOVE IPES-SUC-EMP-NO TO WRK-EMP-NO                  DTSBU600
00176                                       WRK-SUCCESSOR               DTSBU600
00177               GO TO P1000-EXIT.                                   DTSBU600
00178                                                                   DTSBU600
00179      SET WRK-SUCCESSOR-NO-88 TO TRUE.                             DTSBU600
00180      PERFORM P1100-SCAN-IPES THRU P1100-EXIT                      DTSBU600
00181         UNTIL WRK-SUCCESSOR-YES-88                                DTSBU600
00182         OR    WRK-SEARCH-ENDED-88.                                DTSBU600
00183                                                                   DTSBU600
00184  P1000-EXIT. EXIT.                                                DTSBU600
00185                                                                   DTSBU600
00186  P1100-SCAN-IPES.                                                 DTSBU600
00187      PERFORM S921-READ-NEXT THRU S921-EXIT.                       DTSBU600
00188      IF L921-NO-REC-88                                            DTSBU600
00189         SET WRK-SEARCH-ENDED-88 TO TRUE                           DTSBU600
00190         GO TO P1100-EXIT.                                         DTSBU600
00191                                                                   DTSBU600
00192      ADD +1 TO WRK-IPES-CNT.                                      DTSBU600
00193      IF WRK-IPES-CNT > WRK-MAX-CNT                                DTSBU600
00194         SET WRK-ERROR-YES-88    TO TRUE                           DTSBU600
00195         SET WRK-SEARCH-ENDED-88 TO TRUE                           DTSBU600
00196         GO TO P1100-EXIT.                                         DTSBU600
00197                                                                   DTSBU600
00198      MOVE ISKL-REC               TO IPES-REC.                     DTSBU600
00199      IF IPES-PRED-EMP-NO NOT = WRK-EMP-NO                         DTSBU600
00200         SET WRK-SEARCH-ENDED-88 TO TRUE                           DTSBU600
00201         GO TO P1100-EXIT.                                         DTSBU600
00202                                                                   DTSBU600
00203      IF IPES-EXP-TRNSF-YES-88                                     DTSBU600
00204         IF IPES-EFF-DATE > WRK-END-DATE                           DTSBU600
00205            SET WRK-SEARCH-ENDED-88 TO TRUE                        DTSBU600
00206            GO TO P1100-EXIT                                       DTSBU600
00207         ELSE                                                      DTSBU600
00208         IF IPES-EFF-DATE NOT < WRK-EFF-DATE                       DTSBU600
00209            SET WRK-SUCCESSOR-YES-88 TO TRUE                       DTSBU600
00210            MOVE IPES-EFF-DATE TO WRK-EFF-DATE                     DTSBU600
00211            MOVE IPES-SUC-EMP-NO TO WRK-EMP-NO                     DTSBU600
00212                                    WRK-SUCCESSOR.                 DTSBU600
00213                                                                   DTSBU600
00214  P1100-EXIT. EXIT.                                                DTSBU600
00215      EJECT                                                        DTSBU600
00216  S001-FROM-FED-8.                                                 DTSBU600
00217      SET L001-FROM-FED-8 TO TRUE.                                 DTSBU600
00218      GO TO S001-DATE.                                             DTSBU600
00219                                                                   DTSBU600
00220  S001-DATE.                                                       DTSBU600
00221      CALL 'DTSBU001' USING L001-LINK-AREA.                        DTSBU600
00222  S001-EXIT. EXIT.                                                 DTSBU600
00223                                                                   DTSBU600
00224  S921-START-BROWSE.                                               DTSBU600
00225      SKIP1                                                        DTSBU600
00226      SET L921-START-BROWSE-88 TO TRUE.                            DTSBU600
00227      GO TO S921-AIX-IO.                                           DTSBU600
00228                                                                   DTSBU600
00229  S921-READ-NEXT.                                                  DTSBU600
00230      SKIP1                                                        DTSBU600
00231      SET L921-READ-NEXT-88 TO TRUE.                               DTSBU600
00232      GO TO S921-AIX-IO.                                           DTSBU600
00233                                                                   DTSBU600
00234  S921-AIX-IO.                                                     DTSBU600
00235      CALL 'DTSBU921'                                              DTSBU600
00236          USING L921-LINK-AREA                                     DTSBU600
00237                ISKL-REC.                                          DTSBU600
00238      SKIP1                                                        DTSBU600
00239  S921-EXIT. EXIT.                                                 DTSBU600
00240      SKIP3                                                        DTSBU600
00241  S999-ABEND.                                                      DTSBU600
00242      SKIP1                                                        DTSBU600
00243      CALL 'DTSBU999'                                              DTSBU600
00244          USING WRK-ABEND-CODE.                                    DTSBU600
00245      SKIP1                                                        DTSBU600
00246  S999-EXIT. EXIT.                                                 DTSBU600
