*DECK IMFDICT 
USETEXT  TENVIRN
USETEXT  TBASCTB
USETEXT  TIMF 
USETEXT  TIMFDEF
USETEXT  TCMMDEF
USETEXT  TEXPRES
USETEXT  TSBASIC
PROC IMFDICT;                # METADATABASE TABLES LOOK-UP ROUTINES    #
BEGIN 
  
  
XREF PROC STDYES;     XREF PROC STDNO;
XREF PROC DIAG; 
XREF PROC RECNO;                   # RETURN TO STDNO IF RECORDING      #
XREF PROC RECYES;                  # RETURN TO *STDYES* IF RECORDING   #
  
XREF ITEM APATHDUP I;              # TRUE IF ACC. PATH HAS DUPLICATES  #
XREF ITEM APATHREC U;              # RECORD ID OF ACCESS PATH          #
XREF ITEM KEYORDINAL;        # TO COMMUNICATE KEY ORDINL TO EXPANAL    #
XREF ITEM CURWORD C(30);
XREF ITEM FIELDNAMELG I;
XREF ITEM FOLLOWON B;              # TRUE IF -FOLLOW- DIR IN EFFECT    #
XREF ITEM IMFDBM B;                # TRUE IF IMF DATA BASE MODE        #
XREF ITEM KEYMAP I;                # -USING- SEARCH KEY BIT MAP        #
XREF ITEM SEARCHKEY B;             # TRUE IF SEARCH KEY FOUND          #
XREF ITEM SM$GROUPID I;            # CMM GROUP ID FOR THIS DIRECTIVE   #
XREF ITEM THREADINDEX I;           # INDEX INTO ARRAY -THREAD-         #
  
                             # THE FOLLOWING ARRAY CONTAINS A DATA NAME#
                             # POSSIBLY QUALIFIED, STORED THERE BY     #
                             # THE SYNTAX TABLE -DATAATTRIB-.          #
      XREF ARRAY FIELDN [1:2] S(4); 
        BEGIN 
        ITEM FN   C(00,00,30);
        ITEM FNLG I(03,24,18);
        END 
  
  
DEF MAXTYPE # 10 # ;         # LARGEST CODE FOR IMF DATA TYPE          #
ARRAY IMFQUTYPES [0:MAXTYPE];      # IMF TO QU DATA TYPE CODES MAPPING #
  BEGIN 
  ITEM IMFQUTYPE = [ 0, 1, 2, 4, 0, 5, 6, 0, 0, 0, 7 ]; 
  END 
  
*CALL DEFMURL 
  
      BASED ARRAY TEMPA;           # SCRATCH BASED ARRAY               #
        BEGIN 
        ITEM TEMP I(0,0,60);
        END 
  
ITEM K;          # LOOP COUNTER  #
ITEM OWNERID;    ITEM MEMBERID;    # SET BY DES$CST                    #
ITEM ITEMID I;               # DATA ITEM ORDINAL RETURNED BY DES$DIT   #
ITEM DUPLICATES;             # SET TO 1 BY DES$APT IF ACCESS PATH  HAS #
                             # DUPLICATES, 0 OTHERWISE                 #
ITEM WRDADDR I;                    # WORD ADDRESS OF DATA-ITEM TABLE   #
DEF LASTCHAR  # 19 #;              # LAST CHAR POSTN OF APTENCM        #
DEF MAXREC       # SICRCTN # ;
DEF  CALL  #  #;
CONTROL EJECT;
  
     XDEF PROC DES$APT; 
     PROC DES$APT(SYMBOL);   # GET AN ACCESS PATH DESCRIPTION          #
     BEGIN
          ITEM SYMBOL C(30);       # NAME OF ACCESS PATH TO LOCATE     #
          ITEM K;            # LOOP COUNTER                            #
  
          PATHID = 0;        # SET TO 0 IN CASE OF ERROR               #
          P<SAAT> = USERSSST + SICAPTD; 
          FOR K=1 STEP 1 UNTIL SICAPTN DO 
          BEGIN 
             IF SYMBOL EQ APTNAME THEN
             BEGIN
                PATHID = K; 
                RECORDID = APTRCID; 
                ITEMID = B<0,6>APTENCM;  #ID OF 1ST SEARCH KEY IN PATH #
                IF APTDUPF THEN DUPLICATES = 1;  # DUPLICATES ALLOWED  #
                           ELSE DUPLICATES = 0; 
                RETURN; 
             END
             P<SAAT> = P<SAAT> + SAPTENL; 
          END 
          RETURN; 
     END
#----------------------------------------------------------------------#
  
  
     XDEF PROC DES$CST; 
     PROC DES$CST(SYMBOL);   # GET A COSET DESCRIPTION                 #
     BEGIN
          ITEM SYMBOL C(30);       # NAME OF COSET TO LOCATE           #
          ITEM K;                  # LOOP COUNTER                      #
  
          COSETID = 0;             # SET TO 0 IN CASE OF ERROR         #
          P<SCAT> = USERSSST + SICCSTD; 
          FOR K=1 STEP 1 UNTIL SICCSTN DO 
          BEGIN 
             IF SYMBOL EQ CSTNAME THEN
             BEGIN
                COSETID = K;
                OWNERID = CSTORID;
                MEMBERID = CSTMRID; 
                RETURN; 
             END
             P<SCAT> = P<SCAT> + SCTSENL; 
          END 
          RETURN; 
     END
#----------------------------------------------------------------------#
  
  
     XDEF PROC DES$DIT; 
     PROC DES$DIT (SYMBOL, ITEMID1);  # GET A DATA ITEM DESCRIPTION    #
     BEGIN
          ITEM SYMBOL C(30);       # NAME OF ITEM TO LOCATE            #
          ITEM ITEMID1 I;          # SUBSCRIPT OF DIT WITHIN RECORD IF #
                                   # NAME FOUND, ELSE ZERO             #
          ITEM K;                  # LOOP COUNTER                      #
  
          ITEMID1 = 0;             # SET TO 0 IN CASE NOT FOUND        #
          IF RECORDID LQ 0 OR RECORDID GR SICRCTN THEN RETURN;
          P<SRAT> = USERSSST + SICRCTD + (RECORDID - 1) * SRCTENL;
          PATHID = RECFSAP;  # SET FIRST PATH ID BY DEFAULT            #
          P<SDID> = USERSSST + SICDITD + (RECFSDI[1] - 1) * SDITENL;
          FOR K=1 STEP 1 UNTIL RECNRDI[1]   DO
          BEGIN 
             IF SYMBOL EQ SDTNAME THEN
             BEGIN
                WRDADDR = P<SDID>; # STORE ADDR FOR -CUMFUNC- TO ENABLE#
                                   # DISTINCTION BETWEEN ATTRIB TABLES #
                ITEMID1 = K;       # SUBSCRIPT OF DIT WITHIN RECORDID  #
                CALL ITEMATTRIB;   # SET ITEM ATTRIBUTES IN CEXPRESS   #
                RETURN; 
             END
             P<SDID> = P<SDID> + SDITENL; 
          END 
          RETURN; 
     END
#----------------------------------------------------------------------#
  
     XDEF PROC DES$REC; 
     PROC DES$REC(SYMBOL);   # GET A RECORD DESCRIPTION                #
     BEGIN
          ITEM SYMBOL C(30);       # NAME OF RECORD TO LOCATE          #
          ITEM K;            # LOOP COUNTER                            #
  
          RECORDID = 0;      # SET TO 0 IN CASE OF ERROR               #
          P<SRAT> = USERSSST + SICRCTD; 
          FOR K=1 STEP 1 UNTIL SICRCTN DO 
          BEGIN 
             IF SYMBOL EQ RECNAME THEN
             BEGIN
                RECORDID = K; 
                RETURN; 
             END
             P<SRAT> = P<SRAT> + SRCTENL; 
          END 
          RETURN; 
     END
#----------------------------------------------------------------------#
  
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#      F O L $ E N D                                                   #
#                                                                      #
#     THIS PROCEDURE WILL STORE THE NAVIGATION PATH                    #
#     IF THE FLAG FOLLOWON IS TRUE (NO ERRORS HAVE OCCURRED).          #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC FOL$END;
      PROC FOL$END; 
      BEGIN 
      RECYES;                      # RETURN TO STDYES IF RECORDING     #
  
      FOR K = 1 STEP 1
        WHILE THREADENTRY[K] NQ 0 
      DO
        BEGIN                      # MOVE THREAD INTO FOLLOWS          #
        FOLLOWENTRY[K] = THREADENTRY[K];
        END 
  
      STDYES;                      # RETURN, STRATEGY STORED           #
      END                          # END FOL$END                       #
  
  
#----------------------------------------------------------------------#
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#                                                                      #
#     F O L $ I N I                                                    #
#                                                                      #
#     THIS PROCEDURE INITIALIZES THE FOLLOW DIRECTIVE.                 #
#     THE FLAG FOLLOWON IS SET TRUE.  SPACE IS ALLOCATED FOR           #
#     BASED ARRAY FOLLOWS AS WELL AS BASED ARRAY THREAD (*SET60* IS NOT#
#     CALLED SINCE NO DATABASE ACCESSING OCCURS).  THREAD HOLDS THE    #
#     NAVIGATION STRATEGY AND FOLLOWS STORES ITS INFORMATION UNTIL     #
#     A *DISPLAY* OR *EXTRACT*, AT WHICH TIME THREAD IS RESTORED.      #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC FOL$INI;
      PROC FOL$INI; 
      BEGIN 
        RECYES;                    # RETURN TO STDYES IF RECORDING     #
        FOLLOWON = TRUE;           # A NAVIGATION ROUTE IS DESIRED     #
  
        IF P<FOLLOWS> EQ 0         # IF SPACE HAS NOT BEEN ALLOCATED   #
        THEN
          BEGIN 
          P<FOLLOWS> = CMM$ALF ( MAXTHREAD + 1, FIXED$LWA, 0 ); 
          END 
  
        IF P<THREAD> EQ 0          # IF SPACE NOT YET ALLOCATED        #
        THEN
          BEGIN 
          P<THREAD> = CMM$ALF( MAXTHREAD + 1, FIXED$LWA, 0 ); 
          END 
  
        APATHDUP = 0;              # CLEAR IF DUPLICATES SET           #
        APATHREC = 0;              # CLEAR RECORD ID                   #
  
        FOR K = 0 STEP 1           # STEP THROUGH ARRAY                #
          UNTIL MAXTHREAD 
        DO
          BEGIN 
          FOLLOWENTRY[K] = 0;      # CLEAR, ENABLE FRESH START         #
          THREADENTRY[K] = 0; 
          END 
  
        THREADINDEX = 2;
  
        STDYES;                    # RETURN                            #
  
      END 
  
#----------------------------------------------------------------------#
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     F O L $ O F F                                                    #
#                                                                      #
#     THIS PROCEDURE SETS THE FLAG FOLLOWON TO FALSE TO INDICATE THE   #
#     FOLLOW DIRECTIVE IS NOT IN EFFECT.                               #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC FOL$OFF;
      PROC FOL$OFF; 
      BEGIN 
      RECNO;                       # RETURN TO STDNO IF RECORDING      #
  
      FOLLOWON = FALSE;            # INDICATE -FOLLOW- NOT IN EFFECT   #
  
      STDNO;                       # RETURN                            #
  
      END 
  
#----------------------------------------------------------------------#
      CONTROL EJECT;
XDEF PROC IMFNAM; 
     PROC IMFNAM; 
     BEGIN
          ITEM L;            # LOOP COUNTER                            #
  
          RECYES;                  # RETURN TO *STDYES* IF RECORDING   #
          IF FIELDNAMELG EQ 2 THEN # ITEM NAME QUALIFIED BY RECORD NAME#
          BEGIN 
             CALL DES$REC(FIELDN[2]); 
             IF RECORDID EQ 0 THEN
             BEGIN
               RETURN;             # RETURN TO -GETNAME- TO SEARCH     #
                                   # REMAINING SOURCES                 #
             END
             CALL DES$DIT (FIELDN[1], ITEMID);
             IF ITEMID EQ 0 THEN
             BEGIN
               RETURN;             # RETURN TO -GETNAME- TO SEARCH     #
                                   # REMAINING SOURCES                 #
             END
          END 
          ELSE
          BEGIN 
             ITEMID = 0;
             IF DIRLEXID EQ O"107"  # IF CURRENT DIRECTIVE IS *EXHIBIT*#
             THEN 
                BEGIN 
                DES$REC (FIELDN[1]);  # SEARCH FOR RECORD NAME         #
                IF RECORDID NQ 0   # IF RECORD NAME FOUND              #
                THEN
                   BEGIN
                   AREAITM = TRUE;  # RECORD IS AREA ITEM              #
                   RCTYPE = ET$RECORD;  # ITEM TYPE IS RECORD          #
                   STDYES;         # EXIT                              #
                   END
                END 
  
             FOR K=1 STEP 1 WHILE ITEMID EQ 0 DO
             BEGIN
                IF K GR MAXREC THEN     # ALL RECORD TYPES ARE SCANNED #
                BEGIN 
                  RETURN;          # RETURN TO -GETNAME- TO SEARCH     #
                                   # REMAINING SOURCES                 #
                END 
                RECORDID = K; 
                CALL DES$DIT (FIELDN[1], ITEMID); 
             END
          END 
          IF DIRLEXID EQ O"107"    # IF CURRENT DIRECTIVE IS *EXHIBIT* #
          THEN
             BEGIN
             STDYES;               # EXIT                              #
             END
  
  
  
                             # NOW, SEE IF THE ITEM IS THE FIRST       #
                             # (OR ONLY) SEARCH KEY OF AN ACCESS PATH  #
          AKEYITEM = FALSE; 
          KEYFLAG  = FALSE; 
          KEYORDINAL = 0; 
          IF PATHID EQ 0 THEN STDYES; 
          P<SAAT> = USERSSST + SICAPTD + (PATHID - 1) * SAPTENL;
          FOR K=1 STEP 1 UNTIL RECNRAP DO 
          BEGIN 
             IF ITEMID EQ B<0,6>APTENCM THEN
             BEGIN
                AKEYITEM = TRUE;
                KEYFLAG  = TRUE;
                PATHID = PATHID + K - 1;   # STORE THE CORRECT PATH ID #
                KEYORDINAL = PATHID;
                FOR L=0 STEP 9 UNTIL 54 DO
                BEGIN 
                   IF B<L,9> PATHLIST [RECORDID] EQ 0 THEN
                   BEGIN
                     B<L,9> PATHLIST [RECORDID] = PATHID; 
                     IF APTKYNR GR 1   # WE HAVE A MAJOR SEARCH KEY    #
                     OR APTDUPF  THEN  # SYNONYMS ARE ALLOWED          #
                         B<L/9,1> DUPLICLIST [RECORDID] = 1;
                   END
                   IF B<L,9> PATHLIST [RECORDID] EQ PATHID THEN STDYES; 
                END 
                STDYES; 
             END
                                   # CHECK TO SEE IF ITEM IS NOT       #
                                   # THE FIRST, BUT, A SEARCH KEY      #
             FOR L = 1 STEP 1 
               UNTIL LASTCHAR 
             DO 
               BEGIN
               IF ITEMID EQ C<L,1>APTENCM 
               THEN 
                 BEGIN
                 AKEYITEM = TRUE;  # INDICATE KEY ITEM                 #
                 END
               END
             P<SAAT> = P<SAAT> + SAPTENL; 
          END 
          STDYES; 
     END
#----------------------------------------------------------------------#
  
XDEF PROC GET$AP;            # FIND THE ACCESS PATH CORRESPONDING TO   #
     PROC GET$AP;            # A LIST OF SEARCH KEYS.                  #
     BEGIN
          ITEM P I;          # LOOP COUNTER FOR THE ACCESS PATHS       #
          ITEM I I;          # LOOP COUNTER FOR SEARCH KEYS IN A PATH  #
          ITEM PATHMAP I;    # TO BUILD A BIT MAP SIMILAR TO KEYMAP    #
          ITEM C I;          # TO SAVE THE ORDINAL OF A SEARCH KEY     #
  
          RECYES;                  # RETURN TO *STDYES* IF RECORDING   #
          P<BASICTABLE> = BASCPTR;
          IF NOT BASCUSING[BASTABIND]      # IF NOT *USING* CLAUSE     #
          THEN
            BEGIN 
            STDYES;                # RETURN, ROUTINE DOES NOT APPLY    #
            END 
          P<SAAT> = USERSSST + SICAPTD;    # LOCATE ACCESS PATH TABLE  #
          FOR P=1 STEP 1           # FOR EACH ACCESS PATH              #
          UNTIL SICAPTN            # UNTIL THE LAST ONE                #
          DO
          BEGIN 
             IF APTRCID EQ RECORDID    # ACCESS PATH IS ON THE         #
             THEN                      # RIGHT RECORD TYPE             #
             BEGIN
             PATHMAP = 0;    # INITIALIZE ACCESS PATH BIT MAP          #
             FOR I = 0 STEP 1      # FOR ALL KEYS IN CONSIDERED PATH   #
             UNTIL APTKYNR - 1     # UNTIL ALL KEYS INSPECTED          #
             DO 
             BEGIN
                C = C<I, 1> APTENCM;   # GET KEY ORDINAL               #
                IF C LQ 60         # KEY WITHIN FIRST 60 ITEMS         #
                THEN
                BEGIN 
                   B<C-1, 1> PATHMAP = 1; 
                END 
             END
             IF PATHMAP EQ KEYMAP  # KEY LIST MATCHES THIS PATH        #
             THEN 
             BEGIN
                PATHID = P; 
                PATHLIST [RECORDID] = 0;    # CLEAR PATH LIST          #
                B<0, 9> PATHLIST [RECORDID] = PATHID; 
  
                SEARCHKEY = TRUE;  # INDICATE SEARCH KEY FOUND         #
                IF APTDUPF         # THIS ACCESS PATH HAS DUPLICATES   #
                THEN
                BEGIN 
                   B<0, 1> DUPLICLIST [RECORDID] = 1; 
                END 
                ELSE
                BEGIN 
                   B<0, 1> DUPLICLIST [RECORDID] = 0; 
                END 
                STDYES;            # SUCCESSFUL EXIT                   #
             END
             END
             P<SAAT> = P<SAAT> + SAPTENL;  # LOCATE NEXT TABLE ENTRY   #
          END 
          STDNO;                   # UNSUCCESSFUL EXIT                 #
     END
#----------------------------------------------------------------------#
  
  
     PROC ITEMATTRIB;        # TO SET AN ITEM ATTRIBUTES IN CEXPRESS   #
     BEGIN
                ITEM K I;          # LOOP COUNTER                      #
                P<TEMPA> = LOC(DIRECTENTRY);
                FOR K = 0 STEP 1   # ZERO OUT DIRECTENTRY ARRAY        #
                  UNTIL 4 
                DO
                  BEGIN 
                  TEMP[K] = 0;
                  END 
  
                P<DID> = USERSSCT + SDTDIDD;
                BWP = DIDRWA; 
                BBP = DIDRBP; 
                DATALENG = DIDLBIT / 6; 
  
                P<DFM> = USERSSCT + DIDDFMD;
                IF DFMDTYP LQ MAXTYPE 
                             THEN DATATYPE = IMFQUTYPE [DFMDTYP]; 
                             ELSE DATATYPE = 0;   # MAP TO CHARACTER   #
  
          RECORDSEEN [RECORDID] = TRUE; 
          DATANAMEPTR = LOC(DIRECTENTRY);    # POINT TO ITEM ATTRIBUTES#
                                   # SET DATANAMEBASE TO THE           #
                                   # RECORD ID WHERE ITEM WAS FOUND    #
          DATANAMEBASE = RECORDID; # TO BE REPLACED BY POINTER TO WSA  #
          DIRWORDADDR = WRDADDR;   # STORE P<SDID> FOR -CUMFUNC- TO    #
                                   # DISTINGUISH BETWEEN ATTRIB TABLES #
          DATAWORDADDR = BWP; 
          ABSADDRESS = FALSE;      # INDICATE THAT DATAWORDADDR        #
                                   # CONTAINS A RELATIVE WORD ADDRESS, #
                                   # NOT AN ABSOLUTE ONE.              #
          DATACHARPOS = BBP / 6;
  
          EXPICSIZE = DATALENG; 
          INCPICSIZE = DATALENG;
          RESULTSIZE = DATALENG;
          USESIZE = DATALENG; 
  
          RESULTUSAGE = DATATYPE; 
          DATANAMEUSE = DATATYPE; 
          CLASS = DATATYPE; 
          RCTYPE = 1;              # ALWAYS ELEMENTARY ITEM            #
          AREAITM = TRUE; 
          FIGLITDATA = S"AREANAME"; 
          PROGSTACKLEN = -1;
          IF DATATYPE EQ DT$NUM    # IF COBOL COMP                     #
          THEN
            BEGIN 
            SIGN = DFMSIGN;        # TRUE IF SIGN OVERPUNCH            #
            SIGNATERKEY = DFMSIGN;
            CDPTLOC = DFMI2;       # NBR OF CHAR POSITIONS DECIMAL PT  #
                                   # IS LEFT OF RIGHT END OF FIELD     #
            END 
  
          IF DATATYPE EQ DT$INTEGER  # IF COBOL-5 COMP-1               #
            AND SSTHOST EQ 1
          THEN
            BEGIN 
            CDPTLOC = DFMI2;       # MAY BE SCALED INTEGER             #
            EXPICSIZE = DFMI1;     # NBR OF 9-S IN PICTURE             #
            INCPICSIZE = DFMI1; 
            RESULTSIZE = DFMI1; 
            END 
  
          IF (DATATYPE EQ DT$INTEGER  # IF FORTRAN INTEGER             #
              AND (SSTHOST EQ 2    # IF FORTRAN 4                      #
                OR SSTHOST EQ 5))  # IF FORTRAN 5                      #
            OR DATATYPE EQ DT$FLOAT 
            OR DATATYPE EQ DT$DOUBLE
            OR DATATYPE EQ DT$COMPLEX 
            OR DATATYPE EQ DT$LOGICAL 
                                   # IF NO PICTURE IN DFM, USE QU-S    #
                                   # DEFAULT PICTURE                   #
          THEN
            BEGIN 
            BBP = 0;               # INT, FLOAT, LOGICAL ALWAYS        #
                                   # WORD ALIGNED                      #
            DATACHARPOS = 0;
            EXPICSIZE = DISPSIZ[DATATYPE];  # PIC SIZE EXCL EDIT CHARS #
            INCPICSIZE = PICSIZ[DATATYPE];  # PIC SIZE INCL EDIT CHARS #
            RESULTSIZE = INCPICSIZE;
            CDPTLOC = DECPT[DATATYPE];      # DECIMAL POINT LOCATION   #
            IF DATATYPE EQ DT$DOUBLE
              OR DATATYPE EQ DT$COMPLEX 
            THEN
              BEGIN 
              USESIZE = 20;        # ALWAYS TWO CM WORDS               #
              DATALENG = 20;
              END 
  
            ELSE
              BEGIN 
              USESIZE = 10;        # ALWAYS ONE CM WORD                #
              DATALENG = 10;
              END 
  
            IF DEFMURAL [DATATYPE] NQ 0     # IF MURAL EXISTS          #
            THEN
              BEGIN 
              P<TEMPA> = CMM$ALF (1, 0, SM$GROUPID);
              TEMP = DEFMURAL[DATATYPE];
              PTRMURAL = P<TEMPA>;          # ABS ADDRESS OF MURAL     #
              END 
            END 
          RETURN; 
     END
#----------------------------------------------------------------------#
  
  
XDEF PROC STO$AP;            # GET ACCESS PATH IDENTIFIER              #
     PROC STO$AP; 
   BEGIN
          RECYES;                  # RETURN TO *STDYES* IF RECORDING   #
          CALL DES$APT(CURWORD);
          IF PATHID EQ 0 THEN 
          BEGIN 
             CALL DIAG(506, "PATH", CURWORD); 
             STDNO; 
          END 
          THISRECORDID [1] = RECORDID;
          PATHCOSETID [1] = PATHID; 
          PATHLIST [RECORDID] = 0;  B<0,9> PATHLIST [RECORDID] = PATHID;
          B<0,1> DUPLICLIST [RECORDID] = DUPLICATES;
                                   # SAVE FOR FUTURE NAVIGATION        #
          APATHDUP = DUPLICATES;   # IF DUPS OR NOT                    #
          APATHREC = RECORDID;     # RECORD ID OF ACCESS PATH          #
          STDYES; 
   END
#----------------------------------------------------------------------#
  
  
XDEF PROC STO$KEY;           # SAVE SEARCH KEY ORDINAL IN A BIT MAP    #
     PROC STO$KEY;
     BEGIN
          RECYES;                  # RETURN TO *STDYES* IF RECORDING   #
          IF ITEMID LQ 60    # SEARCH KEY IS WITHIN FIRST 60 ITEMS     #
          THEN
          BEGIN 
             B<ITEMID-1, 1> KEYMAP = 1; 
             RETURN;               # SUCCESSFUL EXIT                   #
          END 
          ELSE                     # KEYS BEYOND 60TH ITEM NOT HANDLED #
          BEGIN 
             DIAG( 533 );          # DIAGNOSE ITEM NOT WITHIN FIRST 60 #
             STDNO;                # UNSUCCESSFUL EXIT                 #
          END 
     END
#----------------------------------------------------------------------#
  
XDEF PROC STO$MEM;
     PROC STO$MEM;
     BEGIN
          RECYES;                  # RETURN TO *STDYES* IF RECORDING   #
          CALL DES$CST(CURWORD);
          IF COSETID EQ 0 THEN
          BEGIN 
             CALL DIAG(506, "COSET", CURWORD);
             STDNO; 
          END 
          ORIGRECORDID [THREADINDEX] = OWNERID; 
          THISRECORDID [THREADINDEX] = MEMBERID;
          PATHCOSETID [THREADINDEX] = COSETID;
          OWNER  [THREADINDEX] = FALSE; 
          THREADINDEX = THREADINDEX + 1;
          IF THREADINDEX GR MAXTHREAD THEN
          BEGIN 
             CALL DIAG(509);
             STDNO; 
          END 
          STDYES; 
     END
#----------------------------------------------------------------------#
  
  
XDEF PROC STO$REC;           # GET RECORD IDENTIFIER                   #
     PROC STO$REC;
   BEGIN
          RECYES;                  # RETURN TO *STDYES* IF RECORDING   #
          CALL DES$REC(CURWORD);
          IF RECORDID EQ 0 THEN 
          BEGIN 
             CALL DIAG(506, "RECORD", CURWORD); 
             STDNO; 
          END 
          STDYES; 
   END
#----------------------------------------------------------------------#
  
  
XDEF PROC STO$OWN;
     PROC STO$OWN;
     BEGIN
          RECYES;                  # RETURN TO *STDYES* IF RECORDING   #
          CALL DES$CST(CURWORD);
          IF COSETID EQ 0 THEN
          BEGIN 
             CALL DIAG(506, "COSET", CURWORD);
             STDNO; 
          END 
          ORIGRECORDID [THREADINDEX] = MEMBERID;
          THISRECORDID [THREADINDEX] = OWNERID; 
          PATHCOSETID [THREADINDEX] = COSETID;
          OWNER  [THREADINDEX] = TRUE;
          THREADINDEX = THREADINDEX + 1;
          IF THREADINDEX GR MAXTHREAD THEN
          BEGIN 
             CALL DIAG(509);
             STDNO; 
          END 
          STDYES; 
     END
#----------------------------------------------------------------------#
  
END 
TERM
