*DECK CTL30 
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 TRELTBL 
USETEXT TSBASIC 
      PROC CTL30; 
      BEGIN 
#                                                                      #
#----------------------------------------------------------------------#
#     C T L 3 0                                                        #
#                                                                      #
# THIS IS THE CONTROL MODULE FOR THE 30,00 OVERLAY. ONLY -IF-,         #
# -DISPLAY-, AND -EXTRACT- DIRECTIVES COME HERE. ANY UPDATE DIRECTIVE  #
# GOES TO THE 4X,00 OVERLAYS. THE MAIN PURPOSE OF THIS QUERY-ONLY      #
# OVERLAY IS TO EVALUATE AN EXPRESSION WHICH FOLLOWS A RELATION. SOME  #
# SPECIAL ROUTINES EXIST FOR ACCESSING THE RELATIONAL DATA BASE, SUCH  #
# AS GETRECORDSET, SORTBYORD, GETPRIMKEY, GETALTKEY, GETSEQ.  MOST OF  #
# THIS CODE IS THE SAME AS THAT IN - CTL40-.                           #
#                                                                      #
#----------------------------------------------------------------------#
 # THIS PROC IS THE CONTROL MODULE FOR THE 4,0 OVERLAY #
CONTROL NOLIST;                    #VECTORS   -- LISTED IN SYNTAX      # CTL30
*CALL VECTORS                                                            CTL30
CONTROL LIST;                                                            CTL30
                                                                         CTL30
      XREF PROC LOADX0; 
      XREF PROC GET;
      XREF PROC PUT;
      XREF PROC NEXTGET;
      XREF PROC EXCEV;
      XREF PROC REWND;
      XREF PROC ATTACH; 
      XREF PROC RETURNM;
      XREF PROC READ; 
      XREF PROC EXPEVAL;           # EXPRESSION EVALUATION             #
      XREF PROC MOVEXE; 
      XREF PROC CONVERT;
      XREF PROC DIAG; 
      XREF PROC BGIMAGE;
      XREF PROC BGFILL;            # PAD RECORD WITH BACKGROUND IMAGE  #
      XREF PROC BGINIT;            # PREPARE BACKGROUND IMAGE          #
      XREF PROC EXITCTL;           # ENTRY FOR EXITING CTL30           #
      XREF PROC USINGEX;
  
      XREF ITEM AFPROCESSED B;     # TRUE IF UPDATED UNCLOSED FILE IS  #
                                   # ACCEPTABLE                        #
      XREF ITEM ATPTR I;           # P<AREA$TABLE> AT CALL TO *NEXTGET*#
                                   # OR *CALLOWN*                      #
      XREF ITEM IPROCESSED B;      # FALSE IF INTERACTIVE              #
  
      DEF UPDATED # O"52" #;       # CRM ERROR CODE INDICATING FILE NOT#
                                   # CLOSED SINCE LAST UPDATE          #
  
      ITEM AFANSWER C(1);          # ANSWER TO WHETHER TO ACCEPT       #
                                   # UPDATED UNCLOSED FILE             #
      ITEM  M, UPLG, DTP,  UPLGMAX; 
      ITEM FILEDKI B;              # TRUE IF FILE HAS DUP PRIM KEYS    #
      ITEM GETDKI B;               # TRUE IF GETIO IS READING DUPLICATE#
                                   # PRIMARY KEYS                      #
      ITEM I;                      # INDEX VARIABLE                    #
      ITEM J;                      # INDEX VARIABLE                    #
      ITEM K;                      # INDEX VARIABLE                    #
      ITEM LKEYWD I;               # LENGTH OF PRIMARY KEY IN WORDS    #
      ITEM LOOPCON B; 
      ITEM DUMMY1;
      ITEM READAREA;               # AREA WHICH IS TO BE READ NEXT.    #
                                   # THIS IS AN ORDINAL TO -RELENTRIES-#
      ITEM HIGHAREA;               # HIGHEST AREA IN RELATION.         #
      ITEM WRDADDR; 
      ITEM SAVERL;
      ITEM TEMP I;                 # DUMMY VARIABLE FOR *READ* CALL    #
      ITEM WORD1; 
      ITEM CHAR1; 
      ITEM WORD2; 
      ITEM CHAR2; 
      XDEF ITEM DBP$ACTION I;      # DBP PARAMETER INDICATES WHAT CRM  #
                                   # FUNCTION IS NEEDED FROM DBP.      #
      ITEM DBPRC I;                # RETURN CODE FROM DBP CALL.        #
      ITEM RCB; 
      ITEM UPDVETO B;         # SAVES THE VETO STATUS FROM A UPDATE DIR#
      ITEM UPDPASS B;         # SAVES THE PASS STATUS FROM A UPDATE DIR#
      ITEM UPDATERECORD B = FALSE;  # FLAG FOR -UPDATE- AND -MOVE- #
      ITEM USINGGETREC B = FALSE; 
  
          # BASED ARRAYS TO ACCESS THE CURRENT RECORD, KEY, AREA FIT, 
             AREA NAME, ETC... WHOSE ADDRESSES ARE IN THE COMMON
             BLOCK CBASIC.                                             #
  
  
          #FILE DEFINITION BLOCK (FDB) FOR THE AREA, CONTAINING 
           PERMANENT FILE NAME, LOCAL FILE NAME, ID, CYCLE, PASSWORDS 
           AS APPROPRIATE.  THIS ARRAY IS FILLED IN BY OVERLAY 1-2
           DURING USE SYNTAX ANALYSIS.  # 
      BASED ARRAY FDBAREA;
        BEGIN 
        ITEM ARNAM C(0,0,10); 
        ITEM PFWORD I;
        END 
  
          #FILE DEFINITION BLOCK (FDB) FOR THE INDEX FILE, CONTAINING 
           PERMANENT FILE NAME, LOCAL FILE NAME, ID, CYCLE, PASSWORDS 
           AS APPROPRIATE. THIS ARRAY IS FILLED IN BY OVERLAY 1-2 
           DURING USE SYNTAX ANALYSIS. #
      BASED ARRAY FDBINDEX; 
        BEGIN 
        ITEM INDXNAM    U(0,0,42); #LFN FOR INDEX FILE                 # CTL30
        ITEM IPFWORD I; 
        END 
  
      BASED ARRAY DBP$TBL;         # DESCRIBES DBP INFO IN AREATABLE   #
        BEGIN 
        ITEM DBP$TBLWORD  I(00,00,60); #  WHOLE WORD DEFINITION        #
  
        ITEM DBP$TBLNAME  C(00,00,10); # NAME OF THE ENTRY POINT       #
  
        ITEM DBP$TBLADDR  I(00,42,18); # ABSOLUTE ADDRESS OF THE EP    #
        END 
  
      XREF BASED ARRAY ORDSAVE; 
        ITEM SAVEORD U(0,0,60); 
  
      BASED ARRAY COMP1;
        BEGIN 
        ITEM COMPWORD1  U(0,0,60);
        END 
      BASED ARRAY COMP2;
        BEGIN 
        ITEM COMPWORD2  U(0,0,60);
        END 
      BASED ARRAY DKIKEY;          # SAVE VALUE OF PRIMARY KEY         #
        BEGIN 
        ITEM DKIKEYWD I;
        END 
      XREF BASED ARRAY SAVDAREA;
            BEGIN 
            ITEM AREASAVE  U(0,42,18);
            ITEM AREASAVEWD U(0,0,60);
            ITEM RELORD  U(0,6,12); 
            ITEM AREAINUSE  B(0,0,1); 
            END 
      XREF ITEM IDIRCODE I;        # INTEGER VALUE OF DIRECTIVE CODE   #
      XREF ITEM DBP$DID B;         # TRUE IF WE DID CALL A DBP.        #
      XREF ITEM DBP$FWA;           # FWA OF LOADED DBP"S               #
      XREF PROC DBP$SAC;           # SEARCH AND CALL DB PROCEDURES     #
      ITEM DIAGNO;   # SET TO DIAG NUMBER IF ERROR #
      ARRAY ATTRIB [0:0] S(2);     # ATTRIB TABLE FOR CONVERT KEY      #
         ITEM ATTRCLS  U(0,12,6), 
              ATTRWP   U(0,18,18),
              ATTRBP   U(0,36,6), 
              ATTRSIZE I(0,42,18),
              ATTDPTLC I(1,21, 6); # CHAR POS OF POINT RELATIVE        #
                                   # TO THE END OF THE FIELD           #
                                   # >0 = POINT TO LEFT                #
                                   # <0 = POINT TO RIGHT               #
      XREF ITEM RA0;
      BASED ARRAY CONVPARAM  S(2);
         ITEM LOCNTO  I(0,42,18), 
              TOLOCN  I(1,42,18), 
              CTOCHAR I(0,8,4); 
      ITEM TRUEIF B;
      ITEM COMPAREWSA B;           # IF TRUE, COMPARE FIELD WITHIN REC #
                                   # IF FALSE, COMPARE KEY             #
  
          BASED ARRAY DTABLEPTR;
          ITEM TOCHAR U(0,8,4), 
               CHARLENGTH U(0,12,12),  # LENGTH OF FIELD IN CHARACTERS #
               TOADDRESS I(0,42,18),
               ADDRFROM I(1,24,18), 
               STACKADD I(1,6,18),
           DFROMAD I(0,24,18),
               DUMY I(0,0,60);
          XREF PROC UPBUN;
      XREF PROC WRITEBL;
      XREF PROC OPENM;
      XREF PROC CLOSEM; 
      XREF PROC MOVEC;
      XREF PROC FIGSUB; 
          ITEM UB,RC,PP,JJ,KK,LL; 
      XREF BASED ARRAY DESPTR;
        ITEM DESCOUNT I (0,0,12),  # NUNBER OF LOCAL FILES REFERENCING #
                                   # THIS LIST OF DESCRIBE ITEMS.      #
             DESADDR  U (0,42,18); # ADDRESS OF LIST OF ITEMS.         #
      BASED ARRAY BIMAGE;;         # POINTER FOR USE BY *RELEASESPACE* #
      BASED ARRAY RUSLIST;;        # POINTER FOR USE BY *RELEASESPACE* #
      BASED ARRAY RELENTRIES; 
        BEGIN 
        ITEM RELINUSE B(0,0,1); 
        ITEM RELPOS   B(0,3,1); 
        ITEM RELBGIMAGE B(0,4,1);  # TRUE IF NO RECORD EXISTS SO MUST  #
                                   # CALL BGIMAGE TO COMPLETE RECORD ST#
        ITEM RELATORD U(0,6,12);
        ITEM RELRC    I(0,18,24);  # RECORD COUNT - NUMBER OF REMAINING#
                                   # RECORDS WITH SAME ALTERNATE KEY   #
        ITEM RELADDR  U(0,42,18); 
        ITEM RELWORD  U(0,0,60);
        END 
      XDEF ITEM AKCHPOS I;               # ALTERNATE KEY CHAR POSITION #
      XDEF ITEM AKLNGTH I;               # ALTERNATE KEY LENGTH        #
      XDEF ITEM AKTYPE  I;               # ALTERNATE KEY TYPE          #
      XDEF ITEM AKWOPOS I;               # ALTERNATE KEY WORD POS      #
      XDEF ITEM AKITORD I;               # ITEM ORD IF CDCS AREA ITEM, #
                                         # ELSE 0                      #
      XDEF ITEM ALKEYLOC I;              # ADDR OF ALTERNATE KEY ARRAY #
      XDEF ITEM MKL     I;               # LGTH OF MAJ KEY IF *GET*ON  #
                                         # MAJ KEY, 0 IF ON FULL KEY   #
      XDEF ITEM MKT     I;               # MAJOR KEY TYPE              #
      XDEF ITEM NEWDATA B;               # TRUE IF USINGEX IS CALLED TO#
                                         # UPDATE SAME DATA IN RECORD  #
                                         # WITH DUP ALTERNATE KEY      #
      XDEF ITEM ONALTERKEY B;            # TRUE IF UPDATING BY ALT KEY #
      XREF ITEM UPDATING B;        # TRUE--UPDATING AN AREA.           #
      XREF ITEM UPDTEMP B;
      XREF ITEM TOAREA B; 
      XREF ITEM CURRENTLFPTR; 
      XREF ITEM FROMKEYINFIT I;    # ADDRESS OF *FROM* OR *KEY IN* FIT #
      XREF ITEM LFNLIST;
      XREF ITEM DUMMY;                                                   CTL30
  
      XREF ITEM CURRELLOC;         #   CURRENT RELATION TABLE.         #
      XREF ITEM CURRELATION;
      XREF ITEM USEDIR B;           # TRUE--USE, FALSE--CREATE         #
      XREF ITEM AREATBLPTR; 
      XREF ITEM QUESF I;           # CMM ERROR WORD                    #
          XREF PROC EXTEND; 
      XREF PROC GETN; 
      XREF PROC CMOVE;
      XREF PROC STOPEXEC; 
      ITEM TOBASE;
      CONTROL EJECT;
      BEGIN 
      P<AREA$TABLE> = 0;           # PRESET IN CASE NO AREA TABLE      #
      ATPTR = 0;
      ACCESSES = 0;                # ZERO OUT NO. RECORDS READ         #
      IOS = 0;                     # ZERO OUT NUMBER OF IOS            #
      HITS = 0;                    # ZERO OUT NUMBER OF HITS           #
      OWNFORCD = 0;                # ZERO OUT NUMBER OF FORCED RECORDS #
      OWNREJ = 0;                  # ZERO OUT NUMBER OF REJECTED RECRDS#
      P<BASICTABLE> = BASTABLOC;   #  SET UP BASICTABLE.               #
      P<CCOMMON> = CCOMLOC; 
      BASCPTR = P<BASICTABLE>;
      IF  USEDIR THEN              # USE DIRECTIVE HAS BEEN PROCESSED. #
        BEGIN 
      ATTACHM (RC);                #  ATTACH ALL REQUIRED FILES.       #
      IF RC NQ 0 THEN              # ERROR IN ATTACHING--CLOSE FILES,  #
        BEGIN                      # RETURN SPACE, AND RETURN.         #
        CLOSEAREA;
        RELEASESPACE; 
        RETURN; 
        END 
        END 
      OPENAREA (RC);               # OPEN ALL REQUIRED AREAS.          #
  
      IF RC NQ 0                   #   ERROR                           #
      THEN
        BEGIN 
        CLOSEAREA;
        RELEASESPACE; 
        RETURN; 
        END 
  
        IF FITFO EQ FOIS           # IF *IS* FILE                      #
          AND FITDKI               # IF DUPLICATE KEYS                 #
        THEN
          BEGIN 
          FILEDKI = TRUE; 
          LKEYWD = (KT$LENGTH[1] + 9) / 10; 
                                   # LENGTH OF PRIMARY KEY IN WORDS    #
          P<DKIKEY> = CMM$ALF(LKEYWD, 0, 0);
                                   # THIS ARRAY WILL ONLY BE USED FOR  #
                                   # DISPLAY KEY IN WHICH CASE ONLY ONE#
                                   # AREA IS IN USE.                   #
          END 
      IF KEYLIT NQ 0 THEN          # DISPLAY KEY LITERAL               #
        BEGIN 
        AREALOC = P<AREA$TABLE>;
        KEYLITM (RC);              # GET THE RECORD                    #
        IF RC NQ 0 THEN 
          BEGIN 
          IF (OWNFORCD + OWNREJ NQ 0)  # IF ANY FORCED OR REJECTED BY  #
                                       # DATABASE PROCEDURES           #
            AND NOT PERFLG             # AND NOT PERFORMING            #
          THEN
            BEGIN 
            DIAG (1003, OWNFORCD, OWNREJ);  #DISPLAY FORCED/REJECTD MSG#
                             # REINITIALIZE FORCED AND REJECTED FIELDS #
            OWNFORCD = 0; 
            OWNREJ = 0; 
            END 
          CLOSEAREA;
          RELEASESPACE; 
          RETURN; 
          END 
        END 
      IF DESPASS THEN FILEPASS = TRUE;
      IF FROMKEYINFIT NQ 0         # IF *FROM* OR *KEY IN* FILE        #
      THEN
        BEGIN 
        KEYLIT = 1;                # SET SO ACCESS/HIT/IO MSG IS ISSUED#
        SETDISFROM(RC); 
        IF RC NQ 0
        THEN
          BEGIN 
          CLOSEAREA;
          RELEASESPACE; 
          RETURN; 
          END 
        END 
      IF FILEPASS THEN
        BEGIN 
      IF CURRELLOC  NQ 0 THEN      # RELATIONAL QUERY. GET FIRST RECORD#
                                   #  SET.                             #
        BEGIN 
        P<REL$TABLE> = CURRELLOC; 
        SORTBYORD;                 # SORT BY RELATION ORDINAL AND GET  #
                                   # LIST OF AREAS IN RELATION--SUBSET #
                                   # OF -SAVDAREA-.                    #
        READAREA = 1;              # READ FROM ROOT LEVEL FIRST.       #
        SCANALLAREA = TRUE; 
        GETRECORDSET(RC); 
        IF RC  EQ 2 THEN           #  NO ROOT RECORD QUALIFIES.        #
          BEGIN 
          DIAG (1009);             # NO RECORD FOUND.                  #
          CLOSEAREA;
          RELEASESPACE; 
          RETURN; 
          END 
        IF RC EQ 3 THEN            # CRM ERROR-ALREADY DIAGNOSED.      #
          BEGIN 
          CLOSEAREA;
          RELEASESPACE; 
          RETURN; 
          END 
        IF RC EQ 0                 # IF COMPLETE RECORD SET            #
        THEN
          BEGIN 
          ACCESSES = ACCESSES + 1;  # INCREMENT NO. OF RECORDS READ FOR#
                                    # DIAG 1006 MESSAGE                #
          END 
        END 
      ELSE                         # SINGLE AREA QUERY.                #
        BEGIN 
        AREALOC = P<AREA$TABLE>;
        ATPTR = P<AREA$TABLE>;     # SAVE TO SET IN *NEXTGET*          #
        NEXTGET (RC); 
        P<AREA$TABLE> = ATPTR;     # KEEP ANY CHANGE MADE IN *NEXTGET* #
        IF RC EQ 2 THEN            # ERROR--DIAGNOSE AND QUIT.         #
          BEGIN 
          IF DESPASS               # IF *DISPLAY FROM*                 #
          THEN
            BEGIN 
            P<FIT> = FROMKEYINFIT;  # *FROM* FIT                       #
            END 
          ELSE
            BEGIN 
            P<FIT> = LOC(AT$AFITPOS);  # AREA FIT                      #
            END 
          DIAG(903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR CODE        #
          CLOSEAREA;
          RELEASESPACE; 
           RETURN;
          END 
        ELSE
          BEGIN 
          IF RC NQ 0 THEN          # NO RECORD QUALIFIED.              #
            BEGIN 
            DIAG (1009);           # PRINT MESSAGE AND RETURN.         #
            CLOSEAREA;
            RELEASESPACE; 
            RETURN; 
            END 
          ELSE
            BEGIN 
            ACCESSES = ACCESSES + 1;  # INCREMENT NO. RECORDS READ FOR #
                                      # DIAG 1006 MESSAGE              #
            END 
          END 
        END 
        END 
      BASICLOOP;                   # PROCESS THE DIRECTIVES FOUND IN   #
                                   # THE BASICTABLE.                   #
      CLOSEAREA;                   #  UPON COMPLETION, CLOSE ALL AREAS,#
                                   # RELEASE SPACE, AND RETURN.        #
      RELEASESPACE; 
      RETURN; 
      END 
#                                      #
      PROC CLEANUP; 
# SMALL PROC USED BY -CTL40- TO RELEASE SPACE AND CLOSE THE AREA   #
      BEGIN 
      CLOSEAREA;                                                         CTL30
      RELEASESPACE;                                                      CTL30
      RETURN; 
      END  # CLEANUP #
*CALL ATTACHF 
      CONTROL EJECT;
      PROC ATTACHM (RC);
#                                      #
#        A T T A C H M                 #
#                                      #
# THIS PROC ATTACHES ALL FILES NEEDED BY -CTL40-. THE RETURN CODE -RC- #
# IS ZERO IF ALL ATTACHES SUCCEEDED, ONE IF ANY ATTACH FAILED. #
  
      BEGIN 
      ITEM RC I;               # RETURN CODE FOR CALLING ROUTINE #
      ITEM LOOPCON B; 
      ITEM TBLPTR;
      ITEM RC1 I;              # RETURN CODE FROM -ATTACHF- CALL #
  
#                                                                      #
# ATTACH ALL AREA FILES WHICH HAVE THE -AREAINUSE- BIT SET IN THE      #
# ARRAY -SAVEAREA-.  THE FILES ARE ATTACHED IN ALPHABETICAL ORDER      #
# SO THAT A "DEADLY EMBRACE" IS AVOIDED.                               #
      LOOPCON = TRUE; 
      RC=0; 
      IF REFERFILE EQ 0            # IF NO AREAS IN USE                #
      THEN
        BEGIN 
        RETURN; 
        END 
      FOR DUMMY = 1 STEP 1 WHILE LOOPCON DO 
        BEGIN 
        TBLPTR = SAVEORD[DUMMY];
        IF AREASAVE[TBLPTR] EQ 0 THEN             # NO MORE AREAS TO   #
          BEGIN                                  # ATTACH.  TERMINATE  #
          LOOPCON = FALSE;                       # LOOP AND EXIT.      #
          TEST DUMMY; 
          END 
        IF AREAINUSE[TBLPTR] THEN                 # THIS AREA SHOULD BE#
          BEGIN                                  # ATTACHED. SET UP FDB#
          IF RC NQ 0 THEN          # ERROR HAS OCCURRED. TURN OFF -IN  #
                                   # USE- FLAG.                        #
            BEGIN 
            AREAINUSE[TBLPTR] = FALSE;
            TEST DUMMY; 
            END 
          P<AREA$TABLE> = AREASAVE[TBLPTR];       # AND ATTACH.        #
          IF AT$INDFDB NQ 0 THEN
            BEGIN 
            P<FDBINDEX> = P<AREA$TABLE> + AT$INDFDB;
            P<AREAFIT> = LOC(AT$AFITPOS[0]);
            P<FIT> = P<AREAFIT>;                                         CTL30
            FITXN = INDXNAM[4];                                          CTL30
            END 
          P<FDBAREA> = LOC(AT$AFDBPOS[0]);
          IF NOT AT$TEMPA[0] THEN  # NOT A TEMPORARY AREA.             #
            BEGIN 
          RC1 = 0;                                                       CTL30
          ATTACHF(FDBAREA, TRUE, RC1);
          RC = RC1; 
          IF RC NQ 0 THEN                        # ERROR IN ATTACH.    #
            BEGIN                                # RETURN WITH RC NON- #
            AREAINUSE[TBLPTR] = FALSE;
            TEST DUMMY; 
            END 
          IF AT$INDFDB NQ 0 THEN                 # ATTACH INDEX FILE,  #
            BEGIN                                # IF THERE IS ONE.    #
            P<FDBINDEX> = P<AREA$TABLE> + AT$INDFDB;
            ATTACHF(FDBINDEX, TRUE, RC1); 
            RC = RC1; 
            IF RC NQ 0 THEN                      # ERROR IN ATTACH.    #
              BEGIN                              # EXIT WITH RC NON-   #
              AREAINUSE[TBLPTR] = FALSE;
              TEST DUMMY; 
              END 
            END 
            END 
          END 
        END                                      # END OF -DUMMY- LOOP #
      RETURN; 
      END                                        # END OF ATTACHM.     #
      CONTROL EJECT;
      PROC BASICLOOP; 
#                                      #
#        B A S I C L O O P             #
#                                      #
# THIS PROC IS THE GUTS OF -CTL40-. IT IS THE INTERFACE WITH ALL OF THE#
# DIRECTIVES TO BE PROCESSED BY THIS OVERLAY.  #
      BEGIN 
      ITEM RCB; 
      ITEM FINISHED B = FALSE; # FLAG TO GET OUT OF RECORD PASS LOOP  # 
      ITEM ENDBASICTAB B;      # FLAG TO GET OUT OF BASIC TABLE LOOP   #
      SWITCH DIRECTIVE
        ENDBT,         #  0 # 
        DISPLAYLAB,    #  1 # 
        DIRERROR,                  # 2--DELETE                         #
        DIRERROR,                  #  3--DELETE USING                  #
        DIRERROR,                  # 4--INSERT                         #
        DIRERROR,                  # 5--INSERT USING                   #
        DIRERROR,                  #  6--UPDATE                        #
        DIRERROR,                  #  7--UPDATE USING                  #
        RESERVED,      #  8 # 
        MOVE,                      # 9--MOVE DIRECTIVE                 #
        EVALUATE,                  # 10--EVALUATE                      #
        IFLABEL,       # 11 # 
        EXTRACT,       # 12 # 
        RESERVED,      # 13 # 
        RESERVED,      # 14 # 
        CONTINUELAB,   # 15 # 
        MODIFY;        # 16 # 
      ITEM DISPLAYRC I = 0;    # RETURN CODE FROM -DISPLAY-  #
      ITEM DUMMY1;                                                       CTL30
                                                                         CTL30
      FOR DUMMY=DUMMY                                                    CTL30
        WHILE NOT FINISHED                                               CTL30
      DO                                                                 CTL30
        BEGIN                  # LOOP THRU AREA FILE   #
        ENDBASICTAB = FALSE;
        TRUEIF = TRUE;
        P<BASICTABLE> = BASTABLOC;
        BASCPTR = BASTABLOC;
        IF (BASCODE[0] NQ IFCODE AND FILEPASS) THEN 
          CHKMAT(ENDBASICTAB);                                           CHANGES
        BASTABIND = -1; 
        FOR DUMMY1=DUMMY1                                                CTL30
          WHILE NOT ENDBASICTAB                                          CTL30
        DO                                                               CTL30
          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#
          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;                                                 CTL30
DISPLAYLAB: 
            DISPLAY(DISPLAYRC);                                          CTL30
            IF DISPLAYRC EQ 1                                            CTL30
            THEN                                                         CTL30
              BEGIN                                                      CTL30
              ENDBASICTAB = TRUE;                                        CTL30
              END                                                        CTL30
            TEST DUMMY1;
ENDBT:  
            ENDBASICTAB = TRUE; 
            TEST DUMMY1;                                                 CTL30
  
 EVALUATE:  
            EXCEV;
            TEST DUMMY1;                                                 CTL30
EXTRACT:  
            EXTRACTM;                                                    CTL30
            TEST DUMMY1;                                                 CTL30
IFLABEL:  
            IFM(TRUEIF);                                                 CTL30
            TEST DUMMY1;                                                 CTL30
  
MODIFY: 
            MODIFYM;
            TEST DUMMY1;
  
 MOVE:  
          MOVEM;
          TEST; 
RESERVED:                      # RESERVED FOR FUTURE EXPANSION OF  #
            TEST DUMMY1;                                                 CTL30
DIRERROR: 
            ENDBASICTAB = TRUE; 
            FINISHED = TRUE;
            TEST DUMMY1;                                                 CTL30
            END 
          END  # ENDBASICTAB   #
        FINISHED = NOT (FILEPASS OR GETDKI);
        ENDBASICTAB = FALSE;
        IF FILEPASS THEN
          BEGIN 
          IF TRUEIF                # IF -IF- CONDITION IS TRUE         #
          THEN
            BEGIN 
            HITS = HITS + 1;       # INCREMENT TOTAL NUMBER OF HITS    #
            END 
          IF CURRELLOC NQ 0 THEN   #  RELATIONAL PROCESSING.           #
            BEGIN 
            GETRECORDSET (RCB);    # GET NEXT RECORD SET.              #
            IF RCB EQ 0                  # IF COMPLETE RECORD SET      #
            THEN
              BEGIN 
              ACCESSES = ACCESSES + 1;   # INCREMENT NO. RECORDS READ  #
                                         # FOR DIAG 1006 MESSAGE       #
              END 
            IF RCB EQ 2 THEN       # EOI ON ROOT RECORD--PROCESSING IS #
              BEGIN                # COMPLETE.                         #
              FINISHED = TRUE;
              END 
            IF RCB EQ 3 THEN       # ERROR.                            #
              BEGIN 
              FINISHED = TRUE;
              END 
            END 
          ELSE                     # NON-RELATIONAL PROCESSING.        #
            BEGIN 
            ATPTR = P<AREA$TABLE>;   # SAVE TO SET IN *NEXTGET*        #
            NEXTGET (RC); 
            P<AREA$TABLE> = ATPTR; # KEEP ANY CHANGE MADE IN *NEXTGET* #
            IF RC EQ 2 THEN 
              BEGIN 
              IF DESPASS           # IF *DISPLAY FROM*                 #
              THEN
                BEGIN 
                P<FIT> = FROMKEYINFIT;  # *FROM* FIT                   #
                END 
              ELSE
                BEGIN 
                P<FIT> = LOC(AT$AFITPOS);  # AREA FIT                  #
                END 
              DIAG(903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR CODE    #
              END 
            IF RC NQ 0 THEN 
              BEGIN 
              FINISHED = TRUE;
              END 
            ELSE
              BEGIN 
              ACCESSES = ACCESSES + 1;  # INCREMENT NO. RECORDS READ   #
                                        # FOR DIAG 1006 MESSAGE        #
              END 
            END 
          END 
        IF GETDKI                  # IF GET DUPLICATE PRIMARY KEY      #
        THEN
          BEGIN 
          GETIO;                   # READ NEXT RECORD                  #
          IF DIAGNO NQ 0           # IF NO MORE DUPLICATES             #
          THEN
            BEGIN 
            FINISHED = TRUE;       # EXIT BASIC LOOP                   #
            END 
          END 
        IF DISPLAYRC NQ 0 THEN FINISHED = TRUE; 
        END    # FINISHED  #
      IF (FILEPASS                 # IF PASSING THE DESCRIBE FILE      #
          AND NOT PERFLG)          #  AND NOT PERFORMING               #
        OR (KEYLIT NQ 0            # OR KEY WAS SPECIFIED              #
          AND NOT PERFLG)          #  AND NOT PERFORMING               #
      THEN
        BEGIN 
        DIAG (1006, ACCESSES, HITS, IOS);  # DISPLAY HIT/ACCESS/IO MSG #
                             # REINITIALIZE ACCESSES HITS AND IOS      #
        ACCESSES = 0; 
        HITS = 0; 
        IOS = 0;
        IF OWNFORCD + OWNREJ NQ 0  # IF ANY RECORDS FORCED OR REJECTED #
                                   # BY DATABASE PROCEDURES            #
        THEN
          BEGIN 
          DIAG (1003, OWNFORCD, OWNREJ);  # DISPLAY FORCED/REJECTED MSG#
                             # REINITIALIZE FORCED AND REJECTED FIELDS #
          OWNFORCD = 0; 
          OWNREJ = 0; 
          END 
        END 
      RETURN; 
      END 
  
      CONTROL EJECT;
      XDEF PROC CALLOWN;
*CALL     CALLOWN 
*CALL CHKMAT
      XDEF PROC CHKRET;            # SO NEXTGET CAN CALL IT            #
*CALL CHKRET
      CONTROL EJECT;
      PROC CLOSEAREA; 
#                                      #
#        C L O S E A R E A             #
#                                      #
# PROC TO CLOSE THE AREA, LOG FILE AND -DIS-FROM- FILES    #
      BEGIN 
                                                                         CTL30
      ITEM LOOPCON B; 
      ITEM BC I;                   # BASIC TABLE CODE                  #
      ITEM FINISHED B;             # LOOP CONTROL                      #
                                                                         CTL30
      IF REFERFILE NQ 0 THEN                     # AREA FILE(S) USED.  #
        BEGIN                                    # THIS LOOP CLOSES AND#
        LOOPCON = TRUE;                          # RETURNS AREA FILES  #
                                                 # WHICH ARE OPEN.     #
        FOR DUMMY = 1 STEP 1 WHILE LOOPCON DO 
          BEGIN 
            IF AREAINUSE[DUMMY] THEN             # THIS AREA IS IN USE.#
              BEGIN 
              P<AREA$TABLE> = AREASAVE[DUMMY];   # SET UP BASED ARRAYS #
              ATPTR = P<AREA$TABLE>; # KEEP TRACK OF AREA$TABLE POSN   #
              P<AREAFIT> = LOC(AT$AFITPOS[0]);   # FROM TABLE ADDRESS  #
              P<FIT> = P<AREAFIT>;                                       CTL30
                                                 # WHICH WAS SAVED.    #
              IF FITOC EQ 1        # FILE IS OPEN                      #
                AND NOT AT$DBPSRH  # AND NO ON"SEARCH" EXIT            #
              THEN
                BEGIN 
                CALLOWN(ON"CLOSE", RC);  # TRY CALLING *CLOSE* DBP     #
                CLOSEM(FIT, $DET$, RA0);  # CLOSE FILE, RELEASE BUFFERS#
                IF FITES NQ 0      # IF AN ERROR ON CLOSING            #
                THEN
                  BEGIN 
                  DIAG(903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR     #
                  FITES = 0;       # RESET FIT ERROR FIELD             #
                  END 
                END 
              IF AT$DBPOC          # IF ON"OPEN" HAS BEEN CALLED       #
                AND AT$DBPSRH      # AND ON"SEARCH" EXIT PROVIDED      #
              THEN
                BEGIN 
                CALLOWN(ON"CLOSE", RC);  #CALL *CLOSE* DBP             #
                AT$DBPOC = FALSE;  # AND FLAG IT                       #
                END 
            IF NOT AT$TEMPA[0] AND USEDIR THEN   # RETURN NON-TEMPORARY#
            BEGIN                                # FILES.              #
                RETURNM(FIT, RA0);                                       CTL30
            IF AT$INDFDB[0] NQ 0 THEN            # IF THERE IS AN INDEX#
              BEGIN                              # FILE, RETURN IT.    #
              RETURNM(C<0,7>FITXN, RA0);
              END 
            END 
          END 
          IF AREASAVE[DUMMY + 1] EQ 0 THEN       # NO MORE AREAS TO    #
            BEGIN                                # CLOSE AND RETURN.   #
            LOOPCON = FALSE;                     # EXIT LOOP.          #
            TEST DUMMY; 
            END 
          END                                    # END OF -DUMMY- LOOP.#
        END 
        IF FROMKEYINFIT NQ 0       # IF *FROM* OR *KEY IN* FILE        #
        THEN
          BEGIN 
          P<FIT> = FROMKEYINFIT;
          CLOSEFILE;
          END                                                            CTL30
      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;
*CALL CLOSEFILE 
      CONTROL EJECT;
      PROC DISPLAY (DISPLAYRC); 
#                                      #
#        D I S P L A Y                 #
#                                      #
#  THIS PROC PROCESSES THE DISPLAY DIRECTIVE. IT IS A LARGE KLUGE. #
      BEGIN 
                                                                         CTL30
      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);
                                                                         CTL30
      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 OC$OPEN        # IF FILE NOT OPEN                  #
        THEN
          BEGIN 
          FITBBH = TRUE;           # ALLOCATE BUFFERS BELOW HHA        #
          OPENM (FIT, $IO$, $N$, RA0);                                  000130
          IF FITES NQ 0 THEN       #ERROR IN OPENING FILE.             # CTL30
            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[1];  # ASSUME FILE CONTAINS KEY ONLY    #
            L$WSA = CMM$ALF((KT$PICLEN[1] + 9) / 10, 0, 0); 
            FITWSA = L$WSA; 
            END 
          CVW1[0] = 0;
          CVW2[0] = 0;
          CVCODE[0] = KT$TYPE[1] + 1; 
          CVFRADD[0] = FITWSA;
          CVTOADD[0] = P<AREA$TABLE> + AT$CURRKEY[0]; 
          CVLG[0] = KT$PICLEN[1]; 
          IF KT$TYPE[1] NQ 7       # USE ATTRIBUTE EXCEPT FOR LOGICAL  #
          THEN                                                           QU3A094
            BEGIN 
            CVTOADD[0] = LOC(ATTRIB) -1;
            ATTRCLS[0] = KT$TYPE[1];
            ATTRWP[0] = P<AREA$TABLE> + AT$CURRKEY[0];
            ATTRBP[0] = 0;
            ATTRSIZE[0] = KT$LENGTH[1]; 
            ATTDPTLC[0] = KT$DPTLOC[1]; 
            END 
        CONTIN: # # 
          P<FIT> = FROMKEYINFIT;   # POSITION TO *KEY IN* FIT          #
          GET(FIT,RA0); 
          IF FITES NQ 0            # IF A CRM ERROR OCCURED            #
          THEN
            BEGIN 
            DIAG(903,FITES,FITLFNC);  # DIAGNOSE CRM ERROR             #
            RETURN; 
            END 
          IF FITFP EQ O"100" THEN  #EOF OR EOI                         # CTL30
             BEGIN
             DISPLAYRC = 1;    # SET EOF STATUS AND EXIT"  #
             RETURN;
             END
          IF FITFP NQ O"20" THEN                                         CTL30
            BEGIN                                                        CTL30
            GOTO CONTIN;                                                 CTL30
            END                                                          CTL30
          ELSE
            BEGIN 
            IOS = IOS + 1;         # INCREMENT NO. CRM ACCESSES FOR    #
                                   # DIAG 1006 MESSAGE                 #
            END 
  
            CONVERT(CVTIN,M); 
            IF M NQ 0 THEN
              BEGIN 
              DIAG(805);
              RETURN; 
              END 
            GETIO;
            IF DIAGNO NQ 0 THEN 
              BEGIN 
              IF DIAGNO EQ 816     # IF SOME CRM ERROR                 #
                AND FITES NQ UNKNOWNKEY  # IF NOT UNKNOWNKEY           #
                AND FITES NQ AKUNKNOWNKEY  # IF NOT UNKNOWN AK KEY     #
              THEN
                BEGIN 
                RETURN; 
                END 
              GOTO CONTIN;         #GET NEXT KEY                       #
              END 
            IF FILEDKI             # IF FILE HAS DUPLICATE PRIM KEYS   #
            THEN
              BEGIN 
              FOR DUMMY = 0 STEP 1
                UNTIL LKEYWD - 1
              DO
                BEGIN 
                DKIKEYWD[DUMMY] = IKEY[DUMMY];  # SAVE VALUE OF PR KEY #
                END 
              GETDKI = TRUE;       # TELL GETIO TO GET DUPLICATES      #
              END 
START1: 
            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 ON THE PUT....           # CHANGES
              THEN
                BEGIN 
                DIAG(903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR CODE  #
                END 
              END 
            ELSE
     BEGIN
      DIAGNO = 0; 
      RELCALLOWN (ON"DISPLAY", RC);  # CALL THE *DISPLAY* DBP FOR      #
                                     # SINGLE OR MULTIPLE FILE QUERY   #
      IF RC EQ 1 THEN              # IF SHOULD NOT DISPLAY             #
        BEGIN 
        GOTO DLOOP; 
        END 
      WRITEBL (LINE, UPLGCH, M);
      IF M NQ 0 THEN
        BEGIN 
        DISPLAYRC = 1;
        RETURN; 
        END 
            END 
        IF (NOT FILEPASS           # IF HITS NOT ALREADY INCREMENTED   #
          AND KEYLIT NQ 0)
        THEN
          BEGIN 
          HITS = HITS + 1;         # INCREMENT NO OF HITS              #
          END 
 DLOOP:    # END OF DISPLAY UNLESS KEY IN SPECIFIED # 
          IF BASCKEY3[BASTABIND]   # IF *KEY IN*                       #
          THEN
            BEGIN 
            UPLG = UPLGSAVE;       # RESET UPLG IN CASE CHANGED BY     #
                                   # *ALL* SUBSCRIPT                   #
            UPLGCH = SAVEUPLGCH;   # RESTORE ORIGINAL CHAR LENGTH      #
            IF GETDKI              # IF READING DUPLICATES             #
            THEN
              BEGIN 
              GETIO;               # READ NEXT DUPLICATE               #
              IF DIAGNO EQ 0       # IF DUPLICATE READ                 #
              THEN
                BEGIN 
                GOTO START1;
                END 
              END 
            GOTO CONTIN;
            END 
            RETURN; 
      END 
      P<DTABLEPTR> = P<DTABLE> + DTP; 
   SWITCH DISTY DISMOV,DISMOV,DISCVT,DISEVA,DISSUB; 
      GOTO DISTY[CPTYPE[DTP]];
   DISMOV: # #
      MOVEC(DTABLEPTR); 
      GOTO NXT; 
   DISCVT: # #
      CONVERT(DTABLEPTR,M); 
      IF M EQ 51                   # IF INVALID CHARACTER IN NUM FIELD #
      THEN
        BEGIN 
        M = 217;                   # USE DIAG WITHOUT <C> OR <N>       #
        END 
  
      IF M NQ 0                    # IF CONVERT ERROR OCCURED          #
      THEN
        BEGIN 
        DIAG(M);                   # ISSUE DIAGNOSTIC                  #
        END 
  
      IF M NQ 0                    # IF AN ERROR OCCURED ON THE CONVERT#
        AND M NQ 360               # IF IT WAS NOT A ROUNDING ERROR    #
        AND M NQ 54                # IF IT WAS NOT A TRUNCATION ERROR  #
      THEN                         # THEN WE WILL NOT IGNORE THE ERROR #
        BEGIN 
        RETURN; 
        END 
      GOTO NXT; 
   DISEVA: # #
      LOGICALRESLT = FALSE; 
      PROGSTACKLOC = CPSTACK[DTP+1];
      EXPEVAL(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);                                        CTL30
                        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);                                                         CTL30
        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; 
      PROC GETALTKEY (PTRTOAREA, POSITIONED, RCA);
      BEGIN 
#----------------------------------------------------------------------#
#     G E T A L T K E Y                                                #
# THIS PROC DOES A GET BY ALTERNATE KEY, OR A GETN IF THE FILE IS      #
# POSITIONED. PTRTOAREA IS THE ADDRESS OF THE AREA TABLE TO BE         #
# ACCESSED. RCA IS THE RETURN CODE--0 = SUCCESSFUL GET (JOIN TERMS     #
# MATCH), 1 = JOIN TERMS DO NOT MATCH, 2 = EOI, 3 = CRM ERROR.         #
#                                                                      #
#----------------------------------------------------------------------#
                                                                         CTL30
      ITEM PTRTOAREA; 
      ITEM POSITIONED B;
      ITEM RCA; 
      ITEM REJ B;                  # TRUE IF DBP REJECTS THE RECORD    #
      ITEM TRUERESULT B;
                                                                         CTL30
      P<AREA$TABLE> = PTRTOAREA;
      ATPTR = P<AREA$TABLE>;       # KEEP TRACK OF AREA$TABLE POSN     #
      P<AREAFIT> = LOC(AT$AFITPOS[0]);
      P<FIT> = P<AREAFIT>;                                               CTL30
      IF NOT POSITIONED            # MUST DO -GET- TO POSITION FILE    #
      THEN
        BEGIN 
        P<KEY> = P<AREA$TABLE> + AT$CURRKEY[0]; 
        P<AREA$TABLE> = RR$AREAPTR[0];
        P<AREAFIT> = LOC(AT$AFITPOS[0]);
        P<FIT> = P<AREAFIT>;                                             CTL30
        WRDADDR = FITWSA + RR$BWP[0];  #MOVE VALUE IN RECORD TO -KEY-  # CTL30
        P<COMP1> = WRDADDR; 
        CMOVE (COMP1, RR$BCP[0], RR$LENGTH, KEY, 0);
        P<AREA$TABLE> = PTRTOAREA;
        P<AREAFIT> = LOC(AT$AFITPOS[0]);
        P<FIT> = P<AREAFIT>;
        SAVERL = FITRL;            #SAVE RECORD LENGTH--RESTORE LATER. # CTL30
        FITKP = 0;                 # CHARACTER POSITION OF KEY IS 0    #
        FITRL = 0;                                                       CTL30
        IF RR$AMAJKEY[1]           # IF JOINED ON MAJOR ALTERNATE KEY  #
        THEN
          BEGIN 
          FITKL = RR$AKSIZE[1];    # SIZE OF ALTERNATE KEY             #
          FITMKL = RR$LENGTH[1];   # SIZE OF MAJOR ALTERNATE KEY       #
          END 
        ELSE                       # IF JOINED ON ALTERNATE KEY        #
          BEGIN 
          FITKL = RR$LENGTH[1];    # SIZE OF ALTERNATE KEY             #
          END 
  
        IF RR$AKSUBN[1]            # IF JOIN ON ITEM(N)                #
        THEN
          BEGIN 
          FITRKW = RR$AKBWP[1];    # BEG WORD POSITION OF ITEM(1)      #
          FITRKP = RR$AKBCP[1];    # BEG CHARACTER POSITION OF ITEM(1) #
          END 
        ELSE
          BEGIN 
          FITRKW = RR$BWP[1];      # BEGINNING WORD POSITION OF ALT KEY#
          FITRKP = RR$BCP[1];      # BEGINNING CHAR POSITION OF ALT KEY#
          END 
  
        FITKA = P<KEY>;                                                  CTL30
        P<RECORD> = FITWSA;                                              CTL30
        DBP$ACTION = 2;            # DBP SHOULD DO *GET*               #
        CALLOWN(ON"SEARCH", DBPRC); 
        IF DBP$DID                 # IF A DBP WAS CALLED               #
        THEN
          BEGIN 
          IF DBPRC EQ 1            #   AND NO RECORD RETRIEVED, EXIT.  #
          THEN
            BEGIN 
            IF FITES EQ 0 
            THEN
              BEGIN 
              RCA = 2;             # NO MATCH, EOI.                    #
              END 
            ELSE
              BEGIN 
              IF FITES EQ UNKNOWNKEY
              OR FITES EQ UNKNWNALTKEY
              THEN
                BEGIN 
                RCA = 1;           # JOIN TERMS DONT MATCH             #
                END 
              ELSE
                BEGIN 
                RCA = 3;           # SOME OTHER DBP ERROR              #
                END 
              END 
            RETURN; 
            END 
          IOS = IOS + 1;
          GOTO DBPCONT1;           # ELSE, GO CHECK ON RETRIEVED RECORD#
          END 
  
        GET(FIT, RECORD, KEY, RA0);  #POSITION FILE--GET RECORD.       # CTL30
        IF RR$ALTKEY[1]            # IF JOINED ON ALTERNATE KEY        #
        THEN
          BEGIN 
          RELRC[READAREA] = FITRC - 1;  # NO. OF REMAINING DUPLICATES  #
          END 
        IF FITFP EQ O"100"         #EOI--NO MATCH.                     # CTL30
        THEN                                                             CTL30
          BEGIN 
          RCA = 2;
          FITES = 0;                                                     CTL30
          RETURN; 
          END 
        ELSE
          BEGIN 
          IF FITES NQ 0 THEN       #ERROR IN -GET-                     # CTL30
            BEGIN                                                        CTL30
            IF FITES EQ UNKNOWNKEY                                       CTL30
              OR FITES EQ UNKNWNALTKEY THEN                              CTL30
              BEGIN 
              RCA = 1;
              RETURN; 
              END 
            ELSE
              BEGIN 
              DIAG(903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR CODE    #
              RCA = 3;             # FATAL ERROR.                      #
              RETURN; 
              END 
            END 
          ELSE
            BEGIN 
            IOS = IOS + 1;         # INCREMENT NO. CRM ACCESSES FOR    #
                                   # DIAG 1006 MESSAGE                 #
            END 
          END 
  
        CHKRET(REJ);               # CHECK *ON RETRIEVAL* PROCEDURE    #
        IF REJ                     # IF DBP SAID IGNORE THE RECORD     #
        THEN
          BEGIN 
          RCA = 1;                 # NO RECORD READ                    #
          RETURN; 
          END 
  
DBPCONT1: 
        POSITIONED = TRUE;
        TRUERESULT = TRUE;         # ASSUME GOOD RECORD                #
        IF RR$AKSUBN[1]            # IF JOIN ON ITEM(N)                #
          AND NOT RR$ANYFLG[1]     # NOT JOINED ON ITEM(ANY)           #
        THEN
          BEGIN 
          COMPAREFIELD(TRUERESULT);  # CRM GIVES RECORD JOINED ON      #
                                     # ITEM(ANY).  WE CHECK IF JOINED  #
                                     # ON ITEM(N)                      #
          END 
        IF TRUERESULT              # IF GOOD RECORD                    #
        THEN
          BEGIN 
          IF RR$RESTBLPTR[1] EQ 0  # IF NO RESTRICT                    #
          THEN
            BEGIN 
            RCA = 0;               # GOOD RECORD, FILE POSITIONED      #
            RETURN; 
            END 
          PROGSTACKLOC = RR$RESTBLPTR[1]; 
          RESTRICTER(RCA);         # EVALUATE RESTRICT STACK           #
          IF RCA EQ 0              # IF RECORD QUALIFIES               #
          THEN
            BEGIN 
            RETURN;                # GOOD RECORD, FILE POSITIONED      #
            END 
          END 
        END                        # END IF NOT POSITIONED             #
  
                                   # FILE IS POSITIONED.  DO GETN TO   #
                                   # OBTAIN NEXT RECORD                #
  
      FOR DUMMY = DUMMY 
        WHILE TRUE
      DO
        BEGIN 
        IF RR$ALTKEY[1]            # IF JOINED ON ALTERNATE KEY        #
        THEN
          BEGIN 
          IF RELRC[READAREA] LQ 0  # IF NO REMAINING RECORDS WITH THE  #
                                   # SAME ALTERNATE KEY VALUE          #
          THEN
            BEGIN 
            RCA = 1;               # NO RECORD, FILE NOT POSITIONED    #
            RETURN; 
            END 
          RELRC[READAREA] = RELRC[READAREA] - 1;  # ONE FEWER RECORDS  #
                                                  # WITH THIS KEY      #
          END 
  
        P<RECORD> = FITWSA; 
        P<KEY> = P<AREA$TABLE> + AT$CURRKEY[0]; 
        DBP$ACTION = 3;            # DBP SHOULD DO *GETN*              #
        CALLOWN(ON"SEARCH", DBPRC); 
        IF DBP$DID                 # IF A DBP WAS CALLED               #
        THEN
          BEGIN 
          IF DBPRC EQ 1            #   AND NO RECORD RETRIEVED, EXIT.  #
          THEN
            BEGIN 
            IF FITES EQ 0 
            THEN
              BEGIN 
              RCA = 2;             # NO MATCH, EOI.                    #
              END 
            ELSE
              BEGIN 
              RCA = 3;             # SOME OTHER DBP ERROR              #
              END 
            RETURN; 
            END 
          IOS = IOS + 1;
          GOTO DBPCONT2;           # ELSE, GO CHECK ON RETRIEVED RECORD#
          END 
  
        GETN(FIT, RECORD, KEY, RA0);
        IF FITFP EQ O"100"         # END OF INFORMATION                #
        THEN
          BEGIN 
          RCA = 2;                 # EOI, NO RECORD                    #
          RETURN; 
          END 
  
        IF FITES NQ 0              # ERROR IN GETN.  DIAGNOSE.         #
        THEN
          BEGIN 
          DIAG(903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR CODE        #
          RCA = 3;                 # ERROR RETURN CODE                 #
          RETURN; 
          END 
        ELSE
          BEGIN 
          IOS = IOS + 1;           # INCREMENT NO. CRM ACCESSES FOR    #
                                   # DIAG 1006 MESSAGE                 #
          END 
  
        CHKRET(REJ);               # CHECK *ON RETRIEVAL* PROCEDURE    #
        IF REJ                     # IF DBP SAID IGNORE THE RECORD     #
        THEN
          BEGIN 
          RCA = 1;                 # NO RECORD READ                    #
          RETURN; 
          END 
  
DBPCONT2: 
        IF RR$AMAJKEY[1]           # IF JOINED ON MAJOR ALTERNATE KEY  #
          AND RR$AKSUBN[1]         # ITEM(ANY) OR ITEM(N)              #
        THEN
          BEGIN 
          COMPAREWSA = FALSE;      # COMPARE KEY                       #
          COMPAREFIELD(TRUERESULT);  # SEE IF RECORD JOINED            #
          COMPAREWSA = TRUE;       # RESET TO COMPARE FIELD WITHIN REC #
          IF NOT TRUERESULT 
          THEN
            BEGIN 
            RCA = 1;               # NO RECORD, FILE NOT POSITIONED    #
            RETURN; 
            END 
          END 
  
        IF NOT RR$ANYFLG[1]        # IF ITEM(N) OR NON-SUBSCRIPTED     #
          AND (RR$AMAJKEY[1]       # IF MAJOR ALTERNATE KEY            #
            OR (RR$ALTKEY[1]       # IF ALTERNATE KEY                  #
              AND RR$AKSUBN[1]))   # IF ITEM(N)                        #
        THEN
          BEGIN 
          COMPAREFIELD(TRUERESULT); 
          IF NOT TRUERESULT        # IF FIELDS DO NOT COMPARE          #
          THEN
            BEGIN 
            IF RR$AKSUBN[1]        # IF ITEM(N) OR ITEM(ANY)           #
              AND NOT RR$ANYFLG[1] # IF NOT ITEM(ANY)                  #
                                   # FILE POSITIONED, (ITEM(ANY) IS    #
                                   # JOINED) BUT ITEM(N) NOT JOINED    #
            THEN
              BEGIN 
              TEST DUMMY;          # LOOP BACK FOR ANOTHER GETN        #
              END 
            ELSE
              BEGIN 
              RCA = 1;             # NO RECORD, FILE NOT POSITIONED    #
              RETURN; 
              END 
            END 
          END 
  
        IF RR$RESTBLPTR[1] EQ 0    # IF NO RESTRICT ON RECORD          #
        THEN
          BEGIN 
          RCA = 0;                 # GOOD RECORD, FILE POSITIONED      #
          RETURN; 
          END 
        PROGSTACKLOC = RR$RESTBLPTR[1]; 
        RESTRICTER(RCA);           # EVALUATE RESTRICT STACK           #
        IF RCA EQ 0                # IF RECORD QUALIFIES               #
        THEN
          BEGIN 
          RETURN;                  # GOOD RECORD, FILE POSITIONED      #
          END 
        END                        # END OF DUMMY = DUMMY -GETN- LOOP  #
      END 
*CALL GETWSA
 CONTROL EJECT; 
      PROC GETPRIMKEY (PTRTOAREA, POSITIONED, RCP); 
      BEGIN 
#----------------------------------------------------------------------#
#     G E T P R I M K E Y                                              #
#                                                                      #
# THIS PROC GETS A RECORD FROM THE AREA IN THE AREA TABLE POINTED TO   #
# BY -PTRTOAREA-, CALLS -COMPAREFIELD- TO SEE IF THE JOIN TERMS ARE   # 
# MET, AND PROCESSES ANY RESTRICT INFORMATION.  THIS PROC IS CALLED    #
# ONLY IF THERE IS A READ BY PRIMARY KEY. IF -POSITIONED- IS TRUE, DO  #
# -GETN-.                                                              #
#----------------------------------------------------------------------#
                                                                         CTL30
      ITEM PTRTOAREA; 
      ITEM POSITIONED B;
      ITEM RCP; 
      ITEM REJ B;                  # TRUE IF DBP REJECTS THE RECORD    #
      ITEM TRUERESULT B;
                                                                         CTL30
      P<AREA$TABLE> = PTRTOAREA;
      ATPTR = P<AREA$TABLE>;       # KEEP TRACK OF AREA$TABLE POSN     #
      P<AREAFIT> = LOC(AT$AFITPOS); 
      P<FIT> = P<AREAFIT>;                                               CTL30
      IF NOT POSITIONED            # MUST DO -GET- TO POSITION FILE    #
      THEN
        BEGIN 
        P<KEY> = P<AREA$TABLE> + AT$CURRKEY[0]; 
        P<AREA$TABLE> = RR$AREAPTR[0];    # SET UP FIELDS NEEDED FOR   #
        P<AREAFIT> = LOC(AT$AFITPOS[0]);  # GET BY PRIMARY KEY.        #
        P<FIT> = P<AREAFIT>;                                             CTL30
        WRDADDR = FITWSA + RR$BWP[0];  #MOVE KEY VALUE TO ARRAY -KEY-  # CTL30
        P<COMP1> = WRDADDR; 
        CMOVE (COMP1, RR$BCP[0], RR$LENGTH[0], KEY, 0); 
        P<AREA$TABLE> = PTRTOAREA;
        P<AREAFIT> = LOC(AT$AFITPOS[0]);
        P<FIT> = P<AREAFIT>;                                             CTL30
        IF RR$PMAJKEY[1]           # IF JOINED BY MAJOR PRIMARY KEY    #
        THEN
          BEGIN 
          FITMKL = RR$LENGTH[1];   # LENGTH OF MAJOR KEY INTO FIT      #
          END 
        DBP$ACTION = 2;            # DBP SHOULD DO *GET*               #
        CALLOWN(ON"SEARCH", DBPRC); 
        IF DBP$DID                 # IF A DBP WAS CALLED               #
        THEN
          BEGIN 
          IF DBPRC EQ 1            #   AND NO RECORD RETRIEVED, EXIT.  #
          THEN
            BEGIN 
            IF FITES EQ 0 
            THEN
              BEGIN 
              RCP = 2;             # NO MATCH, EOI.                    #
              END 
            ELSE
              BEGIN 
              IF FITES EQ UNKNOWNKEY
              THEN
                BEGIN 
                RCP = 1;           # JOIN TERMS DONT MATCH             #
                END 
              ELSE
                BEGIN 
                RCP = 3;           # SOME OTHER DBP ERROR              #
                END 
              END 
            RETURN; 
            END 
          IOS = IOS + 1;
          GOTO DBPCONT1;           # ELSE, GO CHECK ON RETRIEVED RECORD#
          END 
  
        GET(FIT, RA0);                                                   CTL30
        IF FITFP EQ O"100"         #EOI--NO MATCHING VALUE             # CTL30
        THEN                                                             CTL30
          BEGIN 
          RCP = 2;                 # CODE MEANS NO MATCH--EOI.         #
          RETURN; 
          END 
        ELSE
          BEGIN 
          IF FITES EQ UNKNOWNKEY   # IF KEY NOT FOUND                  # CHANGES
          THEN
            BEGIN 
            RCP = 1;               # JOIN TERMS OBVIOUSLY DONT MATCH   #
            RETURN; 
            END 
  
          IF FITES NQ 0 THEN       # IF SOME OTHER ERROR               # CHANGES
            BEGIN 
            DIAG(903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR CODE      #
            RCP = 3;               # ERROR RETURN CODE.                #
            RETURN; 
            END 
          ELSE
            BEGIN 
            IOS = IOS + 1;         # INCREMENT NO. CRM ACCESSES FOR    #
                                   # DIAG 1006 MESSAGE                 #
            END 
          END 
  
        CHKRET(REJ);               # CHECK *ON RETRIEVAL* PROCEDURE    #
        IF REJ                     # IF DBP SAID IGNORE THE RECORD     #
        THEN
          BEGIN 
          RCP = 1;                 # NO RECORD READ                    #
          RETURN; 
          END 
  
DBPCONT1: 
        POSITIONED = TRUE;
        IF RR$RESTBLPTR[1] EQ 0    # IF NO RESTRICT ON RECORD          #
        THEN
          BEGIN 
          RCP = 0;                 # GOOD RECORD, FILE POSITIONED      #
          RETURN; 
          END 
        PROGSTACKLOC = RR$RESTBLPTR[1]; 
        RESTRICTER(RCP);           # EVALUATE RESTRICT STACK           #
        IF RCP EQ 0                # IF RECORD QUALIFIES               #
        THEN
          BEGIN 
          RETURN;                  # GOOD RECORD, FILE POSITIONED      #
          END 
        END 
  
                                   # FILE IS POSITIONED.  DO GETN TO   #
                                   # OBTAIN NEXT RECORD                #
  
      IF FITFO EQ FODA             # IF DIRECT FILE                    #
        OR FITFO EQ FOAK           # IF ACTUAL KEY FILE                #
      THEN
        BEGIN 
        RCP = 1;                   # NO RECORD, NOT POSITIONED         #
        RETURN; 
        END 
  
      IF FITFO EQ FOIS             # IF AN *IS* FILE                   #
        AND NOT (FITDKI            # IF NO DUPLICATE PRIMARY KEYS      #
          OR RR$PMAJKEY[1])        # IF NOT ACCESSED BY MAJOR KEY      #
      THEN
        BEGIN 
        RCP = 1;                   # NO DUPLICATES SO FILE NOT POSITION#
        RETURN; 
        END 
  
      FOR DUMMY = DUMMY 
        WHILE TRUE
      DO
        BEGIN 
        DBP$ACTION = 3;            # DBP SHOULD DO *GETN*              #
        CALLOWN(ON"SEARCH", DBPRC); 
        IF DBP$DID                 # IF A DBP WAS CALLED               #
        THEN
          BEGIN 
          IF DBPRC EQ 1            #   AND NO RECORD RETRIEVED, EXIT.  #
          THEN
            BEGIN 
            IF FITES EQ 0 
            THEN
              BEGIN 
              RCP = 2;             # NO MATCH, EOI.                    #
              END 
            ELSE
              BEGIN 
              IF FITES EQ UNKNOWNKEY
              THEN
                BEGIN 
                RCP = 1;           # JOIN TERMS DONT MATCH             #
                END 
              ELSE
                BEGIN 
                RCP = 3;           # SOME OTHER DBP ERROR              #
                END 
              END 
            RETURN; 
            END 
          IOS = IOS + 1;
          GOTO DBPCONT2;           # ELSE, GO CHECK ON RETRIEVED RECORD#
          END 
  
        GETN(FIT, RA0); 
        IF FITFP EQ O"100"         # IF END OF INFORMATION             #
        THEN
          BEGIN 
          RCP = 2;
          RETURN; 
          END 
  
        IF FITES EQ UNKNOWNKEY     # IF KEY NOT FOUND                  #
        THEN
          BEGIN 
          RCP = 1;                 # NO RECORD, FILE NOT POSITIONED    #
          RETURN; 
          END 
  
        IF FITES NQ 0              # IF SOME OTHER ERROR               #
        THEN
          BEGIN 
          DIAG(903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR CODE        #
          RCP = 3;                 # CRM ERROR                         #
          RETURN; 
          END 
        ELSE
          BEGIN 
          IOS = IOS + 1;           # INCREMENT NO. CRM ACCESSES FOR    #
                                   # DIAG 1006 MESSAGE                 #
          END 
  
        CHKRET(REJ);               # CHECK *ON RETRIEVAL* PROCEDURE    #
        IF REJ                     # IF DBP SAID IGNORE THE RECORD     #
        THEN
          BEGIN 
          RCP = 1;                 # NO RECORD READ                    #
          RETURN; 
          END 
  
DBPCONT2: 
        COMPAREFIELD (TRUERESULT);  # COMPARE THE JOINED FIELDS        #
        IF NOT TRUERESULT          # IF RECORD NOT JOINED              #
        THEN
          BEGIN 
          RCP = 1;                 # NO RECORD, FILE NOT POSITIONED    #
          RETURN; 
          END 
  
        IF RR$RESTBLPTR[1] EQ 0    # IF NO RESTRICT ON RECORD          #
        THEN
          BEGIN 
          RCP = 0;                 # GOOD RECORD, FILE POSITIONED      #
          RETURN; 
          END 
  
        PROGSTACKLOC = RR$RESTBLPTR[1]; 
        RESTRICTER (RCP);          # EVALUATE RESTRICT STACK           #
        IF RCP EQ 0                # IF RECORD QUALIFIES               #
        THEN
          BEGIN 
          RETURN;                  # GOOD RECORD, FILE POSITIONED      #
          END 
        END                        # END OF DUMMY = DUMMY -GETN- LOOP  #
      END                          # END OF GETPRIMKEY.                #
 CONTROL EJECT; 
      PROC GETRECORDSET (RC); 
      BEGIN 
#                                                                      #
#----------------------------------------------------------------------#
#     G E T R E C O R D S E T                                          #
#                                                                      #
# THIS PROC GETS A NEW SET OF RECORDS IN THE RELATION.  THIS IS DONE BY#
# READING THE AREA SPECIFIED BY READAREA. IF NO MATCH IS FOUND, THE    #
# -POSITIONED- FLAG (AREAPOS) IS TURNED OFF, READAREA IS SET TO        #
# READAREA-1, AND AN ATTEMPT IS MADE TO FIND A MATCH ON THE NEXT       #
# LOWEST AREA. THIS PROCESSING CONTINUES UNTIL EITHER A MATCH ON JOIN  #
# TERMS IS FOUND, OR READAREA IS 1 (THE ROOT AREA). IF READAREA IS THE #
# ROOT AREA, NEXTGET IS CALLED.  IF NEXTGET RETURNS EOI, THE WHOLE     #
# PROCESS IS THROUGH.  IF NOT EOI, INCREMENT READAREA BY ONE AND       #
# CONTINUE DOWN THE TREE UNTIL THERE IS A COMPLETE RECORD SET. RETURN  #
# CODE VALUES ARE 0 = COMPLETE RECORD SET,  2 = EOI ON ROOT AREA,      #
# 3 = CRM ERROR.                                                       #
#                                                                      #
#----------------------------------------------------------------------#
      ITEM INDEX I;                # LOOP COUNTER                      #
      ITEM RC;                     # RETURN CODE.                      #
      ITEM RC1;                    # RETURN CODE FROM SUBROUTINE CALLS.#
      ITEM POS B; 
      ITEM DUMMY1;                 # LOOP INDUCTION.                   #
      LOOPCON = TRUE; 
      COMPAREWSA = TRUE;           #COMPARE FIELD WITHIN RECORD        #
      FOR DUMMY = DUMMY WHILE LOOPCON DO
        BEGIN 
        FOR DUMMY1 = DUMMY1  WHILE READAREA NQ 1 DO 
          BEGIN 
                                   # SET UP RELATION INFORMATION.      #
                                   # POSITION REL$RANKINFO (RELATION   #
                                   # INFORMATION) TO CORRECT WORD.     #
          P<REL$RANKINFO> = LOC(RT$RANKPOS[0]) +
                             ((RELATORD[READAREA] - 2) * RANKSIZE * 2); 
          IF RR$KEY[1]             # IF PRIMARY KEY                    #
            OR RR$PMAJKEY[1]       # IF PRIMARY MAJOR KEY              #
          THEN
                                   # CALL GETPRIMKEY TO FIND A RECORD  #
                                   # WHICH SATISFIES THE JOIN TERMS.   #
            BEGIN 
            POS = RELPOS[READAREA]; 
            GETPRIMKEY (RR$AREAPTR[1], POS, RC1); 
            RELPOS[READAREA] = POS; 
            END 
          ELSE
            BEGIN 
            IF RR$ALTKEY[1]        # IF ALTERNATE KEY                  #
              OR RR$AMAJKEY[1]     # IF ALTERNATE MAJOR KEY            #
            THEN
                                   # CALL GETALTKEY TO FIND A RECORD   #
                                   # WHICH SATISFIES THE JOIN TERMS.   #
              BEGIN 
              POS = RELPOS[READAREA]; 
              GETALTKEY (RR$AREAPTR[1], POS, RC1);
              RELPOS[READAREA] = POS; 
              IF RC1 NQ 0          # IF NO RECORD RETURNED             #
              THEN
                BEGIN 
                FITRL = SAVERL;    # RESTORE RECORD LENGTH             #
                P<KEY$TBL> = AT$PKEYDPTR;  # POSITION TO KEY DESC TABLE#
                IF FITFO EQ FOAK   # IF FILE ORGANIZATION IS ACTUAL KEY#
                THEN
                  BEGIN 
                  FITKL  = KT$ACTKEYLNG[1]; # MOVE AK KEY LENGTH TO FIT#
                  FITRKP = KT$ACTKEYPOS[1]; 
                  FITKP  = KT$ACTKEYPOS[1]; 
                  END 
                ELSE
                  BEGIN 
                  FITKL  = KT$LENGTH[1];    # MOVE KEY LENGTH TO FIT   #
                  FITRKP = KT$CPOS[1];
                  END 
                END 
              END 
            ELSE                   # NO KEY IN AREA TO BE READ. CALL   #
                                   # GETSEQ TO READ SEQUENTIALLY.      #
              BEGIN 
              POS = RELPOS[READAREA]; 
              GETSEQ (RR$AREAPTR[1], POS, RC1); 
              RELPOS[READAREA] = POS; 
              END 
            END 
                                   # NOW CHECK RETURN CODE FROM CALL.  #
          IF RC1 EQ 3 THEN         # CRM ERROR HAS OCCURRED. DIAGNOSTIC#
                                   # HAS BEEN ISSUED IN CALLED PROC.   #
            BEGIN 
            RC = 3; 
            RETURN; 
            END 
          IF RC1 EQ 1 OR RC1 EQ 2 THEN   # NO RECORD MATCHES.          #
            BEGIN 
            RELPOS [READAREA] = FALSE;   # TURN OFF -POSITIONED- FLAG. #
            READAREA = READAREA - 1;     # MOVE TO LOWER AREA.         #
            IF RELBGIMAGE[READAREA + 1] 
            THEN
              BEGIN 
              FOR INDEX = READAREA + 1 STEP 1 
                UNTIL HIGHAREA
              DO
                BEGIN 
                AREALOC = RELADDR[INDEX]; 
                RELBGIMAGE[INDEX] = TRUE;  # BGIMAGE PREPARED RECORD   #
                BGIMAGE;
                END 
              LOOPCON = FALSE;     # EXIT ROUTINE WITH RECORD SET      #
              RC = 0; 
              END 
            TEST DUMMY; 
            END 
          IF RC1 EQ 0 THEN               # FOUND A MATCH ON A RECORD.  #
            BEGIN 
            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 
            RELBGIMAGE[READAREA] = FALSE;  # NO CALL TO BGIMAGE TO FILL#
                                           # OUT RECORD SET NECESSARY  #
            IF READAREA EQ HIGHAREA THEN  # DONE READING--COMPLETE REC-#
                                          # ORD SET IS NOW IN CORE.    #
              BEGIN 
              LOOPCON = FALSE;     # END PROCESSING.                   #
              RC = 0;              # SUCCESSFUL READ.                  #
              TEST DUMMY; 
              END 
                                   # MOVE TO NEXT HIGHER AREA.         #
            ELSE
              BEGIN 
              READAREA = READAREA + 1;
              RELBGIMAGE[READAREA] = TRUE;  # CALL TO BGIMAGE TO FILL  #
                                            # OUT RECORD SET MAY BE    #
                                            # NECESSARY                #
              TEST DUMMY1;
              END 
            END 
          END                      # DUMMY1 LOOP.                      #
                                   # LOW AREA. CALL NEXTGET TO GET ROOT#
        IF READAREA EQ 1 THEN      # RECORD.                           #
          BEGIN 
          AREALOC = RELADDR [1];
          ATPTR = P<AREA$TABLE>;   # SAVE TO SET IN *NEXTGET*          #
          NEXTGET (RC1);
          P<AREA$TABLE> = ATPTR;   # KEEP ANY CHANGE MADE IN *NEXTGET* #
          IF RC1 EQ 2 THEN         # ERROR FROM NEXTGET                #
            BEGIN 
            P<AREA$TABLE> = AREALOC;  # POINT TO THE ROOT AREA         #
            ATPTR = P<AREA$TABLE>; # KEEP TRACK OF AREA$TABLE POSN     #
            P<AREAFIT> = LOC(AT$AFITPOS);  # LOCATE THE FIT WITHIN ATBL#
            P<FIT> = P<AREAFIT>;
            DIAG(903,FITES,FITLFNC);
            RC = 3; 
            LOOPCON = FALSE;
            TEST DUMMY; 
            END 
          ELSE
            BEGIN 
            IF RC1 NQ 0 THEN       # EOI ON ROOT AREA.                 #
              BEGIN 
              RC = 2;              # TERMINATION CODE.                 #
              LOOPCON = FALSE;
              TEST DUMMY; 
              END 
            ELSE                   # MOVE TO NEXT HIGHER AREA.         #
              BEGIN 
              P<AREA$TABLE> = AREALOC;
              ATPTR = P<AREA$TABLE>; # KEEP TRACK OF AREA$TABLE POSN   #
              P<AREAFIT> = LOC(AT$AFITPOS[0]);
              P<REL$RANKINFO> = LOC(RT$RANKPOS[0]) +
                                ((RELATORD[1] - 1) * RANKSIZE * 2); 
              IF RR$RESTBLPTR[0] NQ 0  # IF RESTRICT ON RECORD         #
              THEN
                                            # TABLE BEFORE PROCEEDING. #
                BEGIN 
                RC1 = 0;
                PROGSTACKLOC = RR$RESTBLPTR[0]; 
                RESTRICTER (RC1);   # CALL RESTRICTER TO EVALUATE STACK#
                IF RC1 NQ 0 THEN    # RESTRICTED RECORD--CANNOT BE PART#
                  BEGIN             # OF THE RECORD SET.               #
                  TEST DUMMY;       # CONTINUE LOOPING.                #
                  END 
                END 
              READAREA = READAREA + 1;
              RELBGIMAGE[READAREA] = TRUE;  # CALL TO BGIMAGE MAY BE   #
                                            # NECESSARY TO COMPLETE    #
                                            # RECORD SET               #
              TEST DUMMY; 
              END 
            END 
          END 
        END                        # DUMMY LOOP.                       #
      END                          # GETRECORDSET.                     #
 CONTROL EJECT; 
      PROC GETSEQ (PTRTOAREA, POSITIONED, RCS); 
      BEGIN 
#----------------------------------------------------------------------#
#     G E T S E Q                                                      #
# THIS PROC DOES A SEQUENTIAL GET ON AN AREA SPECIFIED BY -PTRTOAREA-. #
# THE AREA IS ALWAYS REWOUND, AND THE GET"S START AT BOI. RETURN CODES #
# ARE 0 = MATCH ON JOINED FIELDS, 2 = EOI, 3= CRM ERROR. COMPAREFIELD # 
# IS CALLED TO SEE IF THE JOIN TERMS ARE MET.                          #
#                                                                      #
#----------------------------------------------------------------------#
                                                                         CTL30
      ITEM PTRTOAREA; 
      ITEM RCS; 
      ITEM REJ B;                  # TRUE IF DBP REJECTS THE RECORD    #
      ITEM POSITIONED B;
      ITEM TRUERESULT B;
                                                                         CTL30
      P<AREA$TABLE> = PTRTOAREA;
      ATPTR = P<AREA$TABLE>;       # KEEP TRACK OF AREA$TABLE POSN     #
      P<AREAFIT> = LOC(AT$AFITPOS[0]);
      P<FIT> = P<AREAFIT>;                                               CTL30
      IF NOT POSITIONED THEN       # REWIND FILE--SEQUENTIAL SEARCH.   #
        BEGIN 
        DBP$ACTION = 1;            # DBP SHOULD DO *REWIND*            #
        CALLOWN(ON"SEARCH", DBPRC); 
        IF NOT DBP$DID             # IF NO DBP WAS CALLED,             #
        THEN
          BEGIN 
          REWND(FIT, RA0);         # LET CRM DO REWIND.                #
          END 
        END 
      LOOPCON = TRUE; 
      FOR DUMMY = DUMMY WHILE LOOPCON DO
        BEGIN 
        IF FITFO EQ FOSQ           #SEQUENTIAL FILE--DO A -GET-        # CTL30
        THEN                                                             CTL30
          BEGIN 
          DBP$ACTION = 2;          # DBP SHOULD DO *GET*               #
          CALLOWN(ON"SEARCH", DBPRC); 
          IF NOT DBP$DID           # IF NO DBP WAS CALLED              #
          THEN
            BEGIN 
            GET(FIT, RA0);
            END 
          END 
        ELSE                       #-IS-, -DA-, OR -AK- FILE--DO A GETN#
          BEGIN 
          DBP$ACTION = 3;          # DBP SHOULD DO *GETN*              #
          CALLOWN(ON"SEARCH", DBPRC); 
          IF NOT DBP$DID           # IF NO DBP WAS CALLED              #
          THEN
            BEGIN 
            GETN(FIT, RA0); 
            END 
          END 
  
        IF DBP$DID                 # IF A DBP WAS CALLED               #
        THEN
          BEGIN 
          IF DBPRC EQ 1            #   AND NO RECORD RETRIEVED, EXIT.  #
          THEN
            BEGIN 
            IF FITES EQ 0          # SET FLAG IF EOI                   #
            THEN
              BEGIN 
              RCS = 2;
              END 
            ELSE
              BEGIN 
              RCS = 3;             # SET FLAG IF ERROR IN DBP GET      #
              END 
            RETURN; 
            END 
          IOS = IOS + 1;
          GOTO DBPCONT1;           # ELSE, GO CHECK ON RETRIEVED RECORD#
          END 
  
        IF FITFP EQ O"100"         #EOI--NO MATCH.                     # CTL30
        THEN                                                             CTL30
          BEGIN 
          RCS = 2;                 # RETURN CODE FOR EOI.              #
          RETURN; 
          END 
        ELSE
          BEGIN 
          IF FITES NQ 0            #ERROR IN -GET-.                    # CTL30
          THEN                                                           CTL30
            BEGIN 
            RCS = 3;
            DIAG(903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR CODE      #
            RETURN; 
            END 
          ELSE
            BEGIN 
            IOS = IOS + 1;         # INCREMENT NO. CRM ACCESSES FOR    #
                                   # DIAG 1006 MESSAGE                 #
            END 
          END 
  
        CHKRET(REJ);               # CHECK *ON RETRIEVAL* PROCEDURE    #
        IF REJ                     # IF DBP SAID IGNORE THE RECORD     #
        THEN
          BEGIN 
          RCS = 1;                 # NO RECORD READ                    #
          RETURN; 
          END 
  
DBPCONT1: 
        COMPAREFIELD(TRUERESULT);  # SEE IF FIELDS ARE EQUAL           #
        IF NOT TRUERESULT          # IF FIELDS NOT EQUAL               #
        THEN
          BEGIN 
          TEST DUMMY;              # CONTINUE READING THE FILE         #
          END 
  
        POSITIONED = TRUE;
        IF RR$RESTBLPTR[1] EQ 0    # IF NO RESTRICT ON RECORD          #
        THEN
          BEGIN 
          RCS = 0;                 # GOOD RECORD, FILE POSITIONED      #
          RETURN; 
          END 
        PROGSTACKLOC = RR$RESTBLPTR[1]; 
        RESTRICTER(RCS);           # EVALUATE RESTRICT STACK           #
        IF RCS EQ 0                # IF RECORD QUALIFIES               #
        THEN
          BEGIN 
          RETURN;                  # GOOD RECORD, FILE POSITIONED      #
          END 
        END 
      END                             # END OF GETSEQ.                 #
 CONTROL EJECT; 
      PROC COMPAREFIELD (RESULT); 
      BEGIN 
#                                                                      #
#----------------------------------------------------------------------#
#     C O M P A R E F I E L D S                                        #
# THIS PROC COMPARES TWO JOINED FIELDS, CHARACTER BY CHARACTER. ONE    #
# FIELDS IS ALWAYS IN REL$RANKINFO[0], AND THE OTHER IS ALWAYS IN      #
# REL$RANKINFO[2].  IT IS ASSUMED THAT THE DATA TO BE COMPARED ARE IN  #
# THE WORKING STORAGE AREAS ASSOCIATED WITH EACH FIT. -RESULT- IS      #
# SET TO TRUE IF THE FIELDS ARE EQUAL.                                 #
                                                                         CTL30
      ITEM RESULT B;
      ITEM WORD1; 
      ITEM CHAR1; 
      ITEM WORD2; 
      ITEM CHAR2; 
      P<REL$RANKINFO> = LOC(RT$RANKPOS[0]) +
                             ((RELATORD[READAREA] - 2) * RANKSIZE * 2); 
                                                                         CTL30
      P<AREA$TABLE> = RR$AREAPTR[0];   # GET INFO ABOUT FIRST FIELD.  # 
      P<FIT> = LOC(AT$AFITPOS);                                          CTL30
      WORD1 = RR$BWP[0];                # BEGINNING WORD POSITION.     #
      CHAR1 = RR$BCP[0];                # BEGINNING CHAR POSITION.     #
      P<COMP1> = FITWSA;           #POINT ARRAY TO WSA.                # CTL30
                                                                         CTL30
      P<AREA$TABLE> = RR$AREAPTR[1];
      ATPTR = P<AREA$TABLE>;       # KEEP TRACK OF AREA$TABLE POSN     #
      P<FIT> = LOC(AT$AFITPOS);    #GET INFO ABOUT SECOND FIELD        # CTL30
      IF COMPAREWSA                # IF COMPARE FIELD WITHIN RECORD    #
      THEN
        BEGIN 
        WORD2 = RR$BWP[1];         # BEGINNING WORD POSITION           #
        CHAR2 = RR$BCP[1];         # BEGINNING CHAR POSITION           #
        P<COMP2> = FITWSA;         # POINT ARRAY TO WSA                #
        END 
      ELSE                         # IF COMPARE KEY                    #
        BEGIN 
        WORD2 = 0;                 # BEGINNING WORD POSITION           #
        CHAR2 = 0;                 # BEGINNING CHAR POSITION           #
        P<COMP2> = FITKA;          # POINT ARRAY TO KA                 #
        END 
      RESULT = TRUE;               # START WITH -EQUAL- RESULT.        #
                                   # COMPARE CHATACTER BY CHARACTER.   #
      FOR DUMMY = 1 STEP 1 UNTIL RR$LENGTH[0] DO
        BEGIN 
        IF C<CHAR1,1>COMPWORD1[WORD1] EQ C<CHAR2,1>COMPWORD2[WORD2] THEN
          BEGIN 
          CHAR1 = CHAR1 + 1;       # MOVE TO NEXT CHARACTER.           #
          IF CHAR1 EQ 10 THEN      # MOVE TO NEXT WORD.                #
            BEGIN 
            CHAR1 = 0;
            WORD1 = WORD1 + 1;
            END 
          CHAR2 = CHAR2 + 1;
          IF CHAR2 EQ 10 THEN      # MOVE TO NEXT WORD.                #
            BEGIN 
            CHAR2 = 0;
            WORD2 = WORD2 + 1;
            END 
          TEST DUMMY; 
          END 
        ELSE
          BEGIN 
          RESULT = FALSE;          # INEQUALITY. EXIT LOOP AND RETURN. #
          DUMMY = RR$LENGTH[0] + 1; 
          TEST DUMMY; 
          END 
        END                        # END OF LOOP.                      #
      END                          # END OF COMPAREFIELD.             # 
 CONTROL EJECT; 
      PROC SORTBYORD; 
      BEGIN 
#----------------------------------------------------------------------#
#     S O R T B Y O R D                                                #
#                                                                      #
# THIS PROC SORTS THE ARRAY -SAVDAREA- BY THE FIELD -RECORD-. THE END  #
# RESULT IS THAT THE ARRAY -SAVDAREA- WILL BE IN THE ORDER BY WHICH    #
# THE AREAS WITHIN THE RELATION ARE TO BE ACCESSED. THE ENTRIES IN     #
# SAVDAREA WHICH CONTAIN A RELORD ARE MOVED TO ANOTHER BASED ARRAY,    #
# IN CASE ALL AREAS IN SAVDAREA ARE NOT USED IN THE RELATION.          #
#----------------------------------------------------------------------#
      P<RELENTRIES> = CMM$ALF(66,0,0);
      J = 1;
      FOR DUMMY = 1 STEP 1 UNTIL 64 DO  # EXTRACT AREAS IN RELATION.   #
        BEGIN 
        IF RELORD[DUMMY] NQ 0 AND AREAINUSE[DUMMY] THEN 
                                   # MOVE ENTRY TO -RELENTRIES-.       #
          BEGIN 
          RELWORD[J] = AREASAVEWD[DUMMY]; 
          J = J + 1;
          TEST DUMMY; 
          END 
        END                        # END OF -DUMMY- LOOP.              #
                                   # SORT -RELENTRIES- BY -RELATORD-   #
      FOR DUMMY = 1 STEP 1 UNTIL J - 1 DO 
        BEGIN 
        FOR DUMMY1 = DUMMY + 1 STEP 1 UNTIL J - 1 DO
          BEGIN 
          IF RELATORD[DUMMY] LQ RELATORD[DUMMY1] THEN 
            BEGIN 
            TEST DUMMY1;
            END 
          ELSE
            BEGIN 
            JJ = RELWORD[DUMMY];                # EXCHANGE THE WORDS.  #
            RELWORD [DUMMY] = RELWORD [DUMMY1]; 
            RELWORD [DUMMY1] = JJ;
            TEST DUMMY1;
            END 
          END                      # END OF -DUMMY1- LOOP.             #
        END                        # END OF -DUMMY-  LOOP.             #
      HIGHAREA = J - 1; 
      END                          # SORTBYORD.                        #
      CONTROL EJECT;
*CALL IFM 
      CONTROL EJECT;
*CALL KEYLITM 
  
#----------------------------------------------------------------------#
#                                                                      #
#     M O D I F Y M                                                    #
#                                                                      #
#     *MODIFYM* IS CALLED FROM *BASICLOOP* TO PROCESS A *MODIFY*       #
#     COMMAND WITH NO *USING* CLAUSE.  ONLY TEMPORARY ITEMS ARE        #
#     BEING MODIFIED.  IF *SETTING* WAS SPECIFIED, *USINGEX* IS        #
#     CALLED ONCE TO READ AND STORE THE DATA VALUES.  *MOVEM*          #
#     EXECUTES ANY *MOVE* PRESENT.                                     #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC MODIFYM; 
      BEGIN 
      IF DIAGNO NQ 0                   # IF PREVIOUS ERROR             #
      THEN
        BEGIN 
        RETURN; 
        END 
      IF BASCSET[BASTABIND]            # IF A SETTING LIST IS EXPECTED #
      THEN
        BEGIN 
        RC = 2; 
        FOR DUMMY = DUMMY 
          WHILE RC EQ 2 
        DO
          BEGIN 
          USINGEX (USINGGETREC, RC);   # READ DATA AND MOVE CONVERTED  #
                                       # VALUES TO PROPER LOCATION     #
          END 
        IF RC NQ 0                     # IF RESPONSE IS *END, EXIT     #
        THEN
          BEGIN 
          RETURN; 
          END 
        END 
      IF BASCMOVADDR[BASTABIND] NQ 0   # IF *MOVE* CLAUSE DOES EXIST   #
      THEN
        BEGIN 
        MOVEM;                         # EXECUTE MOVE CLAUSE           #
        END 
  
      KEYLIT  = 1;                     # SO ACC/HITS MSG WILL BE DSPLED#
      RETURN;                          # RETURN TO *BASIC LOOP*        #
      END                              # PROC *MODIFYM*                #
  
 CONTROL EJECT; 
      PROC MOVEM; 
#----------------------------------------------------------------------#
#                                                                      #
#      MOVEM                                                           #
#                                                                      #
# THIS PROC PERFORMS A MOVE OF TEMPORARY ITEMS.                        #
#                                                                      #
#----------------------------------------------------------------------#
      BEGIN 
      MOVEXE; 
      RETURN; 
      END 
      CONTROL EJECT;
      PROC OPENAREA (RC); 
#                                      #
#        O P E N A R E A               #
#                                      #
# PROC TO OPEN THE AREA FILE(S).   #
      BEGIN 
                                                                         CTL30
      ITEM RC;
      ITEM LOOPCON B;                            # LOOP CONTROL.       #
      ITEM NUM I; 
      ITEM INDEX I;                # INDEX INTO SAVDAREA ARRAY.        #
                                                                         CTL30
      IF REFERFILE NQ 0 THEN                     # FILE ACCESS DIREC-  #
        BEGIN                                    # TIVE EXISTS. OPEN   #
        LOOPCON = TRUE;                          # AREAS IN -SAVEAREA-,#
                                                 # IF -AREAINUSE- IS   #
        FOR INDEX = 1 STEP 1 WHILE LOOPCON DO    # TRUE.               #
          BEGIN 
            I = $INPUT$;                                                 CTL30
            J = $R$;               #CODE FOR REWIND                    # CTL30
            IF AREAINUSE[INDEX] THEN            # THIS AREA SHOULD BE  #
              BEGIN                              # OPENED. GET ADDRESS #
                                                 # OF AREA TABLE FROM  #
            P<AREA$TABLE> = AREASAVE[INDEX];     # SAVEAREA AND GET FIT#
          ATPTR = P<AREA$TABLE>;   # KEEP TRACK OF AREA$TABLE POSN     #
              P<AREAFIT> = LOC(AT$AFITPOS[0]);   # ADDRESS FROM AREA.  #
              P<KEY$TBL> = AT$PKEYDPTR;  # POSITION TO KEY DESC TABLE  #
              P<FIT> = P<AREAFIT>;                                       CTL30
              NUM = (FITMRL + 9)/10;  #SPACE AND WORKING STORAGE AREA  # CTL30
              FITWSA = CMM$ALF(NUM, 0, 0);                               CTL30
              IF FITFO NQ FOSQ     # IF -IS-, -DA-, OR -AK-            #
              THEN
                BEGIN              # SET UP KEY FIELDS IN FIT          #
                FITRKW = KT$WPOS[1];
                IF FITFO EQ FOAK   # IF FILE ORGANIZATION IS ACTUAL KEY#
                THEN
                                   # MOVE ACTUAL KEY INFORMATION TO FIT#
                  BEGIN 
                  FITRKP = KT$ACTKEYPOS[1]; 
                  FITKP  = KT$ACTKEYPOS[1]; 
                  FITKL  = KT$ACTKEYLNG[1]; 
                  END 
                ELSE
                                   # MOVE KEY INFORMATION TO FIT       #
                  BEGIN 
                  FITRKP = KT$CPOS[1];
                  FITKL  = KT$LENGTH[1];
                  END 
                FITKA = AT$CURRKEY + P<AREA$TABLE>; 
                END 
  
              IF FITFO NQ FOSQ     # IF NOT A SEQUENTIAL FILE          #
              THEN                 # DETERMINE THE MRL FOR OURSELVES   #
                BEGIN 
                FITMRL = 0;        # LET CRM TELL US THE MRL           #
                END 
              FITBBH = TRUE;       # ALLOCATE BUFFERS BELOW HHA        #
  
              IF AT$DBPSRH         # IF AN ON "SEARCH" EXIT EXISTS     #
              THEN
                BEGIN 
                GOTO OWNOPEN;      # AVOID THE OPENM, SKIP TO DBP CALL #
                END 
  
              OPENM (FIT, I, J, RA0);  # OPEN AREA                     #000180
              IF FITES EQ EMPTYFILE#FILE IS EMPTY--CANNOT PROCESS.     # CTL30
              THEN                 #STOP ALL PROCESSING AT THIS POINT  # CTL30
                BEGIN                                                    CTL30
                DIAG(875, FITLFNC);  # DIAGNOSE EMPTY FILE             #
                FITES = 0;                                               CTL30
                FITFNF = FALSE;                                          CTL30
                  IF USEDIR THEN
                    BEGIN 
                    RETURNM(FIT, RA0);                                   CTL30
                    END 
                  RC = 1; 
                  AREAINUSE[INDEX] = FALSE; 
                  RETURN; 
                  END 
  
              IF FITES EQ UPDATED  # FILE NOT CLOSED SINCE LAST UPDATE #
              THEN
                BEGIN 
                DIAG (821, FITLFNC);  # INFORM THAT ERROR OCCURRED     #
                IF AFPROCESSED     # USER CHOSE TO ACCEPT FILE         #
                THEN
                  BEGIN 
                  DIAG (1017);     # INFORM THAT FILE ACCEPTED         #
                  FITES = 0;       # OVERRIDE THE ERROR                #
                  END 
                ELSE
                  BEGIN 
                  IF NOT IPROCESSED #IF INTERACTIVE AND *AF* NOT CHOSEN#
                  THEN
                    BEGIN 
                    DIAG (1016);   # ASK IF SHOULD ACCEPT FILE         #
                    READ (AFANSWER, TEMP, 1, TEMP); 
                    IF AFANSWER EQ "Y"  # IF ANSWER IS YES             #
                    THEN
                      BEGIN 
                      FITES = 0;   # CLEAR THE ERROR                   #
                      END          # OTHERWISE WILL BE PROCESSED AS    #
                    END            # ANY OTHER ERROR                   #
                  END 
                END 
  
              IF FITFO NQ FOSQ     # IF FILE IS AK, DA, OR IS          #
              THEN
                BEGIN 
  
                IF ( FITFO NQ FOAK                 #  IF KL MISMATCH   #
                    AND FITKL NQ KT$LENGTH[1] ) 
                  OR ( FITFO EQ FOAK
                    AND FITKL NQ KT$ACTKEYLNG[1] )
                THEN
                  BEGIN 
                  DIAG(360,FITLFNC);          # DIAGNOSE MISMATCHED KL #
                  RC = 1;          #       RETURN TO CLOSE FILE        #
                  RETURN; 
                  END 
  
                END 
  
              IF FITES NQ 0        #ERROR OCCURED--DIAGNOSE IT         # CTL30
              THEN                                                       CTL30
                BEGIN                                                    CTL30
                IF FITES NQ UPDATED  # DIAG FOR 52B ALREADY GIVEN      #
                THEN
                  BEGIN 
                  DIAG (903, FITES, FITLFNC);  # DIAGNOSE CRM ERROR    #
                  END 
                FITES = 0;         #ZERO OUT ERROR CODE                # CTL30
                RC = 1;            #SO -CLOSE- WILL NOT FAIL           # CTL30
                FITFNF = FALSE;                                          CTL30
                AREAINUSE[INDEX] = FALSE; 
                                                 # FAIL.               #
                RETURN; 
                END 
  
              IF (FITMRL + 9) / 10 GR NUM  # IF MRL EXCEEDS BUFFER     # QU3A353
              THEN
                BEGIN 
                CMM$FRF(FITWSA);   # RELEASE OLD WSA                   #
                NUM = (FITMRL + 9) / 10;
                FITWSA = CMM$ALF(NUM, 0, 0);  # ALLOCATE LARGER WSA    #
                END 
              IF AT$MRL NQ FITMRL  # IF MRL NOT EQUAL TO BUFFER        #
              THEN
                BEGIN 
                DIAG(358, FITLFNC);  # DIAGNOSE MISMATCH OF MRLS       #
                END 
  
OWNOPEN:                           # HERE TO SKIP TO DBP -OPEN- EXIT.  #
              IF BASCODE[1] EQ ENDCODE THEN  # IF A SINGLE DIRECTIVE   #
                BEGIN 
                IDIRCODE = DIRCODEVAL[BASCODE[0]];
                END 
  
              ELSE
                BEGIN 
                IDIRCODE = DCODE"OTHER";  # MULTIPLE DIRECTIVE TRANSM. #
                END 
  
              IF FITFO EQ FOSQ     # IF FILE IS SEQUENTIAL             #
              THEN
                BEGIN 
                FITKA = O"7777";   # SET FAKE FITKA TO TRICK DBP PARAM #
                                   # LIST.  A ZERO MEANS END OF LIST.  #
                END 
  
              DBP$ACTION = 1;      # OPEN FILE FOR INPUT PROCESSING    #
              CALLOWN (ON"OPEN", RC);  # TRY CALLING AN -OPEN- DBP     #
              IF AT$DBPSRH
              THEN
                BEGIN 
                AT$DBPOC = TRUE;   # FLAG AREA OPEN IF ON"SEARCH" EXIT #
                END 
              AREALOC = P<AREA$TABLE>;
              BGINIT;              # PREPARE BACKGROUND IMAGE          #
              END 
          IF AREASAVE[INDEX + 1] EQ 0 THEN       # NO MORE AREAS. EXIT #
              BEGIN                              # LOOP.               #
              LOOPCON = FALSE;
              TEST INDEX; 
              END 
          END                                    # END OF -DUMMY- LOOP.#
        BITINDEX = -2;                           # INITIALIZE FOR USE  #
        END                                      # IN -NEXTGET-.       #
      RC = 0;                                    # GOOD RETURN.        #
      END                                        # END OF OPENAREAS.   #
*CALL PFDIAG
CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     R E L C A L L O W N                                              #
#                                                                      #
# THIS PROC IS AN INTERMEDIATE STEP TAKEN IN THE CALLING OF DATABASE   #
# PROCEDURES FOR THE ON"MATCH", ON"MISMATCH", AND ON"DISPLAY" EXITS    #
# IN A POSSIBLE RELATIONAL ENVIRONMENT.                                #
#                                                                      #
# FOR A SINGLE FILE QUERY, THIS PROC TRANSLATES TO A CALL TO *CALLOWN*,#
# AND THEN RETURNS.                                                    #
#                                                                      #
# FOR A MULTIPLE FILE QUERY, *CALLOWN* IS CALLED FOR EACH AREA IN THE  #
# RELATION, IN THE ORDER OF THE RELATION. FOR THE ON"MATCH" AND        #
# ON"DISPLAY" EXITS, IF THE RETURN CODE FROM THE DBP WAS NON-ZERO,     #
# THE AREA LEVEL IS SAVED SO THE NEXT READ WILL PROCEED FROM THAT      #
# LEVEL. THUS A REJECTED RECORD OF THE SECOND AREA WOULD RESULT IN THE #
# NEXT RETRIEVAL OF A RECORD SET ACCESSING AREA LEVEL TWO AND ALL HIGH-#
# ER LEVELS. IF MORE THAN ONE CALL IS MADE TO *RELCALLOWN* FOR A       #
# RECORD, AND THE RECORD IS REJECTED MORE THAN ONCE, THE NEXT LEVEL    #
# TO READ FROM WILL BE THE LOWEST LEVEL AT WHICH REJECTION OCCURRED.   #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC RELCALLOWN (EXITYPE, DBPRC); 
        BEGIN 
        ITEM EXITYPE  S:ON;        # TYPE OF DBP EXIT TO TAKE          #
        ITEM DBPRC I;              # RETURN CODE FROM THE DBP          #
  
        ITEM AREALEVEL I;          # LEVEL OF THE AREA FOR WHICH WE ARE#
                                   # CALLING A DBP. CORRESPONDS TO     #
                                   # *READFROM*. USED AS AN INDEX INTO #
                                   # *RELENTRIES*.                     #
  
        ITEM ATABLE I;             # SAVES OLD POSITION OF AREA$TABLE  #
  
  
  
        IF CURRELLOC EQ 0          # IF SINGLE FILE QUERY              #
        THEN
          BEGIN 
          CALLOWN (EXITYPE, DBPRC); 
          END 
  
        ELSE                       # MULTIPLE FILE QUERY               #
          BEGIN 
          ATABLE = P<AREA$TABLE>;  # SAVE CURRENT AREA$TABLE POSITION  #
          DBPRC = 0;               # INITIALIZE DBPRC FOR LOOP         #
          FOR AREALEVEL = 1 STEP 1 # FOR EACH AREA LEVEL IN THE        #
          WHILE DBPRC EQ 0         # RELATION, STOPPING AT END OF LIST #
            AND RELADDR[AREALEVEL] NQ 0  # OR AT FIRST NON-ZERO DBP RC #
          DO
            BEGIN 
            IF RELBGIMAGE[AREALEVEL]  # IF BGIMAGE PREPARED RECORD     #
            THEN
              BEGIN 
              TEST AREALEVEL;      # DO NOT CALL DBP                   #
              END 
            P<AREA$TABLE> = RELADDR[AREALEVEL];  # AREA TABLE FOR THIS #
                                                 # LEVEL IN RELATION.  #
            ATPTR = P<AREA$TABLE>; # KEEP TRACK OF AREA$TABLE POSN     #
            CALLOWN (EXITYPE, DBPRC); 
            IF DBPRC NQ 0          # IF DBP FORCED OR REJECTED RECORD  #
            THEN
              BEGIN 
              IF EXITYPE EQ S"MATCH"
                OR EXITYPE EQ S"DISPLAY"  # IF RECORD REJECTION        #
              THEN
                BEGIN 
                IF AREALEVEL LS READAREA  # IF THIS REJECTION WAS FROM #
                THEN                      # A LEVEL LOWER THAN THAT    #
                                          # FROM WHICH WE WERE TO READ #
                  BEGIN 
                  READAREA = AREALEVEL;   # NEW LEVEL FOR NEXT READ    #
                  END 
                END 
              END 
            END 
  
          P<AREA$TABLE> = ATABLE;  # RESTORE PREVIOUS POSITION         #
          ATPTR = P<AREA$TABLE>;   # KEEP TRACK OF AREA$TABLE POSN     #
          END 
  
        RETURN; 
        END 
*CALL RELSPACE
 CONTROL EJECT; 
#----------------------------------------------------------------------#
#                                                                      #
#     R E S T R I C T E R                                              #
#                                                                      #
# THIS PROC SETS UP A CALL TO *EXPEVAL* WITH THE VALUE OF              #
#  PROGSTACKLOC EQUAL TO THE VALUE IN AT$RESTBLPTR.  THIS TABLE IS A   #
#  PROGRAMSTACK CONTAINING THE RESTRICT INFORMATION AND IS EVALUATED   #
#  AS SUCH.  A RETURN VALUE OF -TRUE- MEANS THAT THIS RECORD IS INDEED #
#  RESTRICTED AND MAY BE USED.                                         #
#----------------------------------------------------------------------#
      PROC RESTRICTER (RCR);
      BEGIN 
      ITEM RCR; 
  
      LOGICALRESLT = TRUE;
      EXPEVAL(RC);                 # EVALUATE EXPRESSION               #
      IF LOGICALRESLT THEN        # RESTRICTED RECORD.                # 
        BEGIN 
        RCR = 0;
        RETURN; 
        END 
      ELSE
        BEGIN 
        RCR = 1;
        RETURN; 
        END 
      END                          # RESTRICTER                        #
      CONTROL EJECT;
*CALL SETDISFRO 
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     G E T I O                                                        #
#                                                                      #
# THIS PROC IS CALLED TO DO THE ACTUAL -GET- NEEDED FOR MOST FUNCTIONS.#
      PROC GETIO; 
      BEGIN 
                                                                         CTL30
      ITEM REJ B;                  #TRUE IF DBP  SAYS IGNORE RECORD    #
                                                                         CTL30
      P<FIT> = P<AREAFIT>;         #AREA FIT IS SET PRIOR TO ENTRY     # CTL30
      P<KEY> = FITKA; 
          IF GETDKI                # IF GET NEXT DUPLICATE             #
          THEN
            BEGIN 
            DBP$ACTION = 3; 
            CALLOWN(ON"SEARCH", DBPRC); 
            IF NOT DBP$DID
            THEN
              BEGIN 
              GETN(FIT, RA0);      # IF NO DBP, DO CRM GETN.           #
              END 
            IF FITFP EQ O"100"
              OR (DBPRC EQ 1
                AND FITES EQ 0) 
            THEN
              BEGIN 
              GETDKI = FALSE;      # NO MORE DUPLICATES                #
              DIAGNO = 1; 
              RETURN; 
              END 
            IF FITES EQ 0 
            THEN
              BEGIN 
              IOS = IOS + 1;       # INCREMENT NO. CRM ACCESSES FOR    #
                                   # DIAG 1006 MESSAGE                 #
              FOR DUMMY = 0 STEP 1
                UNTIL LKEYWD - 1
              DO
                BEGIN 
                IF IKEY[DUMMY] NQ DKIKEYWD[DUMMY]  # IF NOT DUPLICATE  #
                THEN
                  BEGIN 
                  DIAGNO = 1; 
                  GETDKI = FALSE; 
                  RETURN; 
                  END 
                END 
              END 
            END 
          ELSE
            BEGIN 
            DBP$ACTION = 2; 
            CALLOWN(ON"SEARCH", DBPRC); 
            IF NOT DBP$DID
            THEN
              BEGIN 
              GET(FIT, RA0);       # IF NO DBP, DO CRM GET.            #
              END 
            END 
          IF FITES NQ 0                                                  CTL30
          THEN                                                           CTL30
            BEGIN                                                        CTL30
          GETDKI = FALSE;          # NO MORE DUPLICATES                #
            DIAGNO = 816;                                                CTL30
            RC = DIAGNO;                                                 CTL30
            IF FITES EQ UNKNOWNKEY                                       CTL30
            THEN                                                         CTL30
              BEGIN                                                      CTL30
              DIAG(816);                                                 CTL30
              END                                                        CTL30
                                                                         CTL30
            ELSE                                                         CTL30
              BEGIN                                                      CTL30
              IF NOT DBP$DID
              THEN
                BEGIN 
                DIAG(903, FITES, FITLFNC);  # DIAGNOSE CRM CODE        #
                END 
              END                                                        CTL30
                                                                         CTL30
            RETURN;                                                      CTL30
            END                                                          CTL30
          ELSE
            BEGIN 
            IF FITFP NQ O"100"     # IF NOT EOI                        #
              OR (DBP$DID 
                AND DBPRC NQ 1) 
            THEN
              BEGIN 
              IOS = IOS + 1;       # INCREMENT NO. CRM ACCESSES FOR    #
                                   # DIAG 1006 MESSAGE                 #
              END 
            END 
  
        CHKRET(REJ);               # CHECK *ON RETRIEVAL* PROCEDURE    #
        IF REJ                     # IF DBP SAID IGNORE THE RECORD     #
        THEN
          BEGIN 
          DIAGNO = 1;              # NO RECORD READ                    #
          RETURN; 
          END 
  
        IF FITRT GQ RTR            # IF VARIABLE LENGTH RECORD         #
          AND FITRT LQ RTT
        THEN
          BEGIN 
          AREALOC = P<AREA$TABLE>;
          BGFILL;                  # PAD RECORD WITH BACKGROUND IMAGE  #
          END 
        CHKMAT(REJ);               # CHECK -ON MATCH- PROCEDURE        # CHANGES
        IF REJ THEN                #IF DBP  SAID IGNORE RECORD         #
          BEGIN 
          DIAGNO = 1;              #IGNORE RECORD                      #
          RETURN; 
          END 
          ACCESSES = ACCESSES + 1;  # INCREMENT NO. RECORDS READ       #
      RETURN; 
 END
  
  
  
  
  
      XDEF PROC BEFIMAGE; 
      PROC BEFIMAGE;               # NO-OP FOR RO.  NEXTGET CALLS IT   #
        BEGIN 
        RETURN; 
        END 
  
  
  
     # THIS IS THE PLACE TO DO ANY CLEAN UP FOR THE OVERLAY IF AN 
       ABORT HAS OCCURRED - NO ASSURANCE OF HOW FAR THE OVERLAY WAS IN
       EXECUTION #
      XDEF PROC AUTOPSY;
      PROC AUTOPSY; 
      BEGIN 
      CLOSEAREA;                   # CLOSE FILES                       #
      RELEASESPACE;                # RELEASE SPACE FOR THIS DIRECTIVE  #
      IF (ACCESSES + HITS + IOS NQ 0)      # IN CASE OF CP TIME LIMIT  #
                                           # DUE TO NUMBER OF IO-S     #
        AND QUESF EQ 0             # FL NOT EXHAUSTED                  #
      THEN
        BEGIN 
        DIAG (1006, ACCESSES, HITS, IOS);  # DISPLAY ACCESS/HIT/IO MSG #
        END 
      IF (OWNFORCD + OWNREJ NQ 0)        # IF A RECORD HAS BEEN FORCED #
                                         # OR REJECTED BY A DBP        #
        AND QUESF EQ 0             # FL NOT EXHAUSTED                  #
      THEN
        BEGIN 
        DIAG (1003, OWNFORCD, OWNREJ);   # DISPLAY FORCED/REJECTED MSG #
        END 
      END 
      RETURN; 
       END
 TERM 
