*DECK DATANAM                                                           000780
USETEXT TAREATB 
USETEXT TBASCTB 
USETEXT TCMMDEF 
USETEXT TCRMDEF 
USETEXT TDESATT 
USETEXT TENVIRN 
USETEXT TEXPRES 
USETEXT TFIT
USETEXT TIMF
USETEXT TINDTBL 
USETEXT TLFNINF 
USETEXT TOPTION 
USETEXT TPSTACK 
USETEXT TREPORT 
USETEXT TSBASIC 
USETEXT TXSTD 
      PROC DATANAM;                                                     000790
      BEGIN                                                              DATANAM
                                                                         DATANAM
      XREF PROC CDCSNAM;           # SEARCH CDCS SUBSCHEMA FOR DATANAME#
      XREF PROC CRMNAME;           # SEARCH CRM SUBSCHEMA FOR DATA NAME#
      XREF ITEM CDCSDBM B;         # TRUE IF CDCS DATA BASE MODE       #
      XREF ITEM IMFDBM B;          # TRUE IF IMF DATA BASE MODE        #
      XREF PROC IMFNAM;            # SEARCH IMF METASCHEMA FOR NAME    #
      XREF PROC RECNO;
      XREF PROC RECYES; 
      XREF BASED ARRAY DESPTR;
        BEGIN 
        ITEM DESCOUNT I(00,00,12); # NUMBER OF LOCAL FILES REFERENCING #
                                   # THIS LIST OF DESCRIBE ITEMS       #
        ITEM DESSIZE  U(00,24,18); # SIZE OF DESCRIBED LIST IN CHAR    #
        ITEM DESADDR  U(00,42,18); # ADDRESS OF LIST OF ITEMS          #
        END 
      XREF BASED ARRAY SCHEMAFIT; ;                                      DATANAM
      XREF ITEM CURREG B;          # TRUE IF CURRENT-REGISTER          # QU3A334
      XREF ITEM CURRELATION;
      XREF ITEM LFNLIST;           # CONTAINS ADDRESS OF LFNINFO       #
      XREF ITEM SM$GROUPID;        # GROUP ID OF CMM BLOCKS ALLOCATED  #
                                   # FOR THIS DIRECTIVE OR REPORT OR   #
                                   # ZERO IF CM NOT REQUESTED FOR BASIC#
                                   # TABLE DIRECTIVE OR REPORT         #
      XREF ITEM UPDATEAREA B;      # TRUE IF -UPDATE AREANAME- WAS DONE#
      XREF ITEM UPONLFN  C(07);    # LFN OF UPON FILE                  #
      XREF ITEM TARGETAREA;        # AREA TO BE UPDATED.               #
      XREF ITEM AREATBLPTR; 
      BASED ARRAY ANAME1[1:3];                                           QY40163
        ITEM NAME1 C(0,0,10);                                            QY40163
      XDEF BASED ARRAY ANAME2[1:4]; 
        BEGIN 
        ITEM NAME2 C(0,00,10);     # NAME - IN FIRST 3 WORDS           #
        ITEM NLG2  I(0,24,18);     # LENGTH - IN FOURTH WORD           #
        END 
       XDEF 
          ITEM FIELDNAMELG;    #LEVEL OF QUALIFIACTIONS#
       XDEF 
       ARRAY FIELDN[1:FIELDNAMEMAX] S(4); 
              ITEM FN       C(0,0,10), #FIELD NAME# 
                   FN1      C(1,0,10),
                   FN2      C(2,0,10),
               FNWA U(3,0,18),  #TO SAVE THE DIRECTORY WORD ADDRESS#    000120
                   FNINDICE I(3,42,18), #LOCATION OR VALUE OF INDICE# 
                   FNLG     I(3,24,18), #FIELD NAME LENGTH# 
                   FNINDFG  I(3,18,6);  #0-CONSTANT INDICE
                                      1-ANY, 2-ALL, 4-LAST, 8-NEXT
                                      16-INTEGER ITEM INDEX#
            ARRAY [3];; 
          XREF PROC DIAG;                                               000920
          BASED ARRAY LITAVAIL[0];     # LITERAL STORAGE STRUCTURE.    #
        ITEM LIT; 
      XREF ITEM CURANY; 
      XREF ITEM DUMMY;                                                   DATANAM
      XREF ITEM NEWNAME B;         # TRUE--THERE IS A RENAME IN EXTRACT#
     XREF ITEM OLDNAMELG;          # SAVES -FIELDNAMELG-               #
          ITEM I,J,K; 
      BASED ARRAY SAVA;            # SCRATCH BASED ARRAY               #
        BEGIN 
        ITEM SAVAS I(0,0,60); 
        END 
      BASED ARRAY S;               # SCRATCH BASED ARRAY               #
        BEGIN 
        ITEM SS I(0,0,60);
        END 
  
      DEF FFIRST   # 0 #;          # POSSIBLE VALUES FOR -LOOKORDER-   #
      DEF FONLY    # 1 #; 
      DEF DBFIRST  # 2 #; 
      DEF DBONLY   # 3 #; 
      DEF DEFID    # O"101" #;     # LEXICAL ID OF -DEFINE-            #
      DEF ENDSTK   # O"70" #;      # PGRMSTK CODE FOR END OF STACK     #
      DEF EXHID    # O"107" #;     # LEXICAL ID OF -EXTRACT-           #
      DEF MAXREC   # SICRCTN #;    # MAX NO OF RECORDS IN IMF SCHEMA   #
      DEF OPERATR  # 7 #;          # PGRMSTK ENTRY FOR AN OPERATOR     #
  
      XREF ITEM FRMLFN  C(7);      # LFN OF -FROM- FILE                #
      XREF ITEM FROMKEYINFIT I;    # ADDR OF -FROM- FILES FIT          #
      XREF ITEM LOOKORDER;         # CODE INDICATING DATANAME LOOKUP   #
                                   # ORDER ...                         #
                                   #   0 - DESCRIBED FILES FIRST       #
                                   #   1 - DESCRIBED FILES ONLY        #
                                   #   2 - DATABASE FIRST              #
                                   #   3 - DATABASE ONLY               #
  
      ITEM ATTRPTR I;              # DESATT1 PTR RETURNED FROM -SEARCH-#
      ITEM OFLFN   C(7);           # LFN OF FILE QUALIFYING DATA NAME  #
      ITEM SRCHFLG B;              # TRUE WHILE SEARCHING FOR DATA NAME#
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     B L F I L L                                                      #
#                                                                      #
#     *BLFILL* WILL TAKE THE SEVEN-CHARACTER LFN PASSED IN *LFN* AND   #
#     CHANGE IT FROM ZERO-FILLED TO BLANK-FILLED.                      #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC BLFILL (LFN);
      BEGIN 
      ITEM LFN     C(7);           # LFN TO BE CONVERTED TO BLANK-FILL #
  
      FOR I = 0 STEP 1             # FOR EACH CHARACTER IN LFN         #
        UNTIL 6 
      DO
        BEGIN 
        IF C<I,1>LFN EQ 0          # IF THE CHAR IS BINARY 0           #
        THEN
          BEGIN 
          C<I,1>LFN = " ";         # CHANGE IT TO A BLANK              #
          END 
        END 
  
      RETURN; 
      END                          # PROC *BLFILL*                     #
      CONTROL EJECT;                                                     QY40163
      PROC SEARCHFORDUP(RT);                                             QY40163
#                                      #                                 QY40163
#        S E A R C H F O R D U P       #                                 QY40163
#                                      #                                 QY40163
# CHECKS THROUGH DEFINE, DESCRIBE, SPECIFY LISTS FOR THE NAME CONTAINED# QY40163
# IN THE -FIELDNAMELG- ENTRY OF THE -FIELDN- ARRAY. USES A ROUTINE,    # QY40163
# -SEARCH-, TO DO THE WORK.                                            # QY40163
      BEGIN                                                              QY40163
      ITEM RT;                   # RETURN CODE 1-FOUND, 0-NOTFOUND #     QY40163
  
      RT = 0; 
      P<ANAME2> = LOC(FN[1]);      # -NAME2- IS THE NAME TO FIND       #
      DESITM = FALSE;              # INITIAL ASSUMPTION - NOT DESCRIBED#
  
      IF FIELDNAMELG EQ 1          # IF NAME NOT QUALIFIED             #
        AND TYPEALOW GQ 2          # AND DEFINED ITEM ALLOWED          #
      THEN
        BEGIN 
                                   # LOOK FOR IT AMONG DEFINED ITEMS   #
        SEARCH (DEFLIST, RT, ATTRPTR);
  
        IF RT EQ 1                 # IF NAME FOUND ON DEFINE LIST      #
        THEN
          BEGIN 
          FIGLITDATA = S"TEMPNAME";  # SAVE TYPE OF NAME               #
          RETURN; 
          END 
        END                        # END SEARCH OF DEFINED ITEMS       #
  
      IF TYPEALOW EQ 2             # IF ONLY DEFINED ITEM ALLOWED      #
      THEN
        BEGIN 
        RETURN;                    # END SEARCH NOW                    #
        END 
  
      IF TYPEALOW EQ 0             # IF AREA ITEM ALLOWED              #
        OR TYPEALOW EQ 3
        OR TYPEALOW EQ 4
        OR (TYPEALOW EQ 6          # AND OK TO SEARCH DATABASE NOW     #
          AND (LOOKORDER EQ DBFIRST 
            OR LOOKORDER EQ DBONLY
            OR (FIELDNAMELG GQ 3
              AND LOOKORDER NQ FONLY))) 
      THEN
        BEGIN 
        SRCHAREA;                  # SEARCH FOR NAME IN DATABASE -- NO #
                                   # RETURN IF NAME FOUND              #
        END 
  
      IF FIELDNAMELG GQ 3          # IF TWO LEVELS OF QUALIFICATION    #
        OR LOOKORDER EQ DBONLY     # OR ONLY DATABASE TO BE SEARCHED   #
        OR TYPEALOW EQ 0           # OR ONLY AREA/DEFINED ITEM ALLOWED #
        OR TYPEALOW EQ 3
      THEN
        BEGIN 
        RETURN;                    # EXIT SINCE DESCR ITEM NOT ALLOWED #
        END 
  
      IF TYPEALOW EQ 1             # IF DESCRIBED ITEM ALLOWED         #
        OR TYPEALOW GQ 6
      THEN
        BEGIN 
        IF NOT FULLSYNTX           # IF NOT PREPARING A REPORT         #
        THEN
          BEGIN 
          IF LFNLIST NQ 0          # IF ANY FILES ARE KNOWN            #
          THEN
            BEGIN 
                                   # IF NAME IS QUALIFIED, MUST BE     #
            IF FIELDNAMELG EQ 2    # EITHER DESCRIBED OR AREA ITEM     #
            THEN
              BEGIN 
              SRCHOF (RT);         # SEARCH -OF- LFN FOR NAME          #
              END 
  
            ELSE                   # IF NAME NOT QUALIFIED             #
            BEGIN 
                                   # IF A -FROM- FILE ALREADY EXISTS,  #
            IF FROMKEYINFIT NQ 0   # ANY DESCRIBE ITEM MUST BE ON IT   #
            THEN
              BEGIN 
              IF FRMLFN EQ UPONLFN  # MAKE SURE FROM AND UPON DIFFERENT#
                AND FRMLFN NQ " " 
                AND UPONLFN NQ " "
              THEN
                BEGIN 
                DIAG(425,FRMLFN);  # IF NOT, SEND ERROR                #
                STDNO;             # AND END TRANSMISSION              #
                END 
              P<LFNINFO> = FROMKEYINFIT - L$FITOFFSET;
              P<DESPTR> = L$DESPTR;  # LOCATE -FROM- LFNS DESLIST      #
  
                                   # LOOK FOR NAME ON -FROM- DESLIST   #
              SEARCH (DESADDR, RT, ATTRPTR);
              END 
  
            ELSE                   # IF -FROM- LFN NOT GIVEN YET       #
              BEGIN 
              SRCHALL (RT);        # SEARCH EVERY LFN FOR NAME         #
              END 
  
            END                    # END IF NAME NOT QUALIFIED         #
  
            END                    # END IF LFNLIST NOT EMPTY          #
          END                      # END IF NOT PREPARING REPORT, ETC  #
  
        ELSE                       # IF PREPARING A REPORT             #
          BEGIN 
                                   # SEARCH ONLY THE ONE DESLIST       #
          SEARCH (DESLIST, RT, ATTRPTR);
          END 
  
        IF RT EQ 1                 # IF NAME FOUND ON A DESCRIBE LIST  #
        THEN
          BEGIN 
          FIGLITDATA = S"DATANAME";  # SAVE ITS TYPE                   #
          DESITM = TRUE;             # SET DESCRIBE ITEM FLAG          #
          RETURN;                    # RETURN TO -GETNAME-             #
          END 
  
        END                        # END IF DESCRIBED ITEM ALLOWED     #
  
      IF TYPEALOW EQ 6             # IF DATABASE SEARCHED AFTER FILES  #
        AND LOOKORDER EQ FFIRST 
      THEN
        BEGIN 
        SRCHAREA;                  # SEARCH FOR NAME IN DATABASE -- NO #
                                   # RETURN IF FOUND                   #
        END 
  
      IF TYPEALOW GQ 4             # IF SPECIFY ITEM ALLOWED           #
      THEN
        BEGIN 
                                   # SEARCH SPECIFY LIST FOR NAME      #
        SEARCH (SPELIST, RT, ATTRPTR);
  
        IF RT EQ 1                 # IF NAME FOUND                     #
        THEN
          BEGIN 
          FIGLITDATA = S"CONDEXPR";  # SAVE ITS TYPE                   #
          END 
        END                        # END IF SPECIFY ITEM ALLOWED       #
  
      RETURN; 
      END                          # PROC *SEARCHFORDUP*               #
      CONTROL EJECT;                                                     QY40163
      XDEF PROC SEARCH; 
      PROC SEARCH (LIST, RT, ATTRPTR);
#                           #                                            QY40163
#        S E A R C H        #                                            QY40163
#                           #                                            QY40163
# THIS PROC SEARCHES A LIST OF DEFINE, DESCRIBE, OR SPECIFY ENTRIES    # QY40163
# FOR A NAME THAT MATCHES THE NAME IN ARRAY -ANAME2-, A SUBSET OF THE  # QY40163
# -FIELDN- ARRAY. -LIST- CONTAINS THE ADDRESS OF THE FIRST ENTRY.      # QY40163
# IF NAME IS FOUND, -RT- IS SET TO 1 AND THE POINTER TO DESATT1 IS     #
# RETURNED IN -ATTRPTR-.                                               #
  
      BEGIN                                                              QY40163
      ITEM ATTRPTR;                # RETURN PARAMETER FROM CALL TO     #
                                   # SEARCH WHICH HOLDS DESATT1 PTR    #
      ITEM LIST;             # ADDRESS OF THE LIST TO SEARCH #           QY40163
      ITEM RT;               # RETURN CODE, 1-FOUND, 0,NOTFOUND #        QY40163
      ITEM IDENTICAL B;      # BOOLEAN DENOTING EQUALITY OF THE NAMES  # QY40163
      RT = 0;                                                            QY40163
      IF LIST EQ 0 THEN RETURN;    # IF EMPTY LIST                     #
  
      IF NAME2[1] EQ "FILLER"      # THE NAME -FILLER- IS SPECIAL CASE #
      THEN
        BEGIN 
        RETURN;                    # NO ERROR IF -FILLER- REPEATED     #
        END 
  
      P<DESATT1> = LIST;     # FIRST ENTRY, INITIAL POINTING OF DESATT1# QY40163
      FOR DUMMY=DUMMY                                                    DATANAM
        WHILE TRUE                 #EXIT LOOP VIA RETURN WHEN FOUND    # DATANAM
      DO                                                                 DATANAM
        BEGIN                # OR WHEN END OF LIST IS FOUND #            QY40163
        IF DIMOCC[0] THEN                                                QY40163
          P<ANAME1> = P<DESATT1> + 4;  # AVOID THE OCC. DESCRIPTOR #     QY40163
        ELSE                                                             QY40163
          P<ANAME1> = P<DESATT1> + 3;  # NO OCC. DESCR. TO AVOID #       QY40163
        IDENTICAL = TRUE;                                                QY40163
        IF DECNLG[0] NQ NLG2[4]    # NAME LENGTH IN CHARACTERS         #
        THEN
          IDENTICAL = FALSE;     # NOT SAME LENGTH...CANT BE EQUAL #     QY40163
        ELSE                                                             QY40163
          FOR I = 1 STEP 1 UNTIL DEWNLG[0] DO # FOR EACH WORD OF NAME #  QY40163
            IF NAME1[I] NQ NAME2[I] THEN IDENTICAL = FALSE;              QY40163
        IF IDENTICAL THEN    # CHAR LENGTHS EQUAL, ALL CHARS MATCH #     QY40163
          BEGIN                                                          QY40163
          RT = 1;            # FOUND THE NAME #                          QY40163
          ATTRPTR = P<DESATT1>;    # SAVE DESATT1 PTR FOR EXTERNL CALLS#
          RETURN;            # ALL DONE #                                QY40163
          END                                                            QY40163
        IF DABSPTR[0] EQ 0 THEN RETURN;  # END OF THE LIST #             QY40163
        ELSE P<DESATT1> = DABSPTR[0];   # UPDATE DESATT1 FOR NEXT ENTRY# QY40163
        END                                                              QY40163
      END                                                                QY40163
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     S R C H A L L                                                    #
#                                                                      #
#     *SRCHALL* IS CALLED BY *SEARCHFORDUP* WHEN ALL OF THE FILES ON   #
#     LFNLIST MUST BE SEARCHED FOR THE NAME.  TO DO THIS, IT CALLS     #
#     *SEARCH* FOR EACH FILE UNTIL THE NAME IS FOUND OR THE END OF     #
#     LFNLIST IS REACHED.                                              #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC SRCHALL (RT);
      BEGIN 
      ITEM RT      I;              # RETURN CODE = 1 IF NAME FOUND     #
                                   #             = 0 OTHERWISE         #
      ITEM CHAR    C(1);           # TEMP TO MOVE LFN FROM FIT TO      #
                                   # -FRMLFN- 1 CHAR AT A TIME         #
      ITEM SAVEATT I;              # SAVE PTR TO ATTRIB TABLE OF NAME  #
      ITEM SAVEDES I;              # SAVE INFO ON 1ST LFN NAME FOUND IN#
      ITEM SAVELFN I; 
  
      SAVELFN = 0;                 # INIT TO VALUE FOR NAME NOT FOUND  #
      SAVEDES = 0;
      SAVEATT = 0;
      P<LFNINFO> = LFNLIST;        # LOCATE DESLIST OF FIRST FILE      #
      P<DESPTR> = L$DESPTR; 
  
      FOR DUMMY = DUMMY            # LOOP THRU ALL FILES ON LFNLIST    #
      DO
        BEGIN 
                                   # LOOK FOR NAME                     #
        SEARCH (DESADDR, RT, ATTRPTR);
  
        IF RT EQ 1                 # IF FOUND NAME ON DESLIST          #
        THEN
          BEGIN 
          IF SAVELFN NQ 0          # IF THIS IS A DUPLICATE OF NAME    #
          THEN
            BEGIN 
            DIAG (417);            # DIAGNOSE AMBIGUOUS DESCRIBED ITEM #
            STDNO;                 # ERROR EXIT BACK TO SYNGEN         #
            END 
                                   # THIS IS FIRST OCCURRENCE OF NAME  #
          SAVELFN = P<LFNINFO>;    # SAVE POINTERS TO ITS INFO         #
          SAVEDES = P<DESPTR>;
          SAVEATT = ATTRPTR;
          END                      # END IF NAME FOUND                 #
  
        IF L$NEXT EQ 0             # IF NO MORE FILES TO SEARCH        #
        THEN
          BEGIN 
          IF SAVELFN NQ 0          # IF NAME FOUND ON ONE OF FILES     #
          THEN
            BEGIN 
            P<LFNINFO> = SAVELFN;  # RESTORE POINTERS TO ITS INFO      #
            P<DESPTR> = SAVEDES;
            P<DESATT1> = SAVEATT; 
            RT = 1;                # RESTORE RETURN CODE TO -FOUND-    #
  
            DESPASS = TRUE;        # SET UP LFN AS -FROM- FILE         #
            FROMKEYINFIT = LOC(L$FITLOC); 
            FRMLFN = L$FITLFNC;    # SAVE -FROM- FILE LFN OUT OF FIT   #
            IF FRMLFN EQ UPONLFN   # ERROR IF SAME NAME                #
              AND FRMLFN NQ " " 
              AND UPONLFN NQ " "
                                   # NEED TO RETURN UPON FILE          #
            THEN
              BEGIN 
              DIAG(425,FRMLFN); 
              STDNO;               # STOP THE TRANSMISSION             #
              END 
            BLFILL (FRMLFN);       # CHANGE 0-FILL TO BLANK-FILL       #
  
                                   # IF THIS IS BASICTABLE DIRECTIVE   #
            IF BASCPTR NQ 0        # SAVE RELEVANT INFO IN BASICTABLE  #
            THEN
              BEGIN 
              P<BASICTABLE> = BASCPTR;
              BASFITFROM[BASTABIND] = FROMKEYINFIT; 
              BASCFROM[BASTABIND] = TRUE; 
              END 
            END                    # END IF NAME FOUND                 #
  
          RETURN;                  # EXIT LOOP/PROC                    #
          END                      # END IF LAST FILE SEARCHED         #
  
        P<LFNINFO> = L$NEXT;       # ADVANCE TO NEXT FILE              #
        P<DESPTR> = L$DESPTR; 
        END                        # END -DUMMY- LOOP                  #
  
      END                          # PROC *SRCHALL*                    #
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     S R C H O F                                                      #
#                                                                      #
#     *SRCHOF* IS CALLED BY *SEARCHFORDUP* TO LOCATE THE DESCRIBE LIST #
#     FOR THE FILE SPECIFIED BY *OF* AND SEARCH IT FOR THE NAME GIVEN  #
#     IN *NAME2*.  THE SEARCH ITSELF IS DONE BY THE PROC *SEARCH*      #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC SRCHOF (RT); 
      BEGIN 
      ITEM RT      I;              # RETURN CODE = 1 IF NAME FOUND     #
                                   #             = 0 OTHERWISE         #
      ITEM TEMPLFN C(7);           # TEMP HOLD FOR LFN OUT OF FIT      #
  
      OFLFN = FN[2];               # PICK UP -OF- LFN                  #
      P<LFNINFO> = LFNLIST; 
      SRCHFLG = TRUE; 
  
      FOR DUMMY = DUMMY            # SEARCH ALL KNOWN LFNS FOR A MATCH #
        WHILE SRCHFLG 
      DO
        BEGIN 
        TEMPLFN = L$FITLFNC;       # PICK UP LFN OUT OF FIT            #
        BLFILL (TEMPLFN);          # CHANGE IT FROM 0-FILL TO BLANK-FIL#
  
        IF OFLFN EQ TEMPLFN        # IF -OF- LFN MATCHES LFN OF FIT    #
        THEN
          BEGIN 
          SRCHFLG = FALSE;         # GO ON TO SEARCH THIS LIST FOR NAME#
          TEST DUMMY; 
          END 
  
        IF L$NEXT EQ 0             # IF REACHED END OF LFNLIST         #
        THEN
          BEGIN 
          RETURN;                  # RETURN WITHOUT A MATCH            #
          END 
  
        P<LFNINFO> = L$NEXT;       # ADVANCE TO NEXT FILE              #
        END                        # END -DUMMY- LOOP                  #
  
      P<DESPTR> = L$DESPTR;        # PICK UP ADDR OF LFN-S DESLIST     #
  
      IF FROMKEYINFIT EQ 0         # IF NO PREVIOUS -FROM- FILE        #
      THEN
        BEGIN 
                                   # OK TO SEARCH -OF- FILE FOR NAME   #
        SEARCH (DESADDR, RT, ATTRPTR);
  
        IF RT EQ 1                 # IF NAME FOUND                     #
        THEN
          BEGIN 
          FIGLITDATA = S"DATANAME";  # SAVE ITS TYPE                   #
          DESITM = TRUE;           # SET DESCRIBED ITEM FLAG           #
          DESPASS = TRUE;          # SET UP LFN AS -FROM- FILE         #
          FROMKEYINFIT = LOC(L$FITLOC); 
          FRMLFN = OFLFN; 
                                   # IF THIS IS A BASICTABLE DIRECTIVE,#
          IF BASCPTR NQ 0          # SAVE RELEVANT INFO IN BASICTABLE  #
          THEN
            BEGIN 
            P<BASICTABLE> = BASCPTR;
            BASFITFROM[BASTABIND] = FROMKEYINFIT; 
            BASCFROM[BASTABIND] = TRUE; 
            END 
          END                      # END IF NAME FOUND                 #
  
        END                        # END IF NO PREVIOUS -FROM- FILE    #
  
      ELSE                         # IF PREVIOUS -FROM- FILE           #
        BEGIN                      # IF -OF- AND -FROM- LFNS DIFFERENT #
        IF OFLFN NQ FRMLFN
        THEN
          BEGIN 
          DIAG (370);              # DIAGNOSE THE ERROR                #
          STDNO;                   # RETURN TO SYNGEN TO SKIP XMISSN   #
          END 
  
                                   # LOOK FOR NAME ON DESLIST          #
        SEARCH (DESADDR, RT, ATTRPTR);
  
        IF RT EQ 1                 # IF NAME FOUND                     #
        THEN
          BEGIN 
          FIGLITDATA = S"DATANAME";  # SAVE ITS TYPE                   #
          DESITM = TRUE;
          END 
  
        END                        # END IF PREVIOUS -FROM- FILE       #
  
      RETURN; 
      END                          # PROC *SRCHOF*                     #
      CONTROL EJECT;                                                     QY40163
      XDEF PROC STORLIT;
      PROC STORLIT; 
          BEGIN 
 #
 0        STORLIT - ENTERS CONTENTS OF CURWORD INTO THE LITERAL STORAGE 
                   AREA, SETS THE POINTER "NEXTLITAVAIL" TO THE NEXT
                   AVAILABLE WORD FOR LITERAL STORAGE AND RETURNS ALL 
                   ATTRIBUTES OF THE LITERAL IN THE ITEMS OF CEXPRESS.
                   (THE VALUE OF THE LITERAL AFTER CONVERSION IS STORED,
                   IF THE LITERAL IS NUMERIC OR MASK.)
 #
      SWITCH SPACEREQ CHAR,MASK,,INT,INT,SPREC,CMPLX,,SPREC,DPREC;
      RECNO;                       # RETURN TO STDNO IF RECORDING      #
          INDICED = FALSE;                                              005200
      AREAITM = FALSE;
      DESITM = FALSE;              # NOT A DESCRIBED ITEM              #
          ALTKEYITEM = FALSE;                                            XXXX 
      AKEYITEM = FALSE; 
      EXCLKEYITEM = FALSE;
      AMAJKEYITEM = FALSE;
      PMAJKEYITEM = FALSE;
      DATAITEMORD = 0;
      DATARECDORD = 0;
      CURREG = FALSE;              # NOT A CURRENT-REGISTER            # QU3A334
          FALL = FALSE; FANY = FALSE; FNEXT = FALSE; FLAST=FALSE; 
      FN[1] = ICW[0];              # SAVE LITERAL FOR DDIAG            #
      FN1[1] = ICW[1];
      FN2[1] = ICW[2];
      FNLG[1] = CURLENG;
      IF FULLSYNTX                 # IF PREPARING A REPORT             #
        OR NOT STKFLAG             # OR NOT WORKING ON REPORT DIRECTIVE#
      THEN
        BEGIN 
          J = 5;                       # BIAS FOR VALUE OF LITERALS.   #
          GOTO SPACEREQ[CURTYPE-103];  # SET I = NR WORDS IN LITERAL.  #
                                       # AND DATATYPE = CODED VALUE FOR#
                                       # TYPE OF DATA IN LITERAL.      #
      MASK: 
          FOR I=0 STEP 1 UNTIL CURLENW-1 DO # CONVERT MASK CHARS TO    #
            FOR J=0 STEP 6 UNTIL 54 DO # BYTE MASKS.                   #
            BEGIN 
              IF B<J,6>ICW[I] NQ "Y" THEN 
                K = 0;
              ELSE K = O"77"; 
              B<J,6>ICW[I] = K; 
            END 
      CHAR: 
          J = 0;
          DATATYPE = 0; 
          I = CURLENW - 1;
          GOTO ALLOC; 
      INT:  
          DATATYPE = 2; 
          I = 0;
          GOTO ALLOC; 
      SPREC:  
          DATATYPE = 4; 
          I = 0;
          GOTO ALLOC; 
      CMPLX:  
          DATATYPE = 6; 
          I = 1;
          GOTO ALLOC; 
      DPREC:  
          DATATYPE = 5; 
          I = 1;
      ALLOC:  
          P<LITAVAIL> = CMM$ALF(I + 1, 0, SM$GROUPID);
          DATAWORDADDR = P<LITAVAIL>; 
          J = J + I;
      STORE:                           # STORE LITERAL INTO ALLOCATED  #
          LIT[I] = ICWI[J];            # SPACE.                        #
          IF I GR 0 THEN
          BEGIN 
            I = I - 1;
            J = J - 1;
            GOTO STORE; 
          END 
          FIGLITDATA = S"LITERAL";
          IF DATATYPE GQ 2 THEN        # SET DATALENG TO THE CORE SIZE #
            IF DATATYPE LQ 4 THEN      # OF THE LITERAL IN BYTES.      #
              DATALENG = 10;
            ELSE DATALENG = 20; 
          ELSE DATALENG = CURLENG;
          ABSADDRESS = TRUE;
           RESULTUSAGE = DATATYPE;
          RESULTSIZE = CURLENG;        # EXTERNAL SIZE OF LITERAL.     #
          DATACHARPOS = 0;
          DATANAMEUSE = DATATYPE; 
          DATANAMEPIC = FALSE;
          DATANAMEPTR = 0;
          PTRMURAL[0] = 0;         # NO MURALS FOR LITERALS            #
          DATANAMEBASE = 0; 
          INDICED = FALSE;
        END 
          IF OLDTYPE NQ O"7777"    # IF CALLED FROM DEL-UP-SYN         #
          THEN
            BEGIN 
            TYPEALOW = OLDTYPE;    # RESET TYPEALOW                    #
            OLDTYPE = O"7777";
            END 
          STDNO;
          END 
  
  
      CONTROL EJECT;
          XDEF PROC INTSUBS;
          PROC INTSUBS; 
          BEGIN 
      RECYES;                      # RETURN TO STDYES IF RECORDING     #
      IF FULLSYNTX                 # IF PREPARING A REPORT             #
        OR NOT STKFLAG             # OR NOT WORKING ON REPORT DIRECTIVE#
      THEN
            BEGIN 
              FNINDFG[FIELDNAMELG] = 16;
              IF ICW[0] EQ "CURRENT-AN" AND ICW[1] EQ "Y" THEN
                BEGIN 
                FNINDICE[FIELDNAMELG] = LOC(CURANY);  # SUBSCRIPT LOC  #
                STDYES; 
                END 
              FIELDNAMELG = FIELDNAMELG + 1;
              NAMSAVED; 
                                   # POSN TO NAME OF SUBSCRIPT         #
              P<ANAME2> = LOC(FN[FIELDNAMELG]); 
                                   # LOOK FOR NAME AS DEFINED ITEM     #
              SEARCH (DEFLIST, K, ATTRPTR); 
              FIELDNAMELG = FIELDNAMELG - 1;
              IF K EQ 0            # IF NAME NOT FOUND                 #
                OR DECLASS[0] NQ 2 # IF NOT INTEGER                    #
                OR DPTLOC[0] NQ 0  # IF SCALED INTEGER                 #
              THEN
                BEGIN 
                STDNO;             # ERROR EXIT                        #
                END 
              FNINDICE[FIELDNAMELG] = VALULOC[0]; #SAVE ADDRESS#
              FIGLITDATA = S"TEMPNAME";  # FLAG SUBSCRIPT AS DEFINED   #
            END 
              STDYES; 
          END 
      CONTROL EJECT;
      XDEF PROC GETNAME;
      PROC GETNAME; 
          BEGIN 
 #
 0        GETNAME - SEARCHES DEFINE AND DESCRIBE LISTS AND SUBSCHEMA
                    FOR DESCRIPTION OF ITEM NAMED IN CURWORD. IF ITEM 
                    IS NOT FOUND, A DIAGNOSTIC IS ISSUED, ELSE ITS
                    ATTRIBUTES ARE RETURNED IN CEXPRESS.
 #
      RECYES;                      # RETURN TO STDYES IF RECORDING     #
      IF FULLSYNTX                 # IF PREPARING A REPORT             #
        OR NOT STKFLAG             # OR NOT WORKING ON REPORT DIRECTIVE#
      THEN
          BEGIN 
          AREAITM = FALSE;
          DESITM = FALSE;          # ASSUME THAT NOT A DESCRIBED ITEM  #
          ALTKEYITEM = FALSE;                                            XXXX 
          AMAJKEYITEM = FALSE;
          PMAJKEYITEM = FALSE;
          AKEYITEM = FALSE; 
          EXCLKEYITEM = FALSE;
          DATAITEMORD = 0;
          DATARECDORD = 0;
          CURREG = FALSE;          # NOT A CURRENT-REGISTER            # QU3A334
          FALL = FALSE;                                                 000820
          FANY = FALSE;                                                 000830
          FNEXT = FALSE;                                                000840
          FLAST = FALSE;                                                000850
  
          SEARCHFORDUP(K);            # SEARCH LISTS FOR NAME.        # 
          IF K EQ 0                # IF NAME NOT FOUND                 #
          THEN
            BEGIN 
            DDIAG (044);           # DIAGNOSE NAME NOT FOUND           #
            STDNO;                 # ERROR EXIT                        #
            END 
  
          DATANAMEUSE = DECLASS[0]; 
          IF DATANAMEUSE GQ 16 THEN    # DIAGNOSE DATA CLASS CODES NOT #
          BEGIN                        # SUPPORTED BY QU2.             #
        BAD: DDIAG(56); 
            STDNO;
          END 
          IF DATANAMEUSE LQ 7 THEN     # TYPE AND USAGE CODE ARE EQUIV-#
                                       # ALENT FOR CODED BINARY FIELDS,#
            DATATYPE = DATANAMEUSE;    # CHARACTER DATA, AND DISPLAY   #
                                       # NUMERIC DATA.                 #
          ELSE IF DATANAMEUSE GQ 11 AND # FOR DISPLAY-CODED NUMERIC    #
                  DATANAMEUSE LQ 14 THEN # TYPES, TYPE IS SET TO NUMER-#
                  BEGIN                # IC AND USAGE SET TO THE BINARY#
                    DATATYPE = 1;      # CLASS CODE.                   #
                    DATANAMEUSE = DATANAMEUSE - 8;
                  END 
               ELSE IF DATANAMEUSE EQ 8 OR # ALPHABETIC = CHARACTER AND#
                       DATANAMEUSE EQ 15 THEN # DISPLAY LOGICAL = TYPE #
                       BEGIN           # CHARACTER AND USAGE LOGICAL.  #
                         DATATYPE = 0;
                         DATANAMEUSE = DATANAMEUSE - 8; 
                       END
                    ELSE GOTO BAD;     # DATABASE KEY AND BIT STRINGS  #
                                       # ARE NOT SUPPORTED.            #
          RESULTUSAGE = DATATYPE; 
          DATAWORDADDR = DEWPOS[0]; 
          DATALENG = DECLSLG[0];
          IF MURALPTR[0] EQ 0      # SET PTRMURAL                      #
          THEN
            BEGIN 
            DATANAMEPIC = FALSE;
            PTRMURAL[0] = 0;
            END 
          ELSE
            BEGIN 
            DATANAMEPIC = TRUE; 
            PTRMURAL[0] = MURALPTR[0] + P<DESATT1>; 
            END 
          INDICED = FALSE;
          DATANAMEPTR = P<DESATT1>; 
          IF FIGLITDATA EQ S"DATANAME" THEN 
          BEGIN 
            DATANAMEBASE = LOC(CURRENTSOURC);#PTR TO BASE.# 
            ABSADDRESS = FALSE; 
            DATACHARPOS = DBITPOS[0]/6; 
          END 
          ELSE
          BEGIN 
            DATANAMEBASE = 0; 
            DATACHARPOS = 0;
            ABSADDRESS = TRUE;
            IF FIGLITDATA EQ S"CONDEXPR" THEN 
            BEGIN 
               RESULTSLOC = VALULOC[0]; 
              PROGSTACKLOC = DEXPPTR[0];
            IF CONDIT              # IF CONDITION NAME IS USED         #
              THEN
              BEGIN 
              IF DPOINT[0]         # IF AREA ITEMS REFERENCED          #
              THEN
                BEGIN 
                AREAITM = TRUE;    # SET FLAG FOR *CKFILL*             #
                END 
              ELSE
                BEGIN 
                IF DESCON[0]       # IF DESCRIBE ITEMS REFERENCED      #
                THEN
                  BEGIN 
                  DESITM = TRUE;   # SET FLAG FOR *CKFILL*             #
                  END 
                END 
              END 
              IF IMFDBM            # IF IN IMF DATABASE MODE           #
                AND DPOINT[0]      # AND -SPECIFY- REFERENCES DATANAMES#
              THEN
                BEGIN 
                AREAITM = TRUE;    # INDICATE DATABASE ACCESS          #
                P<PROGRAMSTACK> = PROGSTACKLOC; 
                FOR I = 0 STEP 1   # STEP THROUGH PRGM STACK           #
                  WHILE ENTRYTYPE[I] NQ OPERATR 
                    AND OPCODE[I] NQ ENDSTK 
                DO
                                   # DETERMINE TO WHICH IMF RECORD THE #
                                   # ITEM BELONGS AND FLAG IT AS SEEN. #
                                   # REC. ORDINAL IS IN TOWORDBASE     #
                                   # (IF 1ST REFERENCE), OR AREAORD    #
                  BEGIN 
                  IF TOWORDBASE[I] GR 0 
                    AND TOWORDBASE[I] LQ MAXREC 
                  THEN
                    BEGIN 
                    RECORDSEEN[TOWORDBASE[I]] = TRUE; 
                    END 
                  ELSE
                    BEGIN 
                    IF AREAORD[I] NQ 0
                    THEN
                      BEGIN 
                      RECORDSEEN[AREAORD[I]] = TRUE;
                      END 
                    END 
                  END              # END LOOP THROUGH PGRMSTACK        #
                END                # END -SPECIFY- CK FOR IMF DATANAME #
            END 
          END 
          IF FNINDICE[FIELDNAMELG] EQ 0 AND DIMOCC[0]                   000420
            AND FNINDFG[FIELDNAMELG] EQ 0 THEN                          000430
          BEGIN FNINDICE[FIELDNAMELG] = 1;
                GOTO CKDPND;
          END                                                           000460
          IF NOT DIMOCC[0] AND (FNINDFG[FIELDNAMELG] NQ 0               001010
              OR FNINDICE[FIELDNAMELG] NQ 0) THEN                       001020
          BEGIN DDIAG(933); 
                STDNO;                                                  000490
          END                                                           000500
          IF FNINDICE[FIELDNAMELG] NQ 0 AND FNINDFG[FIELDNAMELG] EQ 0 
          THEN BEGIN IF FNINDICE[FIELDNAMELG] GR DMAXOCR[0] THEN
          BEGIN DDIAG(177); STDNO; END
          IF DEPENDS[0] THEN                                            000320
          BEGIN K = 2;                                                  000330
                GOTO DEPEN;                                             000340
          END                                                           000350
                     DATACHARPOS=DATACHARPOS+(FNINDICE[FIELDNAMELG]-1)
              * DATALENG; 
                  K = DATACHARPOS / 10; 
                  DATAWORDADDR = DATAWORDADDR + K;
                  DATACHARPOS = DATACHARPOS - K * 10; 
               END
          IF FNINDFG[FIELDNAMELG] NQ 0
            OR FNINDICE[FIELDNAMELG] NQ 0 
          THEN
          BEGIN 
      CKDPND: #  #
          IF DEPENDS[0] THEN K = 2; ELSE K = 1;                         000370
        DEPEN: # #                                                      000380
          P<INDTBL> = CMM$ALF(K, 0, SM$GROUPID);
              INDTBLWD[0] = 0;
              DPTYPE[0] = FNINDFG[FIELDNAMELG]; #SAVED THE FLASS# 
              TBLGS[0] = K; 
              ENTYLG[0] = DATALENG; 
              UPBND[0] = DMAXOCR[0];
              INDCE[0] = FNINDICE[FIELDNAMELG]; 
              IF K EQ 2 THEN
              BEGIN K = P<DESATT1>; 
          P<DESATT1> = DOCCPTR[0];                                      000400
          INDCE[1] = DEWPOS[0]; 
                    TBLGS[1] = DBITPOS[0] / 6;
                    ENTYLG[1] = DECLSLG[0]; 
          DEPNDFG[0] = TRUE;                                            002340
                    DPTYPE[1] = DECLASS[0]; 
                    P<DESATT1> = K; 
              END 
              INDICED = TRUE; 
              INDCTBLOC = P<INDTBL>;
          IF NEXTFG[0] THEN                                             000520
          BEGIN IF NOT DEPENDS[0] OR FIGLITDATA NQ S"TEMPNAME" THEN     000530
                BEGIN DIAG(934); STDNO; END                             000540
                FNEXT = TRUE;                                           000550
          END                                                           000560
          ELSE                                                          000570
          IF LASTFG[0] THEN                                             000580
          BEGIN IF NOT DEPENDS[0] THEN                                  000590
                BEGIN DIAG(935); STDNO; END                             000600
                FLAST = TRUE;                                           000610
          END                                                           000620
          ELSE                                                          000630
          IF ANYFG[0] THEN                                              000640
          BEGIN IF NOT CONDIT THEN                                      000650
                BEGIN DIAG(936); STDNO; END                             000660
                FANY = TRUE;                                            000670
          END                                                           000680
          ELSE IF ALLFG[0] THEN FALL = TRUE;                            000690
          END 
          RESULTSIZE = DPICSIZ[0];     # PICTURED SIZE OF ITEM.        #
          IF TYPEALOW EQ 6 THEN 
          BEGIN 
              IF FIGLITDATA EQ S"DATANAME" THEN TYPEALOW = 7; 
          ELSE IF FIGLITDATA EQ S"AREANAME" THEN TYPEALOW = 4;
          END 
          IF OLDTYPE NQ O"7777" THEN
          BEGIN TYPEALOW = OLDTYPE; OLDTYPE=O"7777"; END
          END 
          STDYES; 
          END 
      CONTROL EJECT;
      PROC SRCHAREA;
#----------------------------------------------------------------------#
#                                                                      #
#     S R C H A R E A                                                  #
#                                                                      #
#     CALL THE APPROPRIATE SUBROUTINE TO SEARCH THE CRM, CDCS, OR IMF  #
#     DATABASE FOR THE REQUESTED DATANAME.                             #
#                                                                      #
#----------------------------------------------------------------------#
  
      BEGIN 
          IF CDCSDBM               # IF CDCS DATA BASE MODE            #
          THEN
            BEGIN 
            CDCSNAM;               # SEARCH CDCS SUBSCHEMA FOR DATANAME#
            END 
          ELSE
            BEGIN 
            IF IMFDBM              # IF IMF DATA BASE MODE             #
            THEN
              BEGIN 
              IF ( FNINDFG[FIELDNAMELG] NQ 0     # IF SUBSCRIPTED ITEM #
                OR FNINDICE[FIELDNAMELG] NQ 0 ) 
              THEN
                BEGIN 
                DIAG ( 546 );      # ERROR, NOT CURRENTLY SUPPORTED    #
                STDNO;             # RETURN                            #
                END 
              IMFNAM;              # SEARCH IMF METASCHEMA FOR NAME    #
              END 
            ELSE
              BEGIN 
              CRMNAME;             # SEARCH CRM SUBSCHEMA FOR NAME     #
              END 
            END 
          END 
      CONTROL EJECT;
      XDEF PROC SUBSCRIPT;
      PROC SUBSCRIPT; 
          BEGIN 
          RECYES;                  # RETURN TO STDYES IF RECORDING     #
          IF ICWI[5] LS 1 THEN STDNO;   #NEGATIVE INDICE# 
          FNINDICE[FIELDNAMELG] = ICWI[5];
          STDYES; 
          END 
  
  
#----------------------------------------------------------------------#
  
  
      XDEF PROC FIGSUBS;
      PROC FIGSUBS; 
          BEGIN 
          RECYES;                  # RETURN TO STDYES IF RECORDING     #
          IF FIELDNAMELG NQ 1 THEN STDNO;                               000380
          IF ICW[0] EQ "LAST" THEN I=4; 
          ELSE
          IF ICW[0] EQ "NEXT" THEN I=8; 
          ELSE
          IF ICW[0] EQ "ANY" THEN I=1;
          ELSE I=2; 
          FNINDFG[FIELDNAMELG] = I; 
          STDYES; 
          END 
          XDEF PROC RESETNAM; 
          PROC RESETNAM;
          BEGIN FIELDNAMELG =       0;     #RESET LEVEL NUMBER TO 0#
                STDYES; 
          END 
  
  
      CONTROL EJECT;
      XDEF PROC NEWATTRIB;
      PROC NEWATTRIB; 
#----------------------------------------------------------------------#
#                                                                      #
#     N E W A T T R I B                                                #
#  THIS PROC SAVES THE LEVEL OF QUALIFICATION OF A NAME (FIELDNAMELG)  #
#  WHEN THERE IS A RENAME.  THE OLD LEVEL OF QUALIFICATION WILL BE     #
# USED IN -BUDEXTR-.                                                   #
#                                                                      #
#----------------------------------------------------------------------#
      BEGIN 
      NEWNAME = TRUE; 
      OLDNAMELG = FIELDNAMELG;
      STDYES; 
      END 
  
  
#----------------------------------------------------------------------#
  
  
      XDEF PROC ITMNAM; 
      PROC ITMNAM;
      BEGIN 
  
      IF ICW[0] EQ "FILLER"        # -FILLER- ILLEGAL NAME EXCEPT FOR: #
        AND DIRLEXID NQ O"103"     # DESCRIBE                          #
        AND DIRLEXID NQ O"104"     # DISPLAY                           #
        AND DIRLEXID NQ O"110"     # EXTRACT                           #
      THEN
        BEGIN 
        DIAG(182);
        STDNO;
        END 
  
      FIELDNAMELG = FIELDNAMELG + 1; # INCREMENT LEVEL OF QUAL         #
      IF FIELDNAMELG GR 5 
      THEN
        BEGIN 
        DIAG(183);                 # MAX QUALIFICATION LEVEL EXCEEDED  #
        STDNO;
        END 
  
      NAMSAVED;                    # STORE NAME IN -FIELDN-            #
      STDYES; 
      END                          # PROC -ITMNAM-                     #
  
  
  
  
#----------------------------------------------------------------------#
  
  
          PROC NAMSAVED;
          BEGIN 
              FN[FIELDNAMELG] = ICW[0];  #STORE THE NAME# 
              FN1[FIELDNAMELG] = ICW[1];
              FN2[FIELDNAMELG] = ICW[2];
              FNINDFG[FIELDNAMELG] = 0;  #SET INDICE FLAG TO SONSTANT#
              FNINDICE[FIELDNAMELG] = 0;  #SET INDICE VALUE TO 0# 
              FNLG[FIELDNAMELG] = CURLENG; #SAVE LENGTH OF DATA NAME# 
              RETURN; 
          END 
      CONTROL EJECT;
          XDEF FUNC SAVATTR;                                            001020
          FUNC SAVATTR;                                                 001030
     BEGIN
          IF DATANAMEPTR NQ LOC(DIRECTENTRY) THEN 
          BEGIN SAVATTR=DATANAMEPTR;
                RETURN; 
          END 
                P<S> = LOC(DIRECTENTRY);                                001070
                I = 7;             # LENGTH OF ITEM DEF W/O MURAL      #
                P<SAVA> = CMM$ALF(I, 0, SM$GROUPID);
                I = I-1;                                                001100
                FOR J = 0 STEP 1 UNTIL I DO                             001110
                    SAVAS[J] = SS[J];                                   001120
                SAVATTR = P<SAVA>;                                      001130
                IF PTRMURAL[0] GQ 9  # IF A MURAL POINTER EXISTS       #
                THEN               # POINTER IS NOT RELATIVE TO BLOCK  #
                  BEGIN            # MAKE IT A RELATIVE ADDRESS        #
                  B<42,18>SAVAS[2] = PTRMURAL[0] - P<SAVA>; 
                  END 
                RETURN;                                                 001140
          END                                                           001150
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     G E T A R E A N A M E                                            #
# THIS PROC LOCATES THE AREA TABLE WHICH CORRESPONDS TO THE AREA NAME  #
# IN CURRENT WORD. TARGETAREA IS SET TO THE ADDRESS OF THIS TABLE.     #
#                                                                      #
#----------------------------------------------------------------------#
      XDEF PROC GETAREANAME;
      PROC GETAREANAME; 
      BEGIN 
      ITEM LOOPCON B; 
      ITEM DUMNUM I;
      ITEM AREANAMEBF I;           # 1ST TEN CHARACTERS OF AREA NAME,  #
                                   # ZERO FILLED IF NECESSARY          #
  
      AREANAMEBF = ICWI[0];        # 1ST TEN CHARACTERS OF AREA NAME   #
      RECYES;                      # RETURN TO STDYES IF RECORDING     #
      IF CURLENG LS 10             # IF AREA NAME LESS THAN 10 CHARS   #
      THEN
        BEGIN 
        DUMNUM = 6 * CURLENG; 
        B<DUMNUM,60-DUMNUM>AREANAMEBF = 0;  # REPLACE BLANKS WITH 0-S  #
        END 
      LOOPCON = TRUE; 
      P<AREA$TABLE> = AREATBLPTR; 
      FOR DUMMY = DUMMY WHILE LOOPCON DO
        BEGIN 
        IF AT$FORWARD EQ 0 THEN    # ERROR--NO MATCH ON FILE NAMES.    #
          BEGIN 
          STDNO;
          END 
        P<AREA$TABLE> = AT$FORWARD;  # FIRST TABLE IS SUB-SCHEMA.      #
                                   # ONLY COMPARE 10 CHARACTERS        #
        IF AREANAMEBF EQ B<0,60>AT$AFDB$NAME[0]  # IF SAME NAME        #
        THEN
                                                  # USE ONLY FIRST 10  #
                                                  # CHARS, SINCE THEY  #
                                                  # ARE UNIQUE.        #
                                   # FOUND A MATCH. SET TARGETAREA AND #
                                   # RETURN.                           #
          BEGIN 
          LOOPCON = FALSE;
          TARGETAREA = P<AREA$TABLE>; 
          UPDATEAREA = TRUE;
          SEARCHFLAG = FALSE;      # THIS IS NOT A FILEPASS            #
          TEST DUMMY; 
          END 
        END                        # DUMMY LOOP.                       #
      STDYES;                      # GOOD RETURN                       #
      END                          # GETAREANAME                       #
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     C H K D L U P                                                    #
#                                                                      #
#     CHECK IF CALLED FROM DEL-UP-SYN                                  #
#                                                                      #
#----------------------------------------------------------------------#
  
      XDEF PROC CHKDLUP;
      PROC CHKDLUP; 
      BEGIN 
      IF OLDTYPE NQ O"7777"        # IF CALLED FROM DEL-UP-SYN         #
      THEN
        BEGIN 
        STDNO;                     # STDNO IF CALLED FROM DEL-UP-SYN   #
        END 
      ELSE
        BEGIN 
        STDYES;                    # STDYES IF NOT CALLED FROM DEL-UP-S#
        END 
      END 
  
          XDEF PROC DDIAG;
          PROC DDIAG(N);
          BEGIN ITEM N; 
                ICW[0]=FN[1]; ICW[1]=FN1[1]; ICW[2]=FN2[1]; 
                CURLENG = FNLG[1]; CURLENW = (CURLENG + 9)/10;
                DIAG(N);
          END 
      END                                                               001160
      TERM;                                                             001170
