*DECK DCLLBLP 
USETEXT TAREATB 
USETEXT TBASCTB 
USETEXT TCMMDEF 
USETEXT TCOMMON 
USETEXT TCRMDEF 
USETEXT TDTABLE 
USETEXT TENVIRN 
USETEXT TFIT
USETEXT TNUMOPT 
USETEXT TSBASIC 
      PROC DCLLBLP; 
      BEGIN 
  
#----------------------------------------------------------------------#
#     S T A R T    O F    X R E F S                                    #
  
      XREF PROC CLOSEM;            # CRM CLOSE FILE                    #
      XREF PROC DB$CLS;            # CDCS CLOSE FILE                   #
      XREF PROC DB$OPN;            # CDCS OPEN FILE                    #
      XREF PROC DB$RDX1;           # CDCS READ SEQUENTIAL ON INDEX FILE#
      XREF PROC DB$RWX;            # CDCS REWIND INDEX FILE            #
      XREF PROC DB$STX;            # CDCS START ON INDEX FILE          #
      XREF PROC DIAG;              # ISSUE DIAGNOSTIC                  #
      XREF PROC LOADOVL;           # LOAD AND EXECUTE OVERLAY          #
      XREF PROC READ;              # INPUT DATA FROM TERMINAL          #
      XREF PROC RM$BLP;            # BOOLEAN LIST PROCESSOR            #
      XREF PROC RTNSSCM;           # RETURN ALL CM USED BY SUBSCHEMA   #
      XREF PROC WRITEBL;           # WRITE LINE TO OUTPUT              #
  
      XREF ITEM ABORTED B;         # TRUE IF QU WAS REPRIEVED          #
      XREF ITEM AKGRPID I;         # GROUP ID OF CM CONTAINING LITERAL #
                                   # VALUES OF ALTERNATE KEYS          #
      XREF ITEM CDCSUP B;          # TRUE IF TESTING WITH CDCS         #
      XREF ITEM CURRELLOC I;       # ADDRESS OF RELATION TABLE IF      #
                                   # QUERY BY RELATION, ELSE ZERO      #
      XREF ITEM CURRENTLFPTR I;    # POINTER TO LFNINFO ENTRY          #
                                   # FOR CURRENT LFN                   #
      XREF ITEM DUMMY I;           # DUMMY ITEM FOR A *FOR* LOOP       #
      XREF ITEM FROMKEYINFIT;      # ADDRESS OF *FROM* OR *KEY IN* FIT #
      XREF ITEM ITEMORD I;         # CDCS SUBSCHEMA ITEM ORDINAL       #
      XREF ITEM RA0 I;             # RA + 0, END OF PARAMETER LIST     #
      XREF ITEM RECDORD I;         # RECORD ORDINAL USED BY THIS XMISSN#
      XREF ITEM UPDATING B;        # TRUE IF UPDATING AN AREA          #
      XREF ITEM UPDTEMP B;         # TRUE IF UPDATING TEMPORARY ITEMS  #
  
      XREF BASED ARRAY DBSTAT;     # DATA BASE STATUS BLOCK            #
        BEGIN 
        ITEM DBSERRCODE   I(00,00,60);  # CRM OR CDCS ERROR CODE       #
        ITEM DBSAUXSTAT1  I(01,00,60);  # AUXILIARY STATUS WORD 1      #
        ITEM DBSAUXSTAT2  I(02,00,60);  # AUXILIARY STATUS WORD 2      #
        ITEM DBSAUXSTAT3  I(03,00,60);  # AUXILIARY STATUS WORD 3      #
        ITEM DBSFUNCTION  C(04,00,10);  # FUNCTION IN DISPLAY CODE     #
        ITEM DBSRANKERR   I(05,00,60);  # RANK ON WHICH ERROR OCCURRED #
        ITEM DBSRANKCTLB  I(06,00,60);  # LOWEST RANK ON WHICH CONTROL #
                                        # BREAK OCCURRED               #
        ITEM DBSRANKNULL  I(07,00,60);  # LOWEST RANK FOR WHICH THERE  #
                                        # WAS A NULL RECORD            #
        ITEM DBSNAME      C(08,00,30);  # REALM OR AREA NAME ON WHICH  #
                                        # ERROR OCCURRED               #
        ITEM DBSFATALFLG  B(11,00,06);  # TRUE IF FATAL ERROR          #
        ITEM DBSMSGADDR   I(11,42,18);  # ADDR OF CDCS ERROR MSG BUFFER#
        END 
  
      XREF BASED ARRAY ORDSAVE;;   # POINTER FOR USE BY *RELEASESPACE* #
  
      XREF BASED ARRAY SAVDAREA;   # INFO ABOUT AREAS IN USE           #
        BEGIN 
        ITEM AREASAVE   I(0,42,18);  # AREA TABLE ADDRESS              #
        ITEM AREASAVEWD I(0,00,60);  # WHOLE WORD                      #
        ITEM AREAINUSE  B(0,00,01);  # TRUE IF AREA IN USE             #
        END 
  
      XREF ARRAY RM$BLPA[1:7] S(LFIT);;  # SCRATCH FILE FITS           #
  
      XREF ARRAY BLPRC;            # 2ND BLP PARAM: RETURN INFORMATION #
        BEGIN 
        ITEM RC         U(0,00,06);  # RETURN CODE                     #
        ITEM NUMREC     U(0,18,24);  # NUMBERS OF KEYS RETURNED        #
        ITEM LFNKEYLIST I(0,00,60);  # LFN OF SCRATCH FILE WRITTEN     #
                                     # BY RM$BLP                       #
        END 
  
      XREF ARRAY BLPTBLE;          # 1ST BLP PARAMETER: INPUT TABLE    #
        BEGIN 
        ITEM KEYFWA I(0,6,18);     # ADDRESS OF BLOCK WHERE BLP        #
                                   # RETURNS THE LIST OF KEYS          #
        END 
  
#----------------------------------------------------------------------#
#     S T A R T    O F    D E F S                                      #
  
      DEF RETRYCODE    #-2#;       # CDCS REQUEST COULD NOT BE COMPLETD#
      DEF SEARCHCODE   #-1#;       # CONTINUE SEARCHING FOR RECORD     #
      DEF RECFOUNDCODE #0#;        # RECORD HAS BEEN FOUND             #
      DEF EOICODE      #1#;        # END OF INFORMATION                #
      DEF ERRFOUNDCODE #2#;        # CRM OR CDCS ERROR HAS OCCURRED    #
  
#----------------------------------------------------------------------#
#     S T A R T    O F    L O C A L    I T E M S                       #
  
      ITEM ALKEYLOC I;             # ITEM FOR USE BY *RELEASESPACE*    #
      ITEM DUMMY1 I;               # LOOP INDUCTION VARIABLE           #
      ITEM J I;                    # SCRATCH VARIABLE                  #
      ITEM PD I;                   # PROCESSING DIRECTION              #
      ITEM RC1 I;                  # RETURN CODE FORM CHECKDBSTAT      #
      ITEM RETRYANS C(1);          # ANSWER TO WHETHER TO RETRY        #
                                   # CDCS REQUEST                      #
      ITEM SAVEMRL I;              # SAVED VALUE OF FITMRL             #
      ITEM TEMP I;                 # SCRATCH VARIABLE                  #
  
#----------------------------------------------------------------------#
#     S T A R T    O F    L O C A L    A R R A Y S                     #
  
      ARRAY PAKORD [0:0];          # KEY ITEM AND RECORD ORDINAL AS    #
                                   # PASSED TO CDCS                    #
        BEGIN 
        ITEM PAKRECDORD  U(00,36,12);  # KEY RECORD ORDINAL            #
        ITEM PAKITEMORD  U(00,48,12);  # KEY ITEM ORDINAL              #
        END 
  
#----------------------------------------------------------------------#
#     S T A R T    O F    L O C A L    B A S E D    A R R A Y S        #
  
      BASED ARRAY BIMAGE;;         # POINTER FOR USE BY *RELEASESPACE* #
      BASED ARRAY DKIKEY;;         # POINTER FOR USE BY *RELEASESPACE* #
      BASED ARRAY KEYIN;;          # POINTER FOR USE BY *RELEASESPACE* #
      BASED ARRAY RELENTRIES;;     # POINTER FOR USE BY *RELEASESPACE* #
      BASED ARRAY RUSLIST;;        # POINTER FOR USE BY *RELEASESPACE* #
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     A U T O P S Y                                                    #
#                                                                      #
#     THIS PROC PERFORMS CLEAN UP FOR THIS OVERLAY AFTER AN ABORT HAS  #
#     OCCURRED. THERE IS NO ASSURANCE OF HOW FAR THE OVERLAY WAS IN    #
#     EXECUTION.                                                       #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC AUTOPSY;
      PROC AUTOPSY; 
      BEGIN 
      RELEASESPACE; 
      END                          # END PROC    A U T O P S Y         #
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     CHECKDBSTAT                                                      #
#                                                                      #
#     CHECKS DATA BASE STATUS BLOCK AND SETS RC2                       #
#     ACCORDINGLY.  IF DBSTAT INDICATES THAT CDCS COULD NOT COMPLETE   #
#     REQUEST, THIS PROC ASKS THE USER IF QU SHOULD RETRY REQUEST.     #
#                                                                      #
#     ON OUTPUT                                                        #
#     RC2 = ERRFOUNDCODE           TERMINATE TRANSMISSION PROCESSING   #
#                                  DUE TO ERROR                        #
#     RC2 = RECFOUNDCODE           RECORD HAS BEEN READ                #
#     RC2 = RETRYCODE              QU MUST RETRY CDCS REQUEST          #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC CHECKDBSTAT (RC2); 
      BEGIN 
      ITEM RC2 I;                  # RETURN CODE                       #
      IF DBSERRCODE EQ LOCKEDRCRD  # IF CDCS CANNOT COMPLETE REQUEST   #
                                   # BECAUSE RECORD IS LOCKED          #
        OR DBSERRCODE EQ WAITMEMORY  # BECAUSE CDCS WAIT FOR MEMORY    #
      THEN
        BEGIN 
                                   # CRM/CDCS ERROR -X- FILE/RELATION  #
                                   # -Y- FUNCTION -Z-                  #
        DIAG904;                   # PRINT DIAG 904                    #
        DIAG (1018);               # SHALL WE RETRY CDCS REQUEST -     #
                                   # ANSWER Y OR N                     #
        READ (RETRYANS, TEMP, 1, TEMP);  # READ USER-S RESPONSE        #
        IF RETRYANS EQ "Y"         # IF ANSWER IS YES                  #
        THEN
          BEGIN 
          RC2 = RETRYCODE;         # QU MUST RETRY CDCS REQUEST        #
          RETURN; 
          END 
  
        ELSE                       # USER DOES NOT WANT TO RETRY       #
          BEGIN 
          RC2 = ERRFOUNDCODE;      # TERMINATE TRANSMISSION PROCESSING #
          DBSERRCODE = 0;          # CLEAR ERROR FIELD                 #
          RETURN; 
          END 
        END 
  
      IF DBSERRCODE NQ 0           # IF ANY OTHER ERROR                #
      THEN
        BEGIN 
                                   # CRM/CDCS ERROR -X- FILE/RELATION  #
                                   # -Y- FUNCTION -Z-                  #
        DIAG904;                   # PRINT DIAG 904                    #
        DBSERRCODE = 0;            # CLEAR ERROR FIELD                 #
        RC2 = ERRFOUNDCODE;        # TERMINATE TRANSMISSION PROCESSING #
        RETURN; 
        END 
  
      RC2 = RECFOUNDCODE;          # SUCCESSFUL COMPLETION             #
      RETURN; 
      END                          # END PROC    C H E C K D B S T A T #
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     DCREWND                                                          #
#                                                                      #
#     THIS PROC CONVERTS A CRM CALL TO REWND ON INDEX FILE INTO A CDCS #
#     CALL TO DB$RWX                                                   #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC DCREWND;
      PROC DCREWND (CDCSFIT); 
      BEGIN 
      ARRAY CDCSFIT;; 
      PAKITEMORD = ITEMORD;        # CDCS ITEM ORDINAL                 #
      RC1 = RETRYCODE;
      FOR DUMMY1 = 0               # LOOP UNTIL CDCS CAN DO REQUEST    #
        WHILE RC1 EQ RETRYCODE
      DO
        BEGIN 
        DB$RWX (CDCSFIT, AT$AREAORD, PAKORD);  # CDCS REWIND INDEX FILE#000170
        CHECKDBSTAT (RC1);         # CHECK DATA BASE STATUS BLOCK      #
        END 
  
      IF RC1 EQ ERRFOUNDCODE       # IF SOME CRM/CDCS ERROR            #
      THEN
        BEGIN 
        EXIT50;                    # LOAD 50,0 FOR FULL FILE PASS      #
        END 
      RETURN; 
      END                          # END PROC    D C R E W N D         #
*CALL DIAG904 
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     E X I T 5 0                                                      #
#                                                                      #
#     PROC TO CLEAN UP AND LOAD 50,0 IN CASE A CRM/CDCS ERROR HAS      #
#     FORCED A FILE PASS                                               #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC EXIT50;
      BEGIN 
      SCANALLAREA = TRUE;          # TELL 50,0 TO PASS ENTIRE FILE     #
      AKEY = FALSE;                # DONT USE ALTERNATE KEY            #
      CMM$FRF (KEYFWA[0]);
      IF AKGRPID NQ 0              # IF GROUP ID ALLOCATED             #
      THEN
        BEGIN 
        CMM$FGR (AKGRPID);         # FREE CM WITH THIS GROUP ID        #
        AKGRPID = 0;               # INDICATE THAT CM FREED            #
        END 
  
      FOR J = 1 STEP 1             # FOR ALL SCRATCH FILES             #
        UNTIL 7 
      DO
        BEGIN 
        P<FIT> = LOC(RM$BLPA[J]);  # POSITION TO FIT                   #
        IF FITOC EQ OC$OPEN        # IF FILE LEFT OPEN                 #
        THEN
          BEGIN 
          CLOSEM (FIT, $DET$, RA0);  # CLOSE AND RELEASE BUFFER SPACE  #
          END 
        END 
  
      LOADOVL (BASEX0, O"50", 0);  # LOAD EXECUTION OVERLAY            #
      END                          # END PROC    E X I T 5 0           #
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     G E T N                                                          #
#                                                                      #
#     THIS PROC CONVERTS A CRM CALL TO GETN ON INDEX FILE INTO A CDCS  #
#     CALL TO DB$RDX1                                                  #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC GETN; 
      PROC GETN (CDCSFIT, P2);
      BEGIN 
      ARRAY CDCSFIT;; 
      ITEM P2 I;
      PAKITEMORD = ITEMORD;        # CDCS ITEM ORDINAL                 #
      RC1 = RETRYCODE;
      FOR DUMMY1 = 0               # LOOP UNTIL CDCS CAN DO REQUEST    #
        WHILE RC1 EQ RETRYCODE
      DO
        BEGIN 
                                   # CDCS READ SEQUENTIAL ON INDEX FILE#
        DB$RDX1 (CDCSFIT, AT$AREAORD, PAKORD);
        CHECKDBSTAT (RC1);         # CHECK DATA BASE STATUS BLOCK      #
        END 
  
      IF RC1 EQ ERRFOUNDCODE       # IF SOME CRM/CDCS ERROR            #
      THEN
        BEGIN 
        EXIT50;                    # LOAD 50,0 FOR FULL FILE PASS      #
        END 
      RETURN; 
      END                          # END PROC    G E T N               #
*CALL RELSPACE
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     S T A R T M                                                      #
#                                                                      #
#     THIS PROC CONVERTS A CRM CALL TO STARTM INTO A CDCS CALL TO      #
#     DB$STX                                                           #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC STARTM; 
      PROC STARTM (CDCSFIT, P2);
      BEGIN 
      ARRAY CDCSFIT;; 
      ITEM P2 I;
      PAKITEMORD = ITEMORD;        # CDCS ITEM ORDINAL                 #
      RC1 = RETRYCODE;
      FOR DUMMY1 = 0               # LOOP UNTIL CDCS CAN DO REQUEST    #
        WHILE RC1 EQ RETRYCODE
      DO
        BEGIN 
                                   # CDCS START ON INDEX FILE          #
        DB$STX (CDCSFIT, AT$AREAORD, PAKORD); 
        IF DBSERRCODE EQ UNKNWNALTKEY  # BLP HANDLES THIS ERROR        #
        THEN
          BEGIN 
          FITES = UNKNWNALTKEY;    # STORE ERROR CODE INTO FIT         #
          DBSERRCODE = 0;          # CLEAR ERROR IN DBSTAT             #
          RETURN;                  # NO NEED TO CALL CHECKDBSTAT       #
          END 
  
        CHECKDBSTAT (RC1);         # CHECK DATA BASE STATUS BLOCK      #
        END 
  
      IF RC1 EQ ERRFOUNDCODE       # IF SOME CRM/CDCS ERROR            #
      THEN
        BEGIN 
        EXIT50;                    # LOAD 50, 0 FOR FULL FILE PASS     #
        END 
      RETURN; 
      END                          # END PROC    S T A R T M           #
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     DCLLBLP                                                          #
#                                                                      #
#     THIS PROC IS THE CONTROL MODULE FOR THE 20,3 OVERLAY. IT PERFORMS#
#     THE FOLLOWING FUNCTIONS:                                         #
#                                                                      #
#     1.  IT DETERMINES THE CORRECT PROCESSING DIRECTION.              #
#     2.  IF THE FILE IS NOT OPEN, IT OPENS IT.                        #
#     3.  IT CALLS RM$BLP.                                             #
#     4.  IT INTERPRETS THE BLP RESULTS, AND LOADS (1,0) IF NO RECORDS #
#         QUALIFIED, OTHERWISE IT LOADS (50,0).                        #
#                                                                      #
#     ON INPUT                                                         #
#     AREALOC = AREA$TABLE ADDRESS                                     #
#                                                                      #
#----------------------------------------------------------------------#
  
      P<AREA$TABLE> = AREALOC;     # POSITION TO AREA TABLE            #
      P<KEY$TBL> = AT$PKEYDPTR;    # POSITION TO KEY DESC TABLE        #
      PAKRECDORD = RECDORD;        # RECORD ORDINAL                    #
      IF REFERFILE EQ 1            # IF TRANSMISSION IS QUERY          #
      THEN
        BEGIN 
        PD = PD$INPUT;             # OPEN FOR INPUT                    #
        END 
  
      ELSE                         # IF TRANSMISSION IS UPDATE         #
        BEGIN 
        PD = PD$IO;                # OPEN FOR I-O                      #
        END 
  
      P<FIT> = LOC(AT$AFITPOS);    # POSITION TO FIT                   #
      IF FITOC NQ OC$OPEN          # IF FILE NOT OPEN                  #
        OR FITPD NQ PD             # IF FILE HAS DIFFERENT PROCESSING  #
                                   # DIRECTION                         #
      THEN
        BEGIN 
        IF FITOC EQ OC$OPEN        # IF OPEN WITH WRONG PD             #
        THEN
          BEGIN 
          RC1 = RETRYCODE;
          FOR DUMMY1 = 0           # LOOP UNTIL CDCS CAN DO REQUEST    #
            WHILE RC1 EQ RETRYCODE
          DO
            BEGIN 
IF CDCSUP THEN
            DB$CLS (FIT, AT$AREAORD);  # CDCS CLOSE FILE               #
            CHECKDBSTAT (RC1);     # CHECK DATA BASE STATUS BLOCK      #
            END 
  
          IF RC1 EQ ERRFOUNDCODE   # IF SOME CRM/CDCS ERROR            #
          THEN
            BEGIN 
            IF AKGRPID NQ 0        # IF GROUP ID ALLOCATED             #
            THEN
              BEGIN 
              CMM$FGR (AKGRPID);   # FREE CM WITH THIS GROUP ID        #
              AKGRPID = 0;         # INDICATE THAT CM FREED            #
              END 
  
            CMM$FRF (KEYFWA[0]);   # FREE CM FOR KEY AREA              #
            RELEASESPACE;          # RELEASE SPACE FOR THIS XMISSN     #
            LOADOVL (BASEX0,1,0);  # LOAD AND EXECUTE SYNTAX OVERLAY   #
            END 
          END 
  
        FITPD = PD;                # STORE CORRECT PROCESSING DIRECTION#
        RC1 = RETRYCODE;
        FOR DUMMY1 = 0             # LOOP UNTIL CDCS CAN DO REQUEST    #
          WHILE RC1 EQ RETRYCODE
        DO
          BEGIN 
IF CDCSUP THEN
          DB$OPN (FIT, AT$AREAORD);  # CDCS OPEN FILE                  #
          CHECKDBSTAT (RC1);       # CHECK DATA BASE STATUS BLOCK      #
          END 
  
        IF RC1 EQ ERRFOUNDCODE     # IF SOME CRM/CDCS ERROR            #
        THEN
          BEGIN 
          IF AKGRPID NQ 0          # IF GROUP ID ALLOCATED             #
          THEN
            BEGIN 
            CMM$FGR (AKGRPID);     # FREE CM WITH THIS GROUP ID        #
            AKGRPID = 0;           # INDICATE THAT CM FREED            #
            END 
  
          CMM$FRF (KEYFWA[0]);     # FREE CM FOR KEY AREA              #
          RELEASESPACE;            # RELEASE SPACE FOR THIS XMISSN     #
          LOADOVL (BASEX0, 1, 0);  # LOAD AND EXECUTE SYNTAX OVERLAY   #
          FITOC = OC$CLOSED;       # MARK FILE CLOSED                  #
          END 
        FITOC = OC$OPEN;           # MARK FILE OPEN                    #
        END 
  
      LFNKEYLIST[0] = 0;           # ZERO BLP PARAMETERS               #
      LFNKEYLIST[1] = 0;
      SAVEMRL = FITMRL;            # SAVE CURRENT MRL                  #
      RM$BLP (BLPTBLE, BLPRC);     # CALL BLP TO PREPARE LIST OF       #
                                   # PRIMARY KEYS                      #
      FITREL = 0;                  # RESET TO *NO RELATION IN EFFECT*  #
      FITRL = 0;
      FITMRL = SAVEMRL;            # RESTORE MRL                       #
      FITWSA = 0;                  # ZERO WSA IN CASE IT IS STILL      #
                                   # POINTING TO BLP WSA               #
      J = RC[0];                   # RETURN CODE                       #
      IF J EQ 2 
        AND NUMREC[0] EQ 0         # IF NO RECORD QUALIFIED            #
      THEN
        BEGIN 
        DIAG (1009);               # NO RECORD QUALIFIED               #
        RELEASESPACE;              # RELEASE SPACE FOR THIS DIRECTIVE  #
        LOADOVL (BASEX0, 1, 0);    # START UP SYNTAX PROCESSING        #
        END 
  
      IF J EQ 1                    # THE AREA MUST BE PASSED           #
      THEN
        BEGIN 
        SCANALLAREA = TRUE;        # TELL 50,0 TO PASS ENTIRE FILE     #
        CMM$FRF (KEYFWA[0]);       # FREE CM FOR KEY AREA              #
        END 
  
      ELSE                         # AREA IS ACCESSED VIA LIST OF KEYS #
        BEGIN 
        KEYLIST = KEYFWA[0];       # KEY AREA                          #
        KEYFILE = LFNKEYLIST[1];   # LFN OF SCRATCH FILE WRITTEN BY BLP#
        END 
  
      IF AKGRPID NQ 0              # IF GROUP ID ALLOCATED             #
      THEN
        BEGIN 
        CMM$FGR (AKGRPID);         # FREE CM WITH THIS GROUP ID        #
        AKGRPID = 0;               # INDICATE THAT CM FREED            #
        END 
  
      LOADOVL (BASEX0, O"50", 0);  # LOAD EXECUTION OVERLAY            #
      END 
      TERM
