00001  IDENTIFICATION DIVISION.                                         09/19/98
00002  PROGRAM-ID.             DTSCU061.                                DTSCU061
00003  AUTHOR.                 TRICOASTAL CONSULTING LTD.                  LV006
00004  DATE-WRITTEN.           NOVEMBER 1991.                           DTSCU061
00005  DATE-COMPILED.                                                   DTSCU061
00006      SKIP3                                                        DTSCU061
00007 *****                                                             DTSCU061
00008 *                                                                 DTSCU061
00009 *    FUNCTION:  FIELD ASSIGN TERRITORY / FIELD REP ID.               CL**2
00010 *                                                                 DTSCU061
00011 *                                                                 DTSCU061
00012 *    MODIFICATION LOG:                                            DTSCU061
00013 *                                                                 DTSCU061
00014 *    08/19/1998 INITIAL DEVELOPMENT. MODIFIED FROM MACCU061.         CL**2
00015 *               WORK ORDER:                      PROGRAMMER: GD      CL**2
00016 *                                                                 DTSCU061
00017 *                                                                 DTSCU061
00018 *    XX/XX/XXXX XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX     CL**2
00019 *               XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX     CL**2
00020 *               WORK ORDER:                      PROGRAMMER: XXX     CL**2
00021 *                                                                 DTSCU061
00022 *                                                                 DTSCU061
00023 *    DESCRIPTION:                                                 DTSCU061
00024 *                                                                 DTSCU061
00025 *    CALLING PROGRAM PASSES FIELD ASSIGNMENT ZIP AND/OR STATE.       CL**2
00026 *    DTSCU061 FIRST READS THE FFAZ RECORDS USING THE ZIP CODE.       CL**2
00027 *    IF NO RECORD FOUND, THE PROGRAM READS THE FFAZ RECORDS USING    CL**2
00028 *    THE STATE.                                                      CL**5
00029 *                                                                 DTSCU061
00030 *    IF A FFAZ RECORD IS FOUND, THEN RETURN FFAZ-FIELD-REP-ID     DTSCU061
00031 *    IN L061-FLD-REP-ID.                                             CL**4
00032 *                                                                 DTSCU061
00033 *    IF A FFAZ RECORD IS NOT FOUND                                DTSCU061
00034 *        RETURN '??' IN L061-FLD-REP-ID                              CL**2
00035 *    ELSE                                                         DTSCU061
00036 *        RETURN THE APPROPRIATE FFAZ-FLD-REP-ID.                  DTSCU061
00037 *                                                                 DTSCU061
00038 *****                                                             DTSCU061
00039      SKIP3                                                        DTSCU061
00040  ENVIRONMENT DIVISION.                                            DTSCU061
00041      SKIP3                                                        DTSCU061
00042  DATA DIVISION.                                                   DTSCU061
00043      SKIP3                                                        DTSCU061
00044  WORKING-STORAGE SECTION.                                         DTSCU061
000445 77  PAN-VALET PICTURE X(24) VALUE '006DTSCU061  09/19/98'.       DTSCU061
00045      SKIP3                                                        DTSCU061
00046  01  WRK-AREA.                                                    DTSCU061
00047      05  WRK-ABEND-CODE              PIC  X(04)  VALUE 'U061'.    DTSCU061
00048      SKIP2                                                           CL**2
00049      05  WRK-FLD-TERRITORY           PIC  X(05).                     CL**2
00050      SKIP2                                                        DTSCU061
00051      05  WRK-EMP-NO                  PIC  9(07).                     CL**2
00052      05  FILLER REDEFINES WRK-EMP-NO.                                CL**2
00053          10  FILLER                  PIC X(06).                      CL**2
00054          10  WRK-EMP-NO-LAST-DIGIT   PIC  9(01).                     CL**2
00055      EJECT                                                        DTSCU061
00056  01  L831-COMM-AREA.                                              DTSCU061
00057      05  L831-CONTROL-BLOCK.                                      DTSCU061
00058  ++INCLUDE DTSIL831                                                  CL**3
00059      SKIP3                                                        DTSCU061
00060      05  FSKL-REC.                                                DTSCU061
00061  ++INCLUDE DTSIFSKL                                                  CL**3
00062      SKIP3                                                        DTSCU061
00063      05  FFAZ-REC REDEFINES FSKL-REC.                             DTSCU061
00064  ++INCLUDE DTSIFFAZ                                                  CL**3
00065      EJECT                                                        DTSCU061
00066  LINKAGE SECTION.                                                 DTSCU061
00067      SKIP3                                                        DTSCU061
00068  01  DFHCOMMAREA.                                                 DTSCU061
00069  ++INCLUDE DTSIL061                                                  CL**3
00070      EJECT                                                        DTSCU061
00071  PROCEDURE DIVISION.                                              DTSCU061
00072      SKIP2                                                        DTSCU061
00073  DTSCU061-MAIN.                                                      CL**2
00074      MOVE L061-FLD-ZIP TO WRK-FLD-TERRITORY.                         CL**2
00075      SKIP1                                                        DTSCU061
00076      PERFORM P1000-FIND-FIELD-REP THRU P1000-EXIT.                   CL**2
00077      IF L061-FILE-CLOSED                                             CL**2
00078          GO TO DTSCU061-MAIN-RETURN                                  CL**2
00079      ELSE                                                            CL**2
00080      IF L061-FLD-DESK-88                                             CL**2
00081         MOVE L061-FLD-ST TO WRK-FLD-TERRITORY                        CL**2
00082         PERFORM P1000-FIND-FIELD-REP THRU P1000-EXIT.                CL**2
00083      SKIP2                                                        DTSCU061
00084  DTSCU061-MAIN-RETURN.                                               CL**2
00085      EXEC CICS                                                    DTSCU061
00086          RETURN                                                   DTSCU061
00087      END-EXEC.                                                    DTSCU061
00088      SKIP2                                                        DTSCU061
00089      GOBACK.                                                      DTSCU061
00090      SKIP3                                                        DTSCU061
00091  P1000-FIND-FIELD-REP.                                               CL**2
00092      MOVE SPACE TO L061-RESULT-IND                                   CL**2
00093                    L061-FLD-REP-ID                                   CL**2
00094                    L061-MSG-AREA                                     CL**2
00095                    L061-FLD-REP-ID.                                  CL**2
00096      SKIP1                                                           CL**2
00097      MOVE LOW-VALUE TO FFAZ-KEY-AREA.                                CL**2
00098      MOVE WRK-FLD-TERRITORY TO FFAZ-FLD-TERRITORY.                   CL**2
00099      SET FFAZ-FAZ-88 TO TRUE.                                        CL**2
00100      PERFORM S831-READ THRU S831-EXIT.                               CL**2
00101      SKIP1                                                           CL**2
00102      IF L831-FILE-CLOSED-88                                          CL**2
00103          MOVE '2'  TO L061-RESULT-IND                                CL**2
00104          MOVE L831-MSG-AREA TO L061-MSG-AREA                         CL**2
00105      ELSE                                                            CL**2
00106          MOVE '1'  TO L061-RESULT-IND                                CL**2
00107          IF L831-NO-REC-88                                           CL**2
00108              MOVE '??' TO L061-FLD-REP-ID                            CL**2
00109          ELSE                                                        CL**2
00110          IF FFAZ-SINGLE-REP                                          CL**2
00111              MOVE FFAZ-FLD-REP-ID (1) TO L061-FLD-REP-ID             CL**2
00112          ELSE                                                        CL**2
00113              MOVE L061-EMP-NO TO WRK-EMP-NO                          CL**2
00114              IF WRK-EMP-NO-LAST-DIGIT = 0                            CL**2
00115                  MOVE FFAZ-FLD-REP-ID (10) TO L061-FLD-REP-ID        CL**2
00116              ELSE                                                    CL**2
00117                  MOVE FFAZ-FLD-REP-ID (WRK-EMP-NO-LAST-DIGIT)        CL**2
00118                                            TO L061-FLD-REP-ID.       CL**2
00119  P1000-EXIT.                                                         CL**2
00120      EXIT.                                                           CL**2
00121  S831-READ.                                                       DTSCU061
00122      SET L831-READ-88 TO TRUE.                                    DTSCU061
00123      GO TO S831-REF-FILE.                                         DTSCU061
00124  S831-REF-FILE.                                                   DTSCU061
00125      SKIP1                                                        DTSCU061
00126      EXEC CICS                                                    DTSCU061
00127          LINK                                                     DTSCU061
00128              PROGRAM('DTSCU831')                                     CL**6
00129              COMMAREA(L831-COMM-AREA)                             DTSCU061
00130      END-EXEC.                                                    DTSCU061
00131      SKIP1                                                        DTSCU061
00132  S831-EXIT.                                                       DTSCU061
00133      EXIT.                                                        DTSCU061
00134      SKIP2                                                        DTSCU061
00135 ******************  S899-ABEND NOT USED.                          DTSCU061
00136 *S899-ABEND.                                                      DTSCU061
00137 *    SKIP1                                                        DTSCU061
00138 *    EXEC CICS                                                    DTSCU061
00139 *        ABEND                                                    DTSCU061
00140 *            ABCODE (WRK-ABEND-CODE)                              DTSCU061
00141 *    END-EXEC.                                                    DTSCU061
00142 *    SKIP1                                                        DTSCU061
00143 *S899-EXIT.                                                       DTSCU061
00144 *    EXIT.                                                        DTSCU061
