*DECK CTL40 
USETEXT TAREATB 
USETEXT TBASCTB 
USETEXT TCMMDEF 
USETEXT TCOMMON 
USETEXT TCRMDEF 
USETEXT TDTABLE 
USETEXT TENVIRN 
USETEXT TEXPRES 
USETEXT TFIT
USETEXT TLFNINF 
USETEXT TLOGDEF 
USETEXT TOPTION 
USETEXT TSBASIC 
      PROC CTL40;   BEGIN 
 # THIS PROC IS THE CONTROL MODULE FOR THE 4,0 OVERLAY #
CONTROL NOLIST;                    #VECTORS                            # CTL40
*CALL VECTORS                                                            CTL40
CONTROL LIST;                                                            CTL40
                                                                         CTL40
      XREF PROC ATTACH;                                                  CTL40
      XREF PROC BGFILL;            # PAD RECORD WITH BACKGROUND IMAGE  #
      XREF PROC BGIMAGE;                                                 CTL40
      XREF PROC BGINIT;            # PREPARE BACKGROUND IMAGE          #
      XREF PROC CAPLOG;            # DATA BASE LOGGING                 #
      XREF PROC CONVERT;                                                 CTL40
      XREF PROC DIAG;                                                    CTL40
      XREF PROC DLTE;                                                    CTL40
      XREF PROC EXCEV;                                                   CTL40
      XREF PROC EXPEVAL;                                                 CTL40
      XREF PROC GET;                                                     CTL40
      XREF PROC GETPT;                                                   CTL40
      XREF PROC LOADX0;                                                  CTL40
      XREF PROC MOVEXE;                                                  CTL40
      XREF PROC NEXTGET;                                                 CTL40
      XREF PROC PUT;                                                     CTL40
      XREF PROC READ;                                                    CTL40
      XREF PROC REPLC;                                                   CTL40
      XREF PROC RETURNM;                                                 CTL40
      XREF PROC REWND;                                                   CTL40
      XREF PROC RGTABLE;                                                 CTL40
      XREF PROC USINGEX;                                                 CTL40
                                                                         CTL40
      XREF PROC EXITCTL;           # ENTRY FOR EXITING CTL40           #
  
      XREF ITEM AFPROCESSED B;     # TRUE IF UPDATED UNCLOSED FILE IS  #
                                   # ACCEPTABLE                        #
      XREF ITEM ATPTR I;           # P<AREA$TABLE> AT CALL TO *NEXTGET*#
                                   # OR *CALLOWN*                      #
      XREF ITEM IPROCESSED B;      # FALSE IF INTERACTIVE              #
      XREF ITEM QUESF I;           # CMM ERROR WORD                    #
  
      DEF UPDATED # O"52" #;       # CRM ERROR CODE INDICATING FILE NOT#
                                   # CLOSED SINCE LAST UPDATE          #
  
      ITEM AFANSWER C(1);          # ANSWER TO WHETHER TO ACCEPT       #
                                   # UPDATED UNCLOSED FILE             #
      ITEM  M, UPLG, DTP,  UPLGMAX; 
      ITEM I;                      # INDEX VARIABLE                    #
      ITEM FILEDKI B;              # TRUE IF FILE HAS DUP PRIM KEYS    #
      ITEM GETDKI B;               # TRUE IF GETIO IS READING DUPLICATE#
                                   # PRIMARY KEYS, OR MAJOR KEYS       #
      ITEM J;                      # INDEX VARIABLE                    #
      ITEM K;                      # INDEX VARIABLE                    #
      ITEM LKEYB  I;               # NUM OF BITS IN LAST WORD OF KEY   #
      ITEM LKEYWD I;               # LENGTH OF PRIMARY KEY IN WORDS    #
      ITEM OLDDIAGLEV I;           # RETAINS PREVIOUS VALUE OF DIAGLEV #
                                   # WHILE *DIAG,FULL* IS FORCED FOR A #
                                   # UPD/INS/DEL *USING*.              #
      ITEM TEMP I;                 # DUMMY VARIABLE FOR *READ* CALL    #
  
      XREF PROC DIAGFLU;           # FLUSH DUPLICATE DIAGNOSTICS       #
      XREF ITEM DIAGLEV I;         # FLAG FOR OPTION OF *DIAG* DIRECTIV#
                                   # 0 FOR *PART*, "0 FOR *FULL*       #
      ITEM UPDVETO B;         # SAVES THE VETO STATUS FROM A UPDATE DIR# QY40164
      ITEM UPDPASS B;         # SAVES THE PASS STATUS FROM A UPDATE DIR# QY40164
      ITEM INSTFAIL B=FALSE;  # SAVES THE FITES FROM FAILURE ON PUT.   #
      XREF PROC WRITE;                                                  000870
      ITEM UPDATERECORD B = FALSE;  # FLAG FOR -UPDATE- AND -MOVE- #
  
          # BASED ARRAYS TO ACCESS THE CURRENT RECORD, KEY, AREA FIT, 
             AREA NAME, ETC... WHOSE ADDRESSES ARE IN THE COMMON
             BLOCK CBASIC.                                             #
  
  
          #FILE DEFINITION BLOCK (FDB) FOR THE AREA, CONTAINING 
           PERMANENT FILE NAME, LOCAL FILE NAME, ID, CYCLE, PASSWORDS 
           AS APPROPRIATE.  THIS ARRAY IS FILLED IN BY OVERLAY 1-2
           DURING USE SYNTAX ANALYSIS.  # 
      BASED ARRAY FDBAREA;
        BEGIN 
        ITEM ARNAM C(0,0,10); 
        ITEM AREANAM  C(04,00,07);  # LFN OF AREA FILE                 #
        ITEM AMODBITS U(4,48,2);   # MODIFY/EXTEND PERMISSION.         #
        ITEM ARDBIT   U(4,50,1);   # READ PERMISSION.                  #
        ITEM PFWORD I;
        END 
                                                                         XXXX 
          #FILE DEFINITION BLOCK (FDB) FOR THE INDEX FILE, CONTAINING    XXXX 
           PERMANENT FILE NAME, LOCAL FILE NAME, ID, CYCLE, PASSWORDS    XXXX 
           AS APPROPRIATE. THIS ARRAY IS FILLED IN BY OVERLAY 1-2        XXXX 
           DURING USE SYNTAX ANALYSIS. #                                 XXXX 
      BASED ARRAY FDBINDEX; 
        BEGIN 
        ITEM INDXNAM C(4,0,7);     # INDEX LFN IN INDEX FDB.           #
        ITEM IMODBITS U(4,48,2);    # MODIFY/EXTEND PERMISSION.        #
        ITEM IRDBIT  U(4,50,1);    # READ PERMISSION.                  #
        ITEM IPFWORD I; 
        END 
  
      BASED ARRAY DBP$TBL;         # DESCRIBES DBP INFO IN AREATABLE   #
        BEGIN 
        ITEM DBP$TBLWORD  I(00,00,60); #  WHOLE WORD DEFINITION        #
  
        ITEM DBP$TBLNAME  C(00,00,10); # NAME OF THE ENTRY POINT       #
  
        ITEM DBP$TBLADDR  I(00,42,18); # ABSOLUTE ADDRESS OF THE EP    #
        END 
  
  
  
      BASED ARRAY FDBLOG;          # FDB FOR ATTACHING LOGFILE         #
                                   # NONZERO POINTER IF LOGFILE ATTACHD#
        BEGIN 
        ITEM LOGLFN  C(04,00,07);  # LFN OF ATTACHED LOGFILE           #
        ITEM LOGEXTEND B(04,49,01);  # EXTEND PERMISSION BIT IN FDB    #
        END 
  
      XDEF BASED ARRAY BIMAGE;     # BEFORE-IMAGE ARRAY                #
        BEGIN 
        ITEM IBIMAGE I;            # INTEGER ITEM FOR USE IN COPYING   #
        END 
  
      XDEF ITEM LGBIMAGE I = 0;    # LENGTH OF IMAGE IN *BIMAGE*       #
  
      XREF BASED ARRAY ORDSAVE; 
        ITEM SAVEORD U(0,0,60); 
                                                                        000160
                                                                        000170
      XREF BASED ARRAY SAVDAREA;   # INFO ABOUT AREAS IN USE.          #
            BEGIN 
            ITEM AREASAVE  U(0,42,18);
            ITEM AREASAVEWD U(0,0,60);
            ITEM AREAINUSE  B(0,0,1); 
            END 
      BASED ARRAY DKIKEY;          # SAVE VALUE OF PRIMARY KEY         #
                                   # OR MAJOR KEY                      #
        BEGIN 
        ITEM DKIKEYWD  I; 
        END 
      BASED ARRAY RELENTRIES;;     # DEFINED FOR USE BY *RELEASESPACE* #
      BASED ARRAY RUSLIST;;        # DEFINED FOR USE BY *RELEASESPACE* #
  
      ITEM DUPPOS I = $N$;         # POSITIONING FOR DUPLICATE RECORDS.#
                                   # $N$ FOR *DUPLICATES ARE LAST*, THE#
                                   # DEFAULT. $P$ IF *DUPLICATES ARE   #
                                   # FIRST* WAS SPECIFIED IN SUBSCHEMA.#
  
      XREF ITEM CURRELLOC;         #   CURRENT RELATION TABLE.         #
      XREF ITEM DUMMY;                                                   CTL40
      XREF ITEM SMCURR;                                                  CTL40
      XREF ITEM SMLAST;                                                  CTL40
      XREF ITEM UPDATING B;        # TRUE--UPDATING AN AREA.           #
      XREF ITEM UPDTEMP B;
      XREF ITEM CURRELATION;
      XREF ITEM TARGETAREA;        # PTR TO AREA TABLE TO BE UPDATED.  #
      XREF ITEM USEDIR B;          # TRUE--USE, FALSE--CREATE          #
      XREF ITEM IDIRCODE I;        # INTEGER VALUE OF DIRECTIVE CODE   #
      XREF ITEM DBP$DID B;         # TRUE IF WE DID CALL A DBP.        #
      XREF ITEM DBP$FWA;           # FWA OF LOADED DBP"S               #
      XREF PROC DBP$SAC;           # SEARCH AND CALL DB PROCEDURES     #
      ITEM USINGGETKEY B = TRUE;
      ITEM USINGGETREC B = FALSE; 
      ITEM DIAGNO;   # SET TO DIAG NUMBER IF ERROR #
      ARRAY ATTRIB [0:0] S(2);     # ATTRIB TABLE FOR CONVERT KEY      #
         ITEM ATTRCLS  U(0,12,6), 
              ATTRWP   U(0,18,18),
              ATTRBP   U(0,36,6), 
              ATTRSIZE I(0,42,18),
              ATTDPTLC I(1,21, 6); # CHAR POS OF POINT RELATIVE        #
                                   # TO THE END OF THE FIELD           #
                                   # >0 = POINT TO LEFT                #
                                   # <0 = POINT TO RIGHT               #
      XREF ITEM RA0;
      BASED ARRAY CONVPARAM  S(2);                                      003370
         ITEM LOCNTO  I(0,42,18), 
              TOLOCN  I(1,42,18), 
              CTOCHAR I(0,8,4); 
      ITEM TRUEIF B;
                                                                        003390
          BASED ARRAY INDTBL; 
          ITEM    DEPNDFG B(0,0,1),  #TRUE WHEN DEPEND ON EXIST#
                  INTESUB B(0,1,1),  #INTEGER ITEM SUBSCRIPT# 
                  NEXTFG  B(0,2,1),  #SUBSCRIPT IS -NEXT-#
                  LASTFG  B(0,3,1),  #SUBSCRIPT IS -LAST-#
                  ALLFG   B(0,4,1),  #SUBSCRIPT IS -ALL-# 
                  ANYFG   B(0,5,1),  #SUBSCRIPT IS -ANY-# 
                  TBLGS   I(0,6,4),  #LG OF INDICE TBL/CHAR POS#
                  CONSUB  B(0,10,1),  #CONSTANT SUBSCRIPT#
                  ENTYLG I(0,15,15), #LG OF EACH ENTRY/DEPEND ON ITM# 
                  UPBND   I(0,30,12), #UPPER BOUND OF INDICE# 
                  INDCE   I(0,42,18), #LOCATION OR VALUE OF INDICE# 
                                      #OR WORD POS OF DEPEND ON ITEM# 
                  DPTYPE  I(0,0,6),  #TYPE OF DEPEND ON ITEM# 
                  INDTBLWD I(0,0,60); 
          BASED ARRAY DTABLEPTR;
          ITEM TOCHAR U(0,8,4), 
               CHARLENGTH U(0,12,12),  # LENGTH OF FIELD IN CHARACTERS #
               TOADDRESS I(0,42,18),
               ADDRFROM I(1,24,18), 
               STACKADD I(1,6,18),
           DFROMAD I(0,24,18),
               DUMY I(0,0,60);
          XREF PROC UPBUN;
      XREF PROC WRITEBL;
      XREF PROC OPENM;
      XREF PROC CLOSEM; 
      XREF PROC MOVEC;
      XREF PROC FIGSUB; 
      XREF PROC EXPEVALUATE;
          ITEM UB,RC,PP,JJ,KK,LL; 
      ITEM CHARPOS; 
      ITEM INSERTRCD B;            # TRUE IF RECORD IS TO BE INSERTED  #
      XREF BASED ARRAY DESPTR;
        ITEM DESCOUNT I (0,0,12),  # NUNBER OF LOCAL FILES REFERENCING #
                                   # THIS LIST OF DESCRIBE ITEMS.      #
             DESADDR  U (0,42,18); # ADDRESS OF LIST OF ITEMS.         #
      XREF ITEM TOAREA B; 
      XREF ITEM CURRENTLFPTR; 
      XREF ITEM FROMKEYINFIT I;    # ADDRESS OF *FROM* OR *KEY IN* FIT #
      XREF ITEM LFNLIST;
      XREF ITEM RECDORD I;         # RECORD ORDINAL, ALWAYS 1 FOR CRM  #
                                   # DATA BASE MODE                    #
                                                                        003400
      XREF ITEM AREATBLPTR; 
          XREF PROC EXTEND; 
      XDEF ITEM MKL  I;            # LENGTH OF MAJ KEY IF *GET* ON MAJ #
                                   # 0 IF *GET* ON FULL KEY            #
      XDEF ITEM MKT I;             # MAJOR KEY TYPE                    #
      ITEM SAVEKT I;               # ORIGINAL KEY TYPE BEFORE          #
                                   # GET BY MAJOR KEY                  #
      XDEF ITEM ONALTERKEY B; 
      XDEF ITEM AKCHPOS I;         # ALTERN KEY CHAR POS               #
      XDEF ITEM AKLNGTH I;         # ALTERN KEY LENGTH                 #
      XDEF ITEM AKTYPE I;          # ALTERN KEY TYPE                   #
      XDEF ITEM AKWOPOS I;         # ALTERN KEY WORD POS               #
      XDEF ITEM AKITORD I;         # ITEM ORD IF CDCS AREA ITEM, ELSE 0#
XREF PROC SKIP; 
ITEM SKIPCOUNT,RCDCOUNT;
XDEF ITEM ALKEYLOC; 
XDEF ITEM NEWDATA B;
      ITEM REPTALTKEY B;
      XREF PROC GETN; 
      XREF PROC CMOVE;
      XREF PROC FROMERR;           # PRINT CARD IN ERROR IF *FROM*     #
      XREF PROC STOPEXEC; 
      ITEM TOBASE;
      ITEM LINE C(50);             # SCRATCH OUTPUT LINE               #
      XREF ITEM PROMTYPE I;        # PROMPT POSITION INDICATOR         #
      ITEM VSKIP B;                # SKIP MODKEY PROCESS ON VETO FLAG  #
      XDEF ITEM DBP$ACTION I;      # DBP PARAMETER INDICATES WHAT CRM  #
                                   # FUNCTION IS NEEDED FROM DBP.      #
      ITEM DBPRC I;                # RETURN CODE FROM DBP CALL.        #
      CONTROL EJECT;
#                                      #
#        C T L 4 0                     #
#                                      #
# THIS PROC IS THE MAINLINE CONTROL OF THE EXECUTION OF -QU- DIRECTIVES#
      BEGIN 
      CHKINTEGRITY;                #MAKE SURE PARAMETERS ARE IN ORDER  # CTL40
      IF USEDIR THEN               # -USE- DIRECTIVE HAS BEEN PROCESSED#
        BEGIN 
          ATTACHM(RC);                                                   CTL40
          IF RC NQ 0 THEN 
            BEGIN 
            CLEANUP;                                                     CTL40
            RETURN; 
            END 
        END 
        AREALOC = TARGETAREA; 
        OPENAREA(RC);                                                    CTL40
  
        IF RC NQ 0                 #   ERROR                           #
        THEN
          BEGIN 
          CLEANUP;
          RETURN; 
          END 
  
        IF FITFO EQ FOIS           # IF *IS* FILE                      #
          AND FITDKI               # IF DUPLICATE KEYS                 #
        THEN
          BEGIN 
          FILEDKI = TRUE; 
          LKEYWD = (KT$LENGTH[1] + 9) / 10;  # LEN OF PRIM KEY IN WORDS#
          LKEYB = 60;              # NUM OF KEY BITS IN LAST WD OF KEY #
          P<DKIKEY> = CMM$ALF(LKEYWD, 0, 0);
          END 
        LOG (RQTYPE"TRANSACTION", RC);  #  TRY TO LOG A TRANSACTION    #
        IF KEYLIT NQ 0 THEN    # COMPUTE KEY-LIT VALUE AND GET RECORD  #
          BEGIN 
          KEYLITM(RC);                                                   CTL40
          IF RC NQ 0 THEN 
            BEGIN 
            IF NOT PERFLG                          # IF NOT PERFORMING #
            THEN
              BEGIN 
              IF (ACCESSES + HITS + IOS NQ 0)      # IF ACC/HIT/IO MSG #
                                                   # SHOULD BE DISPLAYD#
              THEN
                BEGIN 
                DIAG (1006, ACCESSES, HITS, IOS);  # DISPLAY MESSAGE   #
                                                   # CLEAR PARAMETERS  #
                ACCESSES = 0; 
                HITS = 0; 
                IOS = 0;
                END 
              IF (OWNFORCD + OWNREJ NQ 0)       # IF ANY RECORDS WERE  #
                                                # FORCED OR REJECTED   #
              THEN
                BEGIN 
                DIAG (1003, OWNFORCD, OWNREJ);  # DISPLAY FORCD/REJ MSG#
                                                # CLEAR PARAMETERS     #
                OWNFORCD = 0; 
                OWNREJ = 0; 
                END 
              END 
            CLEANUP;                                                     CTL40
            RETURN; 
            END 
          END 
      IF DESPASS THEN FILEPASS = TRUE;
      IF FROMKEYINFIT NQ 0         # IF *FROM* OR *KEY IN* FILE        #
      THEN
        BEGIN 
        SETDISFROM(RC); 
        IF RC NQ 0
        THEN
          BEGIN 
          CLOSEAREA;
          RELEASESPACE; 
          RETURN; 
          END 
        END 
      IF FILEPASS THEN
        BEGIN 
        ATPTR = P<AREA$TABLE>;     # SAVE TO SET IN *NEXTGET*          #
        NEXTGET(RC);                                                     CTL40
        P<AREA$TABLE> = ATPTR;     # KEEP ANY CHANGE MADE IN *NEXTGET* #
        IF RC EQ 2 THEN     # ERROR FROM -CRM-  # 
          BEGIN 
          P<FIT> = P<AREAFIT>;
          DIAG(903,FITES,FITLFNC);
          CLEANUP;                                                       CTL40
          RETURN; 
          END 
        IF RC EQ 0                 # IF NEXT RECORD WAS READ           #
        THEN
          BEGIN 
          ACCESSES = ACCESSES + 1;  # INCREMENT NO. OF RECORDS READ FOR#
                                    # DIAG 1006 MESSAGE                #
          END 
        END 
      BASICLOOP(RC);               #DO THE MAIN PROCESSING OF (4,0)    # CTL40
      CLEANUP;                                                           CTL40
      RETURN; 
      END # CTL40  #
#                                      #
      PROC CLEANUP; 
# SMALL PROC USED BY -CTL40- TO RELEASE SPACE AND CLOSE THE AREA   #
      BEGIN 
      CLOSEAREA;                                                         CTL40
      RELEASESPACE;                                                      CTL40
      RETURN; 
      END  # CLEANUP #
*CALL ATTACHF 
      CONTROL EJECT;
      PROC ATTACHM (RC);
#                                      #
#        A T T A C H M                 #
#                                      #
# THIS PROC ATTACHES ALL FILES NEEDED BY -CTL40-. THE RETURN CODE -RC- #
# IS ZERO IF ALL ATTACHES SUCCEEDED, ONE IF ANY ATTACH FAILED. #
  
      BEGIN 
      ITEM RC I;               # RETURN CODE FOR CALLING ROUTINE #
      ITEM LOOPCON B; 
      ITEM TBLPTR;
      ITEM READ$ONLY B;        # BOOLEAN PARAMETER TO -ATTACHF- CALL #
                               #REQUESTING READ PERMISSION ONLY # 
      ITEM RC1 I;              # RETURN CODE FROM -ATTACHF- CALL #
  
#                                                                      #
# ATTACH ALL AREA FILES WHICH HAVE THE -AREAINUSE- BIT SET IN THE      #
# ARRAY -SAVEAREA-.  THE FILES ARE ATTACHED IN ALPHABETICAL ORDER      #
# SO THAT A "DEADLY EMBRACE" IS AVOIDED.                               #
      LOOPCON = TRUE; 
      IF REFERFILE EQ 0            # IF NO AREAS IN USE                #
      THEN
        BEGIN 
        RC = 0; 
        RETURN; 
        END 
      FOR DUMMY = 1 STEP 1 WHILE LOOPCON DO 
        BEGIN 
        TBLPTR = SAVEORD[DUMMY];
        IF AREASAVE[TBLPTR] EQ 0 THEN             # NO MORE AREAS TO   #
          BEGIN                                  # ATTACH.  TERMINATE  #
          LOOPCON = FALSE;                       # LOOP AND EXIT.      #
          RC = 0; 
          TEST DUMMY; 
          END 
        IF AREAINUSE[TBLPTR] THEN                 # THIS AREA SHOULD BE#
          BEGIN                                  # ATTACHED. SET UP FDB#
          P<AREA$TABLE> = AREASAVE[TBLPTR];       # AND ATTACH.        #
          P<AREAFIT> = LOC(AT$AFITPOS[0]);
          IF AT$INDFDB[0] NQ 0 THEN 
                                   # PUT INDEX LFN INTO FIT.           #
            BEGIN 
            P<FDBINDEX> = P<AREA$TABLE> + AT$INDFDB[0]; 
            P<FIT> = LOC(AT$AFITPOS);                                    CTL40
            FITXN = INDXNAM;                                             CTL40
            END 
          P<FDBAREA> = LOC(AT$AFDBPOS[0]);
          READ$ONLY = (REFERFILE EQ 1); 
          IF NOT AT$TEMPA[0] THEN  # NOT A TEMPORARY AREA.             #
            BEGIN 
          RC1 = 0;                                                       CTL40
          ATTACHF (FDBAREA, READ$ONLY, RC1);
          RC = RC1; 
          IF RC NQ 0 THEN                        # ERROR IN ATTACH.    #
            BEGIN                                # RETURN WITH RC NON- #
            AREAINUSE[DUMMY] = FALSE; 
            RETURN;                              # ZERO.               #
            END 
          IF ARDBIT[0] NQ 1 THEN   # NO READ PERMISSION.               #
            BEGIN 
            DIAG (872); 
            AREAINUSE[DUMMY] = FALSE; 
            RETURNM(AREANAM, RA0);  # RETURN AREA FILE                 #
            RC = 1; 
            RETURN; 
            END 
          IF AMODBITS[0] NQ 3 THEN # NO MODIFY/EXTEND PERMISSION.      #
            BEGIN 
            DIAG (874); 
            AREAINUSE[DUMMY] = FALSE; 
            RETURNM(AREANAM, RA0);  # RETURN AREA FILE                 #
            RC = 1; 
            RETURN; 
            END 
          IF AT$INDFDB NQ 0 THEN                 # ATTACH INDEX FILE,  #
            BEGIN                                # IF THERE IS ONE.    #
            P<FDBINDEX> = P<AREA$TABLE> + AT$INDFDB;
            ATTACHF (FDBINDEX, READ$ONLY, RC1); 
            RC = RC1; 
            IF RC NQ 0 THEN                      # ERROR IN ATTACH.    #
              BEGIN                              # EXIT WITH RC NON-   #
              AREAINUSE[DUMMY] = FALSE; 
              RETURN;                            # ZERO.               #
              END 
            IF IRDBIT[0] NQ 1 THEN  # NO READ PERMISSION.              #
              BEGIN 
              DIAG (224); 
              AREAINUSE[DUMMY] = FALSE; 
              RETURNM(AREANAM, RA0);  # RETURN AREA FILE               #
              RETURNM(INDXNAM, RA0);  # RETURN INDEX FILE              #
              RC = 1; 
              RETURN; 
              END 
            IF IMODBITS[0] NQ 3 THEN  # NO MODIFY/EXTEND PERMISSION.   #
              BEGIN 
              DIAG (225); 
              AREAINUSE[DUMMY] = FALSE; 
              RETURNM(AREANAM, RA0);  # RETURN AREA FILE               #
              RETURNM(INDXNAM, RA0);  # RETURN INDEX FILE              #
              RC = 1; 
              RETURN; 
              END 
            END 
            END 
          IF NOT READ$ONLY AND AT$LOGFDB NQ 0 THEN  # IF LOG ON TARGET #
            BEGIN 
            P<FDBLOG> = P<AREA$TABLE> + AT$LOGFDB;  #FDB FOR LOG ATTACH#
            ATTACHF (FDBLOG, READ$ONLY, RC1);  # ATTACH THE LOGFILE    #
            RC = RC1; 
            IF RC NQ 0 THEN        # IF SOME ERROR ON LOGFILE ATTACH   #
              BEGIN 
              DIAG (255);          # COULD NOT ATTACH NEEDED LOGFILE   #
              P<FDBLOG> = 0;       # DON-T HAVE LOGFILE ATTACHED       #
              RETURN;              # RETURN WITH NON-ZERO RETURN CODE  #
              END 
            IF NOT LOGEXTEND THEN  # IF NO EXTEND PERMISSION           #
              BEGIN 
              RC = 1;              # SET NON-ZERO RETURN CODE          #
              DIAG (253);          # NO EXTEND PERMISSION ON LOGFILE   #
              RETURNM (LOGLFN, RA0);  # RETURN LOGFILE WE CANT USE     #
              P<FDBLOG> = 0;       # DON-T HAVE LOGFILE ATTACHED       #
              RETURN;              # RETURN WITH NON-ZERO RETURN CODE  #
              END 
            END 
          END 
        END                                      # END OF -DUMMY- LOOP #
      RETURN; 
      END                                        # END OF ATTACHM.     #
      CONTROL EJECT;
      PROC BASICLOOP(NEXTGETSTAT);
#                                      #
#        B A S I C L O O P             #
#                                      #
# THIS PROC IS THE GUTS OF -CTL40-. IT IS THE INTERFACE WITH ALL OF THE#
# DIRECTIVES TO BE PROCESSED BY THIS OVERLAY.  #
      BEGIN 
                                                                         CTL40
      ITEM NEXTGETSTAT;        # EOF / ERROR RETURN FROM -NEXTGET- #
      ITEM FINISHED B = FALSE; # FLAG TO GET OUT OF RECORD PASS LOOP  # 
      ITEM ENDBASICTAB B;      # FLAG TO GET OUT OF BASIC TABLE LOOP   #
      ITEM DUMMY1  I;              #ANOTHER DUMMY INDUCTION VARIABLE   # CTL40
      SWITCH DIRECTIVE
        ENDBT,         #  0 # 
        DISPLAYLAB,    #  1 # 
        DELETE,        #  2 # 
        DELETEUSING,   #  3 # 
        INSERT,        #  4 # 
        INSERTUSING,   #  5 # 
        UPDATE,        #  6 # 
        UPDATEUSING,   #  7 # 
        RESERVED,      #  8 # 
        MOVE,          #  9 # 
        EVALUATE,      # 10 # 
        IFLABEL,       # 11 # 
        EXTRACT,       # 12 # 
        STORE,         # 13 # 
        STORESETTING,  # 14 # 
        CONTINUELAB,   # 15 # 
        MODIFY,        # 16 # 
        MODIFYUSI,     # 17 # 
        REMOVE,        # 18 # 
        REMOVEUSI;     # 19 # 
      ITEM DISPLAYRC I = 0;    # RETURN CODE FROM -DISPLAY-  #
                                                                         CTL40
ALKEYLOC=0; 
      IF NEXTGETSTAT NQ 0 THEN FINISHED = TRUE; 
      FOR DUMMY=DUMMY                                                    CTL40
        WHILE NOT FINISHED                                               CTL40
      DO                                                                 CTL40
        BEGIN                  # LOOP THRU AREA FILE   #
        ENDBASICTAB = FALSE;
        TRUEIF = TRUE;
        P<BASICTABLE> = BASTABLOC;
        BASCPTR = BASTABLOC;
                                                                         CTL40
        IF FILEPASS                                                      CTL40
          AND BASCODE NQ IFCODE                                          CTL40
        THEN                                                             CTL40
          BEGIN                                                          CTL40
          CHKMAT(ENDBASICTAB);                                           CTL40
          END                                                            CTL40
        BASTABIND = -1; 
        FOR DUMMY1=DUMMY1                                                CTL40
          WHILE NOT ENDBASICTAB                                          CTL40
        DO                                                               CTL40
          BEGIN                # LOOP THRU EACH DIRECTIVE IN TRANS-    #
                               # MISSION FOR THIS RECORD   #
          BASTABIND = BASTABIND + 1;   # MOVE INDEX TO NEXT DIRECTIVE  #
          I = BASCODE[BASTABIND];  # SET UP DISPLAY CODE FORM OF   #
                                   # DIRECTIVE CODE#
          ONALTERKEY = BASCUPDALT[BASTABIND];  # TRANSFER UPD ALT  FLAG#
          IDIRCODE = DIRCODEVAL[I];    #STATUS VALUE FOR DIRECTIVE     #
          DIRCODE = IDIRCODE + O"33";  # CHARACTER FORM OF DIRECT. CODE#
                                           # CODE. INDEX INTO THE STRNG#
                                           # ITEM IS BASCODE.          #
          IF TRUEIF OR
            (I EQ IFCODE OR I EQ CONTCODE OR I EQ ENDCODE) THEN 
            BEGIN              # A FALSE -IF- SAYS TO FIND THE NEXT    #
                               # -IF-. CONTINUATION CODES ARE PROCESSED#
                               # TO LINK BASIC TABLE EXTENSIONS    #
            GOTO DIRECTIVE[I];
CONTINUELAB:  
            BASCPTR = BASCLAST[BASTABIND];
            P<BASICTABLE> = BASCPTR;
            BASTABIND = -1; 
            TEST DUMMY1;                                                 CTL40
DELETE:                                                                  CTL40
            DELETEM;                                                     CTL40
            TEST DUMMY1;                                                 CTL40
DELETEUSING:                                                             CTL40
            DELUSI;                                                      CTL40
            TEST DUMMY1;                                                 CTL40
DISPLAYLAB:                                                              CTL40
            DISPLAY(DISPLAYRC);                                          CTL40
            IF DISPLAYRC EQ 1                                            CTL40
            THEN                                                         CTL40
              BEGIN                                                      CTL40
              ENDBASICTAB = TRUE;                                        CTL40
              END                                                        CTL40
            TEST DUMMY1;                                                 CTL40
ENDBT:                                                                   CTL40
            ENDBASICTAB = TRUE;                                          CTL40
            TEST DUMMY1;                                                 CTL40
EVALUATE:                                                                CTL40
            EXCEV;                                                       CTL40
            TEST DUMMY1;                                                 CTL40
EXTRACT:                                                                 CTL40
            EXTRACTM;                                                    CTL40
            TEST DUMMY1;                                                 CTL40
IFLABEL:                                                                 CTL40
            IFM(TRUEIF);                                                 CTL40
            TEST DUMMY1;                                                 CTL40
INSERT:                                                                  CTL40
            INSERTM;                                                     CTL40
            TEST DUMMY1;                                                 CTL40
INSERTUSING:                                                             CTL40
            INSUSI;                                                      CTL40
            TEST DUMMY1;                                                 CTL40
MOVE:                                                                    CTL40
            MOVEM;                                                       CTL40
            TEST DUMMY1;                                                 CTL40
UPDATE:                                                                  CTL40
            UPDATEM;                                                     CTL40
            TEST DUMMY1;                                                 CTL40
UPDATEUSING:  
            TRUEIF = FALSE;    # FOR ACCESSES/HITS COUNT #
            UPDUSI;                                                      CTL40
            TRUEIF = TRUE;
            TEST DUMMY1;
STORE:  
            STOREM; 
            TEST DUMMY1;
STORESETTING: 
            STORSET;
            TEST DUMMY1;
MODIFY: 
            MODIFYM;
            TEST DUMMY1;
MODIFYUSI:  
            MODUSI; 
            TEST DUMMY1;
REMOVE: 
            REMOVEM;
            TEST DUMMY1;
REMOVEUSI:  
            REMUSI; 
            TEST DUMMY1;
RESERVED:                      # RESERVED FOR FUTURE EXPANSION OF  #
            TEST DUMMY1;                                                 CTL40
            END 
          END  # ENDBASICTAB   #
        IF WRTRECD                 # IF UPDATE RECORD                  #
          OR INSERTRCD             # IF INSERT RECORD                  #
        THEN
          BEGIN 
      BASCVETO[BASTABIND] = UPDVETO;    # MOVE UPDATE VETO STATUS#       QY40164
      BASCPASS[BASTABIND] = UPDPASS;    # MOVE UPDATE PASS STATUS#       QY40164
          IF WRTRECD               # IF UPDATE RECORD                  #
          THEN
            BEGIN 
            UPDIO;                 # UPDATE RECORD                     #
            WRTRECD = FALSE;       # CLEAR FLAG                        #
            END 
          ELSE
            BEGIN 
            INSTIO;                # INSERT RECORD                     #
            INSERTRCD = FALSE;     # CLEAR FLAG                        #
            END 
          END 
        UPDATERECORD = FALSE; 
        FINISHED = NOT (FILEPASS OR GETDKI);
        ENDBASICTAB = FALSE;
        IF FILEPASS THEN
          BEGIN 
          IF TRUEIF 
            AND NOT VSKIP          # IF NO ON VETO, OR MODIFY FAILED,  #
            AND NOT INSTFAIL       # DONT INCREMENT NUMBER OF HITS.    #
          THEN
            BEGIN 
            HITS = HITS + 1;
            END 
          ELSE
            BEGIN 
            INSTFAIL = FALSE;      # RESET INSTFAIL FLAG TO PASS       #
            END 
          ATPTR = P<AREA$TABLE>;   # SAVE TO SET IN *NEXTGET*          #
          NEXTGET(RC);                                                   CTL40
          P<AREA$TABLE> = ATPTR;   # KEEP ANY CHANGE MADE IN *NEXTGET* #
          IF RC EQ 2 THEN      # -CRM- ERROR   #
            BEGIN 
            P<FIT> = P<AREAFIT>;
            DIAG(903,FITES,FITLFNC);
            END 
          IF RC EQ 0
          THEN
            BEGIN 
            ACCESSES = ACCESSES + 1;  # INCR. NO. RECORDS READ FOR DIAG#
                                      # 1006 MESSAGE                   #
            END 
          ELSE
            BEGIN 
            FINISHED = TRUE;       # GET OUT OF RECORD PASS LOOP       #
            END 
          END 
        IF GETDKI                  # IF GET DUPLICATE PRIMARY KEY      #
        THEN
          BEGIN 
          GETIO;                   # READ NEXT RECORD                  #
          IF DIAGNO NQ 0           # IF NO MORE DUPLICATES             #
          THEN
            BEGIN 
            FINISHED = TRUE;       # EXIT BASIC LOOP                   #
            END 
          END 
        IF DISPLAYRC NQ 0 THEN FINISHED = TRUE; 
        END    # FINISHED  #
      IF (FILEPASS AND NOT PERFLG) OR 
         (KEYLIT NQ 0 AND NOT PERFLG) THEN
        BEGIN 
        DIAG(1006, ACCESSES, HITS, IOS);  # DISPLAY ACCESS/HIT/IO COUNT#
                             # REINITIALIZE ACCESSES HITS AND IOS      #
        ACCESSES = 0; 
        HITS = 0; 
        IOS = 0;
        IF OWNFORCD + OWNREJ NQ 0 THEN  # IF ANY FORCED OR REJECTED BY #
                                        # DATABASE PROCEDURES.         #
          BEGIN 
          DIAG (1003, OWNFORCD, OWNREJ);  # FORCED AND REJECTED COUNTS #
          END 
        END 
      RETURN; 
      END 
                                                                        003500
      CONTROL EJECT;
      XDEF PROC CALLOWN;
*CALL     CALLOWN 
      CONTROL EJECT;
      PROC CHKINTEGRITY;
#                                      #
#        C H K I N T E G R I T Y       #
#                                      #
# THIS PROC CHECKS THE INTEGRITY OF THE PARAMETERS SET UP TO CALL # 
# -CTL40-. -DIAG- IS CALLED FOR EACH INFRACTION. -DIAGNO- IS 0 IF # 
# ALL APPEARS TO BE OK. # 
      BEGIN 
      RECDORD = 1;                 # CRM DATA BASE MODE USES RECORD    #
                                   # ORDINAL 1                         #
      ACCESSES = 0; 
      IOS = 0;
      HITS = 0; 
      OWNFORCD = 0; 
      OWNREJ = 0; 
      P<BASICTABLE> = BASTABLOC;
      P<CCOMMON> = CCOMLOC; 
      BASCPTR = BASTABLOC;
      END  # CHKINTEGRITY  #
*CALL CHKMAT
      XDEF PROC CHKRET;            # SO NEXTGET CAN CALL IT            #
*CALL CHKRET
      CONTROL EJECT;
      PROC CLOSEAREA; 
#                                      #
#        C L O S E A R E A             #
#                                      #
# PROC TO CLOSE THE AREA, LOG FILE AND -DIS-FROM- FILES    #
      BEGIN 
                                                                         CTL40
      ITEM LOOPCON B; 
      ITEM BC I;                   # BASIC TABLE CODE                  #
      ITEM FINISHED B;             # LOOP CONTROL                      #
                                                                         CTL40
      IF INDEX EQ 1                # IF CALLED FROM CREINIT            #
      THEN
        BEGIN 
        P<AREA$TABLE> = AREATBLPTR; 
        P<AREA$TABLE> = AT$FORWARD;  #CREATED FILE IS 2ND ENTRY IN LIST#
        ATPTR = P<AREA$TABLE>;     # KEEP TRACK OF AREA$TABLE POSN     #
        P<FIT> = LOC(AT$AFITPOS);  # POSITION TO AREA FIT              #
        IF FITOC EQ 1              # FILE IS OPEN                      #
          AND NOT AT$DBPSRH        # AND NO ON"SEARCH" EXIT            #
        THEN
          BEGIN 
          CALLOWN(ON"CLOSE", RC);  # TRY CALLING *CLOSE* DBP           #
          CLOSEM(FIT, $DET$, RA0); # CLOSE FILE, RELEASE BUFFERS       #
          IF FITES NQ 0            # IF AN ERROR ON CLOSING            #
          THEN
            BEGIN 
            DIAG(903, FITES, FIT); # DIAGNOSE CRM ERROR                #
            FITES = 0;             # RESET FIT ERROR FIELD             #
            END 
          END 
        IF AT$DBPOC                # IF ON"OPEN" HAS BEEN CALLED       #
          AND AT$DBPSRH            # AND ON"SEARCH" EXIT PROVIDED      #
        THEN
          BEGIN 
          CALLOWN(ON"CLOSE", RC);  # CALL *CLOSE* DBP                  #
          AT$DBPOC = FALSE;        # AND FLAG IT                       #
          END 
        END 
      IF REFERFILE NQ 0 THEN                     # AREA FILE(S) USED.  #
        BEGIN                                    # THIS LOOP CLOSES AND#
        LOOPCON = TRUE;                          # RETURNS AREA FILES  #
                                                 # WHICH ARE OPEN.     #
        FOR DUMMY = 1 STEP 1 WHILE LOOPCON DO 
          BEGIN 
            IF AREAINUSE[DUMMY] THEN             # THIS AREA IS IN USE.#
              BEGIN 
              P<AREA$TABLE> = AREASAVE[DUMMY];   # SET UP BASED ARRAYS #
              ATPTR = P<AREA$TABLE>; # KEEP TRACK OF AREA$TABLE POSN   #
              P<AREAFIT> = LOC(AT$AFITPOS[0]);   # FROM TABLE ADDRESS  #
              P<FIT> = P<AREAFIT>; # WHICH WAS SAVED                   # CTL40
                                                                         CTL40
              IF FITOC EQ 1        # FILE IS OPEN                      #
                AND NOT AT$DBPSRH  # AND NO ON"SEARCH" EXIT            #
              THEN
                BEGIN 
                CALLOWN(ON"CLOSE", RC);  # TRY CALLING *CLOSE* DBP     #
                CLOSEM(FIT, $DET$, RA0);  # CLOSE FILE, RELEASE BUFFERS#
                IF FITES NQ 0      # IF AN ERROR ON CLOSING            #
                THEN
                  BEGIN 
                  DIAG(903, FITES, FIT);  # DIAGNOSE CRM ERROR         #
                  FITES = 0;       # RESET FIT ERROR FIELD             #
                  END 
                IF NOT AT$TEMPA 
                  AND FITFO EQ FOSQ 
                  AND USEDIR       # MAKE SURE THIS WAS A -USE-        #
                THEN
                  BEGIN            # SEQUENTIAL FILE HAS BEEN WRITTEN  #
                                   # ON, SO EXTEND FILE.               #
                  P<FDBAREA> = LOC(AT$AFDBPOS[0]);
                  EXTEND(FDBAREA, RC);
                  IF RC NQ 0       # DIAGNOSE ANY ERROR                #
                  THEN
                    BEGIN 
                    PFDIAG(FDBAREA, RC);
                    FITES = 0;
                    END 
                  END 
                END 
              IF AT$DBPOC          # IF ON"OPEN" HAS BEEN CALLED       #
                AND AT$DBPSRH      # AND ON"SEARCH" EXIT PROVIDED      #
              THEN
                BEGIN 
                CALLOWN(ON"CLOSE", RC);  #CALL *CLOSE* DBP             #
                AT$DBPOC = FALSE;  # AND FLAG IT                       #
                END 
          IF NOT AT$TEMPA[0] AND USEDIR THEN  # RETURN NON-TEMPORARY   #
            BEGIN                                # FILES.              #
            RETURNM(FIT, RA0);                                           CTL40
            IF AT$INDFDB[0] NQ 0 THEN            # IF THERE IS AN INDEX#
              BEGIN                              # FILE, RETURN IT.    #
              RETURNM(C<0,7>FITXN, RA0);                                 CTL40
              END 
            END 
           END
  
          IF AREASAVE[DUMMY + 1] EQ 0 THEN       # NO MORE AREAS TO    #
            BEGIN                                # CLOSE AND RETURN.   #
            LOOPCON = FALSE;                     # EXIT LOOP.          #
            TEST DUMMY; 
            END 
          END                                    # END OF -DUMMY- LOOP.#
        END 
      IF P<FDBLOG> NQ 0 THEN       # IF THERE IS AN ATTACHED LOGFILE   #
        BEGIN 
        LOG (RQTYPE"CLOSE", RC);   # TRY TO LOG A CLOSE                #
        LOG (RQTYPE"TERMINATE", RC);  # TERMINATE LOGGING ON THIS AREA #
        RETURNM (LOGLFN, RA0);     # RETURN THE LOGFILE                #
        P<FDBLOG> = 0;             # NO ATTACHED LOGFILE, ZERO THE PTR #
        END 
        IF FROMKEYINFIT NQ 0       # IF *FROM* OR *KEY IN* FILE        #
        THEN
          BEGIN 
          P<FIT> = FROMKEYINFIT;
                                                                         CTL40
          CLOSEFILE;
          END                                                            CTL40
      IF BASTABLOC EQ 0            # IF CM ALREADY RELEASED            #
      THEN
        BEGIN 
        RETURN; 
        END 
      P<BASICTABLE> = BASTABLOC;
      BASTABIND = -1; 
      FINISHED = FALSE; 
      FOR DUMMY = DUMMY 
        WHILE NOT FINISHED
      DO
        BEGIN 
        BASTABIND = BASTABIND + 1;
        BC = BASCODE[BASTABIND];
        IF BC EQ ENDCODE           # IF END OF BASIC TABLE             #
        THEN
          BEGIN 
          FINISHED = TRUE;         # EXIT LOOP                         #
          TEST DUMMY; 
          END 
        IF BC EQ CONTCODE          # IF END OF BLOCK                   #
        THEN
          BEGIN 
          P<BASICTABLE> = BASCLAST[BASTABIND];  # LINK TO NEXT BLOCK   #
          BASTABIND = -1; 
          TEST DUMMY;              # LOOP BACK FOR NEXT BLOCK          #
          END 
        IF BASCUPON[BASTABIND]     # IF *UPON* FILE                    #
        THEN
          BEGIN 
          P<FIT> = BASFITUPON[BASTABIND];  # POSITION TO *UPON* FIT    #
          CLOSEFILE;
          END 
        END 
      END 
  
                                                                        003520
CONTROL EJECT;
*CALL CLOSEFILE 
      CONTROL EJECT;
      PROC DELETEM; 
#                                      #
#        D E L E T E M                 #
#                                      #
# PROC TO DO THE CONTROL PORTION OF A DELETE DIRECTIVE     #
      BEGIN 
      DELTIO;                                                            CTL40
      RETURN; 
      END 
      CONTROL EJECT;
      PROC DELUSI;
#                                      #
#        D E L U S I                   #
#                                      #
# THIS PROC PROCESSES -DELETE-USING- DIRECTIVE #
      BEGIN 
                                                                         CTL40
      IF DIAGNO NQ 0 THEN RETURN; 
      DIAGFLU;                     # FLUSH MSG FOR ACCUMULATED DIAGS   #
      OLDDIAGLEV = DIAGLEV;        # SAVE PREV. DIAG OPTION            #
      DIAGLEV = 1;                 # FORCE *DIAG,FULL*.                #
      FOR RC = 0 WHILE RC NQ 1 DO 
        BEGIN 
        USINGEX(USINGGETKEY, RC);                                        CTL40
                                                                         CTL40
        IF RC EQ 0                                                       CTL40
        THEN                                                             CTL40
          BEGIN                                                          CTL40
          REPTALTKEY = FALSE;                                            CHANGES
          GETIO;                                                         CTL40
          REPTALTKEY = TRUE;                                             CHANGES
                                                                         CTL40
          IF ONALTERKEY                                                  CTL40
          THEN                                                           CTL40
            BEGIN                                                        CTL40
            P<FIT> = P<AREAFIT>;                                         CTL40
            RCDCOUNT = FITRC - 2;                                        CTL40
                                                                         CTL40
            IF DIAGNO EQ 0                                               CTL40
            THEN                                                         CTL40
              BEGIN                                                      CTL40
              DELTIO;                                                    CTL40
              END                                                        CTL40
                                                                         CTL40
            ELSE                                                         CTL40
              BEGIN                                                      CTL40
              TEST RC;                                                   CTL40
              END                                                        CTL40
                                                                         CTL40
            IF RCDCOUNT LS 0                                             CTL40
            THEN                                                         CTL40
              BEGIN                                                      CTL40
              TEST RC;                                                   CTL40
              END                                                        CTL40
                                                                         CTL40
            FOR SKIPCOUNT=0 STEP 1                                       CTL40
              UNTIL RCDCOUNT                                             CTL40
            DO                                                           CTL40
              BEGIN                                                      CTL40
              GETIO;                                                     CTL40
                                                                         CTL40
              IF DIAGNO NQ 0                                             CTL40
              THEN                                                       CTL40
                BEGIN                                                    CTL40
                TEST RC;                                                 CTL40
                END                                                      CTL40
                                                                         CTL40
              DELTIO;                                                    CTL40
              END                                                        CTL40
            END                                                          CTL40
                                                                         CTL40
          ELSE                                                           CTL40
            BEGIN                                                        CTL40
            IF DIAGNO EQ 0                                               CTL40
            THEN                                                         CTL40
              BEGIN                                                      CTL40
              DELTIO;                                                    CTL40
              IF FILEDKI           # IF FILE HAS DUPLICATE PRIMARY KEYS#
              THEN
                BEGIN 
                FOR DUMMY = 0 STEP 1
                  UNTIL LKEYWD - 1
                DO
                  BEGIN 
                  DKIKEYWD[DUMMY] = IKEY[DUMMY];  # SAVE VALUE OF PR KY#
                  END 
                GETDKI = TRUE;     # TELL GETIO TO GET DUPLICATES      #
                FOR DUMMY = DUMMY 
                  WHILE TRUE
                DO
                  BEGIN 
                  GETIO;           # READ NEXT DUPLICATE               #
                  IF DIAGNO NQ 0   # IF NO MORE DUPLICATES             #
                  THEN
                    BEGIN 
                    TEST RC;
                    END 
                  DELTIO;          # DELETE RECORD                     #
                  END 
                END 
              END                                                        CTL40
            END                                                          CTL40
          END 
        END 
      DIAGLEV = OLDDIAGLEV;        # RESET TO PREVIOUS DIAG OPTION     #
      KEYLIT = 1;                  # SET SO ACCESSES/HITS MSG APPEARS  #
      END  # DELUSI    #
      CONTROL EJECT;
      PROC DISPLAY (DISPLAYRC); 
#                                      #
#        D I S P L A Y                 #
#                                      #
#  THIS PROC PROCESSES THE DISPLAY DIRECTIVE. IT IS A LARGE KLUGE. #
      BEGIN 
                                                                         CTL40
      ITEM DISPLAYRC; 
      ARRAY CVTIN S(2); 
      ITEM CVCODE I(1,0,6), 
           CVFRADD I(0,24,18),
           CVTOADD I(0,42,18),
           CVLG U(0,12,12),        # LENGTH OF FIELD IN CHARACTERS     #
           CVW1 I(0,0,60),
           CVW2 I(1,0,60);
                                                                         CTL40
      ITEM DTPTEMP I;              # POINTER TO NEXT *DTABLE ENTRY     #
      ITEM SAVEUPLGCH   I;         # SAVE DISPLAY CHAR LENGTH          #
      ITEM UPLGCH  I;              # CHAR LENGTH OF DISPLAY - FOUND IN #
                                   # OVERFLOW WORD OF 1ST DTABLE BLOCK #
      ITEM UPLGSAVE I;             # SAVE MAX DISPLAY LENGTH           #
      BASED ARRAY LINE [0:0];      # LINE OF OUTPUT TO DISPLAY         #
        BEGIN 
        ITEM ALINE   C(0,0,10); 
        END 
  
      P<DTABLE> = BASCADDR[BASTABIND];
      DTP = EESIZE;                # BYPASS KEY ELEMENTARY ENTRY       #
      IFFROMFLAG = FALSE; 
      UPLGCH = SAVFSIZE[30];       # DISPLAY LENGTH IN CHARACTERS      #
      UPLG = (UPLGCH + 9) / 10;    # DISPLAY LENGTH IN WORDS           #
      UPLGSAVE = UPLG;             # MAY NEED TO RESET UPLG IF *KEY IN*#
                                   # AND *OCCURS DEP* BOTH SPECIFIED   #
      SAVEUPLGCH = UPLGCH;         # SAVE CHAR LENGTH FOR RESTORE      #
      UPLG = UPLG + 2;             # IN CASE THERE IS EDITING, TWO     #
                                   # MORE WORD IS NEEDED. THIS IS KLUGY#
                                   # BUT THERE WAS NO OBVIOUS SOLUTION.#
      IF BASCUPON[BASTABIND]       # IF DISPLAY UPON                   #
       THEN 
        BEGIN 
        P<FIT> = BASFITUPON[BASTABIND];  # POSITION TO *UPON* FIT      #
        P<LFNINFO> = P<FIT> - L$FITOFFSET;
  
        IF L$WSA EQ 0              # IF WSA NEVER ASSIGNED TO FILE     #
        THEN
          BEGIN 
          IF UPLGCH GR FITMRL      # SELECT THE MAX RL SET             #
          THEN
            BEGIN 
            FITMRL = UPLGCH;
            END 
          GETWSA (FIT);            # ALLOCATE A WSA  TO -UPON- FILE    #
          END 
  
        ELSE                       # IF WSA FOR FILE ALREADY EXISTS    #
          BEGIN 
          IF FITMRL LS UPLGCH      # IF WSA SMALLER THAN NEEDED        #
          THEN
            BEGIN 
            CMM$FRF (L$WSA);       # FREE OLD WSA                      #
            FITMRL = UPLGCH;       # SET MRL TO NEW, LARGER VALUE      #
            GETWSA (FIT);          # ALLOCATE NEW WSA                  #
            END 
          END 
  
        TORECORDLOC = FITWSA;      # USED FOR MOVE/CONVERT LOCN        #
        P<LINE> = FITWSA;          # USED FOR XFER TO FILE             #
  
                                                                         CTL40
        IF FITOC NQ 1              #OPEN FILE, IF NECESSARY.           # CTL40
        THEN                                                             CTL40
          BEGIN                                                          CTL40
          FITBBH = TRUE;           # ALLOCATE BUFFERS BELOW HHA        #
          OPENM (FIT, $IO$, $N$, RA0);                                  000240
          IF FITES NQ 0            #ERROR IN OPENING FILE.             # CTL40
          THEN                                                           CTL40
            BEGIN                                                        CTL40
            DIAG (819, FITES, FITLFNC);  # DIAGNOSE CRM ERROR ON OPEN  #
            RETURN; 
            END                    # END ERROR ON OPEN                 #
          END                      # END OPEN -UPON- FILE              #
        END                        # END IF -UPON-                     #
  
      ELSE                         # IF DISPLAY TO OUTPUT              #
        BEGIN 
        IF DATALOC EQ 0            # IF BUFFER NOT YET ALLOCATED       #
        THEN
          BEGIN 
          UPLGMAX = UPLG;          # SAVE BUFFER SIZE                  #
          DATALOC = CMM$ALF (UPLG, FIXED$LWA, 0); 
          END 
  
        ELSE                       # IF BUFFER ALREADY EXISTS          #
          BEGIN 
          IF UPLGMAX LS UPLG       # IF NEED LARGER BUFFER             #
          THEN
            BEGIN 
            CMM$FRF (DATALOC);     # FREE OLD, TOO-SMALL UFFER         #
            UPLGMAX = UPLG;        # SAVE NEW, LARGER BUFFER SIZE      #
            DATALOC = CMM$ALF (UPLG, FIXED$LWA, 0); 
            END 
          END 
  
        P<LINE> = DATALOC;         # POSN BASED ARRAY OVER OUTPUT LINE #
        END 
  
      UPLG = UPLG - 2;             # RESTORE ORIGINAL VALUE            #
  
      FOR M = 0 STEP 1             # INIT OUTPUT BUFFER TO BLANKS      #
        UNTIL UPLG - 1
      DO
        BEGIN 
        ALINE[M] = "          ";
        END 
  
        IF BASCKEY3[BASTABIND] THEN       # "KEY-IN" LFN SPECIFIED.    #
          BEGIN 
          P<FIT> = FROMKEYINFIT;   # POSITION TO *KEY IN* FIT          #
          IF FITMRL EQ O"2222"     # IF NO KNOWN MRL                   #
          THEN
            BEGIN 
            P<LFNINFO> = LOC(FIT) - L$FITOFFSET;
            CMM$FRF (L$WSA);       # FREE CM ASSIGNED BY -GETWSA-      #
            FITMRL = KT$PICLEN[1];  # ASSUME FILE CONTAINS KEY ONLY    #
            L$WSA = CMM$ALF((KT$PICLEN[1] + 9) / 10, 0, 0); 
            FITWSA = L$WSA; 
            END 
                  CVW1[0] = 0; CVW2[0]=0; 
          CVCODE[0] = KT$TYPE[1] + 1; 
          CVFRADD[0] = FITWSA;
          CVTOADD[0] = P<AREA$TABLE> + AT$CURRKEY[0]; 
          CVLG[0] = KT$PICLEN[1]; 
          IF KT$TYPE[1] NQ 7       # USE ATTRIBUTE EXCEPT FOR LOGICAL  #
          THEN                                                           QU3A094
                  BEGIN CVTOADD[0] = LOC(ATTRIB) - 1; 
            ATTRCLS[0] = KT$TYPE[1];
            ATTDPTLC[0] = KT$DPTLOC[1]; 
            ATTRWP[0] = P<AREA$TABLE> + AT$CURRKEY[0];
            ATTRBP[0] = 0;
            ATTRSIZE[0] = KT$LENGTH[1]; 
          END 
        CONTIN: # # 
           P<FIT> = FROMKEYINFIT;  # POSITION TO *KEY IN* FIT          #
           GET(FIT,RA0);
                                                                         CTL40
           IF FITFP EQ O"100"      #EOF OR EOI                         # CTL40
           THEN                                                          CTL40
             BEGIN
             DISPLAYRC = 1;    # SET EOF STATUS AND EXIT"  #
             RETURN;
             END
  
          IF FITES NQ 0            # IF A CRM ERROR OCCURED            #
          THEN
            BEGIN 
            DIAG(903,FITES,FITLFNC);  # DIAGNOSE CRM ERROR             #
            RETURN; 
            END 
                                                                         CTL40
           IF FITFP NQ O"20"                                             CTL40
           THEN                                                          CTL40
             BEGIN                                                       CTL40
             GOTO CONTIN;                                                CTL40
             END                                                         CTL40
                                                                         CTL40
            IOS = IOS + 1;         # INCREMENT NO. CRM ACCESSES FOR    #
                                   # DIAG 1006 MESSAGE                 #
            CONVERT(CVTIN,M); 
            IF M NQ 0 THEN
              BEGIN 
              DIAG(805);
              RETURN; 
              END 
            GETIO;
            IF DIAGNO NQ 0 THEN 
              BEGIN 
              IF DIAGNO EQ 816     # IF SOME CRM ERROR                 #
                AND FITES NQ UNKNOWNKEY  # IF NOT UNKNOWNKEY           #
                AND FITES NQ AKUNKNOWNKEY  # IF NOT UNKNOWN AK KEY     #
              THEN
                BEGIN 
                RETURN; 
                END 
              GOTO CONTIN;         #GET NEXT KEY                       #
              END 
            IF FILEDKI             # IF FILE HAS DUPLICATE PRIM KEYS   #
            THEN
              BEGIN 
              FOR DUMMY = 0 STEP 1
                UNTIL LKEYWD - 1
              DO
                BEGIN 
                DKIKEYWD[DUMMY] = IKEY[DUMMY];  # SAVE VALUE OF PR KEY #
                END 
              GETDKI = TRUE;       # TELL GETIO TO GET DUPLICATES      #
              END 
START1: 
            DTP = EESIZE;          #BYPASS KEY ELEMENTARY ENTRY        #
            P<DTABLE> = BASCADDR[BASTABIND];
      END 
   START: # # 
      IF CPENTRY[DTP] EQ 0 THEN 
          BEGIN                                                         001210
            EDTABL: # #                                                 001220
            IF BASCUPON[BASTABIND]  # IF *DISPLAY UPON*                #
            THEN
              BEGIN 
              P<FIT> = BASFITUPON[BASTABIND]; 
              PUT (FIT, LINE, UPLGCH, 0, 0, 0, RA0);
              IF FITES NQ 0        # IF ERROR OCCURED ON THE PUT....   # CHANGES
              THEN
                BEGIN 
                DIAG(903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR CODE  #
                END 
              END 
            ELSE
     BEGIN
      DIAGNO = 0; 
      CALLOWN(ON"DISPLAY", RC);    # TRY CALLING THE -DISPLAY- DBP     #
      IF RC EQ 1 THEN              # IF SHOULD NOT DISPLAY             #
        BEGIN 
        GOTO DLOOP; 
        END 
      WRITEBL (LINE, UPLGCH, M);
      IF M NQ 0 THEN
        BEGIN 
        DISPLAYRC = 1;
        RETURN; 
        END 
            END 
        IF (NOT FILEPASS           # IF HITS NOT ALREADY INCREMENTED   #
          AND KEYLIT NQ 0)
        THEN
          BEGIN 
          HITS = HITS + 1;         # INCREMENT NO OF HITS              #
          END 
 DLOOP:    # END OF DISPLAY UNLESS KEY IN SPECIFIED # 
          IF DTP GQ 29 THEN RETURN; 
          IF BASCKEY3[BASTABIND]   # IF *KEY IN*                       #
          THEN
            BEGIN 
            UPLG = UPLGSAVE;       # RESET UPLG IN CASE CHANGED BY     #
                                   # *ALL* SUBSCRIPT                   #
            UPLGCH = SAVEUPLGCH;   # RESTORE ORIGINAL CHAR LENGTH      #
            IF GETDKI              # IF READING DUPLICATES             #
            THEN
              BEGIN 
              GETIO;               # READ NEXT DUPLICATE               #
              IF DIAGNO EQ 0       # IF DUPLICATE READ                 #
              THEN
                BEGIN 
                GOTO START1;
                END 
              END 
            GOTO CONTIN;
            END 
            RETURN; 
      END 
      P<DTABLEPTR> = P<DTABLE> + DTP; 
   SWITCH DISTY DISMOV,DISMOV,DISCVT,DISEVA,DISSUB; 
      GOTO DISTY[CPTYPE[DTP]];
   DISMOV: # #
      MOVEC(DTABLEPTR); 
      GOTO NXT; 
   DISCVT: # #
      CONVERT(DTABLEPTR,M); 
      IF M EQ 51                   # IF INVALID CHARACTER IN NUM FIELD #
      THEN
        BEGIN 
        M = 217;                   # USE DIAG WITHOUT <C> OR <N>       #
        END 
  
      IF M NQ 0                    # IF CONVERT ERROR OCCURED          #
      THEN
        BEGIN 
        DIAG(M);                   # ISSUE DIAGNOSTIC                  #
        END 
  
      IF M NQ 0                    # IF AN ERROR OCCURED ON THE CONVERT#
        AND M NQ 360               # IF IT WAS NOT A ROUNDING ERROR    #
        AND M NQ 54                # IF IT WAS NOT A TRUNCATION ERROR  #
      THEN                         # THEN WE WILL NOT IGNORE THE ERROR #
        BEGIN 
        RETURN; 
        END 
      GOTO NXT; 
   DISEVA: # #
      LOGICALRESLT = FALSE; 
      PROGSTACKLOC = CPSTACK[DTP+1];
      EXPEVALUATE(RC);             # EVALUATE EXPRESSION               #
      GOTO DISCVT;
   DISSUB: # #
          P<INDTBL> = STACKADD[0];
          JJ = TBLGS[0] -1 ;                                            000730
          FOR KK = 0 STEP 1 UNTIL JJ DO                                 000740
           BEGIN IF ALLFG[KK] OR DEPNDFG[KK] THEN 
          BEGIN                                                         001330
                 LL=ADDRFROM[0];                                        001340
                 UPBUN(INDTBL,UB,LL,RC);                                001350
                      IF RC NQ 0 THEN                                   000780
                        BEGIN 
                        DIAG(RC);                                        CTL40
                        RETURN; 
                        END 
          IF ALLFG[KK] THEN 
                GOTO ALLFOUND;                                          000800
      JJ = JJ - 1;
                END                                                     000810
          END                                                           000820
          GOTO NOALL;                                                   000830
        ALLFOUND: # #                                                   000840
          P<INDTBL> = P<INDTBL> + KK;                                   000850
            JJ = TOCHAR[0]; 
            KK = TOADDRESS[0];
          LL=0; 
          IF NOT ITEMSIZE OR NOT BASCUPON[BASTABIND] THEN LL=1; 
            LL = CHARLENGTH[0]+LL;
            CONSUB[0] = TRUE; 
            ALLFG[0] = FALSE; 
            M = KK * 10 + JJ; 
            FOR PP = 1 STEP 1 UNTIL UB DO 
            BEGIN 
              INDCE[0] = PP;
              RC = M / 10;
              TOADDRESS[0] = RC;
              RC = M - RC * 10; 
              TOCHAR[0] = RC; 
              M = M + LL; 
              FIGSUB(DTABLEPTR,RC); 
              IF RC NQ 0 THEN GOTO RESETALL;
            END 
           RESETALL: # #
            CONSUB[0] = FALSE;
          ALLFG[0] = TRUE;
          INDCE[0] = 1; 
            TOADDRESS[0] = KK;
          M = RC; 
          TOCHAR[0] = JJ; 
          DTPTEMP = DTP+EESIZE;    # POINT TO NEXT DISPLAY ITEM        #
                                   # IF LAST ITEM IN DISPLAY TO OUTPUT,#
                                   # DONT DISPLAY PAST *DEP ON* COUNT  #
          IF NOT BASCUPON[BASTABIND]
            AND (CPENTRY[DTPTEMP] EQ 0
            OR (DTPTEMP GQ 29 AND OVERFLOW[30] EQ 0)) 
          THEN
            BEGIN 
            UPLG = UPLG-(UPBND[0]-UB)*LL/10;  # SUBTRACT UNUSED WORDS  #
                                              # FROM DISPLAY LENGTH    #
            UPLGCH = UPLG * 10;    # SET NEW CHAR LENGTH FOR WRITE     #
            END 
          GOTO CHKM;                                                    000870
        NOALL: # #                                                      000880
      FIGSUB(DTABLEPTR,M);
        CHKM: # #                                                       000900
      IF M EQ 51 THEN M = 217;
      IF M NQ 0 THEN
        BEGIN 
        DIAG(M);                                                         CTL40
        RETURN; 
        END 
   NXT: # # 
      DTP = DTP + EESIZE; 
      IF DTP LS 29 THEN GOTO START; 
      IF OVERFLOW[30] NQ 0 THEN 
      BEGIN P<DTABLE> = OVERFLOW[30]; 
      DTP = 0;
      GOTO START; 
      END 
            GOTO EDTABL;                                                001250
      END  # DISPLAY   #
      CONTROL EJECT;                                                     QY40154
*CALL EXTRACTM
*CALL GETWSA
      CONTROL EJECT;
*CALL IFM 
      CONTROL EJECT;
      PROC INSERTM; 
#                                      #
#        I N S E R T M                 #
#                                      #
# PROC TO DO THE MEAT OF -INSERT- DIRECTIVE    #
      BEGIN 
                                                                         CTL40
      P<FIT> = LOC(AT$AFITPOS);    #SET BY CALLER                      # CTL40
      BGIMAGE;                                                           CTL40
                                                                         CTL40
      IF FITFO NQ FOAK                                                   CTL40
        AND NOT AT$KEYEXCL         #MOVE KEY TO RECORD.                # CTL40
      THEN                                                               CTL40
        BEGIN 
        IF KT$TYPE[1] NQ 7         # IF NOT LOGICAL                    #
        THEN
          BEGIN 
            ATTDPTLC[0] = KT$DPTLOC[1];  # CHAR POSITION OF DECIMAL PT #
            ATTRWP[0] = KT$WPOS[1]; 
            CHARPOS = KT$CPOS[1] * 6;  # KEY BIT POSITION IN WORD      #
                                       # POINTED TO BY KT$WPOS         #
            ATTRBP[0] = CHARPOS;
          END 
        ELSE
          BEGIN 
          LOCNTO[0] = KT$WPOS[1]; 
          END 
        CTOCHAR[0] = CHARPOS; 
        TOLOCN[0] = LOC(FITWSA);                                         CTL40
        CONVERT(CONVPARAM, K);                                           CTL40
                                                                         CTL40
        IF K NQ 0 THEN
          BEGIN 
          DIAG(805);               #ERROR FROM KEY CONVERSION          # CTL40
          RETURN; 
          END 
        END 
      UPDVETO = BASCVETO[BASTABIND];
      UPDPASS = BASCPASS[BASTABIND];
      INSERTRCD = TRUE;            # FLAG THAT RECORD TO BE INSERTED   #
      KEYLIT = 1;                  # SET SO ACCESS/HIT/IO MSG IS ISSUED#
      RETURN; 
      END  #  INSERTM  #
      PROC INSUSI;
#                                      #
#        I N S U S I                   #
#                                      #
# THIS PROC PROCESSES THE -INSERT-USING- DIRECTIVE #
      BEGIN 
                                                                         CTL40
      P<FIT> =  LOC(AT$AFITPOS);                                         CTL40
      IF DIAGNO NQ 0 THEN RETURN; 
      DIAGFLU;                     # FLUSH MSG FOR ACCUMULATED DIAGS   #
      OLDDIAGLEV = DIAGLEV;        # SAVE PREV. DIAG OPTION            #
      DIAGLEV = 1;                 # FORCE *DIAG,FULL*.                #
      FOR RC = 0 WHILE RC NQ 1 DO 
        BEGIN 
        IF (FITFO NQ FOAK                                                CTL40
            AND FITFO NQ FOSQ)     #NEITHER AK NOR SQ                  # CTL40
          OR AT$SORTSEQ            #OR IF SORTED SEQUENTIAL            # CTL40
        THEN                                                             CTL40
          BEGIN 
          USINGEX(USINGGETKEY, RC);                                      CTL40
          IF RC NQ 0 THEN TEST; 
          END 
        BGIMAGE;                                                         CTL40
        USINGEX(USINGGETREC, RC);                                        CTL40
                                                                         CTL40
        IF RC EQ 0                                                       CTL40
        THEN                                                             CTL40
          BEGIN                                                          CTL40
          INSTIO;                                                        CTL40
          END                                                            CTL40
        END 
      DIAGLEV = OLDDIAGLEV;        # RESET TO PREVIOUS DIAG OPTION     #
      KEYLIT = 1;                  # SET SO ACCESSES/HITS MSG APPEARS  #
      END  # INSUSI    #
      CONTROL EJECT;
*CALL KEYLITM 
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     K E Y T O K A                                                    #
#                                                                      #
#     WHEN THE *MODIFY* DIRECTIVE CHANGES THE VALUE OF THE PRIMARY     #
#     KEY A *DELETE/INSERT* MUST BE USED INSTEAD OF A SIMPLE *UPDATE*. #
#     TO DO THIS THE VALUE IN THE KEY ARRAY MUST BE SWITCHED FROM OLD  #
#     TO NEW KEY (AND BACK AGAIN IF MODIFYING DUPLICATES).  *KEYTOKA*  #
#     DOES THIS BY MOVING THE KEY"S VALUE FROM THE *RECORD* (IN THE    #
#     *FITWSA*) TO THE *KEY* ARRAY.                                    #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC KEYTOKA; 
      BEGIN 
      CMOVE (RECORD, (KT$WPOS[1] * 10 + KT$CPOS[1]), KT$LENGTH[1],
             KEY, 0); 
      RETURN; 
      END                          # PROC *KEYTOKA*                    #
CONTROL EJECT;
      PROC LOG(TYPE, RC); 
#----------------------------------------------------------------------#
#                                                                      #
#     L O G                                                            #
#                                                                      #
# THIS PROC IS THE FRONT END TO THE CAPSULE *CAPLOG*.  ITS PURPOSE     #
# IS TO MAKE A QUICK CHECK BEFORE LOADING THE CAPSULE.  IN THIS WAY    #
# IT WILL NOT BE LOADED IN ALMOST ALL CASES WHERE IT IS NOT NEEDED.    #
#----------------------------------------------------------------------#
      BEGIN 
      ITEM TYPE I;                 # TYPE OF LOG ENTRY TO BE WRITTEN.  #
                                   # REFER TO STATUS LIST -RQTYPE- FOR #
                                   # A LIST OF VALUES.                 #
      ITEM RC I;                   # RETURN CODE - ZERO IF ALL WENT OK #
  
  
      RC = 0; 
      IF NOT USEDIR THEN           # IF THIS IS A CREATE, NOT A USE.   #
        BEGIN 
        RETURN; 
        END 
  
      IF TARGETAREA EQ 0           # NO AREA EXISTS                    #
      THEN                         # THEN THERE IS NO LOGGING          #
        BEGIN 
        RETURN; 
        END 
  
      P<AREA$TABLE> = TARGETAREA;  # POINT TO THE TARGET AREA TABLE.   #
      ATPTR = P<AREA$TABLE>;       # KEEP TRACK OF AREA$TABLE POSN     #
      IF AT$LOGFDB EQ 0 THEN       # IF NO LOGFILE FOR THIS AREA       #
        BEGIN 
        RETURN; 
        END 
  
      CAPLOG(TYPE,RC);             # CALL THE CAPSULE FOR LOGGING      #
      RETURN; 
      END 
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     M O D                                                            #
#                                                                      #
#     *MOD* IS CALLED FROM *MODUSI* TO PERFORM THE MODIFICATION        #
#     PROCESS FOR A RECORD WHICH HAS ALREADY BEEN ISOLATED BY *GETIO*. #
#     FIRST IT MODIFIES THE RECORD USING THE DATA FOR THE *SETTING*    #
#     LIST AND *MOVE* CLAUSE. THEN, IF THE PRIMARY KEY WAS CHANGED, IT #
#     REMOVES AND RE-INSERTS THE RECORD IN THE DATABASE.  OTHERWISE,   #
#     THE EXISTING RECORD IS JUST UPDATED BEFORE RETURNING TO *MODUSI*.#
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC MOD; 
      BEGIN 
      NEWDATA = TRUE;              #  FLAG NOT TO READ IN NEW DATA     #
      USINGEX (USINGGETREC, RC);   # CONV AND MOVE *SETTING* DATA TO   #
                                   # RECORD                            #
      IF RC NQ 0                   # IF CONVERSION ERROR               #
      THEN
        BEGIN 
        RETURN;                    # DON"T MODIFY THIS RECORD          #
        END 
  
      SMMOVE;                      # STORE *MOVE* DATA INTO RECORD     #
      VSKIP = FALSE;               # ASSUME VETO RESPONSE IS NO        #
      IF BASCMODKEY[BASTABIND]     # IF PRIMARY KEY WILL BE MODIFIED   #
      THEN
        BEGIN 
        INSTIO;                    # INSERT RECORD WITH NEW KEY        #
        IF VSKIP
          OR INSTFAIL 
        THEN
          BEGIN 
                                   # IF FAILED ON INSERT OR            #
          GOTO VEXIT;              # YES ON VETO, EXIT.                #
          END 
      DELTIO;                      # DELETE OLD RECORD                 #
        END 
  
      ELSE                         # IF PRIMARY KEY NOT CHANGED        #
        BEGIN 
        UPDIO;                     # SIMPLY UPDATE EXISTING RECORD     #
        END 
  
VEXIT:  
      RETURN;                      # RETURN TO *MODUSI*                #
      END                          # PROC *MOD*                        #
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     M O D I F Y M                                                    #
#                                                                      #
#     *MODIFYM* IS CALLED FROM *BASICLOOP* TO PROCESS A *MODIFY*       #
#     COMMAND WITH NO *USING* CLAUSE. IT IS ASSUMED THAT THE RECORD WAS#
#     SELECTED BY A PREVIOUS *IF*, OR ELSE ONLY TEMPORARY ITEMS ARE    #
#     BEING MODIFIED.  THE PROPER FLAG IS SET, INDICATING WHETHER TO   #
#     INSERT OR REWRITE THE RECORD, DEPENDING ON IF THE NEW KEY IS IN  #
#     THE DATABASE OR NOT.  THEN, IF *SETTING* WAS SPECIFIED, *USINGEX*#
#     IS CALLED ONCE TO READ AND STORE THE DATA VALUES.  *SMMOVE*      #
#     EXECUTES ANY *MOVE* PRESENT, AND THEN THE *PASS*/*VETO* OPTIONS  #
#     ARE SAVED BEFORE EXITING.                                        #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC MODIFYM; 
      BEGIN 
      IF BASCSET[BASTABIND]        # IF A SETTING LIST IS EXPECTED     #
      THEN
        BEGIN 
        RC = 2; 
        FOR DUMMY = DUMMY          # LOOP UNTIL VALID RESPONSE RECIEVED#
          WHILE RC EQ 2 
        DO
          BEGIN 
          USINGEX (USINGGETREC, RC);  # READ DATA AND MOVE CONVERTED   #
                                      # VALUES TO PROPER LOCATIONS.    #
          END 
        IF RC NQ 0                 # IF RESPONSE IS *END, EXIT.        #
        THEN
          BEGIN 
          RETURN; 
          END 
        END 
      SMMOVE;                      # EXECUTE MOVE CLAUSE IF PRESENT.   #
      IF NOT INSERTRCD             # IF THIS IS NOT A NEW RECORD       #
      THEN
        BEGIN 
        IF BASCMODKEY[BASTABIND]   # IF PRIMARY KEY WILL BE MODIFIED   #
        THEN
          BEGIN 
          VSKIP = FALSE;           # ASSUME VETO RESPONSE IS YES       #
          INSTIO;                  # INSERT RECORD WITH NEW KEY        #
  
          IF VSKIP                 # IF VETO RESPONSE SAID NO          #
            OR INSTFAIL            #  OR FAILED ON INSERT, EXIT.       #
          THEN
            BEGIN 
            RETURN; 
            END 
          DELTIO;                  # DELETE OLD RECORD                 #
          END 
        ELSE                       # IF PRIMARY KEY UNTOUCHED,         #
          BEGIN 
          IF NOT BASCTEMP[BASTABIND]   # IF AREA ITEMS REFERENCED      #
          THEN
            BEGIN 
            WRTRECD = TRUE;        # ORIGINAL RECORD WILL BE REWRITTEN #
            END 
          END 
        END 
  
      UPDVETO = BASCVETO[BASTABIND];   # SAVE *VETO* AND *PASS* STATUS #
      UPDPASS = BASCPASS[BASTABIND];
      RETURN;                      # RETURN TO *BASICLOOP*             #
      END                          # END *MODIFYM*                     #
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     M O D U S I                                                      #
#                                                                      #
#     *MODUSI* EXECUTES A *MODIFY* DIRECTIVE CONTAINING A *USI* CLAUSE.#
#     FOR EACH SET OF INPUT DATA IT MODIFIES THE RECORD(S) INDICATED   #
#     BY THE *USI* SEARCH KEY.  IF THE KEY IS A SIMPLE PRIMARY KEY ONLY#
#     ONE RECORD/KEY IS CHANGED, BUT MORE MAY BE CHANGED FOR ALTERNATE,#
#     DUPLICATE PRIMARY, OR MAJOR KEYS.  THE NUMBER OF RECORDS WITH    #
#     THE GIVEN ALTERNATE KEY VALUE IS CONTAINED IN *FITRC*, BUT FOR   #
#     DUPLICATE AND MAJOR KEY RETRIEVAL THE KEY VALUE MUST BE CHECKED  #
#     FOR EACH RECORD.  *MOD* IS THE ROUTINE CALLED TO DO THE BUSY     #
#     WORK OF THE UPDATE.                                              #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC MODUSI;
      BEGIN 
      IF DIAGNO NQ 0               # IF PREVIOUS ERROR,                #
      THEN
        BEGIN 
        RETURN;                    # EXIT IMMEDIATELY.                 #
        END 
      DIAGFLU;                     # FLUSH ACCUMULATED DIAGNOSTICS     #
      OLDDIAGLEV = DIAGLEV; 
      DIAGLEV = 1;                 # FORCE *DIAG FULL* FOR THIS PROC   #
  
      FOR RC = 0
        WHILE RC NQ 1              # LOOP UNTIL END OF DATA            #
      DO
        BEGIN 
        USINGEX (USINGGETKEY, RC); # READ DATA AND SAVE KEY            #
        IF RC NQ 0                 # IF ERROR OR END OF DATA           #
        THEN
          BEGIN 
          TEST RC;                 # LOOP AGAIN                        #
          END 
  
        REPTALTKEY = FALSE;        # FLAG TO GET ORIGINAL RECORD       #
        GETIO;                     # READ DATABASE RECORD              #
        REPTALTKEY = TRUE;         # FLAG TO GET ALTS OR DUPS          #
        IF DIAGNO NQ 0             # IF LEGAL RECORD NOT FOUND         #
        THEN
          BEGIN 
          TEST RC;                 # GO GET NEXT INPUT                 #
          END 
  
        IF ONALTERKEY              # IF SEARCH BY ALTERNATE KEY        #
        THEN
          BEGIN 
          P<FIT> = P<AREAFIT>;     # REPOSITION TO ITS *FIT*           #
          END 
  
        IF MKL NQ 0                # IF SEARCHING ON MAJOR KEY         #
          OR FILEDKI               # OR DUPLICATE PRIMARY KEY          #
        THEN
          BEGIN 
          IF MKL NQ 0              # IF ON MAJOR KEY                   #
          THEN
            BEGIN 
            LKEYWD = (MKL + 9) / 10;   # SET KEY LENGTH IN WORDS       #
            LKEYB = 6*MKL-60*(LKEYWD-1);   # NUM OF BITS IN LAST WORD  #
            IF P<DKIKEY> EQ 0      # IF NO SPACE ALLOC TO SAVE MAJ KEY #
            THEN
              BEGIN                # ALLOCATE IT                       #
              P<DKIKEY> = CMM$ALF (LKEYWD, 0, 0); 
              END 
            END 
          IF ONALTERKEY            # IF SEARCH BY ALTERNATE KEY        #
          THEN
            BEGIN 
            P<KEY> = ALKEYLOC;     # POSITION *IKEY* TO ALTERNATE VALUE#
            END 
          FOR DUMMY = 0 STEP 1     # LOOP THRU EACH WORD OF KEY        #
            UNTIL LKEYWD-1
          DO
            BEGIN 
            DKIKEYWD[DUMMY] = IKEY[DUMMY];   # SAVE ITS VALUE          #
            END 
          IF ONALTERKEY 
          THEN
            BEGIN 
            P<KEY> = P<AREA$TABLE> + AT$CURRKEY;   # REPOSITION TO PRIM#
            END 
          GETDKI = TRUE;           # NEXT TIME GET THE DUPLICATES      #
  
          FOR DUMMY = DUMMY        # LOOP UNTIL NEW KEY ENCOUNTERED    #
            WHILE DIAGNO EQ 0 
          DO
            BEGIN 
            MOD;                   # MAKE MODS TO RECORD IN DATABASE   #
            GETIO;                 # GET NEXT RECORD                   #
                                   # SINCE KEY ARRAY MAY HAVE BEEN     #
                                   # CHANGED BY *MOD*, MUST RESTORE IT #
                                   # TO ORIGINAL VALUE.                #
            IF NOT ONALTERKEY      # *GETIO* SAVES PRIMARY IF ALT KEY  #
            THEN
              BEGIN 
              KEYTOKA;             # BUT FOR PRIMARY KEY, NEED         #
                                   # *KEYTOKA* TO SAVE IT              #
              END 
            END                    # *DUMMY* LOOP                      #
          END                      # MAJ OR DUP PR KEY PROCESSING      #
  
        ELSE                       # IF ALTERNATE OR NON-DUP PRIMARY   #
          BEGIN 
          MOD;                     # MAKE MODS TO RECORD IN DATABASE   #
  
          IF ONALTERKEY            # IF ALTERNATE KEY                  #
          THEN
            BEGIN 
            FOR RCDCOUNT = FITRC-1 STEP -1
               UNTIL 1             # LOOP THRU EACH OCCURRENCE OF ALT  #
            DO
              BEGIN 
              GETIO;               # GET NEXT RECORD                   #
              IF DIAGNO NQ 0       # IF RECORD REJECTION OR ERROR      #
              THEN
                BEGIN 
                TEST RC;           # LOOP TO NEXT KEY                  #
                END 
              MOD;                 # MODIFY THIS RECORD                #
              END                  # *RCDCOUNT* LOOP                   #
            END                    # ALTERNATE KEY PROCESSING          #
  
          END                      # ALT OR NON-DUP PRIMARY            #
        END                        # *RC* LOOP                         #
      DIAGLEV = OLDDIAGLEV;        # RESTORE PREVIOUS DIAGNOSTIC LEVEL #
      KEYLIT = 1;                  # SO ACC/HITS MSG WILL BE DISPLAYED #
      RETURN;                      # RETURN TO *BASICLOOP*             #
      END                          # PROC *MODUSI*                     #
      CONTROL EJECT;
      PROC MOVEM; 
#                                      #
#        M O V E M                     #
#                                      #
# PROC TO DO THE CONTROL PORTION OF A -MOVE- DIRECTIVE #
      BEGIN 
      ITEM DIAGNOSED B = FALSE;    # TRUE IF HAVE ISSUED DIAGNOSTIC FOR#
                                   # MOVE NOT PRECEDED BY UPD/INS. THIS#
                                   # IS USED TO AVOID DIAG FOR EACH RCD#
      MOVEXE;                      #MAIN PROC TO DO MOVES              # CTL40
      IF TOAREA THEN
        BEGIN 
        IF NOT (UPDATERECORD       # IF NOT UPDATE                     #
          OR INSERTRCD)            # IF NOT INSERT                     #
        THEN
          BEGIN 
          IF NOT DIAGNOSED         # IF HAVENT DIAGNOSED MOVE TO AREA  #
                                   # ITEM NOT PRECEDED BY UPD/INS      #
          THEN
            BEGIN 
            DIAG(815);             # *UPD*/*INS* REQUIRED FOR REWRITE  #
            DIAGNOSED = TRUE;      # WE HAVE DIAGNOSED IT FOR THIS XMSN#
            END 
  
          END 
        IF UPDATERECORD            # IF UPDATE                         #
        THEN
          BEGIN 
          WRTRECD = TRUE;          # FLAG TO UPDATE RECORD             #
          END 
        END 
      RETURN; 
      END 
      CONTROL EJECT;
      PROC OPENAREA (RC); 
#                                      #
#        O P E N A R E A               #
#                                      #
# PROC TO OPEN THE AREA FILE(S).   #
      BEGIN 
                                                                         CTL40
      ITEM RC;
      ITEM LOOPCON B;                            # LOOP CONTROL.       #
      ITEM NUM I; 
      ITEM INDEX I;                # INDEX INTO SAVDAREA ARRAY.        #
                                                                         CTL40
      IF REFERFILE NQ 0 THEN                     # FILE ACCESS DIREC-  #
        BEGIN                                    # TIVE EXISTS. OPEN   #
        LOOPCON = TRUE;                          # AREAS IN -SAVEAREA-,#
                                                 # IF -AREAINUSE- IS   #
        FOR INDEX = 1 STEP 1 WHILE LOOPCON DO    # TRUE.               #
          BEGIN 
            I = $INPUT$;                                                 CTL40
            J = $R$;                                                     CTL40
            DBP$ACTION = 1;        # TELL DBP TO OPEN FILE FOR INPUT   #
            IF REFERFILE EQ O"77" THEN           # INPUT + OUTPUT ON   #
              BEGIN                              # THIS AREA. OPEN WITH#
              I = $IO$;            #PARAMETER SET TO I/O.              # CTL40
              DBP$ACTION = 3;      # TELL DBP TO OPEN FILE FOR I-O     #
              END 
            IF AREAINUSE[INDEX] THEN             # THIS AREA SHOULD BE #
              BEGIN                              # OPENED. GET ADDRESS #
                                                 # OF AREA TABLE FROM  #
            P<AREA$TABLE> = AREASAVE[INDEX];     # SAVEAREA AND GET FIT#
              ATPTR = P<AREA$TABLE>; # KEEP TRACK OF AREA$TABLE POSN   #
              P<AREAFIT> = LOC(AT$AFITPOS[0]);   # ADDRESS FROM AREA.  #
              P<KEY$TBL> = AT$PKEYDPTR;  # POSITION TO KEY DESC TABLE  #
              P<FIT> = P<AREAFIT>;                                       CTL40
              NUM = (FITMRL + 9)/10; #GET STORAGE AND WORKING SPACE    # CTL40
              FITWSA = CMM$ALF(NUM, 0, 0);                               CTL40
              IF FITFO EQ FOSQ     #SEQUENTIAL FILE--                  # CTL40
              THEN                                                       CTL40
                BEGIN                            # MAY HAVE TO EXTEND. #
                J = $E$;                                                 CTL40
                END 
              ELSE                 # IF -IS-, -DA-, OR -AK-            #
                BEGIN              # SET UP KEY FIELDS IN FIT          #
                FITRKW = KT$WPOS[1];
                IF FITFO EQ FOAK   # IF FILE ORGANIZATION IS ACTUAL KEY#
                THEN
                                   # MOVE ACTUAL KEY INFORMATION TO FIT#
                  BEGIN 
                  FITRKP = KT$ACTKEYPOS[1]; 
                  FITKP  = KT$ACTKEYPOS[1]; 
                  FITKL  = KT$ACTKEYLNG[1]; 
                  END 
                ELSE
                                   # MOVE KEY INFORMATION TO FIT       #
                  BEGIN 
                  FITRKP = KT$CPOS[1];
                  FITKL  = KT$LENGTH[1];
                  END 
                FITKA = AT$CURRKEY + P<AREA$TABLE>; 
                END 
  
              IF FITFO NQ FOSQ     # IF NOT A SEQUENTIAL FILE          #
              THEN                 # DETERMINE THE MRL FOR OURSELVES   #
                BEGIN 
                FITMRL = 0;        # LET CRM TELL US THE MRL           #
                END 
              FITBBH = TRUE;       # ALLOCATE BUFFERS BELOW HHA        #
  
              IF AT$DBPSRH         # IF AN ON "SEARCH" EXIT EXISTS     #
              THEN
                BEGIN 
                GOTO OWNOPEN;      # AVOID THE OPENM, SKIP TO DBP CALL #
                END 
              OPENM (FIT, I, J, RA0);                                   000260
                                                                         CTL40
              IF FITES EQ UPDATED  # FILE NOT CLOSED SINCE LAST UPDATE #
              THEN
                BEGIN 
                DIAG (822, FITLFNC);  # INFORM THAT ERROR OCCURRED     #
                IF AFPROCESSED     # USER CHOSE TO ACCEPT FILE         #
                THEN
                  BEGIN 
                  DIAG (1017);     # INFORM THAT FILE ACCEPTED         #
                  FITES = 0;       # OVERRIDE THE ERROR                #
                  END 
                ELSE
                  BEGIN 
                  IF NOT IPROCESSED #IF INTERACTIVE AND *AF* NOT CHOSEN#
                  THEN
                    BEGIN 
                    DIAG (1016);   # ASK IF SHOULD ACCEPT FILE         #
                    READ (AFANSWER, TEMP, 1, TEMP); 
                    IF AFANSWER EQ "Y"  # IF ANSWER IS YES             #
                    THEN
                      BEGIN 
                      FITES = 0;   # CLEAR THE ERROR                   #
                      END          # OTHERWISE WILL BE PROCESSED AS    #
                    END            # ANY OTHER ERROR                   #
                  END 
                END 
  
              IF FITFO NQ FOSQ     # IF FILE IS AK, DA, OR IS          #
              THEN
                BEGIN 
  
                IF ( FITFO NQ FOAK                 #  IF KL MISMATCH   #
                    AND FITKL NQ KT$LENGTH[1] ) 
                  OR ( FITFO EQ FOAK
                    AND FITKL NQ KT$ACTKEYLNG[1] )
                THEN
                  BEGIN 
                  DIAG(360,FITLFNC);          # DIAGNOSE MISMATCHED KL #
                  RC = 1;          #      RETURN TO CLOSE FILE         #
                  RETURN; 
                  END 
  
                END 
  
              IF FITES NQ 0        #ERROR OCCURRED--ISSUE DIAGNOSTIC   # CTL40
              THEN                                                       CTL40
                BEGIN                                                    CTL40
                IF FITES NQ UPDATED  # DIAG FOR 52B ALREADY GIVEN      #
                THEN
                  BEGIN 
                  DIAG (903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR    #
                  END 
                FITES = 0;         #ZERO OUT ERROR CODE                # CTL40
                RC = 1;            #SO -CLOSE- WILL NOT FAIL           # CTL40
                                                                         CTL40
                IF P<FDBLOG> NQ 0 THEN  # IF AN ATTACHED LOGFILE       #
                  BEGIN 
                  RETURNM (LOGLFN, RA0);  # RETURN ATTACHED LOGFILE    #
                  P<FDBLOG> = 0;   # NO LONGER HAVE AN ATTACHED LOGFILE#
                  END 
  
                RETURN; 
                END 
  
              IF (FITMRL + 9) / 10 GR NUM  # IF MRL EXCEEDS BUFFER     # QU3A353
              THEN
                BEGIN 
                CMM$FRF(FITWSA);   # RELEASE OLD WSA                   #
                NUM = (FITMRL + 9) / 10;
                FITWSA = CMM$ALF(NUM, 0, 0);  # ALLOCATE LARGER WSA    #
                END 
              IF AT$MRL NQ FITMRL  # IF MRL NOT EQUAL TO BUFFER        #
              THEN
                BEGIN 
                DIAG(358, FITLFNC);  # DIAGNOSE MISMATCH OF MRLS       #
                END 
  
OWNOPEN:                           # HERE TO SKIP TO DBP -OPEN- EXIT.  #
              IF BASCODE[1] EQ ENDCODE THEN  # IF A SINGLE DIRECTIVE   #
                BEGIN 
                IDIRCODE = DIRCODEVAL[BASCODE[0]];
                END 
  
              ELSE
                BEGIN 
                IDIRCODE = DCODE"OTHER";  # MULTIPLE DIRECTIVE TRANSM. #
                END 
  
              IF FITFO EQ FOSQ     # IF FILE IS SEQUENTIAL             #
              THEN
                BEGIN 
                FITKA = O"7777";   # SET FAKE FITKA TO TRICK DBP PARAM #
                                   # LIST.  A ZERO MEANS END OF LIST.  #
                END 
  
              CALLOWN (ON"OPEN", RC);  # TRY CALLING AN -OPEN- DBP     #
              IF AT$DBPSRH
              THEN
                BEGIN 
                AT$DBPOC = TRUE;   # FLAG AREA OPEN IF ON"SEARCH" EXIT #
                END 
  
              BGINIT;              # PREPARE BACKGROUND IMAGE          #
              IF AT$LOGB THEN      # IF MUST LOG BEFORE-IMAGES         #
                BEGIN 
                NUM = (FITMRL + 9)/10;  #NUMBER OF WHOLE WORDS FOR MRL # CTL40
                P<BIMAGE> = CMM$ALF (NUM, 0, 0);  # ALLOCATE BUFFER OF #
                                                 # SAME SIZE AS WSA.   #
                END 
  
              LOG (RQTYPE"OPEN", RC);  #  TRY TO LOG AN OPEN           #
              IF AT$DUPFIRST THEN  # IF *DUPLICATES ARE FIRST*         #
                BEGIN 
                DUPPOS = $P$;      # CRM POS FIELD FOR DUPLICATES ARE  #
                                   # FIRST. USED IN INSTIO.            #
                END 
              END 
  
          IF AREASAVE[INDEX + 1] EQ 0 THEN       # NO MORE AREAS. EXIT #
              BEGIN                              # LOOP.               #
              LOOPCON = FALSE;
              TEST INDEX; 
              END 
          END                                    # END OF -DUMMY- LOOP.#
        BITINDEX = -2;                           # INITIALIZE FOR USE  #
        END                                      # IN -NEXTGET-.       #
      RC = 0;                                    # GOOD RETURN.        #
      END                                        # END OF OPENAREAS.   #
*CALL PFDIAG
  
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     R E L C A L L O W N                                              #
#                                                                      #
# THIS PROC IS PROVIDED FOR COMPATIBLITY WITH *CTL30*.  WITHOUT THIS   #
# PROC COMMON DECKS *IFM* AND *CHKMAT* COULD NOT EXIST.                #
#----------------------------------------------------------------------#
      PROC RELCALLOWN(EXITYPE, DBPRC);
      BEGIN 
      ITEM EXITYPE S:ON;           # TYPE OF DBP EXIT TO TAKE          #
      ITEM DBPRC I;                # DBP EXIT RETURN CODE              #
  
      CALLOWN(EXITYPE, DBPRC);     # CALL USER OWNCODE ROUTINE         #
      RETURN; 
      END 
*CALL RELSPACE
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     R E M O V E M                                                    #
#                                                                      #
#     CALLED BY *BASICLOOP* AFTER THE RECORD SPECIFIED BY THE *REMOVE* #
#     COMMAND HAS BEEN SELECTED, *REMOVEM* CALLS *DELTIO* TO DELETE    #
#     THE RECORD FROM THE DATABASE.                                    #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC REMOVEM; 
      BEGIN 
      DELTIO;                      # PERFORMS THE CRM DELETE FUNCTION  #
      RETURN; 
      END                          # PROC *REMOVEM*                    #
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     R E M U S I                                                      #
#                                                                      #
#     *REMUSI* READS A KEY FROM THE *USING* INPUT FILE AND GETS THE    #
#     RECORD IT POINTS TO.  THAT RECORD IS DELETED ALONG WITH ANY      #
#     MORE WITH THE SAME ALTERNATE, DUPLICATE, OR MAJOR KEY, IF THAT   #
#     WAS WHAT *USING* SPECIFIED.  THIS PROCEDURE IS REPEATED FOR EACH #
#     VALUE READ FOR THE *USI* SEARCH KEY UNTIL *END OR EOF IS REACHED.#
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC REMUSI;
      BEGIN 
      IF DIAGNO NQ 0               # IF FORMER ERRORS OCCURRED,        #
      THEN
        BEGIN 
        RETURN;                    # EXIT IMMEDIATELY.                 #
        END 
      DIAGFLU;                     # FLUSH DIAGNOSTIC BUFFER.          #
      OLDDIAGLEV = DIAGLEV;        # SAVE CURRENT DIAGNOSTIC LEVEL,    #
      DIAGLEV = 1;                 # AND FORCE *DIAG FULL*.            #
  
      FOR RC = 0
        WHILE RC NQ 1              # LOOP TILL END OF DATA ENCOUNTERED.#
      DO
        BEGIN 
        USINGEX (USINGGETKEY, RC); # READ KEY AND SAVE IN KEY ARRAY    #
        IF RC NQ 0                 # IF END OF DATA OR ERROR           #
        THEN
          BEGIN 
          TEST RC;                 # EITHER READ MORE DATA OR QUIT.    #
          END 
  
        REPTALTKEY = FALSE;        # SAYS POSITION TO RECORD           #
        GETIO;                     # READ RECORD                       #
        REPTALTKEY = TRUE;         # SAYS READ NEXT RECORD SEQUENTIALLY#
        IF DIAGNO NQ 0             # IF ERROR OR RECORD REJECTED       #
        THEN
          BEGIN 
          TEST RC;                 # THEN LOOP TO NEXT RECORD          #
          END 
  
        IF ONALTERKEY              # IF SEARCH BY ALTERNATE KEY        #
        THEN
          BEGIN 
          P<FIT> = P<AREAFIT>;     # REPOSITION TO ITS *FIT*           #
          END 
  
        IF FILEDKI                 # IF DUPLICATE PRIMARY KEYS         #
          OR MKL NQ 0              # OR MAJOR KEY                      #
        THEN
          BEGIN 
          IF MKL NQ 0              # IF ON MAJOR KEY                   #
          THEN
           BEGIN
            LKEYWD = (MKL + 9) / 10;   # SET KEY LENGTH IN WORDS       #
            LKEYB = 6*MKL-60*(LKEYWD-1);   # NUM OF BITS IN LAST WORD  #
            IF P<DKIKEY> EQ 0      # IF NO SPACE ALLOC TO SAVE MAJ KEY #
            THEN
              BEGIN                # ALLOCATE IT                       #
              P<DKIKEY> = CMM$ALF (LKEYWD, 0, 0); 
              END 
            END 
          IF ONALTERKEY            # IF SEARCH BY ALTERNATE KEY        #
          THEN
            BEGIN 
            P<KEY> = ALKEYLOC;     # POSITION *IKEY* TO ALTERNATE VALUE#
            END 
          FOR DUMMY = 0 STEP 1     # LOOP THRU EACH WORD OF KEY        #
            UNTIL LKEYWD-1
          DO
            BEGIN 
            DKIKEYWD[DUMMY] = IKEY[DUMMY];   # SAVE ITS VALUE          #
            END 
          IF ONALTERKEY 
          THEN
            BEGIN 
            P<KEY> = P<AREA$TABLE> + AT$CURRKEY;   # REPOSITION TO PRIM#
            END 
          GETDKI = TRUE;           # NEXT TIME GET THE DUPLICATES      #
          FOR DUMMY = DUMMY        # LOOP UNTIL ENCOUNTER CHANGE OF KEY#
            WHILE DIAGNO EQ 0 
          DO
            BEGIN 
            DELTIO;                # DELETE THE RECORD                 #
            GETIO;                 # READ NEXT RECORD                  #
            END                    # *DUMMY* LOOP                      #
          END                      # DUPLICATE OR MAJOR KEY PROCESSING #
  
        ELSE                       # IF ALTERNATE OR NON-DUP PRIMARY   #
          BEGIN 
          DELTIO;                  # DELETE ITS RECORD                 #
  
          IF ONALTERKEY            # IF ALTERNATE KEY                  #
          THEN
            BEGIN 
            FOR RCDCOUNT = FITRC-1 STEP -1
              UNTIL 1              # LOOP FOR EACH OCCURRENCE OF ALT   #
            DO
              BEGIN 
              GETIO;               # GET NEXT RECORD                   #
              IF DIAGNO NQ 0       # IF RECORD REJECTION OR ERROR      #
              THEN
                BEGIN 
                TEST RC;           # GO BACK FOR NEXT KEY VALUE        #
                END 
              DELTIO;              # DELETE RECORD                     #
              END                  # *RCDCOUNT* LOOP                   #
            END                    # ALTERNATE KEY PROCESSING          #
  
          END                      # NON-DUP PRIMARY OR ALTERNATE      #
        END                        # *RC* LOOP                         #
      DIAGLEV = OLDDIAGLEV;        # RESTORE FORMER DIAGNOSTIC LEVEL   #
      KEYLIT = 1;                  # SO ACC/HITS MESSAGE APPEARS       #
      RETURN;                      # RETURN TO *BASICLOOP*             #
      END                          # PROC *REMUSI*                     #
      CONTROL EJECT;
*CALL SETDISFRO 
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     S M M O V E                                                      #
#                                                                      #
#     *SMMOVE* IS CALLED BY PROCS *STOREM*, *STORSET*, *MODIFYM*, AND  #
#     *MODUSI* TO SEE IF A *MOVE* CLAUSE EXISTS IN THE *STORE* OR      #
#     *MODIFY* DIRECTIVE.  IT CALLS *MOVEXE* TO PERFORM THE EXPRESSION #
#     ANALYSIS AND MOVE, AND THEN SETS THE APPROPRIATE FLAG TO INSERT  #
#     OR UPDATE THE RECORD DEPENDING UPON THE PARENT DIRECTIVE AND THE #
#     INTEGRITY OF THE KEY.                                            #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC SMMOVE;
      BEGIN 
      IF BASCMOVADDR[BASTABIND] NQ 0   # IF *MOVE* CLAUSE DOES EXIST   #
      THEN
        BEGIN 
        MOVEXE;                    # EVALUATE EXPR(S) AND MOVE INTO REC#
        END 
      RETURN; 
      END                          # PROC *SMMOVE*                     #
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     S T O R E M                                                      #
#                                                                      #
#     *STOREM* IS CALLED TO PROCESS A *STORE* WITH NO *SETTING* CLAUSE.#
#     THEREFORE, THE *MOVE* CLAUSE CONTAINS THE PRIMARY KEY.  FIRST,   #
#     IT CALLS *BGIMAGE* TO BLANK OUT THE RECORD AND THEN *SMMOVE* TO  #
#     EVALUATE AND MOVE ANY EXPRESSIONS.  FINALLY, A CALL TO *KEYTOKA* #
#     MOVES THE PRIMARY KEY FROM THE RECORD TO THE KEY LOCATION IN THE #
#     AREA TABLE BEFORE *STOREM* SETS SOME FLAGS AND RETURNS.          #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC STOREM;
      BEGIN 
      P<FIT> = LOC(AT$AFITPOS);    # POSITION TO *AFIT*                #
      BGIMAGE;                     # BLANK OUT RECORD                  #
      SMMOVE;                      # CONVERT AND MOVE VALUES INTO RECD #
      IF NOT AT$KEYEXCL            # KEY IS EMBEDDED                   #
      THEN
        BEGIN 
           P<RECORD> = FITWSA;     # RECORD IS IN FIT-S WSA            #
           P<KEY> = FITKA;         # POSITION TO MOVE KEY              #
           KEYTOKA;                # COPY KEY FROM RECORD TO KEY ARRAY #
        END 
      UPDVETO = BASCVETO[BASTABIND];   # SAVE *VETO* AND *PASS* STATUS #
      UPDPASS = BASCPASS[BASTABIND];
      INSERTRCD = TRUE;            # FLAG NEW RECORD TO BE STORED      #
      KEYLIT = 1;                  # SO ACC/HIT/IO MESSAGE WILL APPEAR #
      RETURN; 
      END                          # PROC *STOREM*                     #
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     S T O R S E T                                                    #
#                                                                      #
#     *STORSET* DOES THE ENTIRE STORING PROCESS IF THE *SETTING* CLAUSE#
#     IS GIVEN.  FOR EACH POTENTIAL RECORD IT CALLS *USINGEX* TO READ  #
#     A SET OF INPUT DATA.  IF THE RECORD PASSES INSPECTION, THE       #
#     RECORD IMAGE IS BLANKED OUT FOR IT BY *BGIMAGE* AND EVERYTHING   #
#     GIVEN IN THE *SETTING* AND *MOVE* LISTS IS CONVERTED AND MOVED   #
#     THERE BEFORE THE KEY"S VALUE IS SAVED BY *KEYTOKA* AND THE       #
#     RECORD IS STORED BY *INSTIO*.  THIS PROCESS IS REPEATED TILL ALL #
#     INPUT DATA HAS BEEN PROCESSED.                                   #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC STORSET; 
      BEGIN 
      IF DIAGNO NQ 0               # IF THIS RECORD TO BE IGNORED,     #
      THEN
        BEGIN 
        RETURN;                    # RETURN IMMEDIATELY.               #
        END 
      DIAGFLU;                     # FLUSH ACCUMULATED DIAGNOSTICS     #
      OLDDIAGLEV = DIAGLEV; 
      DIAGLEV = 1;                 # FORCE *DIAG FULL* DURING THIS PROC#
  
      P<FIT> = LOC (AT$AFITPOS);   # POSITION TO PROPER *FIT*          #
      P<RECORD> = FITWSA;          # RECORD IS IN WORKING STORAGE AREA #
      P<KEY> = P<AREA$TABLE> + AT$CURRKEY;   # POSITION OF CURRENT KEY #
  
      FOR RC = 0
        WHILE RC NQ 1              # REPEAT UNTIL END OF DATA REACHED  #
      DO
        BEGIN 
        IF (NOT BASCTEMP[BASTABIND]) AND
           (FITFO NQ FOAK)
        THEN
          BEGIN 
          USINGEX(USINGGETKEY, RC);# CONVERT AND MOVE KEY INTO KEY ARRY#
          IF RC NQ 0 THEN TEST; 
          END 
        BGIMAGE;                   # INITIALIZE EMPTY RECORD           #
        USINGEX (USINGGETREC, RC); # CONVERT AND MOVE DATA INTO RECORD #
        IF RC EQ 0                 # IF RECORD OK,                     #
        THEN
          BEGIN 
          SMMOVE;                  # PERFORM *MOVE* IF PRESENT         #
          IF NOT AT$KEYEXCL        # KEY IS EMBEDDED                   #
          THEN
            BEGIN 
            KEYTOKA;               # COPY KEY INTO KEY ARRAY           #
            END 
          INSTIO;                  # INSERT RECORD INTO DATABASE       #
          IF NOT INSTFAIL          # IF RECORD STORED OKAY AND A MOVE  #
            AND BASCMOVADDR[BASTABIND] NQ 0      #  WAS INVOLVED       #
          THEN
            BEGIN 
            HITS = HITS + 1;       # INCREMENT NUMBER OF HITS.         #
            END 
          END 
        END                        # *RC* LOOP END                     #
  
      DIAGLEV = OLDDIAGLEV;        # RESTORE ORIGINAL DIAGNOSTIC LEVEL #
      KEYLIT = 1;                  # SO ACC/HIT/IO MESSAGE WILL APPEAR #
      RETURN;                      # RETURN TO *BASICLOOP*             #
      END                          # PROC *STORSET*                    #
      CONTROL EJECT;
      PROC UPDATEM; 
#                                      #
#        U P D A T E M                 #
#                                      #
# PROC TO SET FALGS TO RE-WRITE THE RECORD IN CORE AFTER KEY OR    #
# MOVE PARAMETERS ARE PROCESSED # 
      BEGIN 
      IF NOT INSERTRCD             # IF RECORD NOT TO BE INSERTED      #
      THEN
        BEGIN 
      UPDATERECORD = TRUE;    # FLAG TO REWRITE RECORD LATER #
      END 
      UPDVETO = BASCVETO[BASTABIND];   # SAVE VETO STATUS FROM UPDATE#   QY40164
      UPDPASS = BASCPASS[BASTABIND];   # SAVE PASS STATUS FROM UPDATE#   QY40164
      RETURN; 
      END 
      PROC UPDUSI;
#                                      #
#        U P D U S I                   #
#                                      #
# THIS PROC PROCESSES THE -UPDATE-USING- DIRECTIVE #
      BEGIN 
                                                                         CTL40
      IF DIAGNO NQ 0 THEN RETURN; 
      DIAGFLU;                     # FLUSH MSG FOR ACCUMULATED DIAGS   #
      OLDDIAGLEV = DIAGLEV;        # SAVE PREV. DIAG OPTION            #
      DIAGLEV = 1;                 # FORCE *DIAG,FULL*.                #
      FOR RC = 0 WHILE RC NQ 1 DO 
        BEGIN 
        IF NOT BASCTEMP [BASTABIND] THEN
          BEGIN 
      REPTALTKEY = FALSE; 
          USINGEX(USINGGETKEY, RC);                                      CTL40
                                                                         CTL40
          IF RC EQ 0 THEN 
            BEGIN 
            GETIO;                                                       CTL40
                                                                         CTL40
            IF DIAGNO NQ 0 THEN TEST; 
            END 
ELSE TEST;
          END 
        USINGEX(USINGGETREC, RC);                                        CTL40
                                                                         CTL40
        IF BASCTEMP[BASTABIND]     # IF UPD USING TEMP                 #
        THEN
          BEGIN 
          IF RC EQ 2               # IF RESPONSE WAS IN ERROR          #
          THEN
            BEGIN 
            TEST RC;               # LOOP BACK FOR ANOTHER RESPONSE    #
            END 
          DIAGLEV = OLDDIAGLEV;    # RESET TO PREVIOUS DIAG OPTION     #
          RETURN; 
          END 
  
                                                                         CTL40
        REPTALTKEY = TRUE;                                               CTL40
                                                                         CTL40
        IF ONALTERKEY                                                    CTL40
        THEN                                                             CTL40
          BEGIN                                                          CTL40
          P<FIT> = P<AREAFIT>;                                           CTL40
          RCDCOUNT = FITRC - 2;                                          CTL40
          UPDIO;                                                         CTL40
                                                                         CTL40
          IF RCDCOUNT LS 0                                               CTL40
          THEN                                                           CTL40
            BEGIN                                                        CTL40
            TEST RC;                                                     CTL40
            END                                                          CTL40
                                                                         CTL40
          FOR SKIPCOUNT=0 STEP 1                                         CTL40
            UNTIL RCDCOUNT                                               CTL40
          DO                                                             CTL40
            BEGIN                                                        CTL40
            GETIO;                                                       CTL40
                                                                         CTL40
            IF DIAGNO NQ 0                                               CTL40
            THEN                                                         CTL40
              BEGIN                                                      CTL40
              TEST SKIPCOUNT;                                            CTL40
              END                                                        CTL40
                                                                         CTL40
            NEWDATA = TRUE;                                              CTL40
            USINGEX(USINGGETREC, RC);                                    CTL40
                                                                         CTL40
            IF RC NQ 0                                                   CTL40
            THEN                                                         CTL40
              BEGIN                                                      CTL40
              TEST SKIPCOUNT;                                            CTL40
              END                                                        CTL40
                                                                         CTL40
            UPDIO;                                                       CTL40
            END                                                          CTL40
          END                                                            CTL40
                                                                         CTL40
        ELSE                                                             CTL40
          BEGIN                                                          CTL40
          IF RC EQ 0                                                     CTL40
          THEN                                                           CTL40
            BEGIN                                                        CTL40
            UPDIO;                                                       CTL40
            IF FILEDKI             # IF FILE HAS DUPLICATE PRIMARY KEYS#
            THEN
              BEGIN 
              FOR DUMMY = 0 STEP 1
                UNTIL LKEYWD - 1
              DO
                BEGIN 
                DKIKEYWD[DUMMY] = IKEY[DUMMY];  # SAVE VALUE OF PR KEY #
                END 
              GETDKI = TRUE;       # TELL GETIO TO GET DUPLICATES      #
              FOR DUMMY = DUMMY 
                WHILE TRUE
              DO
                BEGIN 
                GETIO;             # READ NEXT DUPLICATE               #
                IF DIAGNO NQ 0     # IF NO MORE DUPLICATES             #
                THEN
                  BEGIN 
                  TEST RC;
                  END 
                NEWDATA = TRUE; 
                USINGEX(USINGGETREC, RC); 
                IF RC NQ 0
                THEN
                  BEGIN 
                  TEST DUMMY; 
                  END 
                UPDIO;             # UPDATE RECORD                     #
                END 
              END 
            END                                                          CTL40
          END                                                            CTL40
        END 
      DIAGLEV = OLDDIAGLEV;        # RESET TO PREVIOUS DIAG OPTION     #
      KEYLIT = 1;      # SO HITS/ACCESSES WILL BE DISPLAYED. #
      END  # UPDUSI  #
      CONTROL EJECT;
  
  
  
  
*CALL PVV 
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     G E T I O                                                        #
#                                                                      #
# THIS PROC IS CALLED TO DO THE ACTUAL -GET- NEEDED FOR MOST FUNCTIONS.#
      PROC GETIO; 
      BEGIN 
                                                                         CTL40
      ITEM REJ B;                  #TRUE IF DBP  SAYS IGNORE RECORD    #
                                                                         CTL40
        P<FIT> = P<AREAFIT>;                                             CTL40
        P<RECORD> = FITWSA;                                              CTL40
        P<KEY> = AT$CURRKEY + P<AREA$TABLE>;
        DIAGNO = 0; 
                                                                         CTL40
        IF ONALTERKEY                                                    CTL40
        THEN                                                             CTL40
          BEGIN                                                          CTL40
                                   # MOVE ALTERNATE KEY INFORMATION TO #
                                   # FIT                               #
          FITKP = 0;
          FITRKW = AKWOPOS;                                              CTL40
          FITRKP = AKCHPOS; 
          FITKL = AKLNGTH;                                               CTL40
          P<KEY> = ALKEYLOC;                                             CTL40
          FITKA = ALKEYLOC;        # MAKE SURE *IKEY* GETS RESET       #
                                                                         CTL40
          IF NOT REPTALTKEY                                              CTL40
          THEN                                                           CTL40
            BEGIN                                                        CTL40
            FITMKL = MKL;          # GET BY MAJOR KEY IF *FITMKL* IS   #
                                   # NON-ZERO                          #
            SAVEKT = FITKT;        # STORE ORIGINAL VALUE              #
            FITKT  = MKT;          # SET KEY TYPE                      #
  
            DBP$ACTION = 2;                  # DBP SHOULD DO *GET*     #
            CALLOWN(ON"SEARCH", DBPRC); 
            IF NOT DBP$DID                   # IF NO DBP WAS CALLED    #
            THEN
              BEGIN 
              GET(FIT, RECORD, KEY, 0, RA0); # DO CRM GET.             #
              END 
  
            FITKT = SAVEKT;        # RESTORE ORIGINAL VALUE            #
            END                                                          CTL40
                                                                         CTL40
          ELSE                                                           CTL40
            BEGIN                                                        CTL40
            DBP$ACTION = 3;                  # DBP SHOULD DO *GETN*    #
            CALLOWN(ON"SEARCH", DBPRC); 
            IF NOT DBP$DID                   # IF NO DBP WAS CALLED    #
            THEN
              BEGIN 
              GETN(FIT, RECORD, RA0);        # DO CRM GET.             #
              END 
  
            END                                                          CTL40
                                                                         CTL40
          IF FITES EQ 0            # IF NO CRM ERROR                   #
            AND FITFP EQ O"20"     # AND POSITIONED AT END OF RECORD   #
           OR (DBP$DID             # OR DBP WAS CALLED                 #
            AND DBPRC EQ 0)        #  AND EVERYTHING WAS OK.           #
          THEN
            BEGIN 
            IOS = IOS + 1;         # INCREMENT NO. RECORDS READ FOR    #
                                   # DIAG 1006 MESSAGE                 #
            END 
          IF GETDKI                # IF GETTING DUPLICATE MAJOR KEYS   #
          THEN
            BEGIN 
            IF FITFP EQ O"100"     # AND NO MORE RECORDS LEFT          #
              OR (DBPRC EQ 1
                AND FITES EQ 0) 
            THEN
              BEGIN 
              DIAGNO = 1;          # END OF DUPLICATE MAJOR KEYS       #
              GETDKI = FALSE; 
              RETURN; 
              END 
            FOR DUMMY = 0 STEP 1
              UNTIL LKEYWD-2       # LOOP THRU EACH FULL WORD OF KEY   #
            DO
              BEGIN 
              IF DKIKEYWD[DUMMY] NQ IKEY[DUMMY] 
              THEN                 # IF THIS KEY DIFFERENT THAN FIRST  #
                BEGIN 
                DIAGNO = 1;        # END OF DUPLICATE MAJOR KEYS       #
                GETDKI = FALSE; 
                RETURN; 
                END 
              END 
            IF B<0,LKEYB>DKIKEYWD[LKEYWD-1] NQ B<0,LKEYB>IKEY[LKEYWD-1] 
            THEN                   # ALSO CHECK LAST PARTIAL WD OF KEY #
              BEGIN 
              DIAGNO = 1; 
              GETDKI = FALSE;      # END OF DUPLICATE MAJOR KEYS       #
              RETURN; 
              END 
            END 
          P<KEY> = AT$CURRKEY + P<AREA$TABLE>;                           CTL40
          END                                                            CTL40
                                                                         CTL40
        ELSE                                                             CTL40
          BEGIN                                                          CTL40
          IF GETDKI                # IF GET NEXT DUPLICATE             #
          THEN
            BEGIN 
            DBP$ACTION = 3;                  # DBP SHOULD DO *GETN*    #
            CALLOWN(ON"SEARCH", DBPRC); 
            IF NOT DBP$DID                   # IF NO DBP WAS CALLED    #
            THEN
              BEGIN 
              GETN(FIT, RA0);                # DO CRM GET.             #
              END 
  
            IF FITFP EQ O"100"
              OR (DBPRC EQ 1
                AND FITES EQ 0) 
            THEN
              BEGIN 
              GETDKI = FALSE;      # NO MORE DUPLICATES                #
              DIAGNO = 1; 
              RETURN; 
              END 
            IF FITES EQ 0 
            THEN
              BEGIN 
              IOS = IOS + 1;       # INCREMENT NO. CRM ACCESSES FOR    #
                                   # DIAG 1006 MESSAGE                 #
              FOR DUMMY = 0 STEP 1
                UNTIL LKEYWD-2     # LOOP THRU EACH FULL WORD OF KEY   #
              DO
                BEGIN 
                IF DKIKEYWD[DUMMY] NQ IKEY[DUMMY] 
                THEN               # IF THIS KEY DIFFERENT THAN FIRST  #
                  BEGIN 
                  DIAGNO = 1;      # END OF DUPLICATE MAJOR KEYS       #
                  GETDKI = FALSE; 
                  RETURN; 
                  END 
                END 
              IF B<0,LKEYB>DKIKEYWD[LKEYWD-1] NQ
                B<0,LKEYB>IKEY[LKEYWD-1]
                                   # IF THIS KEY DIFFERENT THAN FIRST  #
                THEN
                  BEGIN 
                  DIAGNO = 1; 
                  GETDKI = FALSE; 
                  RETURN; 
                  END 
              END 
            END 
          ELSE
            BEGIN 
            FITMKL = MKL;          # GET BY MAJ KEY IF *FITMKL* NON-ZER#
            SAVEKT = FITKT;        # STORE ORIGINAL VALUE              #
            FITKT  = MKT;          # SET KEY TYPE                      #
            DBP$ACTION = 2;                  # DBP SHOULD DO *GET*     #
            CALLOWN(ON"SEARCH", DBPRC); 
            IF NOT DBP$DID                   # IF NO DBP WAS CALLED    #
            THEN
              BEGIN 
              GET(FIT, RA0);                 # DO CRM GET.             #
              END 
  
            FITKT = SAVEKT;        # RESTORE ORIGINAL VALUE            #
            IF FITES EQ 0          # IF NO CRM ERROR                   #
              AND FITFP EQ O"20"   # AND POSITIONED AT END OF RECORD   #
               OR (DBP$DID         # OR DBP WAS CALLED                 #
                AND DBPRC EQ 0)    #  AND EVERYTHING WAS OK            #
            THEN
              BEGIN 
              IOS = IOS + 1;       # INCREMENT NO. CRM ACCESS FOR      #
                                   # DIAG 1006 MESSAGE                 #
              END 
            END 
          END                                                            CTL40
                                                                         CTL40
        IF FITES NQ 0                                                    CTL40
        THEN                                                             CTL40
          BEGIN                                                          CTL40
          GETDKI = FALSE;          # NO MORE DUPLICATES                #
          IF BASCFROM[BASTABIND]   # IF UPDATE/DELETE FROM USING       #
          THEN
            BEGIN 
            FROMERR(RC);           # PRINT CARD IMAGE IN ERROR         # QU3A335
            END 
          DIAGNO = 816;                                                  CTL40
          RC = DIAGNO;                                                   CTL40
                                                                         CTL40
          IF FITES EQ UNKNOWNKEY                                         CTL40
          THEN                                                           CTL40
            BEGIN                                                        CTL40
            DIAG(816);                                                   CTL40
            END                                                          CTL40
                                                                         CTL40
          ELSE                                                           CTL40
            BEGIN                                                        CTL40
            IF NOT DBP$DID         # IF ERROR NOT COMING FROM DBP      #
            THEN
              BEGIN 
              DIAG(903, FITES, FITLFNC);  # THEN GIVE CRM ERROR.       #
              END 
            END                                                          CTL40
                                                                         CTL40
          RETURN;                                                        CTL40
          END                                                            CTL40
                                                                         CTL40
        CHKRET(REJ);               # CHECK *ON RETRIEVAL* PROCEDURE    #
        IF REJ                     # IF DBP SAID IGNORE THE RECORD     #
        THEN
          BEGIN 
          DIAGNO = 1;              # NO RECORD READ                    #
          RETURN; 
          END 
  
        IF FITRT GQ RTR            # IF VARIABLE LENGTH RECORD         #
          AND FITRT LQ RTT
        THEN
          BEGIN 
          BGFILL;                  # PAD RECORD WITH BG IMAGE          #
          END 
        BEFIMAGE (RECORD);         # SAVE THE BEFORE IMAGE OF RECORD   #
        CHKMAT(REJ);                                                     CTL40
        IF REJ THEN                #IF DBP  SAID IGNORE RECORD         #
          BEGIN 
          DIAGNO = 1;              #IGNORE RECORD                      #
          RETURN; 
          END 
      ACCESSES = ACCESSES + 1;     # INCR. NO. ACCESSES FOR DIAG 1006  #
      IF ONALTERKEY THEN
BEGIN 
        CMOVE(RECORD, ((KT$WPOS[1] * 10) + KT$CPOS[1]), KT$LENGTH[1], 
               KEY, 0); 
          FITKA = P<KEY>;                                                CTL40
          FITRKW = KT$WPOS[1];     # INDICATE PRIMARY KEY              #
          IF FITFO EQ FOAK         # IF FILE ORGANIZATION IS ACTUAL KEY#
          THEN
                                   # MOVE ACTUAL KEY INFORMATION TO FIT#
            BEGIN 
            FITRKP = KT$ACTKEYPOS[1]; 
            FITKP  = KT$ACTKEYPOS[1]; 
            FITKL  = KT$ACTKEYLNG[1]; 
            END 
          ELSE
                                   # MOVE KEY INFORMATION TO FIT       #
            BEGIN 
            FITRKP = KT$CPOS[1];
            FITKL  = KT$LENGTH[1];
            END 
END 
      RETURN; 
 END
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     C H K U P D                                                      #
#                                                                      #
# THIS PROC IS CALLED TO INITIATE DATABASE PROCEDURES FOR ANY FORM OF  #
# UPDATE TO THE AREA FILE.                                             #
      PROC CHKUPD;
      BEGIN 
      CALLOWN(ON"UPDATE", DIAGNO);  # TRY CALLING THE -UPDATE- DBP     #
      IF DBP$DID                   # IF DBP WAS CALLED                 #
      THEN
        BEGIN 
        IOS = IOS + 1;             #   INCREMENT NUMBER OF I-O COUNTER #
        P<KEY> = P<AREA$TABLE> + AT$CURRKEY;  # REPOSITION KEY ARRAY   #
                                              # IN CASE CHANGED FOR BY #
                                              # DBP FOR ALTERNATE KEYS #
  
        IF DIAGNO EQ 1             # IF RECORD IS TO BE IGNORED        #
        THEN
          BEGIN 
          DIAG(920);               # DISPLAY RECORD IGNORED MESSAGE    #
  
          IF BASCFROM[BASTABIND]   # IF FROM ... USING ...             #
          THEN
            BEGIN 
            FROMERR(RC);           # PRINT CARD IMAGE IN ERROR         #
            END 
  
          IF FITES NQ 0 
          THEN
            BEGIN 
            IF FITES EQ UNKNOWNKEY # IF -UNKNOWN KEY- ERROR            #
            THEN
              BEGIN 
              DIAG (802);          # UNKNOWN KEY ON DELETE             #
              END 
            ELSE
              BEGIN 
              IF FITES EQ DUPLICATEKEY
              THEN
                BEGIN 
                DIAG (800);        # DIAGNOSE DUP PRIMARY KEY ERROR    #
                END 
              ELSE
                BEGIN 
                IF FITES EQ DUPALTKEY 
                THEN
                  BEGIN 
                  DIAG (347);      # DUPLICATE ALTERNATE KEY ON INSERT #
                  END 
                END 
              END 
            END 
          END 
        END 
      RETURN; 
      END 
  
  
  
  
  
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     D E L T I O                                                      #
#                                                                      #
# THIS PROC IS CALLED TO DO THE DELETE OF THE RECORD. IT SPECIFIES A   #
# "C" IN THE *POS* PARAMETER SO A DELETE OF A DUPLICATE KEY RECORD     #
# WILL OCCUR AT THE CURRENT POSITION. THE ON"UPDATE" DBP IS CALLED     #
# BEFORE THE DELETE TAKES PLACE (PROC CHKUPD DOES IT). *DIAGNO* IS THE #
# RETURN CODE FROM THE DBP WHICH, IF ZERO, MEANS DELETION SHOULD BE    #
# ALLOWED.                                                             #
# HOWEVER, IF AN ON"SEARCH" EXIT EXISTS FOR THIS AREA, THE USER HAS    #
# INDICATED THAT DBP-S WILL TAKE CARE OF ALL I/O. THUS, THE ON"UPDATE" #
# DBP HAS ALREADY TAKEN CARE OF THE WORK. IF THERE IS NO ON"UPDATE"    #
# EXIT, A DIAGNOSTIC INFORMS THE USER OF THE MISSING DBP, AN QU        #
# TERMINATES THE TRANSMISSION.                                         #
# REGARDLESS OF WHO DELETES, LOGGING TAKES PLACE IF THE DBP SAID       #
# DELETION WAS ALLOWED (IF DIAGNO EQ 0 -- THIS IS ALSO THE DEFAULT     #
# RETURN CODE IF THERE WAS NO ON"UPDATE" DBP). THE HITS COUNTER IS     #
# LIKEWISE UPDATED.                                                    #
  
      PROC DELTIO;
      BEGIN 
                                                                         CTL40
      IF NOT BASCMODKEY[BASTABIND] # IF MODIFYING ON PRIMARY KEY,      #
                                   # NO NEED TO CHECK VETO AGAIN,      #
                                   # BECAUSE INSTIO ALREADY DONE SO.   #
        AND PVV                    # ELSE IF VETO RESPONSE IS YES, EXIT#
      THEN
        BEGIN 
        RETURN; 
        END 
  
      P<KEY> = P<AREA$TABLE> + AT$CURRKEY;  # POSITION OF CURRENT KEY  #
      P<FIT> = LOC(AT$AFITPOS);                                          CTL40
      P<RECORD> = FITWSA;          #RECORD IS IN WORKING STORAGE AREA  # CTL40
      IF AKEY                      # IF DELETE BY ALTERNATE KEY        #
      THEN
        BEGIN 
       P<KEY> = FITKA;             # KEY FOR DELETE IS FROM FITKA      #
       END
  
      DBP$ACTION = 2;              # TELL DBP TO DELETE ON UPDATE      #
      CHKUPD;                      # ASK DBP IF OK TO DELETE           #
      IF DIAGNO EQ 0 THEN          # IF OK TO DELETE                   #
        BEGIN 
        IF AT$DBPSRH THEN          # IF QU SHOULD NOT DO ANY I/O       #
          BEGIN 
          IF NOT AT$DBPUPD THEN    # IF NO ON"UPDATE" DBP TO DO THE I/O#
            BEGIN 
            DIAG (348);            # MISSING ON"UPDATE" EXIT.          #
            CLEANUP;               # CLEANUP FROM THIS TRANSMISSION    #
            EXITCTL;               # EXIT THIS OVERLAY                 #
            END 
          END 
  
        ELSE
          BEGIN 
          DLTE (FIT, KEY, FITKP, $C$, RA0);  # DELETE AT CURRENT POS.  #
          IOS = IOS + 1;           # INCR. NO. IO-S FOR DIAG 1006 MSG  #
          P<KEY> = P<AREA$TABLE> + AT$CURRKEY;  # REPOSITION KEY ARRAY #
                                                # IN CASE CHANGED FOR  #
                                                # DELETE BY ALT KEY.   #
          IF FITES NQ 0                                                  CTL40
          THEN                     #IF SOME ERROR PREVENTED DELETION   # CTL40
            BEGIN 
            IF BASCFROM[BASTABIND] # IF DELETE FROM ... USING ...      #
            THEN
              BEGIN 
              FROMERR(RC);         # PRINT CARD IMAGE IN ERROR         # QU3A335
              END 
            IF FITES EQ UNKNOWNKEY #IF -UNKNOWN KEY- ERROR             # CTL40
            THEN                                                         CTL40
              BEGIN 
              DIAG (802);          # UNKNOWN KEY ON DELETE             #
              END 
  
            ELSE                   # IF OTHER THAN *UNKNOWN KEY*       #
              BEGIN 
              DIAG(903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR CODE    #
              END 
  
            FITES = 0;             #RESET THE -ES- FIELD IN THE FIT    # CTL40
            RETURN;                # RETURN - DELETE WAS NOT DONE      #
            END 
          END                      # END OF QU-S DELETE ACTIVITY       #
  
                                   # UPDATE HITS COUNTER IN A STRANGE  #
                                   # WAY SUCH THAT THE TOTAL COMES OUT #
                                   # CORRECT.                          #
        IF NOT(FILEPASS AND TRUEIF) THEN
          BEGIN 
          HITS = HITS + 1;         # INCREMENT COUNT OF HITS           #
          END 
  
        LOG (RQTYPE"DELETE", RC);  # TRY TO LOG THE SUCCESSFUL DELETE  #
        END                        # END OF *DELETION ALLOWED* CODE    #
  
      RETURN; 
      END                          # END OF PROC DELTIO                #
  
  
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     U P D I O                                                        #
#                                                                      #
# THIS PROC IS CALLED TO DO THE REPLACE OF THE UPDATED RECORD. IT      #
# SPECIFIES A "C" IN THE *POS* PARAMETER SO A REPLACE OF A DUPLICATE   #
# KEY RECORD OCCURS AT THE CURRENT POSITION. THE ON"UPDATE" DBP IS     #
# CALLED BEFORE THE REPLACE TAKES PLACE (PROC CHKUPD DOES IT). *DIAGNO*#
# IS THE RETURN CODE FROM THE DBP WHICH, IF ZERO, MEANS THE REPLACE    #
# SHOULD BE ALLOWED.                                                   #
# HOWEVER, IF AN ON"SEARCH" EXIT EXISTS FOR THIS AREA, THE USER HAS    #
# INDICATED THAT DBP-S WILL TAKE CARE OF ALL I/O. THUS, THE ON"UPDATE" #
# DBP HAS ALREADY TAKEN CARE OF THE WORK. IF THERE IS NO ON"UPDATE"    #
# EXIT, A DIAGNOSTIC INFORMS THE USER OF THE MISSING DBP, AN QU        #
# TERMINATES THE TRANSMISSION.                                         #
# REGARDLESS OF WHO REPLACES, LOGGING TAKES PLACE IF THE DBP SAID      #
# REPLACEMENT WAS ALLOWED (IF DIAGNO EQ 0 -- THIS IS THE DEFAULT       #
# RETURN CODE IF THERE WAS NO ON"UPDATE" DBP). THE HITS COUNTER IS     #
# LIKEWISE UPDATED.                                                    #
  
  
      PROC UPDIO; 
      BEGIN 
                                                                         CTL40
      P<KEY> = P<AREA$TABLE> + AT$CURRKEY;  # POSITION OF CURRENT KEY  #
      P<FIT> = LOC(AT$AFITPOS);                                          CTL40
      P<RECORD> = FITWSA;          #RECORD IS IN WORKING STORAGE AREA  # CTL40
      IF PVV THEN                  # IF *VETO* RESPONSE SAID DONT DO IT#
        BEGIN 
        RETURN; 
        END 
  
      IF AKEY                      # IF UPDATE BY ALTERNATE KEY        #
      THEN
        BEGIN 
        P<KEY> = FITKA;            # KEY FOR REPLACE IS ONE FROM FITKA #
        END 
  
      DBP$ACTION = 3;              # TELL DBP TO REPLACE RECORD        #
      CHKUPD;                      # ASK DBP IF OK TO REPLACE          #
      IF DIAGNO EQ 0 THEN          # IF OK TO REPLACE                  #
        BEGIN 
        IF AT$DBPSRH THEN          # IF QU SHOULD NOT DO ANY I/O       #
          BEGIN 
          IF NOT AT$DBPUPD THEN    # IF NO ON"UPDATE" DBP TO DO THE I/O#
            BEGIN 
            DIAG (348);            # MISSING ON"UPDATE" EXIT.          #
            CLEANUP;               # CLEANUP FROM THIS TRANSMISSION    #
            EXITCTL;               # EXIT THIS OVERLAY                 #
            END 
          END 
  
        ELSE
          BEGIN 
          REPLC (FIT, RECORD, FITMRL, KEY, FITKP, $C$, RA0);
          IOS = IOS + 1;           # INCR. NO. IO-S FOR DIAG 1006 MSG  #
          P<KEY> = P<AREA$TABLE> + AT$CURRKEY;  # REPOSITION KEY ARRAY #
                                                # IN CASE CHANGED FOR  #
                                                # REPLACE BY ALT. KEY  #
          IF FITES NQ 0                                                  CTL40
          THEN                     #IF SOME ERROR PREVENTED REPLACE    # CTL40
            BEGIN                                                        CTL40
            IF BASCFROM[BASTABIND] # IF UPDATE FROM ... USING ...      #
            THEN
              BEGIN 
              FROMERR(RC);         # PRINT CARD IMAGE IN ERROR         # QU3A335
              END 
            DIAG(903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR CODE      #
            FITES = 0;             #RESET THE -ES- FIELD IN THE FIT    # CTL40
            RETURN;                # RETURN - REPLACE NOT DONE         #
            END 
          END                      # END OF QU-S REPLACE ACTIVITY      #
  
                                   # UPDATE HITS COUNTER IN A STRANGE  #
                                   # WAY SUCH THAT THE TOTAL COMES OUT #
                                   # CORRECT.                          #
        IF NOT (FILEPASS AND TRUEIF) THEN 
          BEGIN 
          HITS = HITS + 1;         # INCREMENT COUNT OF HITS           #
          END 
  
        LOG (RQTYPE"UPDATE", RC);  # TRY TO LOG THE SUCCESSFUL REPLACE #
        END                        # END OF *REPLACEMENT ALLOWED* CODE #
  
      RETURN; 
      END                          # END OF PROC UPDIO                 #
  
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     I N S T I O                                                      #
#                                                                      #
# THIS PROC IS CALLED TO DO THE PUT OF THE NEW RECORD.                 #
# THE ON"UPDATE" DBP IS CALLED (VIA A CALL TO CHKUPD) BEFORE THE PUT   #
# TAKES PLACE. *DIAGNO* IS THE RETURN CODE FROM THE DBP WHICH, IF ZERO,#
# MEANS THE PUT SHOULD BE ALLOWED.                                     #
# HOWEVER, IF AN ON"SEARCH" EXIT EXISTS FOR THIS AREA, THE USER HAS    #
# INDICATED THAT DBP-S WILL TAKE CARE OF ALL I/O. THUS, THE ON"UPDATE" #
# DBP HAS ALREADY TAKEN CARE OF THE WORK. IF THERE IS NO ON"UPDATE"    #
# EXIT, A DIAGNOSTIC INFORMS THE USER OF THE MISSING DBP, AN QU        #
# TERMINATES THE TRANSMISSION.                                         #
# REGARDLESS OF WHO PUTS, LOGGING TAKES PLACE IF THE DBP SAID THE PUT  #
# WAS TO BE ALLOWED (IF DIAGNO EQ 0 -- THIS IS ALSO THE DEFAULT FOR    #
# RETURN CODE IF THERE WAS NO ON"UPDATE" DBP). THE HITS COUNTER IS     #
# LIKEWISE UPDATED.                                                    #
  
  
      PROC INSTIO;
      BEGIN 
                                                                         CTL40
      P<KEY> = P<AREA$TABLE> + AT$CURRKEY;  # POSITION OF CURRENT KEY  #
      P<FIT> = LOC(AT$AFITPOS);                                          CTL40
      P<RECORD> = FITWSA;          #RECORD IS IN WORKING STORAGE AREA  # CTL40
                                                                         CTL40
      INSTFAIL = FALSE;            # ASSUME GOOD ON INSERT             #
      IF PVV                       # IF VETO RESPONSE SAID DONT DO IT  #
      THEN
        BEGIN 
        IF BASCMODKEY[BASTABIND]   # AND IF DOING MOD ON PRIMARY KEY   #
        THEN
          BEGIN 
          VSKIP = TRUE;            # SET FLAG TO SKIP DELTIO IN MODIFY #
          END 
        RETURN;                    # EXIT DELTIO.                      #
      END 
  
      IF FITFO EQ FOAK             # IF AN -AK- FILE                   #
      THEN
        BEGIN 
        FITKA = P<KEY>; 
        IKEY[0] = 0;               # ZERO KEY FIELD TO RECEIVE RECORD- #
                                   # MANAGER-SUPPLIED KEY              #
        END 
  
      DBP$ACTION = 1;              # TELL DBP TO PUT RECORD            #
      CHKUPD;                      # ASK DBP IF OK TO PUT              #
      IF DIAGNO EQ 0 THEN          # IF OK TO PUT                      #
        BEGIN 
        IF AT$DBPSRH THEN          # IF QU SHOULD NOT DO ANY I/O       #
          BEGIN 
          IF NOT AT$DBPUPD THEN    # IF NO ON"UPDATE" DBP TO DO THE I/O#
            BEGIN 
            DIAG (348);            # MISSING ON"UPDATE" EXIT.          #
            CLEANUP;               # CLEANUP FROM THIS TRANSMISSION    #
            EXITCTL;               # EXIT THIS OVERLAY                 #
            END 
          ELSE
            BEGIN 
            ACCESSES = ACCESSES + 1;  # INCRMNT NO. OF DBP ACCESSES.   #
            END 
          END 
  
        ELSE
          BEGIN 
                                   # THIS PUT POSITIONS DUPLICATES LAST#
                                   # UNLESS SUBSCHEMA SAID DUPLICATES  #
                                   # ARE FIRST. DUPPOS SET IN OPENAREA.#
          PUT (FIT, RECORD, FITMRL, KEY, FITKP, DUPPOS, RA0); 
          ACCESSES = ACCESSES + 1;  # INCR. NO. ACCESSES FOR DIAG 1006 #
          IOS = IOS + 1;           # INCR. NO. IO-S FOR DIAG 1006 MSG  #
                                                                         CTL40
          IF FITES NQ 0            #IF SOME ERROR ON PUT               # CTL40
          THEN                                                           CTL40
            BEGIN                                                        CTL40
            IF BASCFROM[BASTABIND] # IF INSERT FROM ... USING ...      #
            THEN
              BEGIN 
              FROMERR(RC);         # PRINT CARD IMAGE IN ERROR         # QU3A335
              END 
            IF FITES EQ DUPLICATEKEY                                     CTL40
            THEN                                                         CTL40
              BEGIN 
              DIAG (800);          # DIAGNOSE DUP KEY WHEN NOT ALLOWED #
              END 
  
            ELSE                   # NOT A DUP PRIMARY KEY ERROR       #
              BEGIN 
              IF FITES EQ DUPALTKEY                                      CTL40
              THEN                                                       CTL40
                BEGIN 
                DIAG (347);        # DUPLICATE ALTERNATE KEY ON INSERT #
                END 
  
              ELSE                 # NOT A DUP ALTERNATE KEY ERROR     #
                BEGIN 
                DIAG(903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR CODE  #
                END 
              END 
  
            INSTFAIL = TRUE;       # INSERT FAILED. SET FLAG TO TRUE.  #
            FITES = 0;             #RESET THE -ES- FIELD OF THE FIT    # CTL40
            RETURN;                # RETURN - PUT NOT DONE             #
            END 
          IF NOT BASCMODKEY[BASTABIND]
            AND NOT (FILEPASS AND TRUEIF) 
          THEN
            BEGIN 
            HITS = HITS + 1;       # INCREMENT NO OF SUCCESSFUL *PUTS* #
                                   # ONLY IF THIS IS NOT A FILEPASS,   #
                                   # TRUEIF, AND KEY MODIFY.  DELTIO   #
                                   # WILL UPDATE THE COUNTERS ITSELF.  #
                                   # THIS IS A UNIQUE SITUATION THAT   #
                                   # AFFECTS MODIFY ONLY.  ONLY 1 HIT, #
                                   # INSTEAD OF 2, IS GIVEN TO MODIFY. #
            END 
          END                      # END OF QU PUT ACTIVITY            #
  
        LOG (RQTYPE"INSERT", RC);  # TRY TO LOG SUCCESSFUL INSERT      #
        END                        # END OF *PUT ALLOWED* CODE         #
  
      RETURN; 
      END                          # END OF PROC INSTIO                #
  
  
  
  
  
  
  
#----------------------------------------------------------------------#
#                                                                      #
#     B E F I M A G E                                                  #
#                                                                      #
#     RETAINS A COPY OF THE BEFORE-IMAGE OF THE RECORD FOR IMAGE LOG-  #
#     GING. THE IMAGE IS SAVED IN AN XDEF-D BASED ARRAY CALLED *BIMAGE*#
#     AND THE LENGTH IS SAVED IN *LGBIMAGE*.                           #
#                                                                      #
#     BEFIMAGE ASSUMES THAT MEMORY FOR THE *BIMAGE* ARRAY HAS ALREADY  #
#     BEEN PROPERLY ALLOCATED, AND REALIZES IT NEED NOT COPY THE RECORD#
#     IF THERE IS NO MEMORY ALLOCATED.                                 #
  
      XDEF PROC BEFIMAGE; 
      PROC BEFIMAGE(RECORD);
      BEGIN 
                                                                         CTL40
      ARRAY RECORD; 
        BEGIN 
        ITEM IRECORD   I(00,00,60);  # SCRATCH FOR COPYING IMAGE       #
        END 
      ITEM  I;                     # INDEX FOR WORD BY WORD COPYING    #
  
      IF P<BIMAGE> EQ 0 THEN       # IF NO BEFORE-IMAGE BUFFER         #
        BEGIN 
        RETURN;                    # NO COPYING TO BE DONE.            #
        END 
      P<FIT> = P<AREAFIT>;                                               CTL40
      LGBIMAGE = FITRL;            #LENGTH OF THE RECORD IN BIMAGE     # CTL40
      I = (LGBIMAGE + 9) / 10;     # NUMBER OF WORDS TO CONTAIN THE RCD#
      FOR I = I - 1 STEP -1 UNTIL 0 DO  # FOR EACH WORD OF THE RECORD  #
        BEGIN 
        IBIMAGE[I] = IRECORD[I];   # SAVE THIS WORD OF THE RECORD      #
        END 
      RETURN; 
      END  # BEFIMAGE # 
  
  
  
  
     # THIS IS THE PLACE TO DO ANY CLEAN UP FOR THE OVERLAY IF AN       000800
       ABORT HAS OCCURRED - NO ASSURANCE OF HOW FAR THE OVERLAY WAS IN  000810
       EXECUTION #                                                      000820
      XDEF PROC AUTOPSY;                                                000830
      PROC AUTOPSY;                                                     000840
      BEGIN 
      CLOSEAREA;                   # CLOSE FILES                       #
      RELEASESPACE;                # RELEASE SPACE FOR THIS DIRECTIVE  #
      IF (ACCESSES + HITS + IOS NQ 0)      # IN CASE OF CP TIME LIMIT  #
                                           # DUE TO NUMBER OF IO-S     #
        AND QUESF EQ 0             # FL NOT EXHAUSTED                  #
      THEN
        BEGIN 
        DIAG (1006, ACCESSES, HITS, IOS);  # DISPLAY ACCESS/HIT/IO MSG #
        END 
      IF (OWNFORCD + OWNREJ NQ 0)        # IF A RECORD HAS BEEN FORCED #
                                         # OR REJECTED BY A DBP        #
        AND QUESF EQ 0             # FL NOT EXHAUSTED                  #
      THEN
        BEGIN 
        DIAG (1003, OWNFORCD, OWNREJ);   # DISPLAY FORCED/REJECTED MSG #
        END 
      END 
      RETURN;                                                           000850
       END
 TERM 
