       IDENTIFICATION DIVISION.
       PROGRAM-ID. TEST001T.
      *REMARKS.
      *
      *    Copyright (C) 1991-2007 Micro Focus International Ltd.
      *    All rights reserved.
      *
      *    TESTING SERVICES REQUEST
      *    THIS IS THE MAIN LINE DRIVER FOR THE TRANCODE TESTMENU.
      *
       ENVIRONMENT DIVISION.
       DATA DIVISION.
       WORKING-STORAGE SECTION.
       77  SAVE-DATE      PIC X(08) VALUE SPACES.
       77  PRINTERS       PIC X(20) VALUE 'PRINTER LOCATIONS'.
       77  ABEND          PIC X(08) VALUE 'ABEND'.
       77  OTTEST00       PIC X(08) VALUE 'OTTEST00'.
       77  OTTEST02       PIC X(08) VALUE 'OTTEST02'.
       77  OTTEST03       PIC X(08) VALUE 'OTTEST03'.
       77  OTDEMO90       PIC X(08) VALUE 'OTDEMO90'.
       77  DEMO-ERROR     PIC X VALUE '0'.
       77  END-OF-XREF    PIC X VALUE '0'.
       77  PROCESS-MSG    PIC X VALUE '0'.
       77  EDIT-SWITCH    PIC X VALUE '0'.
       77  EDIT-AGAIN     PIC X VALUE '0'.
       77  CRT-EOD        PIC X VALUE '0'.
       77  FIRST-TIME     PIC X VALUE '1'.
       77  CRT-LENGTH     PIC  9(4) COMP VALUE 1600.
       77  I              PIC  9(4) COMP VALUE ZERO.
       77  J              PIC  9(4) COMP VALUE ZERO.
       77  K              PIC  9(4) COMP VALUE ZERO.
       77  L              PIC  9(4) COMP VALUE ZERO.
       77  N              PIC  9(4) COMP VALUE ZERO.
      ******************************************************************
      * MFS BUFFER TERMINAL AREA DEFINITION - PROGRAM TEST001T.
      ******************************************************************
       01  MESSAGE-I-O-AREA.
           04  LL01-IN   PIC S9(4) COMP.
           04  Z001      PIC X(01) VALUE LOW-VALUES.
           04  Z0012     PIC X(01) VALUE LOW-VALUES.
           04  BUFFER-CONTENT PIC X(3000).
       01  MSG-SW-AREA.
           04  LL0X-IN   PIC S9(4) COMP VALUE +31.
           04  Z00X      PIC X(01) VALUE LOW-VALUES.
           04  Z00X2     PIC X(01) VALUE LOW-VALUES.
           04  MSG-TEXT   PIC X(120) VALUE 'ABCDEFGHIJKLMNOPQR'.
      ******************************************************************
      * MFS INTERFACE AREA FOR MOD DEFINITION(S) - PROGRAM TEST001T.
      ******************************************************************
       01  COMMON-END-SCREEN.
           03  ENDING-TRANCODEC    PIC X(01) VALUE SPACES.
           03  ENDING-TRANCODEA    PIC X(01) VALUE SPACES.
           03  ENDING-TRANCODE     PIC X(79) VALUE SPACES.
           03  END-LINE1           PIC X(60) VALUE
           '      * * * * MICRO FOCUS SUPPORT SYSTEMS * * * *'.
           03  END-LINE2           PIC X(60) VALUE ' '.
           03  END-LINE3           PIC X(60) VALUE
           '            TRANCODE - TESTMENU - ENDED   '.
           03  END-LINE4           PIC X(60) VALUE ' '.
           03  END-LINE5           PIC X(60) VALUE ' '.
           03  END-LINE6           PIC X(60) VALUE ' '.
           COPY TEST00M.
           COPY TEST02M.
           COPY TEST03M.
      ******************************************************************
      ****** IMS DATABASE SEGMENT DEFINITION AREA - PROGRAM TEST001T ***
      ******************************************************************
      ****** INCLUDE FOR SEGMENT TESTHDRS - DEMO HEADER SEGMENT
           COPY TESTHDRS.
      ****** INCLUDE FOR SEGMENT TESTDETS - DEMO PROBLEM SEGMENT(S)
           COPY TESTDETS.
      ******************************************************************
      ** IMS DATABASE DEFINITION FOR TABLES DATA BASE PROGRAM TEST001T
      ******************************************************************
      ****** INCLUDE FOR SEGMENT DEMOHDRS - TABLE HEADER SEGMENT
           COPY DEMOHDRS.
      ****** INCLUDE FOR SEGMENT DEMOELES - ELEMENTARY TABLE SEGMENT
           COPY DEMOELES.
      ******************************************************************
      ****** IMS DATABASE SEGMENT SEARCH ARGUMENTS - PROGRAM TEST001T **
      ******************************************************************
      ****** SSA FOR SEGMENT TESTHDRS -                           ******
       01  SSA-HDRS.
           03  HDRS-SEGNAME        PIC X(08) VALUE 'TESTHDRS'.
           03  HDRS-COM            PIC X     VALUE '*'.
           03  HDRS-COM1           PIC X     VALUE '-'.
           03  HDRS-COM2           PIC X     VALUE '-'.
           03  HDRS-QUALIFY        PIC X     VALUE '('.
           03  HDRS-KEYFLD         PIC X(8)  VALUE 'SEQFIELD'.
           03  HDRS-RLO1           PIC XX    VALUE ' ='.
           03  HDRS-FLDVALUE1      PIC 9(08) COMP VALUE ZERO.
           03  HDRS-ENDQUALIFY PIC X     VALUE ')'.
      ****** SSA FOR SEGMENT DEMODETS - TESTMENU REFERENCE SEGMENT *****
       01  SSA-DETS.
           03  DETS-SEGNAME        PIC X(08) VALUE 'TESTDETS'.
           03  DETS-COM            PIC X     VALUE '*'.
           03  DETS-COM1           PIC X     VALUE '-'.
           03  DETS-COM2           PIC X     VALUE '-'.
           03  DETS-QUALIFY        PIC X     VALUE '('.
           03  DETS-KEYFLD         PIC X(8)  VALUE 'SEQFIELD'.
           03  DETS-RLO1           PIC XX    VALUE ' ='.
           03  DETS-FLDVALUE1      PIC 9(04) COMP VALUE ZERO.
           03  DETS-ENDQUALIFY PIC X     VALUE ')'.
      ****** SSA FOR SEGMENT TESTHDRS  - TEST XREF SSA
       01  SSA-TEST.
           03  TEST-SEGNAME        PIC X(08) VALUE 'TESTHDRS'.
           03  TEST-COM            PIC X     VALUE '*'.
           03  TEST-COM1           PIC X     VALUE '-'.
           03  TEST-COM2           PIC X     VALUE '-'.
           03  TEST-QUALIFY        PIC X     VALUE '('.
           03  TEST-KEYFLD         PIC X(8)  VALUE 'REQUEST '.
           03  TEST-RLO1           PIC XX    VALUE ' ='.
           03  TEST-FLDVALUE1      PIC X(20).
           03  TEST-ENDQUALIFY PIC X     VALUE ')'.
      ****** SSA FOR SEGMENT TESTHDRS  - DEPT XREF SSA
       01  SSA-DEPT.
           03  DEPT-SEGNAME        PIC X(08) VALUE 'TESTHDRS'.
           03  DEPT-COM            PIC X     VALUE '*'.
           03  DEPT-COM1           PIC X     VALUE '-'.
           03  DEPT-COM2           PIC X     VALUE '-'.
           03  DEPT-QUALIFY        PIC X     VALUE '('.
           03  DEPT-KEYFLD         PIC X(8)  VALUE 'DEPT    '.
           03  DEPT-RLO1           PIC XX    VALUE ' ='.
           03  DEPT-FLDVALUE1      PIC X(05).
           03  DEPT-ENDQUALIFY PIC X     VALUE ')'.
      ****** SSA FOR SEGMENT DEMOHDRS - TABLE HEADER SEGMENT ***********
       01  SSA-TBLS.
           03  TBLS-SEGNAME        PIC X(08) VALUE 'DEMOHDRS'.
           03  TBLS-COM            PIC X     VALUE '*'.
           03  TBLS-COM1           PIC X     VALUE '-'.
           03  TBLS-COM2           PIC X     VALUE '-'.
           03  TBLS-QUALIFY        PIC X     VALUE '('.
           03  TBLS-KEYFLD         PIC X(8)  VALUE 'SEQFIELD'.
           03  TBLS-RLO1           PIC XX    VALUE ' ='.
           03  TBLS-FLDVALUE0.
               05  TBLS-FLDVALUE2  PIC X(08) VALUE LOW-VALUES.
               05  TBLS-FLDVALUE1  PIC X(32).
           03  TBLS-ENDQUALIFY PIC X     VALUE ')'.
      ****** SSA FOR SEGMENT DEMOELES - TABLES ELEMENTARY SEGMENT
       01  SSA-ELES.
           03  ELES-SEGNAME    PIC X(08) VALUE 'DEMOELES'.
           03  ELES-COM        PIC X     VALUE '*'.
           03  ELES-COM1       PIC X     VALUE '-'.
           03  ELES-COM2       PIC X     VALUE '-'.
           03  ELES-QUALIFY    PIC X     VALUE '('.
           03  ELES-KEYFLD     PIC X(8)  VALUE 'SEQFIELD'.
           03  ELES-RLO1       PIC XX    VALUE ' ='.
           03  ELES-FLDVALUE0.
               05  ELES-FLDVALUE2  PIC X(10) VALUE LOW-VALUES.
               05  ELES-FLDVALUE1  PIC X(20).
           03  ELES-ENDQUALIFY PIC X     VALUE ')'.
      *****PROGRAM WORK AREAS*************************************
       01  IMS-FUNCTIONS.
           03  GU                      PIC X(4)      VALUE 'GU'.
           03  GN                      PIC X(4)      VALUE 'GN'.
           03  GNP                     PIC X(4)      VALUE 'GNP'.
           03  ISRT                    PIC X(4)      VALUE 'ISRT'.
           03  GHNP                    PIC X(4)      VALUE 'GHNP'.
           03  REPL                    PIC X(4)      VALUE 'REPL'.
           03  DLET                    PIC X(4)      VALUE 'DLET'.
           03  GHN                     PIC X(4)      VALUE 'GHN'.
           03  CHNG                    PIC X(4)      VALUE 'CHNG'.
           03  PURG                    PIC X(4)      VALUE 'PURG'.
           03  GHU                     PIC X(4)      VALUE 'GHU '.
           03  ROLB                    PIC X(4)      VALUE 'ROLB'.
       01  IMS-RETURN-CODES.
           03  BB                      PIC XX        VALUE '  '.
           03  GE                      PIC XX        VALUE 'GE'.
           03  GB                      PIC XX        VALUE 'GB'.
           03  II                      PIC XX        VALUE 'II'.
           03  AI                      PIC XX        VALUE 'AI'.
           03  QC                      PIC XX        VALUE 'QC'.
           03  QD                      PIC XX        VALUE 'QD'.
           03  QE                      PIC XX        VALUE 'QE'.
       01  IMS-ATTRIBUTES-PRINT.
           03  UMDAN                   PIC X VALUE 'A'.
           03  UMDAD                   PIC X VALUE 'E'.
           03  UMDNN                   PIC X VALUE 'J'.
           03  UMDAH                   PIC X VALUE 'I'.
           03  UMDNH                   PIC X VALUE 'R'.
           03  PNMDD                   PIC X VALUE 'U'.
           03  PMDDD                   PIC X VALUE 'V'.
           03  PMDAN                   PIC X VALUE '3'.
           03  PNMDH                   PIC X VALUE 'Y'.
           03  CURSORPOS               PIC X VALUE '{'.
       01  PROGRAM-FIELDS.
           03  HOLD-REF                PIC X(07).
           03  NUM-REF REDEFINES HOLD-REF PIC 9(07).
           03  RGHT-WORK-AREA.
               05  RGHT-IN-LENGTH PIC S9(8) COMP VALUE ZERO.
               05  RGHT-RETURN        PIC X VALUE 'X'.
           03  DATE-WRK.
               05  DATE-YY         PIC XX.
               05  DATE-MM         PIC XX.
               05  DATE-DD         PIC XX.
           03  DATE-WORK  REDEFINES DATE-WRK PIC 9(6).
           03  CURR-DATE        PIC 9(6).
           03  GREGORIAN-DATE-WORK.
               05  GREG-MM         PIC XX.
               05  FILLER          PIC X VALUE '/'.
               05  GREG-DD         PIC XX.
               05  FILLER          PIC X VALUE '/'.
               05  GREG-YY         PIC XX.
           03  ABEND-CODE          PIC 9(6).
           03  ERROR-STATUS        PIC X(02).
      ******************************************************************
      * DEMO006  *******************************************************
      ******************************************************************
       01  DEMO006L-PARMS.
           02  DEMO006L-INPUT-PARMS.
               03  DEMO006L-TBL-KEY          PIC X(32).
               03  DEMO006L-ELEM-KEY         PIC X(20).
               03  FILLER                    PIC X(20) VALUE SPACES.
           02  DEMO006L-OUTPUT-PARMS.
               03  DEMO006L-RETURN-CD        PIC X(02).
                   88  DEMO006L-RETURN-CD-GOOD         VALUE  '00'.
                   88  DEMO006L-RETURN-CD-NOFIND       VALUES '05'
                                                              '10'.
                   88  DEMO006L-RETURN-CD-NOFIND-ELEM  VALUE  '05'.
                   88  DEMO006L-RETURN-CD-NOFIND-TBL   VALUE  '10'.
                   88  DEMO006L-RETURN-CD-CALL-ERROR   VALUE  '20'.
               03  DEMO006L-ELEM-DSC         PIC X(133).
               03  FILLER REDEFINES DEMO006L-ELEM-DSC.
                   05  DEMO006L-OFFICE       PIC X(03).
                   05  FILLER                PIC X(03).
                   05  DEMO006L-REGION       PIC X(06).
                   05  FILLER                PIC X(121).
               03  FILLER                    PIC X(20) VALUE SPACES.
           02  FILLER                        PIC X(23) VALUE SPACES.
           02  FILLER                        PIC X(16) VALUE SPACES.
       COPY TESTSPA.
       LINKAGE SECTION.
       01  CRT-PCB.
           03  CRT-PCBNAME              PIC X(8).
           03  FILLER                   PIC XX.
           03  CRT-STATUS               PIC XX.
           03  CRT-DATE                 PIC S9(7) COMP-3.
           03  CRT-TIME                 PIC S9(7) COMP-3.
           03  CRT-SEQNO                PIC S9(3) COMP.
           03  FILLER                   PIC XX.
           03  CRT-MODNAME              PIC X(8).
           03  FILLER                   PIC X(224).
       01  ALT-PCB.
           03  ALT-PCBNAME              PIC X(8).
           03  FILLER                   PIC XX.
           03  ALT-STATUS               PIC XX.
           03  ALT-DATE                 PIC S9(7) COMP-3.
           03  ALT-TIME                 PIC S9(7) COMP-3.
           03  ALT-SEQNO                PIC S9(3) COMP.
           03  FILLER                   PIC XX.
           03  ALT-MODNAME              PIC X(8).
           03  FILLER                   PIC X(224).
       01  DEMO-PCB.
           03  DEMO-DBD-NAME PIC X(08).
           03  DEMO-LEVEL-NO PIC XX.
           03  DEMO-STATUS PIC XX.
           03  DEMO-PROCOPTS PIC XXXX.
           03  DEMO-RESVD-DLI PIC XXXX.
           03  DEMO-SEGMENT PIC X(08).
           03  DEMO-FILLER PIC X(8).
           03  DEMO-KEYFEEDBCK PIC X(220).
       01  TEST-PCB.
           03  TEST-DBD-NAME PIC X(08).
           03  TEST-LEVEL-NO PIC XX.
           03  TEST-STATUS PIC XX.
           03  TEST-PROCOPTS PIC XXXX.
           03  TEST-RESVD-DLI PIC XXXX.
           03  TEST-SEGMENT PIC X(08).
           03  TEST-FILLER PIC X(8).
           03  TEST-KEYFEEDBCK PIC X(220).
       01  DEPT-PCB.
           03  DEPT-DBD-NAME PIC X(08).
           03  DEPT-LEVEL-NO PIC XX.
           03  DEPT-STATUS PIC XX.
           03  DEPT-PROCOPTS PIC XXXX.
           03  DEPT-RESVD-DLI PIC XXXX.
           03  DEPT-SEGMENT PIC X(08).
           03  DEPT-FILLER PIC X(8).
           03  DEPT-KEYFEEDBCK PIC X(220).
       01  TBLS-PCB.
           03  TBLS-DBD-NAME   PIC X(08).
           03  TBLS-LEVEL-NO   PIC XX.
           03  TBLS-STATUS     PIC XX.
           03  TBLS-PROCOPTS   PIC XXXX.
           03  TBLS-RESVD-DLI  PIC XXXX.
           03  TBLS-SEGMENT    PIC X(08).
           03  TBLS-FILLER     PIC X(8).
           03  TBLS-KEYFEEDBCK PIC X(220).
       PROCEDURE DIVISION.
           ENTRY 'DLITCBL' USING
                                  CRT-PCB
                                  ALT-PCB
                                  DEMO-PCB
                                  TEST-PCB
                                  DEPT-PCB
                                  TBLS-PCB.
           PERFORM C-010-INITIALIZE THRU C-010-EXIT.
           PERFORM C-020-GET-MESSAGE THRU C-020-EXIT.
           MOVE '0' TO CRT-EOD.
           PERFORM A-010-MAINLINE THRU A-010-EXIT
               UNTIL (CRT-EOD = '1')
           GOBACK.
       A-010-MAINLINE.
           IF SPA-PHASE < '1'
               MOVE '1' TO SPA-PHASE
               MOVE '1' TO FIRST-TIME
               PERFORM A-020-FIRST-TIME THRU A-020-EXIT
           ELSE
               PERFORM A-030-PROCESS-TRAN THRU A-030-EXIT.
       A-010-EXIT.
           PERFORM C-010-INITIALIZE THRU C-010-EXIT.
           PERFORM C-020-GET-MESSAGE THRU C-020-EXIT.
       A-020-FIRST-TIME.
      *** SEND BACK INITIAL TESTMENU SCREEN
           IF FIRST-TIME = '1'
               MOVE '0' TO FIRST-TIME.
           MOVE 'TESTMENU' TO SPA-DEST-TRANCODE.
           MOVE 'TESTMENU' TO SPA-ORIG-TRANCODE.
           IF EDIT-SWITCH = '0'
               MOVE CURSORPOS TO S00-ADDC
               MOVE SPACES TO S00-TRANCODE.
           MOVE DEMO00-SCREEN TO BUFFER-CONTENT.
           PERFORM C-030-ISRT-SPA THRU C-030-EXIT.
           CALL 'CBLTDLI' USING
            ISRT
            CRT-PCB
            MESSAGE-I-O-AREA
            OTTEST00
            IF CRT-STATUS = BB
                 NEXT SENTENCE
            ELSE
                 MOVE 3505             TO ABEND-CODE
                 MOVE CRT-STATUS       TO ERROR-STATUS
                 PERFORM C-099-ABEND.
       A-020-EXIT.
           EXIT.
       A-030-PROCESS-TRAN.
      *** CHECK TO SEE IF EXIT HAS BEEN INPUT
           IF S00-EXIT NOT = SPACE
               PERFORM C-100-RETURN THRU C-100-EXIT
               GOBACK.
      *** EDIT INPUT FOR ERRORS
           MOVE '0' TO EDIT-SWITCH.
           PERFORM A-040-EDIT THRU A-040-EXIT.
      *** IF AN ERROR DETECTED RETURN WITH ERROR MESSAGE
           IF EDIT-SWITCH = '1'
               PERFORM A-020-FIRST-TIME THRU A-020-EXIT
               GO TO A-030-EXIT.
      *** SET SWITCH OFF - INDICATES MULTIPLE FUNCTIONS (PROCESS-MSG)
           MOVE '0' TO PROCESS-MSG.
           MOVE LOW-VALUES TO SPA-PHASE.
      *** CHECK FOR AN ADD TRANSACTION
           IF S00-ADD NOT = ' '
               MOVE '1' TO SPA-FUNCTION
               MOVE '1' TO PROCESS-MSG.
      *** SET UPDATE TRANCODE
           IF S00-CHANGE NOT = SPACES
               MOVE '2' TO SPA-FUNCTION
               IF PROCESS-MSG > '0'
                   MOVE '2' TO PROCESS-MSG
               ELSE
                   MOVE '1' TO PROCESS-MSG
                   MOVE 'TESTMAIN' TO SPA-DEST-TRANCODE
                   MOVE NUM-REF TO SPA-TEST-NO.

      *** SET DISPLAY TRAN CODE
           IF S00-INQUIRE NOT = SPACES
               MOVE '3' TO SPA-FUNCTION
               IF PROCESS-MSG > '0'
                   MOVE '2' TO PROCESS-MSG
               ELSE
                   MOVE '1' TO PROCESS-MSG
                   MOVE NUM-REF TO SPA-TEST-NO.
      *** SET DELIVERY REVIEW TRANCODE
           IF S00-REVIEW-TEST NOT = SPACES
               IF PROCESS-MSG > '0'
                   MOVE '2' TO PROCESS-MSG
               ELSE
                   MOVE '4' TO SPA-FUNCTION
                   MOVE '1' TO PROCESS-MSG
                   PERFORM D-010-TESTER-XREF THRU D-010-EXIT
                   GO TO A-030-EXIT.
      *** SET DELIVERY REVIEW DEPT TRANCODE
           IF S00-REVIEW-DEPT NOT = SPACES
               IF PROCESS-MSG > '0'
                   MOVE '2' TO PROCESS-MSG
               ELSE
                   MOVE '5' TO SPA-FUNCTION
                   MOVE '1' TO PROCESS-MSG
                   PERFORM E-010-DEPARTMENT-XREF THRU E-010-EXIT
                   GO TO A-030-EXIT.
      *** ISSUE ERROR MESSAGE IF MORE THAN ONE FUNCTION SELECTED
           IF PROCESS-MSG = '2'
               MOVE '1' TO EDIT-SWITCH
               MOVE 'ERROR!! - MORE THAT ONE OPTION SELECTED' TO
                S00-TRANCODE
               PERFORM A-020-FIRST-TIME THRU A-020-EXIT
               GO TO A-030-EXIT.
      *** ISSUE MESSAGE SWITCH SPA TO SPA
           PERFORM C-090-MESSAGE-SWITCH THRU C-090-EXIT.
       A-030-EXIT.
           EXIT.
       A-040-EDIT.
      *** EDIT TO INSURE A FUNCTION HAS BEEN SPECIFIED
           IF S00-ADD     = SPACES AND
              S00-CHANGE  = SPACES AND
              S00-INQUIRE = SPACES AND
              S00-REVIEW-TEST = SPACES AND S00-REVIEW-DEPT = SPACES
                  MOVE '1' TO EDIT-SWITCH
                  MOVE CURSORPOS TO S00-ADDC
                  MOVE 'SELECT A FUNCTION PLEASE' TO S00-TRANCODE
                  GO TO A-040-EXIT.

      *** EDIT CHANGE SELECT
           MOVE '0' TO DEMO-ERROR.
           IF S00-CHANGE NOT = SPACES
              MOVE S00-CHANGE TO HOLD-REF
              PERFORM C-060-GU-TESTHDRS THRU C-060-EXIT
              IF DEMO-ERROR = '1' OR '2'
                  MOVE CURSORPOS TO S00-CHANGEC
                  MOVE UMDAH TO S00-CHANGEA
                  IF EDIT-SWITCH NOT = '1'
                      MOVE 'INVALID REQUEST NUMBER' TO S00-TRANCODE
                      MOVE '1' TO EDIT-SWITCH.

      *** EDIT VIEW SELECT
           MOVE '0' TO DEMO-ERROR.
           IF S00-INQUIRE NOT = SPACES
              MOVE S00-INQUIRE TO HOLD-REF
              PERFORM C-060-GU-TESTHDRS THRU C-060-EXIT
              IF DEMO-ERROR = '1' OR '2'
                  MOVE CURSORPOS TO S00-INQUIREC
                  MOVE UMDAH TO S00-INQUIREA
                  IF EDIT-SWITCH NOT = '1'
                      MOVE 'INVALID REQUEST NUMBER' TO S00-TRANCODE
                      MOVE '1' TO EDIT-SWITCH.
       A-040-EXIT.
           EXIT.
       C-010-INITIALIZE.
      *** INITIALIZATION ROUTINE - INSURE RE-ENTRABILITY
           MOVE '0' TO FIRST-TIME.
           MOVE '0' TO EDIT-SWITCH.
       C-010-EXIT.
           EXIT.
       C-020-GET-MESSAGE.
      *** GET SPA FOR CONVERSATION
           CALL 'CBLTDLI' USING GU
                                CRT-PCB
                                SPA-IO-AREA.
      *** IO-PCB MESSAGE PROCESSING - INPUT
           CALL 'CBLTDLI' USING
               GN
               CRT-PCB
               MESSAGE-I-O-AREA.
           IF CRT-STATUS NOT = BB AND NOT = QC AND NOT = QD
               MOVE 3514             TO ABEND-CODE
               MOVE CRT-STATUS       TO ERROR-STATUS
               PERFORM C-099-ABEND.
           IF CRT-STATUS = QC OR QD
               IF SPA-PHASE NOT = LOW-VALUES
                   MOVE '1' TO CRT-EOD
                   GO TO C-020-EXIT.
           MOVE LOW-VALUES TO DEMO00-SCREEN.
           MOVE BUFFER-CONTENT TO DEMO00-SCREEN.
           IF SPA-PHASE NOT = LOW-VALUES
               INSPECT DEMO00-SCREEN REPLACING ALL '~' BY ' '.
           PERFORM C-021-FORMAT-NULL-SCREEN THRU C-021-EXIT.
           MOVE CRT-LENGTH TO LL01-IN.
       C-020-EXIT.
           EXIT.
       C-021-FORMAT-NULL-SCREEN.
      *** SCREEN HANDLING FOR DYNAMIC ATTRIBUTE MODIFICATION
           MOVE LOW-VALUES TO
                 S00-ADDC
                 S00-CHANGEC
                 S00-INQUIREC
                 S00-REVIEW-TESTC
                 S00-REVIEW-DEPTC
                 S00-EXITC.
           MOVE UMDAN TO
                 S00-ADDA
                 S00-CHANGEA
                 S00-INQUIREA
                 S00-REVIEW-TESTA
                 S00-REVIEW-DEPTA
                 S00-EXITA.
      *** INSERT ~ TO VALID INPUT FIELDS
           IF SPA-PHASE = LOW-VALUES
                MOVE ALL '~' TO
                 S00-ADD
                 S00-CHANGE
                 S00-INQUIRE
                 S00-REVIEW-TEST
                 S00-REVIEW-DEPT
                 S00-EXIT.
           IF CRT-PCBNAME NOT = 'IMSVS86' AND NOT = 'MFIMS'
               MOVE SPACES TO
                 S00-CHANGE
                 S00-REVIEW-TEST
                 S00-REVIEW-DEPT
               MOVE PMDAN TO
                     S00-CHANGEA
                     S00-REVIEW-TESTA
                     S00-REVIEW-DEPTA.
       C-021-EXIT.
           EXIT.
       C-030-ISRT-SPA.
           CALL 'CBLTDLI' USING
                          ISRT
                          CRT-PCB
                          SPA-IO-AREA.
       C-030-EXIT.
           EXIT.
       C-060-GU-TESTHDRS.
      *** CHECK FOR NUMERIC THE ZERO FILL
           MOVE SPACE TO RGHT-RETURN.
           MOVE 7 TO RGHT-IN-LENGTH.
           CALL 'RGHTJUST' USING
             RGHT-RETURN
             HOLD-REF
             RGHT-IN-LENGTH.
           IF RGHT-RETURN NOT = SPACE
               MOVE '1' TO DEMO-ERROR
               GO TO C-060-EXIT.
           IF RGHT-RETURN = SPACE AND NUM-REF = 0
               MOVE '1' TO DEMO-ERROR
               GO TO C-060-EXIT.
           MOVE NUM-REF TO HDRS-FLDVALUE1.
      *** ISSUE DL/I CALL TO VERIFY DEMO HEADER RECORD
           CALL 'CBLTDLI' USING
            GU
            DEMO-PCB
            TESTHDRS
            SSA-HDRS.
      *** SET ERROR CODE IF NOT FOUND
           IF DEMO-STATUS = BB
               NEXT SENTENCE
           ELSE IF DEMO-STATUS = GE
                MOVE '1' TO DEMO-ERROR
                GO TO C-060-EXIT
           ELSE
                MOVE 3916              TO ABEND-CODE
                MOVE DEMO-STATUS       TO ERROR-STATUS
                PERFORM C-099-ABEND.
           MOVE HDRS-FLDVALUE1 TO SPA-TEST-NO.
       C-060-EXIT.
           EXIT.
       C-080-ISRT-TESTMENU.
           MOVE DEMO00-SCREEN TO BUFFER-CONTENT.
           MOVE 'TESTMENU' TO SPA-DEST-TRANCODE.
           MOVE 'TESTMENU' TO SPA-ORIG-TRANCODE.
           PERFORM C-030-ISRT-SPA THRU C-030-EXIT.
           CALL 'CBLTDLI' USING
            ISRT
            CRT-PCB
            MESSAGE-I-O-AREA
            OTTEST00.
           IF CRT-STATUS = BB
                NEXT SENTENCE
           ELSE
                MOVE 3906              TO ABEND-CODE
                MOVE CRT-STATUS        TO ERROR-STATUS
                PERFORM C-099-ABEND.
       C-080-EXIT.
           EXIT.
       C-090-MESSAGE-SWITCH.
      *** PRIME THE ALTERNATE PCB FOR MESSAGE SWITCH
           MOVE LOW-VALUES TO SPA-PHASE.
           MOVE 'TESTMAIN' TO SPA-DEST-TRANCODE.
           CALL 'CBLTDLI' USING
            CHNG
            ALT-PCB
            SPA-DEST-TRANCODE
           IF ALT-STATUS = BB
                NEXT SENTENCE
           ELSE
           IF ALT-STATUS = 'A4'
                MOVE 'TRANCODE SECURITY VIOLATION' TO END-LINE6
                PERFORM C-100-RETURN THRU C-100-EXIT
           ELSE
                MOVE 3936              TO ABEND-CODE
                MOVE ALT-STATUS        TO ERROR-STATUS
                PERFORM C-099-ABEND.
      *** ISSUE THE MESSAGE SWITCH
           CALL 'CBLTDLI' USING
                          ISRT
                          ALT-PCB
                          SPA-IO-AREA.
           IF ALT-STATUS = BB
                NEXT SENTENCE
           ELSE
           IF ALT-STATUS = 'A4'
                MOVE 'TRANCODE SECURITY VIOLATION' TO END-LINE6
                PERFORM C-100-RETURN THRU C-100-EXIT
           ELSE
                MOVE 3946              TO ABEND-CODE
                MOVE ALT-STATUS        TO ERROR-STATUS
                PERFORM C-099-ABEND.
      *** ISSUE THE MESSAGE SWITCH
           CALL 'CBLTDLI' USING
                          ISRT
                          ALT-PCB
                          MSG-SW-AREA.
           IF ALT-STATUS = BB
                NEXT SENTENCE
           ELSE
                MOVE 3947              TO ABEND-CODE
                MOVE ALT-STATUS        TO ERROR-STATUS
                PERFORM C-099-ABEND.
           GOBACK.
       C-090-EXIT.
           EXIT.
       C-099-ABEND.
      * SETUP ENDING MESSAGES
           MOVE SPACES                 TO END-LINE3.
           STRING 'TRANCODE TESTMENU ABENDED WITH USER CODE: '
                  ABEND-CODE
               DELIMITED BY SIZE     INTO END-LINE3.
           STRING 'PCB ERROR STATUS: '
                  ERROR-STATUS
               DELIMITED BY SIZE     INTO END-LINE4.
      * BACKOUT ANY PENDING UPDATES
           CALL 'CBLTDLI' USING ROLB
                                CRT-PCB.
      * ISRT THE NULL STATE SPA
           MOVE SPACES                 TO SPA-DEST-TRANCODE.
           CALL 'CBLTDLI' USING ISRT
                                CRT-PCB
                                SPA-IO-AREA.
      * SEND INFORMATIONAL ENDING SCREEN
           MOVE COMMON-END-SCREEN TO BUFFER-CONTENT.
           MOVE 1920              TO LL01-IN.
           CALL 'CBLTDLI' USING ISRT
                                CRT-PCB
                                MESSAGE-I-O-AREA
                                OTDEMO90.
      * IGNORE ANY FAILED STATUS CODE ON THESE INSERTS - JUST RETURN
           GOBACK.
       C-099-EXIT.
           EXIT.
       C-100-RETURN.
      *** ISRT THE NULL STATE SPA
           MOVE SPACES TO SPA-ORIG-TRANCODE.
           MOVE SPACES TO SPA-DEST-TRANCODE.
           CALL 'CBLTDLI' USING
                          ISRT
                          CRT-PCB
                          SPA-IO-AREA.
           IF CRT-STATUS = BB
                NEXT SENTENCE
           ELSE
                MOVE 3944              TO ABEND-CODE
                MOVE CRT-STATUS        TO ERROR-STATUS
                PERFORM C-099-ABEND.
      *** MAINLINE ROUTINE TO END PROCESSING
           MOVE COMMON-END-SCREEN TO BUFFER-CONTENT.
           CALL 'CBLTDLI' USING
            ISRT
            CRT-PCB
            MESSAGE-I-O-AREA
            OTDEMO90
            IF CRT-STATUS = BB
                 NEXT SENTENCE
            ELSE
                MOVE 3505              TO ABEND-CODE
                MOVE CRT-STATUS        TO ERROR-STATUS
                PERFORM C-099-ABEND.
            GOBACK.
       C-100-EXIT.
           EXIT.
       D-010-TESTER-XREF.
           MOVE LOW-VALUES TO DEMO02-SCREEN.
           MOVE S00-REVIEW-TEST TO TEST-FLDVALUE1.
           MOVE 0 TO I.
           MOVE 0 TO J.
           MOVE '-' TO TEST-COM1.
           MOVE '=>' TO TEST-RLO1.
           CALL 'CBLTDLI' USING
                          GU
                          TEST-PCB
                          TESTHDRS
                          SSA-TEST.
           MOVE ' >' TO TEST-RLO1.
           MOVE '1' TO FIRST-TIME.
           MOVE 0 TO N.
           IF HDRS-TESTER NOT = S00-REVIEW-TEST
               MOVE '1' TO END-OF-XREF
           ELSE
               MOVE HDRS-TESTER TO S02-REQUESTOR
               MOVE '0' TO END-OF-XREF
               PERFORM D-020-BUILD-TEST-XREF THRU D-020-EXIT
                UNTIL END-OF-XREF = '1'.
           PERFORM D-050-ISRT-TEST-SCREEN THRU D-050-EXIT.
           GOBACK.
       D-010-EXIT.
           EXIT.
       D-020-BUILD-TEST-XREF.
           COMPUTE I = I + 1.
           IF I > 21
               PERFORM D-050-ISRT-TEST-SCREEN THRU D-050-EXIT
               MOVE 1 TO I.
           MOVE HDRS-KEY TO            S02-REQUEST-NO (I).
           MOVE N TO            S02-REQUEST-NO (I).
           MOVE HDRS-REQUEST-DEPT TO   S02-REQUEST-DEPT (I).
           MOVE HDRS-NAME TO           S02-NAME (I).
           MOVE HDRS-PHONE TO          S02-PHONE (I).
           IF HDRS-KEY = ZERO
               MOVE ZERO TO HDRS-ENTRY-DATE.
           MOVE HDRS-ENTRY-DATE TO     DATE-WORK.
           MOVE DATE-YY TO GREG-YY.
           MOVE DATE-MM TO GREG-MM.
           MOVE DATE-DD TO GREG-DD.
           MOVE GREGORIAN-DATE-WORK TO  S02-ENTRY-DATE (I).
           MOVE HDRS-PRODUCT TO       S02-PRODUCT (I).
           MOVE HDRS-LOCATION TO       S02-LOCATION (I).
           IF HDRS-STATUS = 'N'
               MOVE 'NEW REQUEST' TO  S02-STATUS (I).
           IF HDRS-STATUS = 'I'
               MOVE 'IN PROCESS' TO  S02-STATUS (I).
           IF HDRS-STATUS = 'C'
               MOVE 'COMPLETED' TO  S02-STATUS (I).
           IF HDRS-STATUS = 'D'
               MOVE 'DELETED' TO  S02-STATUS (I).
           MOVE ' ' TO TEST-COM1.
           CALL 'CBLTDLI' USING
                          GN
                          TEST-PCB
                          TESTHDRS
                          SSA-TEST.
           IF TEST-STATUS NOT = '  '
                IF N > 55
                    MOVE '1' TO END-OF-XREF.
      *    IF TEST-STATUS NOT = '  '
      *         MOVE '1' TO END-OF-XREF.
      *    IF HDRS-TESTER NOT = S00-REVIEW-TEST
      *        MOVE '1' TO END-OF-XREF.
           COMPUTE N = N + 1.
       D-020-EXIT.
           EXIT.
       D-050-ISRT-TEST-SCREEN.
           IF I > 21
               MOVE 'HIT <PA1> TO VIEW NEXT PAGE' TO S02-ERROR-MSG
           ELSE
               MOVE 'HIT ENTER TO RETURN TO MAIN MENU' TO S02-ERROR-MSG.
           MOVE DEMO02-SCREEN TO BUFFER-CONTENT.
           IF FIRST-TIME = '1'
               MOVE LOW-VALUES TO SPA-PHASE
               MOVE 'TESTMENU' TO SPA-DEST-TRANCODE
               PERFORM C-030-ISRT-SPA THRU C-030-EXIT.
           IF FIRST-TIME = '1'
               MOVE '0' TO FIRST-TIME
               CALL 'CBLTDLI' USING ISRT
                                    CRT-PCB
                                    MESSAGE-I-O-AREA
                                    OTTEST02
           ELSE
               CALL 'CBLTDLI' USING ISRT
                                    CRT-PCB
                                    MESSAGE-I-O-AREA.
           MOVE LOW-VALUES TO S02-MATRIX.
       D-050-EXIT.
           EXIT.
       E-010-DEPARTMENT-XREF.
           MOVE LOW-VALUES TO DEMO03-SCREEN.
           MOVE S00-REVIEW-DEPT TO DEPT-FLDVALUE1.
           MOVE 0 TO I.
           MOVE 0 TO J.
           MOVE '-' TO DEPT-COM1.
           MOVE '=>' TO DEPT-RLO1.
           CALL 'CBLTDLI' USING
                          GU
                          DEPT-PCB
                          TESTHDRS
                          SSA-DEPT.
           MOVE ' >' TO DEPT-RLO1.
           MOVE '1' TO FIRST-TIME.
           IF HDRS-REQUEST-DEPT NOT = S00-REVIEW-DEPT
               MOVE '1' TO END-OF-XREF
           ELSE
               MOVE '0' TO END-OF-XREF
               MOVE HDRS-REQUEST-DEPT TO S03-REQUEST-DEPT
               PERFORM E-020-BUILD-DEPT-XREF THRU E-020-EXIT
                UNTIL END-OF-XREF = '1'.
           PERFORM E-050-ISRT-DEPT-SCREEN THRU E-050-EXIT.
           GOBACK.
       E-010-EXIT.
           EXIT.
       E-020-BUILD-DEPT-XREF.
           COMPUTE I = I + 1.
           IF I > 21
               PERFORM E-050-ISRT-DEPT-SCREEN THRU E-050-EXIT
               MOVE 1 TO I.
           MOVE HDRS-KEY TO            S03-REQUEST-NO (I).
           MOVE HDRS-NAME TO           S03-NAME (I).
           MOVE HDRS-PHONE TO          S03-PHONE (I).
           MOVE HDRS-TESTER TO      S03-TESTER (I).
           MOVE HDRS-ENTRY-DATE TO     DATE-WORK.
           MOVE DATE-YY TO GREG-YY.
           MOVE DATE-MM TO GREG-MM.
           MOVE DATE-DD TO GREG-DD.
           MOVE GREGORIAN-DATE-WORK TO  S03-ENTRY-DATE (I).
           MOVE HDRS-PRODUCT TO       S03-PRODUCT (I).
           MOVE HDRS-LOCATION TO       S03-LOCATION (I).
           IF HDRS-STATUS = 'N'
               MOVE 'NEW REQUEST' TO  S03-STATUS (I).
           IF HDRS-STATUS = 'I'
               MOVE 'IN PROCESS' TO  S03-STATUS (I).
           IF HDRS-STATUS = 'C'
               MOVE 'COMPLETED' TO  S03-STATUS (I).
           IF HDRS-STATUS = 'D'
               MOVE 'DELETED' TO  S03-STATUS (I).
           MOVE ' ' TO DEPT-COM1.
           CALL 'CBLTDLI' USING
                          GN
                          DEPT-PCB
                          TESTHDRS
                          SSA-DEPT.
           IF DEPT-STATUS NOT = ' '
               MOVE '1' TO END-OF-XREF.
           IF HDRS-REQUEST-DEPT NOT = S00-REVIEW-DEPT
               MOVE '1' TO END-OF-XREF.
       E-020-EXIT.
           EXIT.
       E-050-ISRT-DEPT-SCREEN.
           IF I > 21
               MOVE 'HIT <PA1> TO VIEW NEXT PAGE' TO S03-ERROR-MSG
           ELSE
               MOVE 'HIT ENTER TO RETURN TO MAIN MENU' TO S03-ERROR-MSG.
           MOVE DEMO03-SCREEN TO BUFFER-CONTENT.
           IF FIRST-TIME = '1'
               MOVE LOW-VALUES TO SPA-PHASE
               MOVE 'TESTMENU' TO SPA-DEST-TRANCODE
               PERFORM C-030-ISRT-SPA THRU C-030-EXIT.
           IF FIRST-TIME = '1'
               MOVE '0' TO FIRST-TIME
               CALL 'CBLTDLI' USING ISRT
                                    CRT-PCB
                                    MESSAGE-I-O-AREA
                                    OTTEST03
           ELSE
               CALL 'CBLTDLI' USING ISRT
                                    CRT-PCB
                                    MESSAGE-I-O-AREA.
           MOVE LOW-VALUES TO S03-MATRIX.
       E-050-EXIT.
           EXIT.
       PROGRAM-TERMINATOR.
