*DECK CDCSREQ 
USETEXT TCRMDEF 
USETEXT TENVIRN 
USETEXT TFIT
      PROC CDCSREQ ((FNC), AFIT); 
#----------------------------------------------------------------------#
#                                                                      #
#     C D C S R E Q                                                    #
#                                                                      #
#----------------------------------------------------------------------#
  
      BEGIN 
  
#----------------------------------------------------------------------#
#     P A R A M E T E R S                                              #
  
      ARRAY AFIT;;                 # FILE INFO TABLE OF THE CATALOG    #
  
      ITEM FNC  I;                 # CODE NUMBER OF FUNCTION TO PERFORM#
  
#----------------------------------------------------------------------#
#     X R E F S                                                        #
  
      XREF PROC DB$CLS;            # CDCS CLOSE FILE                   #
      XREF PROC DB$DEL;            # CDCS DELETE RECORD                #
      XREF PROC DB$OPN;            # CDCS OPEN FILE                    #
      XREF PROC DB$RD1;            # CDCS SEQUENTIAL READ ON AREA      #
      XREF PROC DB$RD2;            # CDCS RANDOM READ ON AREA          #
      XREF PROC DB$RWF;            # CDCS REWIND FILE                  #
      XREF PROC DB$SKF;            # CDCS SKIP RECORD(S)               #
      XREF PROC DB$STR;            # CDCS START AT GIVEN KEY           #
      XREF PROC DB$WR2;            # CDCS RANDOM WRITE                 #
      XREF PROC DIAG;              # PROC FOR ISSUING DIAGNOSTICS      #
      XREF PROC LOADOVL;           # LOAD QU OVERLAY                   #
      XREF PROC READ;              # READ KEYBOARD INPUT               #
      XREF PROC RTNSSCM;           # RELEASE CM IF CDCS CANNOT BE      #
                                   # REINVOKED                         #
      XREF PROC WRITEBL;           # WRITE LINE TO OUTPUT              #
  
      XREF ITEM CATGORD  I;        # AREA ORDINAL OF CATALOG FILE      #
      XREF ITEM CATRORD  I;        # ORDINAL OF RECORD IN CATALOG      #
      XREF ITEM CPAKORD  I;        # CATALOG"S KEY AND RECORD ORDINAL  #
  
      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 
  
#----------------------------------------------------------------------#
#     B A S E D    A R R A Y S                                         #
  
      BASED ARRAY FROMWSA;         # ARRAY FOR FIT WSA                 #
        BEGIN 
        ITEM F1 I;
        END 
  
      BASED ARRAY SBSCNAMEA;;      # ARRAY FOR SUBSCHEMA NAME          #
  
      BASED ARRAY TOKA;            # ARRAY FOR FIT KA                  #
        BEGIN 
        ITEM T1 I;
        END 
  
#----------------------------------------------------------------------#
#     A R R A Y S                                                      #
  
      ARRAY AREAORDINAL [0:0];     # AREA ORDINAL AS PASSED TO CDCS    #
        BEGIN 
        ITEM RECLENFLAG   B(00,00,01);  # IF TRUE CDCS WILL RETURN     #
                                        # RECORD LENGTH                #
        ITEM AREAORDCDCS  U(00,48,12);  # AREA ORDINAL                 #
        END 
  
#----------------------------------------------------------------------#
#     D E F S                                                          #
  
      DEF ERRFOUNDCODE #2#;        # CDCS ERROR HAS OCCURRED           #
      DEF RETRYCODE    #-2#;       # CDCS REQUEST NOT YET COMPLETED    #
  
#----------------------------------------------------------------------#
#     I T E M S                                                        #
  
      ITEM DUMMY I;                # LOOP COUNTER                      #
      ITEM RC I;                   # RETURN CODE                       #
      ITEM RETRYANS C(1);          # Y OR N RESPONSE TO RETRY MESSAGE  #
      ITEM WORD I;                 # SCRATCH VARIABLE                  #
  
#----------------------------------------------------------------------#
#     S W I T C H E S                                                  #
  
      SWITCH CDCSFUNC RD2,RD1,WR2,DEL,STR,OPN,CLS,RWND,SKB; 
  
  
CONTROL EJECT;
      PROC ISS904;
#----------------------------------------------------------------------#
#                                                                      #
#     I S S 9 0 4                                                      #
#                                                                      #
#     THIS PROC ISSUES DIAG 904, GETTING THE PARAMETERS FOR THE        #017800
#     MESSAGE FROM THE CDCS STATUS BLOCK:                              #017900
#                                                                      #018000
#           CRM/CDCS ERROR -X- FILE/RELATION -Y- FUNCTION -Z-          #018100
#                                                                      #018200
#                                                                      #
#----------------------------------------------------------------------#
  
      BEGIN                                                             019100
      ITEM  CHAR I;                # CHARACTER POSITION                #019200
      ITEM  LOOPCON B;             # LOOP CONTROL                      #019300
      ITEM  RC I;                  # RETURN CODE                       #019400
      ITEM  WD I;                  # WORD POSITION                     #019500
                                                                        019600
      BASED ARRAY  ERRMSG;         # ARRAY TO HOLD ERROR MESSAGE       #019700
        BEGIN                                                           019800
        ITEM  MSGW          U(00,00,60);                                019900
        END                                                             020000
                                                                        020100
      IF DBSERRCODE[0] GQ CDCSERRCODE 
      THEN                         # CDCS ERROR, PRINT ERROR TEXT      #
        BEGIN 
        DIAG (904, DBSERRCODE, SBSCNAMEA, DBSFUNCTION); 
        P<ERRMSG> = DBSMSGADDR[0]; # POSITION TO ERROR TEXT            #020700
        C<0,2>MSGW[0] = " ";       # CARRIAGE CONTROL                  #020800
        LOOPCON = TRUE;                                                 020900
        FOR WD = 0 STEP 1          # SCAN ERROR TEXT FOR TRAILING ZERO #021000
          WHILE LOOPCON                                                 021100
        DO                                                              021200
          BEGIN                                                         021300
          FOR CHAR = 0 STEP 1      # SCAN 1 WORD                       #021400
            UNTIL 9                                                     021500
          DO                                                            021600
            BEGIN                                                       021700
            IF B<CHAR*6,6>MSGW[WD] EQ 0                                 021800
            THEN                   # IF TRAILING ZERO                  #021900
              BEGIN                                                     022000
              LOOPCON = FALSE;     # ZERO FOUND, TERMINATE LOOP        #022100
              TEST WD;                                                  022200
              END                                                       022300
            END                                                         022400
          END                                                           022500
                                                                        022600
                                   # PRINT ERROR TEXT                  #022700
        WRITEBL (ERRMSG, ((WD - 1) * 10) + CHAR, RC);                   022800
        END                                                             022900
                                                                        023000
      IF DBSFATALFLG               # IF CDCS FATAL ERROR               #
      THEN
        BEGIN 
        RTNSSCM;                   # RELEASE CM                        #
        LOADOVL (BASEX0, 1, 0);    # LOAD PRIMARY SYNTAX OVERLAY       #
        END 
      RETURN;                      # ALL DONE                          #
      END 
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     MAIN ROUTINE                                                     #
#                                                                      #
#     *CDCSREQ* IS CALLED FROM *CATCHK* TO PERFORM THE CDCS ROUTINES   #
#     NEEDED WHILE ACCESSING A CATALOG FILE. THE PARAMETER *FNC*       #
#     INDICATES WHICH ROUTINE IS TO BE PERFORMED AND *ISS904* IS       #
#     CALLED IF AN ERROR OCCURS.                                       #
#                                                                      #
#----------------------------------------------------------------------#
  
      P<FIT> = LOC(AFIT);          # POSITION FIT                      #
      RC = RETRYCODE;              # SET LOOP CONTROL                  #
      FOR DUMMY = DUMMY 
        WHILE RC EQ RETRYCODE 
      DO
        BEGIN 
        GOTO CDCSFUNC[FNC];        # DO REQUESTED CDCS ROUTINE         #
RD2:                               # RANDOM READ                       #
        RECLENFLAG = TRUE;         # REQUEST RECORD LENGTH             #
        AREAORDCDCS = CATGORD;     # CATALOG AREA ORDINAL              #
        DB$RD2 (FIT, AREAORDINAL, CPAKORD);  # CDCS READ RANDOM        #
        IF DBSERRCODE EQ 0         # IF NO ERROR OCCURRED              #
        THEN
          BEGIN 
                                   # MOVE WSA TO KA IN FIT             #
          P<FROMWSA> = FITWSA;
          P<TOKA> = FITKA;
          T1 = F1;
          END 
        GOTO REQEND;               # CHECK ERROR STATUS                #
RD1:                               # SEQUENTIAL READ                   #
        RECLENFLAG = TRUE;         # REQUEST RECORD LENGTH             #
        AREAORDCDCS = CATGORD;     # CATALOG AREA ORDINAL              #
        DB$RD1 (FIT, AREAORDINAL);  # CDCS READ SEQUENTIAL             #
        IF DBSERRCODE EQ 0         # IF NO ERROR OCCURRED              #
        THEN
          BEGIN 
                                   # MOVE WSA TO KA IN FIT             #
          P<FROMWSA> = FITWSA;
          P<TOKA> = FITKA;
          T1 = F1;
          END 
        GOTO REQEND;               # CHECK ERROR STATUS                #
WR2:                               # RANDOM WRITE                      #
        DB$WR2 (FIT, 0, CATRORD, CPAKORD);
        GOTO REQEND;               # CHECK ERROR STATUS                #
DEL:                               # DELETE RECORD                     #
        DB$DEL (FIT, 0, CATGORD, CPAKORD);
        GOTO REQEND;               # CHECK ERROR STATUS                #
STR:                               # POSITION TO INDICATED RECORD      #
        DB$STR (FIT, CATGORD, CPAKORD); 
        GOTO REQEND;               # CHECK ERROR STATUS                #
OPN:                               # OPEN FILE                         #
        DB$OPN (FIT, CATGORD);
        IF DBSERRCODE EQ 0         # IF NO ERROR OCCURRED              #
        THEN
          BEGIN 
          FITOC = OC$OPEN;         # SET FIT OPEN/CLOSE FLAG TO OPEN   #
          END 
        GOTO REQEND;               # CHECK ERROR STATUS                #
CLS:                               # CLOSE FILE                        #
        DB$CLS (FIT, CATGORD);
        IF DBSERRCODE EQ 0         # IF NO ERROR OCCURRED              #
        THEN
          BEGIN 
          FITOC = OC$CLOSED;       # SET FIT OPEN/CLOSE FLAG TO CLOSED #
          END 
        GOTO REQEND;               # CHECK ERROR STATUS                #
RWND:                              # REWIND FILE                       #
        DB$RWF (FIT, CATGORD);
        GOTO REQEND;               # CHECK ERROR STATUS                #
SKB:                               # SKIP BACK ONE RECORD              #
        DB$SKF (FIT, CATGORD, -1);
        GOTO REQEND;               # CHECK ERROR STATUS                #
REQEND: 
        IF DBSERRCODE EQ PFWAITAREA 
          OR DBSERRCODE EQ PFWAITPRLIB
          OR DBSERRCODE EQ WAITMEMORY 
        THEN                       # CDCS PASSED BACK A RETURN         #
                                   # CODE TO INDICATE THAT IT COULD NOT#
                                   # COMPLETE THE REQUEST BECAUSE THERE#
                                   # IS SOMETHING IT HAS TO WAIT FOR.  #
                                   # QU NOW ASKS THE INTERACTIVE USER  #
                                   # IF HE WANTS QU TO TRY THE         #
                                   # REQUEST AGAIN OR TO ABORT THE     #
                                   # INVOKE                            #
          BEGIN 
          ISS904;                  #ISSUE DIAG 904                     #
          DBSERRCODE = 0;          # CLEAR ERROR FIELD               #
          DIAG (1018);             # REQUEST -Y- OR -N-                #
          READ (RETRYANS, WORD, 1, RC); 
          IF RETRYANS EQ "Y"
          THEN
            BEGIN 
            RC = RETRYCODE;        # INDICATE ANOTHER TRY IN ORDER     #
            TEST DUMMY;            # START LOOP AGAIN                  #
            END 
  
          ELSE                     # USER INDICATED NO                 #
            BEGIN 
            RC = ERRFOUNDCODE;     # INDICATE ERROR OCCURRED           #
            DBSERRCODE = 0;        # CLEAR ERROR FIELD                 #
            TEST DUMMY;            # GO ON TO ABORT INVOKE             #
            END 
          END 
  
        IF DBSERRCODE NQ 0         # IF SOME OTHER CDCS ERROR          #
          AND DBSERRCODE GQ CDCSERRCODE 
        THEN
          BEGIN 
          ISS904;                  #ISSUE DIAG 904                     #
          END 
  
          DBSERRCODE = 0;          # CLEAR ERROR FIELD                 #
          RETURN; 
        END 
      END 
      TERM; 
