00001  IDENTIFICATION DIVISION.                                         09/16/99
00002  PROGRAM-ID.             DTSBU061.                                DTSBU061
00003  AUTHOR.                 TRICOASTAL CONSULTING LTD.                  LV008
00004  DATE-WRITTEN.           JULY 1994.                               DTSBU061
00005  DATE-COMPILED.                                                   DTSBU061
00006      SKIP3                                                        DTSBU061
00007 *****                                                             DTSBU061
00008 *                                                                 DTSBU061
00009 *    FUNCTION:  FIELD ASSIGN ZIP / FIELD REP ID.                  DTSBU061
00010 *                                                                 DTSBU061
00011 *                                                                 DTSBU061
00012 *    MODIFICATION LOG:                                            DTSBU061
00013 *                                                                 DTSBU061
00014 *    07/12/94  CLONED FROM DTSCU061.                                 CL**2
00015 *              WORK ORDER:                      PROGRAMMER: RHC   DTSBU061
00016 *                                                                 DTSBU061
00017 *    10/15/1998  REVIEWED AND MODIFIED FOR DC.                       CL**5
00018 *                REFERENCE: DC DEVELOPMENT      PROGRAMMER: EHH      CL**5
00019 *                                                                    CL**5
00020 *    MM/DD/YYYY  XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX      CL**5
00021 *                XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX      CL**5
00022 *                REFERENCE: XXXXXXXXXXXXXXX     PROGRAMMER: XXX      CL**5
00023 *                                                                 DTSBU061
00024 *                                                                 DTSBU061
00025 *    DESCRIPTION:                                                 DTSBU061
00026 *                                                                 DTSBU061
00027 *    CALLING PROGRAM PASSES FIELD ASSIGNMENT ZIP AND STATE CODE.     CL**5
00028 *    DTSCU061 FIRST READS THE FFAZ RECORDS USING THE ZIP CODE.       CL**5
00029 *    IF NO RECORD FOUND, THE PROGRAM READS THE FFAZ RECORDS USING    CL**5
00030 *    THE STATE CODE.                                                 CL**5
00031 *                                                                 DTSBU061
00032 *    IF A FFAZ RECORD IS FOUND, THEN RETURN FFAZ-FIELD-REP-ID     DTSBU061
00033 *    IN L061-FLD-REP-ID.                                             CL**4
00034 *                                                                 DTSBU061
00035 *    IF A FFAZ RECORD IS NOT FOUND                                DTSBU061
00036 *        RETURN '??' IN L061-FLD-REP-ID                              CL**5
00037 *    ELSE                                                         DTSBU061
00038 *        RETURN THE APPROPRIATE FFAZ-FLD-REP-ID.                     CL**5
00039 *                                                                 DTSBU061
00040 *****                                                             DTSBU061
00041      SKIP3                                                        DTSBU061
00042  ENVIRONMENT DIVISION.                                            DTSBU061
00043      SKIP3                                                        DTSBU061
00044  DATA DIVISION.                                                   DTSBU061
00045      SKIP3                                                        DTSBU061
00046  WORKING-STORAGE SECTION.                                         DTSBU061
000465 77  PAN-VALET PICTURE X(24) VALUE '008DTSBU061  09/16/99'.       DTSBU061
00047      SKIP3                                                        DTSBU061
00048  01  WRK-AREA.                                                    DTSBU061
00049      05  WRK-ABEND-CODE              PIC S9(04)  COMP             DTSBU061
00050                                                  VALUE +061.      DTSBU061
00051                                                                      CL**5
00052      05  WRK-FLD-TERRITORY           PIC X(05).                      CL**6
00053                                                                      CL**5
00054      05  WRK-EMP-NO                  PIC 9(07).                      CL**6
00055      05  FILLER REDEFINES WRK-EMP-NO.                                CL**6
00056          10  FILLER                  PIC X(06).                      CL**2
00057          10  WRK-EMP-NO-LAST-DIGIT   PIC 9(01).                      CL**6
00058      EJECT                                                        DTSBU061
00059  01  L931-LINK-AREA.                                              DTSBU061
00060  ++INCLUDE DTSIL931                                                  CL**2
00061      SKIP3                                                        DTSBU061
00062  01  FFAZ-REC.                                                       CL**5
00063  ++INCLUDE DTSIFFAZ                                                  CL**2
00064      EJECT                                                        DTSBU061
00065  LINKAGE SECTION.                                                 DTSBU061
00066      SKIP3                                                        DTSBU061
00067  01  L061-LINK-AREA.                                              DTSBU061
00068  ++INCLUDE DTSIL061                                                  CL**2
00069      EJECT                                                        DTSBU061
00070  PROCEDURE DIVISION                                               DTSBU061
00071      USING L061-LINK-AREA.                                        DTSBU061
00072                                                                      CL**6
00073                                                                      CL**6
00074      MOVE L061-FLD-ZIP TO WRK-FLD-TERRITORY.                         CL**3
00075                                                                      CL**5
00076      MOVE 'Z' TO L061-TERRITORY-IND.                                 CL**8
00077                                                                      CL**8
00078      PERFORM P1000-FIND-FIELD-REP THRU P1000-EXIT.                   CL**3
00079                                                                      CL**5
00080      IF L061-FLD-DESK-88                                             CL**3
00081          MOVE L061-FLD-ST TO WRK-FLD-TERRITORY                       CL**3
00082          MOVE 'S' TO L061-TERRITORY-IND                              CL**8
00083          PERFORM P1000-FIND-FIELD-REP THRU P1000-EXIT.               CL**3
00084                                                                      CL**5
00085                                                                      CL**5
00086      GOBACK.                                                         CL**3
00087      EJECT                                                           CL**6
00088  P1000-FIND-FIELD-REP.                                               CL**3
00089      MOVE SPACE TO L061-RESULT-IND                                   CL**3
00090                    L061-FLD-REP-ID.                                  CL**5
00091                                                                      CL**5
00092      MOVE LOW-VALUE TO FFAZ-KEY-AREA.                                CL**3
00093                                                                      CL**5
00094      MOVE WRK-FLD-TERRITORY TO FFAZ-FLD-TERRITORY.                   CL**3
00095                                                                      CL**5
00096      SET FFAZ-FAZ-88 TO TRUE.                                        CL**3
00097                                                                      CL**5
00098      PERFORM S931-READ THRU S931-EXIT.                               CL**3
00099                                                                      CL**5
00100      MOVE '1' TO L061-RESULT-IND.                                    CL**5
00101                                                                      CL**5
00102      IF L931-NO-REC-88                                               CL**3
00103          MOVE '??' TO L061-FLD-REP-ID                                CL**3
00104      ELSE                                                            CL**3
00105      IF  FFAZ-SINGLE-REP                                             CL**3
00106          MOVE FFAZ-FLD-REP-ID (1) TO L061-FLD-REP-ID                 CL**4
00107      ELSE                                                            CL**3
00108          MOVE L061-EMP-NO TO WRK-EMP-NO                              CL**3
00109          IF WRK-EMP-NO-LAST-DIGIT = 0                                CL**3
00110              MOVE FFAZ-FLD-REP-ID (10) TO L061-FLD-REP-ID            CL**3
00111          ELSE                                                        CL**3
00112              MOVE FFAZ-FLD-REP-ID (WRK-EMP-NO-LAST-DIGIT)            CL**6
00113                                        TO L061-FLD-REP-ID.           CL**3
00114  P1000-EXIT.                                                         CL**3
00115      EXIT.                                                           CL**3
00116      EJECT                                                           CL**5
00117  S931-READ.                                                          CL**3
00118      SET L931-READ-88 TO TRUE.                                       CL**3
00119      GO TO S931-REF-FILE.                                            CL**3
00120                                                                      CL**5
00121  S931-REF-FILE.                                                      CL**3
00122      CALL 'DTSBU931' USING L931-LINK-AREA                            CL**3
00123                            FFAZ-REC.                                 CL**5
00124  S931-EXIT.                                                          CL**3
00125      EXIT.                                                           CL**3
