*DECK CTL50 
USETEXT TAREATB 
USETEXT TBASCTB 
USETEXT TCMMDEF 
USETEXT TCOMMON 
USETEXT TCRMDEF 
USETEXT TDTABLE 
USETEXT TENVIRN 
USETEXT TEXPRES 
USETEXT TFIT
USETEXT TINDTBL 
USETEXT TLFNINF 
USETEXT TOPTION 
USETEXT TPSTACK 
USETEXT TRELTBL 
USETEXT TSBASIC 
      PROC CTL50; 
      BEGIN 
CONTROL NOLIST;                    # *CALL VECTORS FOLLOWS             #
*CALL VECTORS 
CONTROL LIST; 
  
#----------------------------------------------------------------------#
#     S T A R T    O F    X D E F S                                    #
  
      XDEF ITEM AKCHPOS I;         # ALT KEY CHARACTER POSITION        #
      XDEF ITEM AKITORD I;         # ITEM ORDINAL OF ALTERNATE KEY     #
      XDEF ITEM AKLNGTH I;         # ALT KEY LENGTH IN CHARACTERS      #
      XDEF ITEM AKTYPE  I;         # ALT KEY TYPE                      #
      XDEF ITEM AKWOPOS I;         # ALT KEY WORD POSITION             #
      XDEF ITEM ALKEYLOC I;        # ADDRESS OF ALTERNATE KEY ARRAY    #
      XDEF ITEM MKL  I;            # LENGTH OF MAJ KEY IF *GET* ON MAJ #
                                   # 0 IF *GET* ON FULL KEY            #
      XDEF ITEM MKT  I;            # TYPE OF MAJ KEY IF *GET* ON MAJ   #
                                   # 0 IF GET ON FULL KEY              #
      XDEF ITEM NEWDATA B;         # TRUE IF USINGEX IS CALLED TO UPDAT#
                                   # SAME DATA IN RECORDS WITH         #
                                   # DUPLICATE ALTERNATE KEYS          #
      XDEF ITEM ONALTERKEY B;      # TRUE IF UPDATING BY ALTERNATE KEY #
  
#----------------------------------------------------------------------#
#     S T A R T    O F    X R E F S                                    #
  
      XREF PROC BGFILL;            # PAD RECORD WITH BACKGROUND IMAGE  #
      XREF PROC BGIMAGE;           # COPY BACKGROUND IMAGE TO WSA      #
      XREF PROC BGINIT;            # PREPARE BACKGROUND IMAGE          #
      XREF PROC CDCSGET;           # READ NEXT (EXTENDED) RECORD       #
      XREF PROC CLOSEM;            # CRM CLOSE FILE                    #
      XREF PROC CMOVE;             # CHARACTER MOVE ROUTINE            #
      XREF PROC CONVERT;           # CONVERT FROM ONE TYPE TO ANOTHER  #
      XREF PROC DB$CLS;            # CDCS CLOSE FILE                   #
      XREF PROC DB$DEL;            # CDCS DELETE RECORD                #
      XREF PROC DB$OPN;            # CDCS OPEN FILE                    #
      XREF PROC DB$RD1;            # CDCS SEQUENTIAL READ ON AREA      #
      XREF PROC DB$RD2;            # CDCS RANDOM READ ON AREA          #
      XREF PROC DB$REW;            # CDCS REWRITE                      #
      XREF PROC DB$RWF;            # CDCS REWIND AREA                  #
      XREF PROC DB$RWR;            # CDCS REWIND RELATION              #
      XREF PROC DB$WR2;            # CDCS RANDOM WRITE                 #
      XREF PROC DIAG;              # ISSUE DIAGNOSTIC                  #
      XREF PROC DIAGFLU;           # FLUSH DUPLICATE DIAGNOSTICS       #
      XREF PROC EXCEV;             # PROCESS EVALUATE TABLE            #
      XREF PROC EXITCTL;           # TERMINATE THIS OVERLAY            #
      XREF PROC EXPEVAL;           # EVALUATE PROGRAM STACK            #
      XREF PROC EXPEVALUATE;       # EVALUATE PROGRAM STACK            #
      XREF PROC FIGSUB;            # CALCULATE POSITION OF SUBSCRIPTED #
                                   # VALUE                             #
      XREF PROC FROMERR;           # PRINT CARD IN ERROR IF *FROM*     #
      XREF PROC GET;               # CRM READ RECORD                   #
      XREF PROC LOADOVL;           # LOAD OVERLAY                      #
      XREF PROC MOVEC;             # CHARACTER MOVE ROUTINE            #
      XREF PROC MOVEXE;            # PROCESS MOVE TABLE                #
      XREF PROC OPENM;             # CRM OPEN FILE                     #
      XREF PROC PUT;               # CRM WRITE RECORD                  #
      XREF PROC READ;              # INPUT DATA FROM TERMINAL          #
      XREF PROC RTNSSCM;           # RETURN ALL CM USED BY SUBSCHEMA   #
      XREF PROC UPBUN;             # CALCULATE UPPER BOUND             #
      XREF PROC USINGEX;           # PROCESS *USING* LIST              #
      XREF PROC WRITE;             # WRITE LINE TO TERMINAL            #
      XREF PROC WRITEBL;           # WRITE CONTENTS OF *DISPLAY*       #
  
      XREF ITEM ATPTR I;           # AREA TABLE POINTER IF UPDATE OR   #
                                   # SINGLE AREA QUERY OR *CREATE*     #
      XREF ITEM CDCSUP B;          # TRUE IF ACTUALLY CALL CDCS        #
      XREF ITEM CURRELLOC I;       # ADDRESS OF RELATION TABLE IF QUERY#
                                   # BY RELATION, ELSE ZERO            #
      XREF ITEM CURRENTLFPTR I;    # PTR TO LFNINFO ENTRY FOR CURRENT  #
                                   # LFN                               #
      XREF ITEM DIAGLEV I;         # FLAG FOR OPTION OF *DIAG* DIRECTIV#
      XREF ITEM DUMMY I;           # DUMMY ITEM FOR A *FOR* LOOP       #
      XREF ITEM FROMKEYINFIT I;    # ADDRESS OF *FROM* OR *KEY IN* FIT #
      XREF ITEM IDIRCODE I;        # INTEGER VALUE OF DIRECTIVE CODE   #
      XREF ITEM QUESF I;           # CMM ERROR WORD                    #
      XREF ITEM RA0 I;             # ZERO FOR TERMINATING PARAM LISTS  #
      XREF ITEM RECDORD I;         # RECORD ORDINAL USED BY THIS XMISSN#
      XREF ITEM RECNAM I;          # SUBSCHEMA ADDR OF RECORD ENTRY    #
      XREF ITEM TARGETAREA I;      # AREA TABLE POINTER IF UPDATE OR   #
                                   # *CREATE*                          #
      XREF ITEM TOAREA B;          # TRUE IF *MOVE* HAS MOVED A VALUE  #
                                   # TO A DATA BASE ITEM               #
      XREF ITEM UPDATING B;        # TRUE IF UPDATING AN AREA          #
      XREF ITEM UPDTEMP B;         # TRUE IF UPDATING TEMPORARY ITEM   #
      XREF ITEM PROMTYPE I;        # PROMPT POSITION INDICATOR         #
  
      XREF BASED ARRAY DBSTAT;     # DATA BASE STATUS BLOCK            #
        BEGIN 
        ITEM DBSERRCODE   I(00,00,60);  # CRM OR CDCS ERROR CODE       #
        ITEM DBSAUXSTAT1  I(01,00,60);  # AUXILIARY STATUS WORD 1      #
        ITEM DBSFP        I(02,00,60);  # FILE POSITION                #
        ITEM DBSAUXSTAT3  I(03,00,60);  # AUXILIARY STATUS WORD 3      #
        ITEM DBSFUNCTION  C(04,00,10);  # FUNCTION IN DISPLAY CODE     #
        ITEM DBSRANKERR   I(05,00,60);  # RANK ON WHICH ERROR OCCURRED #
        ITEM DBSRANKCTLB  I(06,00,60);  # LOWEST RANK ON WHICH CONTROL #
                                        # BREAK OCCURRED               #
        ITEM DBSRANKNULL  I(07,00,60);  # LOWEST RANK FOR WHICH THERE  #
                                        # WAS A NULL RECORD            #
        ITEM DBSNAME      C(08,00,30);  # REALM OR AREA NAME ON WHICH  #
                                        # ERROR OCCURRED               #
        ITEM DBSFATALFLG  B(11,00,06);  # TRUE IF FATAL ERROR          #
        ITEM DBSMSGADDR   I(11,42,18);  # ADDR OF CDCS ERROR MSG BUFFER#
        END 
      XREF BASED ARRAY ORDSAVE;;   # DEFINED FOR USE BY RELEASESPACE   #
  
      XREF BASED ARRAY RUSLIST;;   # RELATION USAGE LIST               #
  
      XREF BASED ARRAY SAVDAREA;   # INFO ABOUT AREAS IN USE           #
        BEGIN 
        ITEM AREAINUSE    B(0, 0, 1);  # TRUE IF AREA USED BY THIS     #
                                       # TRANSMISSION                  #
        ITEM AREASAVE     I(0,42,18);  # AREA TABLE ADDRESS            #
        ITEM AREASAVEWD   I(0, 0,60);  # ENTIRE WORD                   #
        END 
  
#----------------------------------------------------------------------#
#     S T A R T    O F    D E F S                                      #
  
      DEF RETRYCODE    #-2#;       # CDCS REQUEST COULD NOT BE COMPLETD#
      DEF SEARCHCODE   #-1#;       # CONTINUE SEARCHING FOR RECORD     #
      DEF RECFOUNDCODE #0#;        # RECORD HAS BEEN FOUND             #
      DEF EOICODE      #1#;        # END OF INFORMATION                #
      DEF ERRFOUNDCODE #2#;        # CRM OR CDCS ERROR HAS OCCURRED    #
  
#----------------------------------------------------------------------#
#     S T A R T    O F    L O C A L    I T E M S                       #
  
      ITEM CHARPOS I;              # CHARACTER POSITION                #
      ITEM DIAGNO I;               # SET TO DIAG NUMBER IF ERROR       #
      ITEM DTP I;                  # INDEX INTO DISPLAY TABLE          #
      ITEM DUMMY1 I;               # LOOP COUNTER                      #
      ITEM DUPPOS I;               # DUPLICATE POSITION                #
      ITEM GETDKI  B;              # TRUE IF *GETIO* TO GET DUPLICATE  #
                                   # MAJOR KEYS                        #
      ITEM I I;                    # INDEX VARIABLE                    #
      ITEM INSERTRCD B;            # TRUE IF RECORD TO BE INSERTED     #
      ITEM INSTFAIL B=FALSE;  # SAVES THE FITES FROM FAILURE ON PUT.   #
      ITEM IOA I;                  # LOOP COUNTER                      #
      ITEM J I;                    # SCRATCH VARIABLE                  #
      ITEM JJ I;                   # SCRATCH VARIABLE                  #
      ITEM K I;                    # SCRATCH VARIABLE                  #
      ITEM KK I;                   # SCRATCH VARIABLE                  #
      ITEM LINE C(50);             # SCRATCH OUTPUT LINE               #
      ITEM LKEYB  I;               # NUM OF BITS IN LAST WORD OF KEY   #
      ITEM LKEYWD  I;              # LENGTH OF KEY IN WORDS            #
      ITEM LL I;                   # SCRATCH VARIABLE                  #
      ITEM LOOPCON1 B;             # LOOP CONTROL VARIABLE             #
      ITEM M I;                    # SCRATCH VARIABLE                  #
      ITEM MOREALTKEY B;           # TRUE IF MORE DUPLICATE ALT KEYS   #
      ITEM NUM I;                  # SCRATCH VARIABLE                  #
      ITEM OLDDIAGLEV I;           # SAVE DIAGLEV DURING *USING*       #
      ITEM PD I;                   # PROCESSING DIRECTION              #
      ITEM PP I;                   # SCRATCH VARIABLE                  #
      ITEM PRINTDIAG B = TRUE;     # CHECKDBSTAT SHOULD PRINT DIAG 904 #
      ITEM PRINTNODIAG B = FALSE;  # CHECKDBSTAT SHOULD NOT PRINT 904  #
                                   # BECAUSE CALLER WILL PRINT DIAG    #
      ITEM RC I;                   # RETURN CODE                       #
      ITEM RC1 I;                  # RETURN CODE                       #
      ITEM REPTALTKEY B;           # TRUE IF SEQUENTIALLY READING      #
                                   # RECORDS WITH DUPLICATE ALTERNATE  #
                                   # OR MAJOR KEYS                     #
      ITEM RETRYANS C(1);          # ANSWER TO WHETHER TO RETRY        #
                                   # CDCS REQUEST                      #
      ITEM SAVEKT  I;              # HOLDS ORIGINAL KEY TYPE BEFORE    #
                                   # GET ON MAJOR KEY                  #
      ITEM SKIPCOUNT I;            # LOOP INDUCTION VARIABLE           #
      ITEM TEMP I;                 # SCRATCH VARIABLE                  #
      ITEM TRUEIF B;               # TRUE IF *IF* IS SATISFIED         #
      ITEM UB I;                   # UPPER BOUND                       #
      ITEM UPDATERECORD B = FALSE;  # SET TRUE BY UPDATE DIRECTIVE     #
      ITEM UPDPASS B;              # SAVES THE PASS STATUS FROM AN     #
                                   # UPDATE DIRECTIVE                  #
      ITEM UPDVETO B;              # SAVES THE VETO STATUS FROM AN     #
                                   # UPDATE DIRECTIVE                  #
      ITEM UPLG I;                 # LENGTH OF DISPLAY IN WORDS        #
      ITEM UPLGMAX I;              # LENGTH OF LARGEST DISPLAY IN      #
                                   # XMISSN IN WORDS                   #
      ITEM UPLGSAVE I;             # SAVE VALUE OF UPLG                #
      ITEM USINGGETKEY B = TRUE;   # *USING* WILL COLLECT VALUE OF     #
                                   # KEY                               #
      ITEM USINGGETREC B = FALSE;  # *USINGEX* WILL COLLECT VALUES OF  #
                                   # ALL ITEMS                         #
      ITEM VSKIP B=FALSE;          # SKIP MODKEY PROCESS ON VETO FLAG. #
  
#----------------------------------------------------------------------#
#     S T A R T    O F    L O C A L    A R R A Y S                     #
  
      ARRAY AREAORDINAL [0:0];     # AREA ORDINAL AS PASSED TO CDCS    #
        BEGIN 
        ITEM RECLENFLAG   B(00,00,01);  # IF TRUE CDCS WILL RETURN     #
                                        # RECORD LENGTH                #
        ITEM AREAORDCDCS  U(00,48,12);  # AREA ORDINAL                 #
        END 
  
      ARRAY ATTRIB [0:0] S(2);     # ATTRIB TABLE FOR CONVERT KEY      #
        BEGIN 
        ITEM ATTRCLS      U(0,12, 6);  # DATA TYPE                     #
        ITEM ATTRWP       I(0,18,18);  # BEGINNING WORD POSITION       #
        ITEM ATTRBP       U(0,36, 6);  # BEGINNING BIT POSITION        #
        ITEM ATTRSIZE     I(0,42,18);  # INTERNAL LENGTH IN CHARACTERS #
        ITEM ATTDPTLC     I(1,21, 6);  # CHAR POS OF DECIMAL POINT     #
        END 
  
      ARRAY PAKORD [0:0];          # KEY ITEM AND RECORD ORDINAL AS    #
                                   # PASSED TO CDCS                    #
        BEGIN 
        ITEM PAKRECDORD   U(00,36,12);  # KEY RECORD ORDINAL           #
        ITEM PAKITEMORD   U(00,48,12);  # KEY ITEM ORDINAL             #
        END 
  
#----------------------------------------------------------------------#
#     S T A R T    O F    L O C A L    B A S E D    A R R A Y S        #
  
      BASED ARRAY BIMAGE;;         # DEFINED FOR USE BY RELEASESPACE   #
  
      BASED ARRAY CONVPARAM S(2);      # CONVERT PARAMETERS            #
        BEGIN 
        ITEM CTOCHAR      U(0, 8, 4);  # *TO* CHARACTER POSITION       #
        ITEM LOCNTO       I(0,42,18);  # *TO* ADDRESS                  #
        ITEM TOLOCN       I(1,42,18);  # *TO* BASE ADDRESS             #
        END 
  
  
      BASED ARRAY DKIKEY;          # DEFINED FOR USE BY RELEASESPACE   #
        BEGIN 
        ITEM DKIKEYWD  I;          # TO SAVE MAJOR KEY VALUE           #
        END 
  
      BASED ARRAY DTABLEPTR;       # ARRAY USED FOR DISPLAY TABLE AND  #
                                   # ACTUAL CONTENTS OF DISPLAY        #
        BEGIN 
        ITEM TOCHAR       U(0, 8, 4);  # *TO* CHARACTER POSITION       #
        ITEM CHARLENGTH   U(0,12,12);  # LENGTH OF FIELD IN CHARACTERS #
        ITEM DFROMAD      I(0,24,18);  # RELATIVE ADDR OF *FROM* FIELD #
        ITEM TOADDRESS    I(0,42,18);  # RELATIVE ADDR OF *TO* FIELD   #
        ITEM STACKADD     I(1, 6,18);  # ADDRESS OF PROGRAM STACK      #
        ITEM ADDRFROM     I(1,24,18);  # BASE OF *FROM* FIELD          #
        ITEM DUMY         I(0, 0,60);  # ENTIRE WORD                   #
        END 
  
      BASED ARRAY GIVEA;           # ARRAY FOR SEARCHING FOR ZERO      #
        BEGIN 
        ITEM GIVEITEM I(0,0,60);   # ENTIRE WORD                       #
        END 
  
      BASED ARRAY RELENTRIES;;     # DEFINED FOR USE BY *RELEASESPACE* #
      BASED ARRAY NEWKEY;          # SAVES THE MODIFIED NEW KEY VALUE. #
        BEGIN 
        ITEM NKEY I;
        END 
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     A U T O P S Y                                                    #
#                                                                      #
#     THIS PROC PERFORMS CLEAN UP FOR THIS OVERLAY AFTER AN ABORT HAS  #
#     OCCURRED.  THERE IS NO ASSURANCE OF HOW FAR THE OVERLAY WAS IN   #
#     EXECUTION.                                                       #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC AUTOPSY;
      PROC AUTOPSY; 
      BEGIN 
      CLOSEFRMUPN;                 # CLOSE *FROM* AND *UPON* 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 
      RETURN; 
      END                          # END PROC    A U T O P S Y         #
      CONTROL EJECT;
      PROC BASICLOOP; 
#                                      #
#        B A S I C L O O P             #
#                                      #
# THIS PROC IS THE GUTS OF -CTL50-. IT IS THE INTERFACE WITH ALL OF THE#
# DIRECTIVES TO BE PROCESSED BY THIS OVERLAY.  #
      BEGIN 
  
      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   #
      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-  #
  
      ALKEYLOC = 0; 
      FOR DUMMY=DUMMY 
        WHILE NOT FINISHED
      DO
        BEGIN                  # LOOP THRU AREA FILE   #
        ENDBASICTAB = FALSE;
        TRUEIF = TRUE;
        P<BASICTABLE> = BASTABLOC;
        BASCPTR = BASTABLOC;
        BASTABIND = -1; 
        FOR DUMMY1=DUMMY1 
          WHILE NOT ENDBASICTAB 
        DO
          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;
DELETE: 
            DELETEM;
            TEST DUMMY1;
DELETEUSING:  
            DELUSI; 
            TEST DUMMY1;
DISPLAYLAB: 
            DISPLAY(DISPLAYRC); 
            IF DISPLAYRC EQ 1 
            THEN
              BEGIN 
              ENDBASICTAB = TRUE; 
              END 
            TEST DUMMY1;
ENDBT:  
            ENDBASICTAB = TRUE; 
            TEST DUMMY1;
EVALUATE: 
            EXCEV;
            TEST DUMMY1;
EXTRACT:  
            EXTRACTM; 
            TEST DUMMY1;
IFLABEL:  
            IFM(TRUEIF);
            TEST DUMMY1;
INSERT: 
            INSERTM;
            TEST DUMMY1;
INSERTUSING:  
            INSUSI; 
            TEST DUMMY1;
MOVE: 
            MOVEM;
            TEST DUMMY1;
UPDATE: 
            UPDATEM;
            TEST DUMMY1;
UPDATEUSING:  
            TRUEIF = FALSE;    # FOR ACCESSES/HITS COUNT #
            UPDUSI; 
            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;
            END 
          END  # ENDBASICTAB   #
  
        IF WRTRECD                 # IF RECORD TO BE REWRITTEN         #
          OR INSERTRCD             # IF RECORD TO BE INSERTED          #
        THEN
          BEGIN 
          BASCVETO[BASTABIND] = UPDVETO;  # MOVE UPDATE VETO STATUS    #
          BASCPASS[BASTABIND] = UPDPASS;  # MOVE UPDATE PASS STATUS    #
          UPDINSIO;                # UPDATE OR INSERT RECORD           #
        WRTRECD = FALSE;           # CLEAR REWRITE FLAG                #
        INSERTRCD = FALSE;         # CLEAR INSERT FLAG                 #
          END 
  
        UPDATERECORD = FALSE;      # CLEAR FLAG                        #
        FINISHED = NOT FILEPASS;
        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.                            #
            END 
          CDCSGET (RC);            # FETCH NEXT (EXTENDED) RECORD      #
          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 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#
        END 
      RETURN; 
      END 
  
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     CHECKDBSTAT                                                      #
#                                                                      #
#     CHECKS DATA BASE STATUS BLOCK AND SETS RC2                       #
#     ACCORDINGLY.  IF DBSTAT INDICATES THAT CDCS COULD NOT COMPLETE   #
#     REQUEST, THIS PROC ASKS THE USER IF QU SHOULD RETRY REQUEST.     #
#                                                                      #
#     ON OUTPUT                                                        #
#     RC2 = ERRFOUNDCODE           TERMINATE TRANSMISSION PROCESSING   #
#                                  DUE TO ERROR                        #
#     RC2 = RECFOUNDCODE           RECORD HAS BEEN READ                #
#     RC2 = RETRYCODE              QU MUST RETRY CDCS REQUEST          #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC CHECKDBSTAT (RC2, DIAGFLAG); 
      BEGIN 
      ITEM RC2 I;                  # RETURN CODE                       #
      ITEM DIAGFLAG B;             # TRUE IF DIAG 904 SHOULD BE ISSUED #
                                   # FOR ERRORS OTHER THAN CDCS CANNOT #
                                   # COMPLETE REQUEST                  #
      IF DBSERRCODE EQ LOCKEDRCRD  # IF CDCS CANNOT COMPLETE REQUEST   #
                                   # BECAUSE RECORD IS LOCKED          #
        OR DBSERRCODE EQ WAITMEMORY  # BECAUSE CDCS WAIT FOR MEMORY    #
      THEN
        BEGIN 
                                   # CRM/CDCS ERROR -X- FILE/RELATION  #
                                   # -Y- FUNCTION -Z-                  #
        DIAG904;                   # PRINT DIAG 904                    #
        DIAG (1018);               # SHALL WE RETRY CDCS REQUEST -     #
                                   # ANSWER Y OR N                     #
        READ (RETRYANS, TEMP, 1, TEMP);  # READ USER-S RESPONSE        #
        IF RETRYANS EQ "Y"         # IF ANSWER IS YES                  #
        THEN
          BEGIN 
          RC2 = RETRYCODE;         # QU MUST RETRY CDCS REQUEST        #
          RETURN; 
          END 
  
        ELSE                       # USER DOES NOT WANT TO RETRY       #
          BEGIN 
          RC2 = ERRFOUNDCODE;      # TERMINATE TRANSMISSION PROCESSING #
          DBSERRCODE = 0;          # CLEAR ERROR FIELD                 #
          RETURN; 
          END 
        END 
  
      IF DBSERRCODE NQ 0           # IF ANY OTHER ERROR                #
      THEN
        BEGIN 
                                   # CRM/CDCS ERROR -X- FILE/RELATION  #
                                   # -Y- FUNCTION -Z-                  #
        IF DIAGFLAG                # IF DIAG 904 SHOULD BE PRINTED     #
        THEN
          BEGIN 
          DIAG904;                 # PRINT DIAG 904                    #
          END 
  
        RC2 = ERRFOUNDCODE;        # TERMINATE TRANSMISSION PROCESSING #
        RETURN; 
        END 
  
      RC2 = RECFOUNDCODE;          # SUCCESSFUL COMPLETION             #
      RETURN; 
      END                          # END PROC    C H E C K D B S T A T #
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     C L E A N U P                                                    #
#                                                                      #
#     SMALL PROC USED BY *CTL50* TO RELEASE SPACE AND CLOSE            #
#     SEQUENTIAL FILES                                                 #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC CLEANUP; 
      BEGIN 
      CLOSEFRMUPN;                 # CLOSE *FROM* AND *UPON* FILES     #
      RELEASESPACE;                # RELEASE CENTRAL MEMORY            #
      RETURN; 
      END                          # END PROC   C L E A N U P          #
CONTROL EJECT;
*CALL CLOSEFILE 
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     C L O S E F R M U P N                                            #
#                                                                      #
#     PROC TO CLOSE THE *FROM* AND *UPON* FILES.                       #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC CLOSEFRMUPN; 
      BEGIN 
      ITEM BC I;                   # BASIC TABLE CODE                  #
      ITEM FINISHED B;             # LOOP CONTROL VARIABLE             #
      IF FROMKEYINFIT NQ 0         # IF *FROM* OR KEY IN* FILE         #
      THEN
        BEGIN 
        P<FIT> = FROMKEYINFIT;     # PASS FIT ADDRESS TO CLOSEFILE     #
        CLOSEFILE;                 # CLOSE *FROM* OR *KEY IN* FILE     #
        END 
  
      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 
      CONTROL EJECT;
      PROC DELETEM; 
#                                      #
#        D E L E T E M                 #
#                                      #
# PROC TO DO THE CONTROL PORTION OF A DELETE DIRECTIVE     #
      BEGIN 
      DELTIO; 
      RETURN; 
      END 
      CONTROL EJECT;
      PROC DELUSI;
#                                      #
#        D E L U S I                   #
#                                      #
# THIS PROC PROCESSES -DELETE-USING- DIRECTIVE #
      BEGIN 
  
      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); 
  
        IF RC EQ 0
        THEN
          BEGIN 
          REPTALTKEY = FALSE; 
          GETIO;
          REPTALTKEY = TRUE;
  
          IF ONALTERKEY 
          THEN
            BEGIN 
            P<FIT> = P<AREAFIT>;
  
            IF DIAGNO EQ 0
            THEN
              BEGIN 
              DELTIO; 
              END 
  
            ELSE
              BEGIN 
              TEST RC;
              END 
  
            FOR SKIPCOUNT = SKIPCOUNT 
              WHILE MOREALTKEY     # WHILE MORE DUPLICATE ALTERNATE KEY#
            DO
              BEGIN 
              GETIO;
  
              IF DIAGNO NQ 0
              THEN
                BEGIN 
                TEST RC;
                END 
  
              DELTIO; 
              END 
            END 
  
          ELSE
            BEGIN 
            IF DIAGNO EQ 0
            THEN
              BEGIN 
              DELTIO; 
              END 
            END 
          END 
        END 
      DIAGLEV = OLDDIAGLEV;        # RESET TO PREVIOUS DIAG OPTION     #
      KEYLIT = 1;                  # SET SO ACCESSES/HITS MSG APPEARS  #
      END  # DELUSI    #
CONTROL EJECT;
*CALL PVV 
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     D E L T I O                                                      #
#                                                                      #
#     THIS PROC CALLS CDCS TO DELETE A RECORD                          #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC DELTIO;
      BEGIN 
      IF NOT BASCMODKEY[BASTABIND] # IF MODIFYING ON PRIMARY KEY,      #
                                   # NO NEED TO CHECK PVV AGAIN.       #
        AND PVV                    # IF *VETO* RESPONSE SAID YES       #
      THEN
        BEGIN 
        RETURN; 
        END 
  
      P<KEY> = P<AREA$TABLE> + AT$CURRKEY;  # POSITION TO CURRENT KEY  #
      P<FIT> = LOC(AT$AFITPOS);    # POSITION TO FIT                   #
      P<RECORD> = FITWSA;          # RECORD IS IN WORKING STORAGE AREA #
      RC1 = RETRYCODE;
      FOR DUMMY1 = 0               # LOOP UNTIL CDCS CAN DO REQUEST    #
        WHILE RC1 EQ RETRYCODE
      DO
        BEGIN 
IF CDCSUP THEN
        DB$DEL (FIT, DUPPOS, AREAORDINAL, PAKORD);
        CHECKDBSTAT (RC1, PRINTNODIAG);  # CHECK DATA BASE STATUS BLOCK#
        END                        # END DUMMY1 LOOP                   #
  
      IF RC1 EQ ERRFOUNDCODE       # IF SOME ERROR OCCURRED            #
      THEN
        BEGIN 
        IF FITES EQ UNKNOWNKEY     # IF UNKNOWN KEY ERROR              #
        THEN
          BEGIN 
          DIAG (802);              # UNKNOWN KEY ON DELETE             #
          DBSERRCODE = 0;          # CLEAR ERROR FIELD                 #
          END 
  
        ELSE                       # IF SOME OTHER ERROR               #
          BEGIN 
          DIAG904;                 # PRINT DIAG 904                    #
          END 
  
        IF BASCFROM[BASTABIND]     # IF DELETE FROM USING              #
        THEN
          BEGIN 
          FROMERR (RC1);           # PRINT CARD IMAGE IN ERROR         #
          END 
  
        RETURN; 
        END 
  
      IOS = IOS + 1;               # INCREMENT NUM OF LOGICAL IOS      #
                                   # 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 
      RETURN; 
      END                          # END PROC    D E L T I O           #
*CALL DIAG904 
      CONTROL EJECT;
      PROC DISPLAY (DISPLAYRC); 
#                                      #
#        D I S P L A Y                 #
#                                      #
#     THIS PROC PROCESSES THE DISPLAY DIRECTIVE.                       #
      BEGIN 
  
      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);
  
      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             #
  
  
        IF FITOC NQ 1              #OPEN FILE, IF NECESSARY.           #
        THEN
          BEGIN 
          FITBBH = TRUE;           # ALLOCATE BUFFERS BELOW HHA        #
          OPENM (FIT, $IO$, $N$, RA0);
          IF FITES NQ 0            #ERROR IN OPENING FILE.             #
          THEN
            BEGIN 
            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 BUFFER        #
            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[RECDORD];  # ASSUME FILE CONTAINS KEY   #
                                          # ONLY                       #
            L$WSA = CMM$ALF ((KT$PICLEN[RECDORD] + 9) / 10, 0, 0);
            FITWSA = L$WSA; 
            END 
          CVW1[0] = 0;             # INITIALIZE CONVERT TABLE TO 0-S   #
          CVW2[0] = 0;
          CVCODE[0] = KT$TYPE[RECDORD] + 1;  # CONVERT CODE            #
          CVFRADD[0] = FITWSA;     # FROM ADDRESS                      #
          CVTOADD[0] = P<AREA$TABLE> + AT$CURRKEY[0];  # TO ADDRESS    #
          CVLG[0] = KT$PICLEN[RECDORD];  # SIZE OF FROM FIELD          #
          IF KT$TYPE[RECDORD] NQ 7  # IF KEY IS NOT LOGICAL            #
          THEN                     # USE ATTRIBUTE TABLE               #
            BEGIN 
                                   # BUILD CONVERT TABLE               #
            CVTOADD[0] = LOC(ATTRIB) - 1;  # CVT TBL POINTS TO ATTRIB  #
            ATTRCLS[0] = KT$TYPE[RECDORD];  # DATA TYPE                #
            ATTDPTLC[0] = KT$DPTLOC[RECDORD];  # DECIMAL POINT POSITION#
            ATTRSIZE[0] = KT$LENGTH[RECDORD];  # SIZE IN CHARACTERS    #
                                   # BUILD ATTRIBUTE TABLE             #
            ATTRWP[0] = P<AREA$TABLE> + AT$CURRKEY;  # WORD POSITION   #
            ATTRBP[0] = 0;         # BIT POSITION                      #
            END 
  
        CONTIN: # # 
           P<FIT> = FROMKEYINFIT;  # POSITION TO *KEY IN* FIT          #
           GET(FIT,RA0);
  
           IF FITFP EQ O"100"      #EOF OR EOI                         #
           THEN 
             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 
  
           IF FITFP NQ O"20"
           THEN 
             BEGIN
             GOTO CONTIN; 
             END
  
            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 
START1: 
            FOR M = 0 STEP 1       # LENGTH OF THIS DISPLAY AREA       #
              UNTIL UPLG - 1
            DO
              BEGIN 
              ALINE[M] = "          ";   # BLANK FILL DISPLAY AREA     #
              END 
  
            DTP = EESIZE;          #BYPASS KEY ELEMENTARY ENTRY        #
            P<DTABLE> = BASCADDR[BASTABIND];
      END 
   START: # # 
      IF CPENTRY[DTP] EQ 0 THEN 
          BEGIN 
            EDTABL: # # 
            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....   #
              THEN
                BEGIN 
                DIAG(903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR CODE  #
                END 
              END 
            ELSE
     BEGIN
      DIAGNO = 0; 
      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      #
            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 ;
          FOR KK = 0 STEP 1 UNTIL JJ DO 
           BEGIN IF ALLFG[KK] OR DEPNDFG[KK] THEN 
          BEGIN 
                 LL=ADDRFROM[0];
                 UPBUN(INDTBL,UB,LL,RC);
                      IF RC NQ 0 THEN 
                        BEGIN 
                        DIAG(RC); 
                        RETURN; 
                        END 
          IF ALLFG[KK] THEN 
                GOTO ALLFOUND;
      JJ = JJ - 1;
                END 
          END 
          GOTO NOALL; 
        ALLFOUND: # # 
          P<INDTBL> = P<INDTBL> + KK; 
            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;
        NOALL: # #
      FIGSUB(DTABLEPTR,M);
        CHKM: # # 
      IF M EQ 51 THEN M = 217;
      IF M NQ 0 THEN
        BEGIN 
        DIAG(M);
        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;
      END  # DISPLAY   #
CONTROL EJECT;
*CALL EXTRACTM
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     G E T I O                                                        #
#                                                                      #
#     THIS PROC CALLS CDCS TO READ A RECORD                            #
#     IF ONALTERKEY IS TRUE AND REPTALTKEY IS TRUE, IT READS           #
#     SEQUENTIALLY BY ALTERNATE KEY.                                   #
#     IF ONALTERKEY IS TRUE AND REPTALTKEY IS FALSE, IT READS          #
#     RANDOMLY BY ALTERNATE KEY                                        #
#     IF ONALTERKEY IS FALSE, IT READS RANDOMLY BY PRIMARY KEY         #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC GETIO; 
      BEGIN 
      DIAGNO = 0;                  # ASSUME GOOD RECORD WILL BE READ   #
      P<FIT> = P<AREAFIT>;         # POSITION TO FIT                   #
      P<RECORD> = FITWSA;          # POSITION TO WORKING STORAGE AREA  #
      P<KEY> = AT$CURRKEY + P<AREA$TABLE>; # POSITION TO KEY           #
      IF ONALTERKEY                # IF READING BY ALTERNATE KEY       #
      THEN
        BEGIN 
        PAKITEMORD[0] = AKITORD;   # ALTERNATE KEY ITEM ORDINAL        #
        P<KEY> = ALKEYLOC;         # ADDR OF ALTERNATE KEY AREA        #
        FITKA = ALKEYLOC;          # ADDR OF ALTERNATE KEY AREA        #
        FITKP = 0;                 # CHAR POSITION WITHIN KEY AREA     #
        FITRKW = AKWOPOS;          # WORD POSITION WITHIN RECORD       #
        FITRKP = AKCHPOS;          # CHAR POSITION WITHIN RECORD       #
        FITKL  = AKLNGTH;          # ALTERNATE KEY LENGTH              #
        FITKT = AKTYPE;            # ALTERNATE KEY TYPE                #
        END 
  
      RC1 = RETRYCODE;
      FOR DUMMY1 = 0               # LOOP UNTIL CDCS CAN DO REQUEST    #
        WHILE RC1 EQ RETRYCODE
      DO
        BEGIN 
        IF REPTALTKEY              # IF SEQUENTIALLY READING DUPLICATE #
                                   # ALTERNATE OR MAJOR KEYS           #
        THEN
          BEGIN 
                                   # CDCS SEQUENTIAL READ ON AREA      #
IF CDCSUP THEN
          DB$RD1 (FIT, AREAORDINAL);
          END 
  
        ELSE                       # RANDOM READ ON PRIMARY OR ALTERNAT#
          BEGIN 
                                   # CDCS RANDOM READ ON AREA          #
IF CDCSUP THEN
          FITMKL = MKL;            # GET BY MAJOR KEY IF *FITMKL* IS   #
                                   # NON-ZERO                          #
          SAVEKT = FITKT;          # STORE ORIGINAL VALUE              #
          FITKT  = MKT;            # SET KEY TYPE                      #
          DB$RD2 (FIT, AREAORDINAL, PAKORD);
          FITKT = SAVEKT;          # RESTORE ORIGINAL VALUE            #
          END 
  
        CHECKDBSTAT (RC1, PRINTNODIAG);  # CHECK DATA BASE STATUS BLOCK#
        END                        # END DUMMY1 LOOP                   #
  
      IF RC1 EQ ERRFOUNDCODE       # IF SOME CRM/CDCS ERROR            #
      THEN
        BEGIN 
        DIAGNO = 816;              # REPORT ERROR TO CALLER            #
        GETDKI = FALSE;            # NO MORE GETS ON DUP MAJOR KEYS    #
        IF FITES EQ UNKNOWNKEY     # IF UNKNOWN KEY ERROR              #
          OR FITES EQ UNKNWNALTKEY  # UNKNOWN ALTERNATE KEY            #
          OR FITES EQ AKUNKNOWNKEY  # UNKNOWN AK KEY                   #
        THEN
          BEGIN 
          DIAG (816);              # UNKNOWN KEY                       #
          DBSERRCODE = 0;          # CLEAR ERROR FIELD                 #
          END 
  
        ELSE                       # IF SOME OTHER ERROR               #
          BEGIN 
          DIAG904;                 # PRINT DIAG 904                    #
          END 
  
        IF BASCFROM[BASTABIND]     # IF UPDATE/DELETE FROM USING       #
        THEN
          BEGIN 
          FROMERR (RC1);           # PRINT CARD IMAGE IN ERROR         #
          END 
  
        RETURN; 
        END 
  
      IF ONALTERKEY                # IF ACCESS BY ALTERNATE KEY        #
      THEN
        BEGIN 
        IF GETDKI                  # AND BY DUPLICATE MAJOR KEY        #
        THEN
          BEGIN 
                                   # MOVE ALTERNATE KEY FROM RECORD    #
                                   # TO ALTERNATE KEY ARRAY            #
          CMOVE (RECORD, (FITRKW * 10 + FITRKP), FITKL, KEY, 0);
          END 
        END 
      ELSE                         # IF ACCESS BY PRIMARY KEY          #
        BEGIN 
        KEYTOKA;                   # MOVE PRIMARY KEY FROM RECORD TO   #
                                   # KEY ARRAY                         #
        END 
  
      IF FITRT GQ RTR              # IF VARIABLE LENGTH RECORD         #
        AND FITRT LQ RTT
      THEN
        BEGIN 
        AREALOC = P<AREA$TABLE>;
        BGFILL;                    # PAD RECORD WITH BACKGROUND IMAGE  #
        END 
  
      IOS = IOS + 1;               # INCREMENT NUM OF LOGICAL IOS      #
      ACCESSES = ACCESSES + 1;     # INCREMENT NUM OF ACCESSES         #
      IF GETDKI                    # IF GETTING DUPLICATE MAJOR KEYS   #
      THEN
        BEGIN 
        IF FITFP EQ O"100"         # IF NO MORE RECORDS LEFT           #
        THEN
          BEGIN 
          DIAGNO = 1;              # END OF DUPLICATE MAJOR KEYS       #
          GETDKI = FALSE; 
          RETURN; 
          END 
        FOR DUMMY = 0 STEP 1       # LOOP THRU EACH FULL WORD IN KEY   #
          UNTIL LKEYWD-2
        DO
          BEGIN 
          IF DKIKEYWD[DUMMY] NQ IKEY[DUMMY]  # IF THIS KEY DIFFERENT   #
          THEN
            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                       # IF THIS KEY DIFF THAN ORIGINAL    #
          BEGIN 
          DIAGNO = 1;              # END OF DUPLICATE MAJOR KEYS       #
          GETDKI = FALSE; 
          RETURN; 
          END 
        END 
      IF ONALTERKEY                # IF READING BY ALTERNATE KEY       #
      THEN
        BEGIN 
        IF DBSFP NQ ENDOFKEY       # IF MORE DUPLICATE ALTERNATE KEYS  #
          AND DBSFP NQ ENDOFILE 
        THEN
          BEGIN 
          MOREALTKEY = TRUE;
          END 
  
        ELSE
          BEGIN 
          MOREALTKEY = FALSE; 
          END 
  
        FITRKW = KT$WPOS[RECDORD];  # RESET FIT TO REFLECT PRIMARY KEY #
        FITKA = AT$CURRKEY + P<AREA$TABLE>; 
        P<KEY> = FITKA;            # POSITION TO PRIMARY KEY ARRAY     #
        KEYTOKA;                   # MOVE PRIM KEY FROM RECORD TO *KEY*#
        PAKITEMORD[0] = KT$ITEMORD[RECDORD];  # PRIMARY KEY ITM ORDINAL#
        IF FITFO EQ FOAK           # IF ACTUAL KEY FILE                #
        THEN
          BEGIN 
          FITRKP = KT$ACTKEYPOS[RECDORD]; 
          FITKP  = KT$ACTKEYPOS[RECDORD]; 
          FITKL  = KT$ACTKEYLNG[RECDORD]; 
          END 
  
        ELSE
          BEGIN 
          FITRKP = KT$CPOS[RECDORD];
          FITKL  = KT$LENGTH[RECDORD];
          END 
        END 
  
      RETURN; 
      END                          # END PROC    G E T I O             #
*CALL GETWSA
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     I F M                                                            #
#                                                                      #
# THIS PROC PROCESSES *IF* STATEMENTS.                                 #
#----------------------------------------------------------------------#
      PROC IFM (TRUEIF);
      BEGIN 
      ITEM TRUEIF B;           # TRUE IF -IF- IS TRUE  #
      ITEM REJ B; 
  
      B<0,60>PROGSTACKLOC = BASCADDR[BASTABIND];
      LOGICALRESLT = TRUE;
      EXPEVAL(RC);                 # EVALUATE EXPRESSION               #
      TRUEIF    = LOGICALRESLT; 
      RETURN; 
      END                          # I F M                             #
      CONTROL EJECT;
      PROC INSERTM; 
#                                      #
#        I N S E R T M                 #
#                                      #
# PROC TO DO THE MEAT OF -INSERT- DIRECTIVE    #
      BEGIN 
  
      P<FIT> = LOC(AT$AFITPOS);    #SET BY CALLER                      #
      BGIMAGE;
  
      IF FITFO NQ FOAK
        AND NOT AT$KEYEXCL         #MOVE KEY TO RECORD.                #
      THEN
        BEGIN 
        IF KT$TYPE[RECDORD] NQ 7   # IF NOT LOGICAL                    #
        THEN
          BEGIN 
          ATTDPTLC[0] = KT$DPTLOC[RECDORD];  # CHARACTER POSITION OF   #
                                             # DECIMAL POINT           #
          ATTRWP[0] = KT$WPOS[RECDORD]; 
          CHARPOS = KT$CPOS[RECDORD] * 6;  # KEY BIT POSITION IN WORD  #
                                           # POINTER TO BY KT$WPOS     #
          ATTRBP[0] = CHARPOS;
          END 
  
        ELSE
          BEGIN 
          LOCNTO[0] = KT$WPOS[RECDORD]; 
          END 
        CTOCHAR[0] = CHARPOS; 
        TOLOCN[0] = LOC(FITWSA);
        CONVERT(CONVPARAM, K);
  
        IF K NQ 0 THEN
          BEGIN 
          DIAG(805);               #ERROR FROM KEY CONVERSION          #
          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                          # END PROC    I N S E R T M         #
CONTROL EJECT;
      PROC INSUSI;
#                                      #
#        I N S U S I                   #
#                                      #
# THIS PROC PROCESSES THE -INSERT-USING- DIRECTIVE #
      BEGIN 
  
      P<FIT> =  LOC(AT$AFITPOS);
      IF DIAGNO NQ 0 THEN RETURN; 
      DIAGFLU;                     # FLUSH MSG FOR ACCUMULATED DIAGS   #
      OLDDIAGLEV = DIAGLEV;        # SAVE PREV. DIAG OPTION            #
      DIAGLEV = 1;                 # FORCE *DIAG,FULL*.                #
      INSERTRCD = TRUE;            # FLAG THAT RECORD TO BE INSERTED   #
      FOR RC = 0 WHILE RC NQ 1 DO 
        BEGIN 
        IF FITFO NQ FOAK           # IF NOT AK                         #
        THEN
          BEGIN 
          USINGEX(USINGGETKEY, RC); 
          IF RC NQ 0 THEN TEST; 
          END 
        BGIMAGE;
        USINGEX(USINGGETREC, RC); 
  
        IF RC EQ 0
        THEN
          BEGIN 
          UPDINSIO;                # INSERT RECORD                     #
          END 
        END 
      INSERTRCD = FALSE;           # CLEAR INSERT FLAG                 #
      DIAGLEV = OLDDIAGLEV;        # RESET TO PREVIOUS DIAG OPTION     #
      KEYLIT = 1;                  # SET SO ACCESSES/HITS MSG APPEARS  #
      END  # INSUSI    #
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     K E Y L I T M                                                    #
#                                                                      #
# THIS PROC COMPUTES THE KEY-LIT VALUE AND GETS THE RECORD.            #
#----------------------------------------------------------------------#
      PROC KEYLITM (RC);
      BEGIN 
      ITEM RC;
      FILEPASS = FALSE; 
      P<KEY> = P<AREA$TABLE> + AT$CURRKEY[0]; 
      BASTABIND = B<0,18>KEYLIT;
      BASCPTR = B<42,18>KEYLIT; 
      P<BASICTABLE> = BASCPTR;
      P<CONVPARAM> = BASCADDR[BASTABIND]; 
      LOCNTO[0] = P<KEY>; 
      TOLOCN[0] = 0;
      CTOCHAR[0] = 0; 
      IF KT$TYPE[RECDORD] NQ 7     # IF NOT LOGICAL USE ATTRIB TABLE   #
      THEN
        BEGIN 
        LOCNTO[0] = LOC(ATTRIB) - 1;  # CVT TBL POINTS TO ATTRIB TABLE #
        ATTRCLS[0] = KT$TYPE[RECDORD];  # DATA TYPE                    #
        ATTRWP[0] = P<KEY>;        # WORD POSITION                     #
        ATTRBP[0] = 0;             # BIT POSITION                      #
        ATTRSIZE[0] = KT$LENGTH[RECDORD];  # KEY LENGTH IN CHARACTERS  #
        ATTDPTLC[0] = KT$DPTLOC[RECDORD];  # DECIMAL POINT POSITION    #
        END 
      CONVERT(CONVPARAM, RC); 
      IF RC NQ 0
      THEN
        BEGIN 
        DIAG(805);
        END 
  
      IF BASCODE[BASTABIND] NQ INSTCODE THEN
        BEGIN 
        GETIO;
        IF DIAGNO NQ 0 THEN RC = 1; 
        END 
      RETURN; 
      END 
      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[RECDORD] * 10 + KT$CPOS[RECDORD]),
             KT$LENGTH[RECDORD], KEY, 0); 
      RETURN; 
      END                          # PROC *KEYTOKA*                    #
      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 
      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     #
      IF BASCMODKEY[BASTABIND]     # IF PRIMARY KEY WILL BE MODIFIED   #
      THEN
        BEGIN 
        VSKIP = FALSE;             # ASSUME VETO RESPONSE SAID NO.     #
        INSERTRCD = TRUE;          # SET NEW RECORD FLAG FOR UPDINSIO. #
        UPDINSIO;                  # WRITE NEW RECORD WITH NEW KEY.    #
        IF VSKIP                   # IF NO ON VETO,                    #
          OR INSTFAIL              # OR INSERT FAILED, EXIT.           #
        THEN
          BEGIN 
          GOTO VEXIT; 
          END 
                                   # INSERTED NEW RECORD SUCCESSFULLY. #
                                   # NOW SAVE THE NEW KEY IMAGE.  THE  #
                                   # OLD KEY IS STILL AT FITKA.  READ  #
                                   # THE OLD RECORD AGAIN TO REGAIN    #
                                   # LOCK, THEN CALL DELTIO TO DELETE  #
                                   # THE OLD RECORD.                   #
        P<NEWKEY>= CMM$ALF(KT$LENGTH[RECDORD], FIXED$LWA, 0); 
        CMOVE(RECORD, (KT$WPOS[RECDORD] * 10 + KT$CPOS[RECDORD]), 
             KT$LENGTH[RECDORD], NEWKEY, 0);
        DB$RD2(FIT, AREAORDINAL, PAKORD);   # READ OLD REC AND DELETE. #
        DELTIO;                    # DELETE OLD RECORD FIRST           #
        IF RC1 EQ ERRFOUNDCODE     # IF DELETION OF OLD RECORD FAILED, #
                                   # RESET FITKA WITH THE NEW KEY SAVED#
                                   # EARLIER.  READ THE NEWLY INSERTED #
                                   # RECORD IN TO REGAIN LOCK.  CALL   #
                                   # DELTIO TO DELETE IT. DATEBASE NOW #
                                   # RESTORED TO ITS ORIGINAL STATE.   #
        THEN
          BEGIN 
          CMOVE(NEWKEY, 0, KT$LENGTH[RECDORD], KEY, 0); 
          DB$RD2(FIT, AREAORDINAL, PAKORD); 
          DELTIO; 
          END 
        CMM$FRF(P<NEWKEY>); 
        END 
  
      ELSE                         # IF PRIMARY KEY NOT CHANGED        #
        BEGIN 
        INSERTRCD = FALSE;         # SIMPLY UPDATE EXISTING RECORD     #
        UPDINSIO;                  # UPDATE RECORD, NO KEY INVOLVED.   #
        END 
  
VEXIT:  
      INSERTRCD = FALSE;
      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 SAID NO.     #
          INSERTRCD = TRUE;        # SET NEW RECORD FLAG FOR UPDINSIO. #
          UPDINSIO;                # WRITE NEW RECORD WITH NEW KEY.    #
          INSERTRCD = FALSE;       # RESET FLAG TO AVOID REWRITE.      #
          IF VSKIP                 # IF NO ON VETO,                    #
            OR INSTFAIL            # OR INSERT FAILED, EXIT.           #
          THEN
            BEGIN 
            RETURN; 
            END 
                                   # INSERTED NEW RECORD SUCCESSFULLY. #
                                   # NOW SAVE THE NEW KEY IMAGE.  THE  #
                                   # OLD KEY IS STILL AT FITKA.  READ  #
                                   # THE OLD RECORD AGAIN TO REGAIN    #
                                   # LOCK, THEN CALL DELTIO TO DELETE  #
                                   # THE OLD RECORD.                   #
          P<NEWKEY>= CMM$ALF(KT$LENGTH[RECDORD], FIXED$LWA, 0); 
          CMOVE(RECORD, (KT$WPOS[RECDORD] * 10 + KT$CPOS[RECDORD]), 
               KT$LENGTH[RECDORD], NEWKEY, 0);
          DB$RD2(FIT, AREAORDINAL, PAKORD);  # READ OLD REC AND DELETE.#
          DELTIO;                  # ORIGINAL RECORD MUST BE DELETED,  #
          IF RC1 EQ ERRFOUNDCODE   # IF DELETION OF OLD RECORD FAILED, #
                                   # RESET FITKA WITH THE NEW KEY SAVED#
                                   # EARLIER.  READ THE NEWLY INSERTED #
                                   # RECORD IN TO REGAIN LOCK.  CALL   #
                                   # DELTIO TO DELETE IT. DATEBASE NOW #
                                   # RESTORED TO ITS ORIGINAL STATE.   #
          THEN
            BEGIN 
            CMOVE(NEWKEY, 0, KT$LENGTH[RECDORD], KEY, 0); 
            DB$RD2(FIT, AREAORDINAL, PAKORD); 
            DELTIO; 
            END 
          CMM$FRF(P<NEWKEY>); 
          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         #
        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 
          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 ALL WDS OF MAJ KEY      #
            UNTIL LKEYWD-1
          DO
            BEGIN 
            DKIKEYWD[DUMMY] = IKEY[DUMMY];   # SAVE MAJ KEY"S 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 
                                   # LOOP FOR EACH OCCURRENCE OF ALT   #
            FOR SKIPCOUNT = SKIPCOUNT 
              WHILE MOREALTKEY     # WHILE MORE DUPLICATE ALTERNATE KEY#
            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                  # *SKIPCOUNT* 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              #
      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;
#----------------------------------------------------------------------#
#                                                                      #
#     O P E N A R E A                                                  #
#                                                                      #
#     THIS PROC DETERMINES THE PROPER PROCESSING DIRECTION, INPUT, I-O #
#     OR OUTPUT.  IT REQUESTS CM FOR WSA.  IT SETS FIT TO DESCRIBE THE #
#     PRIMARY KEY.  IF ANY FILE IS NOT OPEN, IT IS OPENED.  IF ANY FILE#
#     IS OPEN WITH THE WRONG PROCESSING DIRECTION, IT IS CLOSED AND    #
#     REOPENED.  IF ANY FILE IS OPEN WITH THE CORRECT PROCESSING       #
#     DIRECTION, IT IS REWOUND.                                        #
#                                                                      #
#     ON INPUT                                                         #
#     IF QUERY BY RELATION, RT$FITADDR WITHIN RELATION TABLE POINTS TO #
#     LIST OF FITS OF ALL FILES TO BE OPENED.                          #
#     OTHERWISE ATPTR CONTAINS AREA TABLE ADDRESS OF THE SINGLE FILE   #
#     TO BE OPENED.                                                    #
#                                                                      #
#     ON OUTPUT                                                        #
#     IF QUERY BY RELATION, P<AREA$TABLE> POSITIONED TO AREA TABLE OF  #
#     ROOT AREA.                                                       #
#     OTHERWISE, P<AREA$TABLE> POSITIONED TO SINGLE AREA IN USE.       #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC OPENAREA (RC); 
      BEGIN 
      ITEM RC I;                   # RETURN CODE                       #
      ITEM RC1 I;                  # RETURN CODE FROM CHECKDBSTAT      #
  
      IF REFERFILE EQ 0            # IF NO AREAS TO BE REFERENCED      #
      THEN
        BEGIN 
        RETURN;                    # EXIT WITHOUT DOING ANYTHING       #
        END 
  
      IF RECDORD EQ 0              # IF RECORD DESCRIPTION NOT         #
                                   # DETERMINED YET                    #
      THEN
        BEGIN 
        RECDORD = 1;               # ASSUME 1ST RECORD DESCRIPTION     #
        END 
  
      IF CROPEN                    # IF 1ST OPEN SINCE *CREATE*        #
      THEN
        BEGIN 
        CROPEN = FALSE;            # RESET FLAG                        #
        PD = PD$OUTPUT;            # OPEN FOR OUTPUT                   #
        END 
  
      ELSE
        BEGIN 
        IF REFERFILE EQ 1          # IF TRANSMISSION IS QUERY          #
        THEN
          BEGIN 
          PD = PD$INPUT;           # OPEN FOR INPUT                    #
          END 
  
        ELSE
          BEGIN 
          PD = PD$IO;              # OPEN FOR IO                       #
          END 
        END 
  
      IF CURRELLOC NQ 0            # IF QUERY BY RELATION              #
      THEN
        BEGIN 
        P<REL$TABLE> = CURRELLOC;  # POSITION TO RELATION TABLE        #
        P<FITADDRTBL> = RT$FITADDR;  # POSITION TO FIT LIST            #
        RECNAM = 0;                # ONLY 1 RECORD DESCRIPTION PER AREA#
                                   # SO BGINIT USE FIRST DESCRIPTION   #
        END 
  
      LOOPCON1 = TRUE;
      FOR IOA = 0 STEP 1           # LOOP THROUGH FIT LIST, IF ANY     #
        WHILE LOOPCON1
      DO
        BEGIN 
        IF CURRELLOC NQ 0          # IF FIT LIST EXISTS                #
        THEN
          BEGIN 
          IF FITADDR[IOA] EQ 0     # IF END OF FIT LIST                #
          THEN
            BEGIN 
            LOOPCON1 = FALSE;      # END OF LOOP THROUGH FIT LIST      #
            TEST IOA; 
            END 
  
                                   # CALCULATE AREA TABLE ADDRESS      #
          ATPTR = FITADDR[IOA] - AT$FITOFFSET;
          END 
  
        ELSE
          BEGIN 
          LOOPCON1 = FALSE;        # ONLY ONCE THROUGH LOOP, TARGETAREA#
                                   # ALREADY SET UP                    #
          END 
  
        P<AREA$TABLE> = ATPTR;     # POSITION TO AREA TABLE            #
        AREALOC = ATPTR;
        P<KEY$TBL> = AT$PKEYDPTR;  # POSITION TO KEY TABLE             #
        IF CURRELLOC EQ 0          # IF ONLY ONE AREA IN USE           #
        THEN
          BEGIN 
          RECNAM = KT$RECNAM[RECDORD];  # WORD ADDRESS OF RECORD       #
                                        # DESCRIPTION IN SUBSCHEMA     #
          END 
        BGINIT;                    # PREPARE BACKGROUND IMAGE          #
        P<AREAFIT> = LOC(AT$AFITPOS); 
        P<FIT> = P<AREAFIT>;
        NUM = (AT$MRL + 9) / 10;   # SIZE OF WSA IN WORDS              #
        FITWSA = CMM$ALF (NUM, 0, 0);  # REQUEST CM FOR WSA            #
        IF CURRELLOC NQ 0          # IF USING FIT LIST                 #
        THEN
          BEGIN 
          RELFITWSA[IOA] = FITWSA;
          END 
  
                                   # PREPARE PARAMETERS FOR CDCS       #
        PAKRECDORD[0] = KT$SBRCDORD[RECDORD];  # SUBSCHEMA RECORD ORD  #
        AREAORDCDCS[0] = AT$AREAORD;  # AREA ORDINAL                   #
        RECLENFLAG[0] = TRUE;      # CDCS WILL RETURN RECORD LENGTH    #
        PAKITEMORD[0] = KT$ITEMORD[RECDORD];  # KEY ITEM ORDINAL       #
        FITRKW = KT$WPOS[RECDORD];  # SET UP KEY FIELDS IN FIT         #
        FITMRL = AT$MRL;           # MAXIMUM RECORD LENGTH             #
        FITRL = AT$MRL;            # MAXIMUM RECORD LENGTH             #
        IF FITFO EQ FOAK           # IF ACTUAL KEY ORGANIZATION        #
        THEN
                                   # MOVE ACTUAL KEY INFORMATION TO FIT#
          BEGIN 
          FITRKP = KT$ACTKEYPOS[RECDORD]; 
          FITKP  = KT$ACTKEYPOS[RECDORD]; 
          FITKL  = KT$ACTKEYLNG[RECDORD]; 
          P<KEY> = AT$CURRKEY + P<AREA$TABLE>;  # POSITION TO KEY      #
          IKEY[0] = 0;             # ZERO KEY AREA SO CRM WILL ASSIGN  #
                                   # KEY VALUE IN CASE THIS IS AN INSRT#
          END 
  
        ELSE
          BEGIN 
                                   # MOVE KEY INFORMATION TO FIT       #
          FITRKP = KT$CPOS[RECDORD];
          FITKP = 0;
          FITKL  = KT$LENGTH[RECDORD];
          END 
  
        FITKA = AT$CURRKEY + P<AREA$TABLE>; 
        IF FITPD NQ PD             # IF FILE HAS DIFFERENT PROCESSING  #
                                   # DIRECTION                         #
          OR FITOC NQ OC$OPEN      # IF FILE NOT OPEN AT ALL           #
        THEN
          BEGIN 
          IF FITOC EQ OC$OPEN      # IF OPEN WITH WRONG PD             #
          THEN
            BEGIN 
            RC1 = RETRYCODE;
            FOR DUMMY1 = 0         # LOOP UNTIL CDCS CAN DO REQUEST    #
              WHILE RC1 EQ RETRYCODE
            DO
              BEGIN 
IF CDCSUP THEN
              DB$CLS (FIT, AT$AREAORD);  # CDCS CLOSE FILE             #
              CHECKDBSTAT (RC1, PRINTDIAG);  # CHECK DB STATUS BLOCK   #
              END 
  
            IF RC1 EQ ERRFOUNDCODE  # IF SOME CRM/CDCS ERROR           #
            THEN
              BEGIN 
              RC = 1;              # TERMINATE TRANSMISSION PROCESSING #
              RETURN; 
              END 
            FITOC = OC$CLOSED;     # MARK FILE CLOSED                  #
            END 
  
          FITPD = PD;              # STORE CORRECT PROCESSING DIRECTION#
          RC1 = RETRYCODE;
          FOR DUMMY1 = 0           # LOOP UNTIL CDCS CAN DO REQUEST    #
            WHILE RC1 EQ RETRYCODE
          DO
            BEGIN 
IF CDCSUP THEN
            DB$OPN (FIT, AT$AREAORD);  # CDCS OPEN FILE                #
            CHECKDBSTAT (RC1, PRINTDIAG);  # CHECK DB STATUS BLOCK     #
            END 
  
          IF RC1 EQ ERRFOUNDCODE   # IF SOME CRM/CDCS ERROR            #
          THEN
            BEGIN 
            RC = 1;                # TERMINATE TRANSMISSION PROCESSING #
            RETURN; 
            END 
          FITOC = OC$OPEN;         # MARK FILE OPEN                    #
          END 
  
        ELSE                       # FILE IS OPEN WITH CORRECT         #
                                   # PROCESSING DIRECTION              #
          BEGIN 
          IF CURRELLOC EQ 0        # IF ACCESSING SINGLE AREA          #
          THEN
            BEGIN 
            RC1 = RETRYCODE;
            FOR DUMMY1 = 0         # LOOP UNTIL CDCS CAN DO REQUEST    #
              WHILE RC1 EQ RETRYCODE
            DO
              BEGIN 
IF CDCSUP THEN
              DB$RWF (FIT, AT$AREAORD);  # CDCS REWIND AREA FILE       #
              CHECKDBSTAT (RC1, PRINTDIAG);  # CHECK DB STATUS BLOCK   #
              END 
  
            IF RC1 EQ ERRFOUNDCODE  # IF SOME CRM/CDCS ERROR           #
            THEN
            BEGIN 
            RC = 1;                # TERMINATE TRANSMISSION PROCESSING #
              RETURN; 
              END 
            END 
          END 
        END                        # END OF IOA LOOP                   #
  
      RC = 0;                      # SUCCESSFUL RETURN                 #
      BITINDEX = -2;               # INITIALIZE FOR CDCSGET            #
      IF CURRELLOC NQ 0            # IF QUERY BY RELATION              #
      THEN
        BEGIN 
                                   # LEAVE P<AREA$TABLE> POSITIONED TO #
                                   # AREA WITH LOWEST RANK             #
        P<AREA$TABLE> = FITADDR[0] - AT$FITOFFSET;
IF CDCSUP THEN
        DB$RWR (FITADDRTBL, RT$ORDINAL);  # CDCS REWIND RELATION       #
        END 
  
      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 MKL NQ 0                # IF GET ON MAJOR KEY               #
        THEN
          BEGIN 
                                   # SAVE VALUE OF DELETED KEY         #
          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 
          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 ALL WDS OF MAJ KEY      #
           UNTIL LKEYWD-1 
          DO
            BEGIN 
            DKIKEYWD[DUMMY] = IKEY[DUMMY];   # SAVE MAJ KEY"S 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 
                                   # LOOP FOR EACH OCCURRENCE OF ALT   #
            FOR SKIPCOUNT = SKIPCOUNT 
              WHILE MOREALTKEY     # WHILE MORE DUPLICATE ALTERNATE KEY#
            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                  # *SKIPCOUNT* 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;
#----------------------------------------------------------------------#
#                                                                      #
#     R E S E T P                                                      #
#                                                                      #
#     RESET THE FIT FOR PRIMARY KEY ACCESS.  BY CLOSING THE            #
#     AREA FILE, THE ALTERNATE KEY INFORMATION IS CLEARED.             #
#     CONSEQUENTLY, THE NEXT SUBSEQUENT OPEN WILL REFLECT              #
#     PRIMARY KEY ACCESS.                                              #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC RESETP;
      BEGIN 
                                   # RESET PARAMETERS                  #
      P<AREA$TABLE> = ATPTR;       # POINT TO THE AREA TABLE           #
      P<FIT> = LOC(AT$AFITPOS);    # LOCATE THE AREA FIT               #
  
      RC1 = RETRYCODE;             # PRESET FOR CDCS REQUEST           #
      FOR DUMMY1 = 0               # LOOP UNTIL CDCS REQUEST COMPLETE  #
        WHILE RC1 EQ RETRYCODE
      DO
        BEGIN 
        DB$CLS( FIT, AREAORDINAL );  # CLOSE THE AREA FILE             #
  
        CHECKDBSTAT( RC1, PRINTDIAG );
        END 
  
      FITOC = OC$CLOSED;           # MARK THE FILE CLOSED              #
      RETURN;                      # EXIT                              #
      END                          # END *RESETP*                      #
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 #
      P<RECORD> = FITWSA;          # RECORD IS IN FIT-S WSA            #
      P<KEY> = FITKA;              # POSITION TO MOVE KEY              #
      KEYTOKA;                     # COPY KEY FROM RECORD TO KEY ARRAY #
      UPDVETO = BASCVETO[BASTABIND];   # SAVE *VETO* AND *PASS* STATUS #
      UPDPASS = BASCPASS[BASTABIND];
      INSERTRCD = TRUE;            # FLAG NEW RECORD TO BE STORED      #
      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 
        BGIMAGE;                   # INITIALIZE EMPTY RECORD           #
        NEWDATA = FALSE;           # FLAG TO READ IN NEW DATA          #
        USINGEX (USINGGETREC, RC); # CONVERT AND MOVE DATA INTO RECORD #
        IF RC EQ 0                 # IF RECORD OK,                     #
        THEN
          BEGIN 
          SMMOVE;                  # PERFORM *MOVE* IF PRESENT         #
          KEYTOKA;                 # COPY KEY INTO KEY ARRAY           #
          INSERTRCD = TRUE;        # INSERT RECORD INTO DATABASE       #
          UPDINSIO; 
          INSERTRCD = FALSE;
          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#
      UPDPASS = BASCPASS[BASTABIND];   # SAVE PASS STATUS FROM UPDATE#
      RETURN; 
      END 
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     U P D I N S I O                                                  #
#                                                                      #
#     THIS PROC CALLS CDCS TO WRITE OR REWRITE A RECORD                #
#                                                                      #
#     ON INPUT                                                         #
#     INSERTRCD TRUE IF RECORD TO BE INSERTED, ELSE RECORD WILL BE     #
#     REWRITTEN.                                                       #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC UPDINSIO;
      BEGIN 
      INSTFAIL = FALSE;            # ASSUME GOOD ON INSERT.            #
      IF PVV                       # IF VETO RESPONSE SAID DONT DO IT, #
      THEN
        BEGIN 
        IF BASCMODKEY[BASTABIND]   # AND KEY IS BEING MODIFIED         #
        THEN
          BEGIN 
          VSKIP = TRUE;            # SET FLAG TO SKIP DELTIO IN MOD    #
          END                      # AND MODIFYM.                      #
        RETURN;                    # EXIT UPDINSIO.                    #
        END 
  
      P<KEY> = P<AREA$TABLE> + AT$CURRKEY;  # POSITION TO CURRENT KEY  #
      P<FIT> = LOC(AT$AFITPOS);    # POSITION TO FIT                   #
      FITRL = AT$MRL;              # RESET RECORD LENGTH IN CASE       #
                                   # DB$RD1 OR DB$RD2 RESET IT         #
      P<RECORD> = FITWSA;          # RECORD IS IN WORKING STORAGE AREA #
      RC1 = RETRYCODE;
      FOR DUMMY1 = 0               # LOOP UNTIL CDCS CAN DO REQUEST    #
        WHILE RC1 EQ RETRYCODE
      DO
        BEGIN 
        IF INSERTRCD               # IF RECORD TO BE INSERTED          #
        THEN
          BEGIN 
IF CDCSUP THEN
                                   # CDCS RANDOM WRITE                 #
          DB$WR2 (FIT, DUPPOS, KT$SBRCDORD[RECDORD], PAKORD); 
          END 
  
        ELSE                       # IF RECORD TO BE UPDATED           #
          BEGIN 
IF CDCSUP THEN
                                   # CDCS RANDOM REWRITE               #
          DB$REW (FIT, DUPPOS, KT$SBRCDORD[RECDORD], PAKORD); 
          END 
  
        CHECKDBSTAT (RC1, PRINTNODIAG);  # CHECK DATA BASE STATUS BLOCK#
        END                        # END DUMMY1 LOOP                   #
  
      IF INSERTRCD                 # IF RECORD TO BE INSERTED          #
      THEN
        BEGIN 
        ACCESSES = ACCESSES + 1;   # INCREMENT COUNT OF ACCESSES       #
                                   # (ATTEMPTED INSERTS)               #
        END 
  
      IF RC1 EQ ERRFOUNDCODE       # IF SOME ERROR OCCURRED            #
      THEN
        BEGIN 
        IF FITES EQ DUPLICATEKEY   # IF DUPLICATE KEY                  #
        THEN
          BEGIN 
          DIAG (800);              # DUPLICATE PRIMARY KEY ON INSERT   #
          END 
  
        ELSE
          BEGIN 
          IF FITES EQ DUPALTKEY    # IF DUPLICATE ALTERNATE KEY        #
          THEN
            BEGIN 
            DIAG (347);            # DUPLICATE ALTERNATE KEY ON INSERT #
            END 
  
          ELSE                     # IF SOME OTHER ERROR               #
            BEGIN 
            DIAG904;               # PRINT DIAG 904                    #
            END 
          END 
  
        DBSERRCODE = 0;            # CLEAR ERROR FIELD                 #
  
        IF BASCFROM[BASTABIND]     # IF DELETE FROM USING              #
        THEN
          BEGIN 
          FROMERR (RC1);           # PRINT CARD IMAGE IN ERROR         #
          END 
  
        INSTFAIL = TRUE;           # INSERT FAILED, SET FLAG.          #
        RETURN; 
        END 
  
      IOS = IOS + 1;               # INCREMENT NUM OF LOGICAL IOS      #
        IF NOT BASCMODKEY[BASTABIND] # DONT COUNT HITS IF MODIFYING    #
                                     # KEY.  DELTIO WILL COUNT 1 HIT   #
                                     # FOR EACH SUCCESSFUL MODIFY.     #
          AND (INSERTRCD             # IF INSERTING                    #
        OR NOT (FILEPASS           # IF UPDATING AND HITS HAS NOT      #
            AND TRUEIF))             # ALREADY INCREMENTED             #
      THEN
        BEGIN 
        HITS = HITS + 1;           # INCREMENT COUNT OF HITS           #
        END 
  
      RETURN; 
      END                          # END PROC     U P D I N S I O      #
CONTROL EJECT;
      PROC UPDUSI;
#                                      #
#        U P D U S I                   #
#                                      #
# THIS PROC PROCESSES THE -UPDATE-USING- DIRECTIVE #
      BEGIN 
  
      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); 
  
          IF RC EQ 0 THEN 
            BEGIN 
            GETIO;
  
            IF DIAGNO NQ 0 THEN TEST; 
            END 
ELSE TEST;
          END 
        USINGEX(USINGGETREC, RC); 
  
        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 
  
  
        REPTALTKEY = TRUE;
  
        IF ONALTERKEY 
        THEN
          BEGIN 
          P<FIT> = P<AREAFIT>;
          UPDINSIO;                # UPDATE RECORD                     #
  
          FOR SKIPCOUNT = SKIPCOUNT 
            WHILE MOREALTKEY       # WHILE MORE DUPLICATE ALTERNATE KEY#
          DO
            BEGIN 
            GETIO;
  
            IF DIAGNO NQ 0
            THEN
              BEGIN 
              TEST RC;             # EXIT LOOP                         #
              END 
  
            NEWDATA = TRUE; 
            USINGEX(USINGGETREC, RC); 
  
            IF RC NQ 0
            THEN
              BEGIN 
              TEST SKIPCOUNT; 
              END 
  
            UPDINSIO;              # UPDATE RECORD                     #
            END 
          END 
  
        ELSE
          BEGIN 
          IF RC EQ 0
          THEN
            BEGIN 
            UPDINSIO;              # UPDATE RECORD                     #
            END 
          END 
        END 
      DIAGLEV = OLDDIAGLEV;        # RESET TO PREVIOUS DIAG OPTION     #
      KEYLIT = 1;      # SO HITS/ACCESSES WILL BE DISPLAYED. #
      END  # UPDUSI  #
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     C T L 5 0                                                        #
#                                                                      #
#     THIS PROC IS THE CONTROL MODULE FOR THE 50,0 OVERLAY.  IT CALLS  #
#     *OPENAREA* TO INSURE ALL AREAS ARE OPEN, THEN IT CALLS *KEYLITM* #
#     OR *CDCSGET* TO FETCH THE FIRST RECORD IF REQUIRED.  THEN IT     #
#     CALLS *BASICLOOP* TO EXECUTE THE DIRECTIVES IN THE BASIC TABLE   #
#     THEN IT CALLS *RELEASESPACE* TO RELEASE CM                       #
#                                                                      #
#----------------------------------------------------------------------#
      ACCESSES = 0;                # ZERO OUT NUMBER OF RECORDS READ   #
      HITS = 0;                    # ZERO OUT NUMBER OF HITS           #
      IOS = 0;                     # ZERO OUT NUMBER OF LOGICAL IOS    #
      P<BASICTABLE> = BASTABLOC;   # ADDRESS OF BASIC TABLE            #
      BASCPTR = P<BASICTABLE>;
      OPENAREA (RC);               # OPEN ALL REQUIRED AREAS           #
      IF RC NQ 0                   # IF ERROR                          #
      THEN
        BEGIN 
        INDEX = 0;                 # CLEAR INDEX SO RELEASESPACE WILL  #
                                   # PERFORM                           #
        RELEASESPACE; 
        RETURN; 
        END 
  
      IF KEYLIT NQ 0               # IF DISPLAY/INSERT/DELETE/UPDAT KEY#
      THEN
        BEGIN 
        KEYLITM (RC);              # CONVERT KEY AND UNLESS INSERT,    #
                                   # READ RECORD                       #
        IF RC NQ 0                 # IF SOME ERROR                     #
        THEN
          BEGIN 
          RELEASESPACE;            # RELEASE CENTRAL MEMORY            #
          RETURN; 
          END 
        END 
  
      IF FROMKEYINFIT NQ 0         # IF *FROM* OR *KEY IN* FILE        #
      THEN
        BEGIN 
        KEYLIT = 1;                # SET SO ACCESS/HIT/IO MSG IS ISSUED#
        SETDISFROM (RC);           # OPEN *FROM* OR *KEY IN* FILE      #
        IF RC NQ 0                 # IF SOME ERROR                     #
        THEN
          BEGIN 
          CLEANUP;                 # RELEASE SPACE AND CLOSE FILES     #
          RETURN; 
          END 
        END 
  
      IF FILEPASS                  # IF CDCSGET WILL READ FILE         #
      THEN
        BEGIN 
        AREALOC = P<AREA$TABLE>;
        CDCSGET (RC); 
        IF RC EQ 2                 # ERROR -- DIAGNOSE AND QUIT        #
        THEN
          BEGIN 
          IF ONEAKEY               # IF ACCESSING BY ALT KEY           #
          THEN
            BEGIN 
            RESETP;                # RESET FOR PRIMARY KEY             #
            END 
          RELEASESPACE; 
          RETURN; 
          END 
  
        IF RC EQ 1                 # IF NO RECORD QUALIFIED            #
        THEN
          BEGIN 
          DIAG (1009);             # NO RECORD QUALIFIED               #
          IF ONEAKEY               # IF ACCESSING BY ALT KEY           #
          THEN
            BEGIN 
            RESETP;                # RESET FOR PRIMARY KEY             #
            END 
          RELEASESPACE; 
          RETURN; 
          END 
  
        ELSE
          BEGIN 
          ACCESSES = ACCESSES + 1;  # INCREMENT NO. RECORDS READ FOR   #
                                    # ACCESSES HITS MESSAGE            #
          END 
        END 
  
      BASICLOOP;                   # EXECUTE BASIC TABLE DIRECTIVES    #
      IF ONEAKEY                   # IF ACCESSING BY ALT KEY           #
      THEN
        BEGIN 
        RESETP;                    # RESET FOR PRIMARY KEY             #
        END 
      CLEANUP;                     # RETURN FILES AND RELEASE CM       #
      RETURN; 
      END 
      TERM
