*COMDECK EXTRACTM 
#----------------------------------------------------------------------#
#                                                                      #
#     E X T R A C T M                                                  #
#                                                                      #
# THIS PROC MOVES DATA FROM THE CURRENT RECORD INTO THE RECORD WHICH   #
# IS TO BE WRITTEN ONTO THE EXTRACT FILE.  THIS PROC ALSO OPENS THE    #
# FILE IF THERE IS NO FET ADDRESS GIVEN (I.E. FIRST CALL TO            #
# *EXTRACTM*).                                                         #
#----------------------------------------------------------------------#
      PROC EXTRACTM;
      BEGIN                                                              QY40154
      BASED ARRAY MOVEPARAM;;      # SCRATCH USE TO PASS ARRAY ITM ADDR# QY40154
      ITEM ALLMOVED B;             # ALL EXTRACT ITEMS MOVED #           QY40154
      ITEM IDX    I;               # LOOP VARIABLE THRU -INDTBL-       #
      ITEM INDLG  I;               # INDTBL LENGTH - 1                 #
  
      P<DTABLE> = BASCADDR[BASTABIND];   # START AT BEGINNING OF TABLE #
      P<FIT> = BASFITUPON[BASTABIND]; 
      P<LFNINFO> = P<FIT> - L$FITOFFSET;
      FITRL = SAVFSIZE[30];        # CHAR LENGTH OF THIS EXTRACT       #
      IF L$WSA EQ 0                # IF NO WSA ASSIGNED                #
      THEN
        BEGIN 
        GETWSA(FIT);               # ASSIGN A WSA                      #
        END 
  
      ELSE                         # IF WSA ALREADY EXISTS             #
        BEGIN 
        IF FITMRL LS FITRL         # IF WSA TOO SMALL FOR THIS RECORD  #
        THEN
          BEGIN 
          CMM$FRF (L$WSA);         # FREE OLD WSA                      #
          FITMRL = FITRL;          # SET LARGER MRL                    #
          GETWSA (FIT);            # ALLOCATE NEW WSA                  #
          END 
        END 
  
      TORECORDLOC = FITWSA;        # SAVE PTR TO WSA                   #
  
      IF FITOC NQ OC$OPEN          # IF -UPON- FILE NOT OPEN           #
      THEN                                                               CTL40
        BEGIN                                                            CTL40
        FITBBH = TRUE;             # ALLOCATE BUFFERS BELOW HHA        #
        OPENM (FIT, $OUTPUT$, $N$, RA0);                                000150
        END                                                              CTL40
                                                                         CTL40
      ALLMOVED = FALSE;                                                  QY40154
      FOR DUMMY=DUMMY                                                    CTL40
        WHILE NOT ALLMOVED                                               CTL40
      DO                                                                 CTL40
        BEGIN                                                            CTL40
        FOR I = 0 STEP 3 UNTIL 30 DO
          BEGIN                                                          QY40154
          IF CPENTRY[I] EQ 0 THEN   # END OF THE TABLE #                 QY40154
            BEGIN                                                        QY40154
            ALLMOVED = TRUE;                                             QY40154
            TEST DUMMY;             # TEST OUTER LOOP TO EXIT #          QY40154
            END                                                          QY40154
          IF CPTYPE[I] EQ 0 THEN    # NEED OVERFLOW TABLE. #             QY40154
            BEGIN                                                        QY40154
            P<DTABLE> = OVERFLOW[I];                                     QY40154
            TEST DUMMY;             # TEST OUTER LOOP TO RESET -I- #     QY40154
            END                                                          QY40154
          P<MOVEPARAM> = LOC(CPENTRY[I]);    # POINT TO THIS ENTRY #     QY40154
          IF CPTYPE[I] EQ 1 THEN   # IF STRAIGHT MOVE                  #
            BEGIN 
            MOVEC(MOVEPARAM);      #MOVE ANOTHER ITEM                  # CTL40
            END 
  
          IF CPTYPE[I] EQ 3        # IF TO MOVE EXPRESSION             #
          THEN
            BEGIN 
            LOGICALRESLT = FALSE;  # RESULT WILL NOT BE TYPE LOGICAL   #
            PROGSTACKLOC = CPSTACK[I+1];
            EXPEVAL (M);           # EVALUATE EXPRESSION               #
            MOVEC (MOVEPARAM);     # MOVE THE RESULT                   #
            END 
  
          IF CPTYPE[I] EQ 4        # IF TO MOVE SUBSCRIPTED ITEM       #
          THEN
            BEGIN 
            UB = 0;                # INITIALIZE UPPER BOUND TO ZERO    #
            P<INDTBL> = CPSTACK[I+1];  # POSN TO INDEX TABLE           #
            INDLG = TBLGS[0] - 1;  # LENGTH OF INDEX TABLE             #
  
            FOR IDX = 0 STEP 1     # STEP THROUGH TABLE                #
              UNTIL INDLG 
            DO
              BEGIN                # IF DEPEND ENTRY EXISTS, IT WILL   #
              IF DEPNDFG[IDX]      # BE THE LAST WORD IN THE TABLE     #
              THEN
                BEGIN 
                INDLG = INDLG - 1; # DON-T LOOK AT IT                  #
                END 
  
              IF ALLFG[IDX]        # IF ENTRY SUBSCRIPTED BY -ALL-     #
              THEN
                BEGIN 
                ALLFOUND (IDX, MOVEPARAM);  # CALL FIGSUB FOR EACH ITEM#
                END                # (-ALLFG- IS ONLY POSSIBLE IN LAST #
                                   # ENTRY, SO DROPS OUT OF LOOP NOW)  #
              END                  # END -IDX- LOOP                    #
  
            IF UB EQ 0             # IF -ALL- NOT FOUND                #
            THEN
              BEGIN 
              FIGSUB (MOVEPARAM, M);  # MOVE SINGLE ITEM               #
              END 
  
            IF M NQ 0              # IF ERROR OCCURRED                 #
            THEN
              BEGIN 
              DIAG (M);            # DIAGNOSE IT                       #
              RETURN;              # ERROR EXIT                        #
              END 
            END                    # END SUBSCRIPTED ITEM              #
  
          END                      # END -I- LOOP                      #
        END                        # END -DUMMY- LOOP                  #
  
      PUT(FIT, RA0);                                                     CTL40
      RETURN;                                                            QY40154
      END                                                                QY40154
      CONTROL EJECT;
#----------------------------------------------------------------------#
#                                                                      #
#     A L L F O U N D                                                  #
#                                                                      #
#     *ALLFOUND* PROCESSES THE EXTRACT OF ANY ITEM(ALL).  IF THE ITEM  #
#     IS A *DEPEND ON* ITEM IT IGNORES THE FACT, AND IT ALWAYS IGNORES #
#     THE *ALL*.  FOR EACH ITEM IN THE ARRAY, IT CALCULATES THE        #
#     DESTINATION ADDRESS AND CALLS *FIGSUB* WITH A CONSTANT SUBSCRIPT.#
#     ANY ERROR FOUND BY *FIGSUB* IS PASSED BACK TO *EXTRACTM* TO BE   #
#     DIAGNOSED.                                                       #
#                                                                      #
#----------------------------------------------------------------------#
  
      PROC ALLFOUND (IDX, MPARAM);
      BEGIN 
      ITEM IDX     I;              # INDEX IN INDTBL OF ITEM(ALL)      #
      ITEM MPARAM  I;              # POSITION OF DTABLE ARRAY          #
  
      ITEM HOLD    I;              # TEMP FOR ADDRESS CALCULATION      #
      ITEM NXTITEM I;              # REL CHAR ADDR OF ITEM DESTINATION #
      ITEM SAVCHAR I;              # SAVE REL CHAR TO RESTORE LATER    #
      ITEM SAVITBL I;              # SAVE ENTRY IN INDEX TABLE         #
      ITEM SAVWORD I;              # SAVE REL WORD TO RESTORE LATER    #
      ITEM SUBSCR  I;              # CONSTANT SUBSCRIPT                #
  
      SAVCHAR = CPTCHAR[I];        # SAVE REL CHAR AND WORD ADDR-S     #
      SAVWORD = CPTOADDR[I];
      SAVITBL = INDTBLWD[IDX];     # SAVE WHOLE -INDTBL- ENTRY         #
      UB = UPBND[IDX];             # FIND NUMBER OF ENTRIES FOR ITEM   #
      IF DEPNDFG[IDX]              # IF -DEPEND- ENTRY EXISTS          #
      THEN
        BEGIN 
        TBLGS[0] = TBLGS[0] - 1;   # IGNORE IT FOR THE TIME BEING      #
        END 
                                   # EXTRACT NEEDS THE NULL ITEMS AS   #
      DEPNDFG[IDX] = FALSE;        # WELL AS THE ONES IN USE           #
      ALLFG[IDX] = FALSE; 
      CONSUB[IDX] = TRUE;          # EACH ENTRY WILL HAVE A CONST SUB  #
      NXTITEM = SAVWORD*10 + SAVCHAR;  # CHARS TO FIRST ITEM           #
  
      FOR SUBSCR = 1 STEP 1        # FOR EACH ENTRY                    #
        UNTIL UB
      DO
        BEGIN 
        INDCE[IDX] = SUBSCR;       # GIVE IT A CONSTANT SUBSCRIPT      #
        HOLD = NXTITEM / 10;
        CPTOADDR[I] = HOLD;        # DESTINATION WORD ADDRESS          #
        CPTCHAR[I] = NXTITEM - HOLD*10;   # CHAR WITHIN THAT WORD      #
        NXTITEM = NXTITEM + CPCHARLG[I];  # INCREMENT TO NEXT ITEM     #
        FIGSUB (MPARAM, M);        # MOVE THIS ITEM                    #
        IF M NQ 0                  # IF ERROR OCCURRED                 #
        THEN
          BEGIN 
          SUBSCR = UB + 1;         # DROP OUT OF LOOP - ERROR WILL BE  #
                                   # DIAGED IN -EXTRACTM-              #
          END 
        END                        # END -SUBSCR- LOOP                 #
  
      INDTBLWD[IDX] = SAVITBL;     # RESTORE ORIGINAL VALUES           #
      IF DEPNDFG[IDX] 
        AND IDX NQ 0
      THEN
        BEGIN 
        TBLGS[0] = TBLGS[0] + 1;
        END 
      CPTOADDR[I] = SAVWORD;
      CPTCHAR[I] = SAVCHAR; 
      RETURN;                      # BACK TO -EXTRACTM-                #
      END                          # END PROC *ALLFOUND*               #
