*DECK DB$DPIF 
USETEXT RELCMTX 
USETEXT CDCSCTX 
      FUNC DB$DPIF((DBPENTR))I; 
      BEGIN 
 #
* *   DB$DPIF - DATABASE PROCEDURE INTERFACE      PAGE  1 
* *   J E ESLER                                   DATE  04/21/76
* 
* DC  PURPOSE 
* 
*     EXECUTE APPROPRIATE DATABASE PROCEDURES, BASED ON THE ENTRY CODE, 
*     AND CHECK THEIR RETURN CODES.  ABORT FUNCTIONS OR TASKS WHEN ERROR
*     CONDITIONS OCCUR. 
* 
* DC  ENTRY CONDITIONS
* 
*     BASED ARRAY POINTERS ARE SET FOR: 
*         SAL 
*         CSFIXED 
*         ASL 
*         TQT 
*         UFT 
*         RSARBLK  (AREA LEVEL CALLS ONLY)
*         RSRECBLK (RECORD LEVEL PRIVACY CALLS ONLY)
*         RSBRLNBLK ( READ RELATION FUNCTIONS ONLY) 
*         CSLOKTBL (PRIVACY LEVEL CALLS ONLY) 
* 
* DC  EXIT CONDITIONS 
* 
*     NORMAL EXIT - ALL REQUIRED DB PROCS HAVE BEEN EXECUTED AND
*     CHECKED.  ANY RETURN PARAMETERS HAVE BEEN SAVED.
*     A NORMAL EXIT IS TAKEN AFTER A ZERO RETURN
*     CODE FROM ALL PROCEDURES AND AFTER
*     A ONE "1" RETURN CODE FROM ANY "ON ERROR" 
*     DATABASE PROCEDURES.
*     A "3" RETURN CODE ON A PRIVACY PROCEDURE IS RETURNED TO DB$PVC$ 
*     AS A FUNCTION VALUE.
*     OTHER PROCEDURES DEFINE DB$DPIF AS A PROC INSTEAD OF A FUNC.
*     IN THOSE INSTANCES THE FUNCTION VALUE OF "0" IS IGNORED.
* 
*     ABNORMAL EXIT - AN ERROR MESSAGE IS SENT, AND THE FUNCTION OR TASK
*     IS ABORTED.  CONTROL IS NOT RETURNED TO CALLER. 
*     AN EXCEPTION IS RETURN CODE 3 FOR PRIVACY PROCEDURES. 
*     THAT VALUE IS RETURNED AS A DB$DPIF FUNCTION VALUE. 
* 
* DC  CALLING ROUTINES
* 
*     ALL ROUTINES THAT CALL DATA BASE PROCEDURES 
* 
* DC  CALLED ROUTINES 
# 
      XREF PROC DB$CALL;      #CALL A ROUTINE#
      XREF PROC DB$DBPL;     #LOAD A DATA BASE PROCEDURE# 
      XREF PROC DB$ERR;      #ISSUE AN ERROR MESSAGE AND TERMINATE# 
      XREF PROC DB$FLOP;     #GENERATE FLOW POINT#
      XREF PROC DB$FSET;     # SELECT AND SET A FIT                    #
      XREF PROC DB$PUNT;     #CDCS ABORT PROCESSOR# 
      XREF ARRAY DB$RA0;;    #ARRAY BASED AT LOC 0# 
# 
*     CDCSCOMMN 
*     CSTRCDCLS 
*     CSTOPDCLS 
*     CSLCMDCLS 
*     RELCMDCLS 
 #
      CONTROL NOLIST; 
*CALL CSTOPDCLS 
*CALL CSTRCDCLS 
*CALL CSLCMDCLS 
      CONTROL LIST; 
# 
*     LOCAL VARIABLES 
# 
      ITEM DBPENTR;          #DBP ENTRY CODE# 
      ITEM DBPRTN;           #DBP RETURN CODE#
      ITEM ERRSTAT;          #ERROR STATUS# 
      BASED ARRAY KA;;       #KEY BUFFER# 
      ITEM KL;               #KEY LENGTH# 
      ITEM KP;               #KEY POSITION IN WORD# 
      ITEM LOCKNAME C(30);   #NAME OF ELEMENT FOR PRIVACY LOCK CHECK# 
      ITEM LOCKTYPE;         #ELEMENT TYPE FOR PRIVACY LOCK CHECK#
      ITEM RELNAME C(30);    #RELATION NAME#
      ITEM RL;               #CURRENT RECORD LENGTH#
      BASED ARRAY WSA;;      #BUFFER FOR CURRENT RECORD#
      ARRAY RECBUF;          #BUFFER FOR RECORD CODE                   #
        ITEM RECCODE U(0,0,60);  #RECORD CODE                          #
      BASED ARRAY FIT;;      #USER FIT FOR DBP CALL#
      DEF ORIF #ELSE IF#; 
      ARRAY MASKCODES [37] S (1); 
        BEGIN 
        ITEM MASK U(0,0,60);
        ITEM AREAFLTR U(0,0,21);
          ITEM FLTRBOPN  U(DFDPBOPN ,0,21)=[O"2"];
          ITEM FLTREOPN  U(DFDPEOPN ,0,21)=[O"1"];
          ITEM FLTRAOPN  U(DFDPAOPN ,0,21)=[O"4"];
          ITEM FLTRBCLS  U(DFDPBCLS ,0,21)=[O"2000000"];
          ITEM FLTRECLS  U(DFDPECLS ,0,21)=[O"1000000"];
          ITEM FLTRACLS  U(DFDPACLS ,0,21)=[O"4000000"];
        ITEM RECFLTR U(0,0,15); 
          ITEM FLTRBRGET U(DFDPBRGET,0,15)=[O"200"];
          ITEM FLTRERGET U(DFDPERGET,0,15)=[O"100"];
          ITEM FLTRARGET U(DFDPARGET,0,15)=[O"400"];
          ITEM FLTRBRSTO U(DFDPBRSTO,0,15)=[O"2"];
          ITEM FLTRERSTO U(DFDPERSTO,0,15)=[O"1"];
          ITEM FLTRARSTO U(DFDPARSTO,0,15)=[O"4"];
          ITEM FLTRBRMOD U(DFDPBRMOD,0,15)=[O"20"]; 
          ITEM FLTRERMOD U(DFDPERMOD,0,15)=[O"10"]; 
          ITEM FLTRARMOD U(DFDPARMOD,0,15)=[O"40"]; 
          ITEM FLTRBFIND U(DFDPBFIND,0,15)=[O"2000"]; 
          ITEM FLTREFIND U(DFDPEFIND,0,15)=[O"1000"]; 
          ITEM FLTRAFIND U(DFDPAFIND,0,15)=[O"4000"]; 
          ITEM FLTRBDEL  U(DFDPBDEL ,0,15)=[O"20000"];
          ITEM FLTREDEL  U(DFDPEDEL ,0,15)=[O"10000"];
          ITEM FLTRADEL  U(DFDPADEL ,0,15)=[O"40000"];
        ITEM DBPOPTNS U(0,50,10); 
        ITEM ERRDBP B(0,49,1);
          ITEM OPTNBOPN  U(DFDPBOPN ,49,11)=[O"401"]; 
          ITEM OPTNEOPN  U(DFDPEOPN ,49,11)=[O"2201"];
          ITEM OPTNAOPN  U(DFDPAOPN ,49,11)=[O"1001"];
          ITEM OPTNBCLS  U(DFDPBCLS ,49,11)=[O"500"]; 
          ITEM OPTNECLS  U(DFDPECLS ,49,11)=[O"2300"];
          ITEM OPTNACLS  U(DFDPACLS ,49,11)=[O"1100"];
          ITEM OPTNBRGET U(DFDPBRGET,49,11)=[O"420"]; 
          ITEM OPTNERGET U(DFDPERGET,49,11)=[O"2220"];
          ITEM OPTNARGET U(DFDPARGET,49,11)=[O"1020"];
          ITEM OPTNBRSTO U(DFDPBRSTO,49,11)=[O"404"]; 
          ITEM OPTNERSTO U(DFDPERSTO,49,11)=[O"2204"];
          ITEM OPTNARSTO U(DFDPARSTO,49,11)=[O"1004"];
          ITEM OPTNBRMOD U(DFDPBRMOD,49,11)=[O"410"]; 
          ITEM OPTNERMOD U(DFDPERMOD,49,11)=[O"2210"];
          ITEM OPTNARMOD U(DFDPARMOD,49,11)=[O"1010"];
          ITEM OPTNBFIND U(DFDPBFIND,49,11)=[O"440"]; 
          ITEM OPTNEFIND U(DFDPEFIND,49,11)=[O"2240"];
          ITEM OPTNAFIND U(DFDPAFIND,49,11)=[O"1040"];
          ITEM OPTNBDEL  U(DFDPBDEL ,49,11)=[O"500"]; 
          ITEM OPTNEDEL  U(DFDPEDEL ,49,11)=[O"2300"];
          ITEM OPTNADEL  U(DFDPADEL ,49,11)=[O"1100"];
          ITEM ERRBIGET  U(DFDPBIGET,49, 1)=[0];
          ITEM ERREIGET  U(DFDPEIGET,49, 1)=[1];
          ITEM ERRAIGET  U(DFDPAIGET,49, 1)=[0];
          ITEM ERRBISTO  U(DFDPBISTO,49, 1)=[0];
          ITEM ERREISTO  U(DFDPEISTO,49, 1)=[1];
          ITEM ERRAISTO  U(DFDPAISTO,49, 1)=[0];
          ITEM ERRBIMOD  U(DFDPBIMOD,49, 1)=[0];
          ITEM ERREIMOD  U(DFDPEIMOD,49, 1)=[1];
          ITEM ERRAIMOD  U(DFDPAIMOD,49, 1)=[0];
          ITEM ERRENCODE U(DFDPENCODE,49,1)=[0];
          ITEM ERRDECODE U(DFDPDECODE,49,1)=[0];
          ITEM ERRACTUAL U(DFDPACTUAL,49,1)=[0];
          ITEM ERRVIRTUAL U(DFDPVIRTUAL,49,1)=[0];
          ITEM ERRCHECK   U(DFDPCHECK  ,49,1)=[0];
          ITEM ERRPRIV    U(DFDPPRIV   ,49,1)=[0];
        END 
      ARRAY MASKCODEOI [0:3] S(1);
        BEGIN 
        ITEM OPINPMASK U(0,0,60); 
          ITEM FLTRBOPNI U(DFDPBOPN ,0,21)=[O"2"];
          ITEM FLTREOPNI U(DFDPEOPN ,0,21)=[O"1"];
          ITEM FLTRAOPNI U(DFDPAOPN ,0,21)=[O"4"];
          ITEM OPTNBOPNI U(DFDPBOPN ,49,11)=[O"402"]; 
          ITEM OPTNEOPNI U(DFDPEOPN ,49,11)=[O"2202"];
          ITEM OPTNAOPNI U(DFDPAOPN ,49,11)=[O"1002"];
        END 
  
      BASED ARRAY PARAMS S(1);     # ARRAY TO HOLD PARAMETERS FOR A    #
                                   # CALL TO DB$DPII. DECLARED AS S(1) #
                                   # SO ITEM PRDBPWORD CAN BE INDEXED  #
                                   # TO ACCESS CONTIGUOUS WORDS.       #
        BEGIN 
        ITEM PRNDBP    I(00,00,60);  # PARAMETER *NUMDBP*. IDENTIFIES  #
                                     # NUMBER OF PRDBPWORD ENTRIES.    #
        ITEM PRECOD    I(01,00,60);  # PARAMETER *ENTRCOD*             #
        ITEM PRTFWA    I(02,00,60);  # PARAMETER *TARGFWA*             #
        ITEM PRTBBP    I(03,00,60);  # PARAMETER *TARGBBP*             #
        ITEM PRTSZ     I(04,00,60);  # PARAMETER *TARGSZ*              #
        ITEM PRTCLS    I(05,00,60);  # PARAMETER *TARGCLS*             #
        ITEM PRSFWA    I(06,00,60);  # PARAMETER *SRCFWA*              #
        ITEM PRSBBP    I(07,00,60);  # PARAMETER *SRCBBP*              #
        ITEM PRSSZ     I(08,00,60);  # PARAMETER *SRCSZ*               #
        ITEM PRSCLS    I(09,00,60);  # PARAMETER *SRCCLS*              #
        ITEM PRMMOD    I(10,00,60);  # ITEM DB$MMOD                    #
        ITEM PRMSUB    I(11,00,60);  # ITEM DB$MSUB                    #
        ITEM PRDBPWORD I(12,00,60);  # THERE ARE *PRNDBP* CONTIGUOUS   #
                                     # ENTRIES LOCATED HERE. THEY ARE  #
                                     # THE INDIVIDUAL ENTRIES FROM     #
                                     # PARAMETER ARRAY *DBPLIST*. WHEN #
                                     # PASSING THIS ARRAY TO DB$DPII,  #
                                     # POSITION A BASED ARRAY TO -     #
                                     #    LOC(PRDBPWORD[0]),           #
                                     # AND PASS THE BASED ARRAY NAME.  #
                                     # INDEXING THIS ITEM TO ACCESS    #
                                     # CONTIGUOUS WORDS REQUIRES THE   #
                                     # CONTAINING ARRAY TO BE DECLARED #
                                     # AS S(1). ALSO, SINCE THIS ITEM  #
                                     # REPRESENTS A VARIABLE LENGTH    #
                                     # LIST, IT MUST BE THE LAST ITEM  #
                                     # DECLARED IN THIS ARRAY.         #
        END 
 #
* 
* DC  LOCAL PROCEDURES AND FUNCTIONS
* 
 #
  
  
  
#     I N T E R N A L   F U N C T I O N   -   A D D R D B P .          #
  
  
      FUNC ADDRDBP; 
      BEGIN 
 #
*     ADDRDBP - FUNCTION TO OBTAIN THE DBP ENTRY POINT ADDRESS. 
*     IF THE REQUIRED PROCEDURE IS NOT LOADED, LOAD IT. 
*     ALLOW CDCS TO ABORT USER IF CMM REQUEST CANNOT BE SATISFIED.
 #
      IF APEPADD[APLX] EQ 0 THEN
        BEGIN 
  
          CONTROL IFGR DFFLOP,0;
            DB$FLOP("DPIF-AD"); 
          CONTROL ENDIF;
  
          DB$DBPL(APWORD0[0],LOC(APDBPNAM[APLX]));
        END 
 #
*     IF THE PROC IS PROPERLY LOADED, RETURN ITS ENTRY ADDRESS. IF THERE
*     IS AN ERROR, ISSUE APPROPRIATE MESSAGE AND ABORT THE RUN UNIT.
 #
      IF APEPADD[APLX] LQ DFMAXDBPERR THEN
        BEGIN 
          DB$ERR(19);              #FDL ERROR#
        END 
      $BEGIN                       #DEBUG TRACE#
      XREF PROC DB$TRCT;
      DB$TRCT("DBP=:",C<0,7>APDBPNAM[APLX],7);
      $END
      APDBPAGE[APLX] = TIMESTAMP;      #SET AGE TO CURRENT TIME#
      ADDRDBP = APEPADD[APLX];
      END 
  
  
  
#     I N T E R N A L   P R O C E D U R E   -   C A L L R D B P .      #
  
  
      PROC CALLRDBP;
      BEGIN 
 #
*     CALLRDBP - CALL A RECORD LEVEL DATABASE PROCEDURE 
 #
  
      CONTROL IFGR DFFLOP,0;
        DB$FLOP("DPIF-CL"); 
      CONTROL ENDIF;
  
      DB$CALL((ADDRDBP),DBPENTR,DBPRTN,ERRSTAT,FIT,WSA,RL,KA,KP,KL, 
        RECBUF,TQPRNAME[0],RELNAME, 
        DB$RA0);
      END 
  
  
  
#     I N T E R N A L   P R O C E D U R E   -   C K R T N .            #
  
  
      PROC CKRTN; 
      BEGIN 
 #
*     CKRTN - CHECK THE RETURN CODE FROM A DATABASE PROCEDURE.
*     IF AN ERROR IS DETECTED, ISSUE THE APPROPRIATE ERROR MESSAGE, AND 
*     ABORT THE FUNCTION OR RUN UNIT. 
 #
      IF DBPRTN EQ 0 THEN 
        RETURN;                    #DB PROC OK - RETURN#
  
#  WE HAVE AN ERROR RETURN CODE - CALL DB$ERR TO ISSUE THE APPROPRIATE #
#  MESSAGE AND ABORT, UNLESS THIS IS AN ON ERROR DBP AND RETURN=1#
  
      IF DBPRTN EQ 1 THEN 
        BEGIN 
          IF ERRDBP[DBPENTR] THEN  #FUNCTION ALREADY ABORTED# 
            RETURN; 
          DB$ERR(17);              #FUNCTION ABORT# 
        END 
      IF DBPRTN EQ 3 THEN 
        BEGIN 
          IF ERRDBP[DBPENTR] THEN  #MAKE ERROR FATAL# 
            DB$ERR(26); 
          DB$ERR(18);              #RUN UNIT ABORT# 
        END 
      DB$ERR(20);                  #BAD RETURN CODE#
      END 
  
  
  
#     I N T E R N A L   P R O C E D U R E   -   G E T P A R M S .      #
  
  
      PROC GETPARMS;
      BEGIN 
 #
*     GETPARMS - SET UP THE RECORD LEVEL PARAMETERS REQUIRED BY RECORD
*     AND ITEM LEVEL DBP"S. 
 #
      IF UFFITWSA[0] EQ 0    # THIS WOULD TERMINATE PARAMETER LIST     #
      THEN
        BEGIN 
        P<WSA> = O"400000"; 
        END 
      ELSE
        BEGIN 
        P<WSA> = UFFITWSA[0]; 
        END 
      RL = UFFITRL[0];
      IF UFFITKA[0] EQ 0     # THIS WOULD TERMINATE PARAMETER LIST     #
      THEN
        BEGIN 
        P<KA> = O"400000";
        END 
      ELSE
        BEGIN 
        P<KA> = UFFITKA[0]; 
        END 
      KP = UFFITKP[0];
      KL = UFFITKL[0];
      RETURN; 
      END 
  
  
  
#     I N T E R N A L   P R O C E D U R E   -   S C A N D B P .        #
  
  
      PROC SCANDBP((PROCPTR));
      BEGIN 
 #
*     SCANDBP - GIVEN A PROCEDURE OPTION TABLE POINTER, SEARCH FOR AND
*     EXECUTE APPROPRIATE DATABASE PROCEDURES.
 #
      ITEM PROCPTR U;        #PROC OPTION TABLE POINTER#
      ITEM LENGTH U;         #LENGTH OF PROC OPTION LIST# 
      ITEM RIGHTCOL U;       #1=RIGHT COLUMN, 0=LEFT COLUMN#
      ITEM INDEX U;          #LOOP INDEX# 
  
      LENGTH = B<42,6> PROCPTR-1; 
      RIGHTCOL = B<48,1> PROCPTR; 
      P<CSOPTTBL> = ASCSTLOC [0] + CSFOPTPT [0] + B<49,11> PROCPTR; 
      IF RIGHTCOL EQ 0 THEN 
        BEGIN 
          MASK [0] = DBPOPTNS [0] * 2**30;
        END 
      ELSE
        BEGIN 
          MASK [0] = DBPOPTNS [0];
        END 
  
      FOR INDEX = 0 STEP 1 UNTIL LENGTH DO
        BEGIN 
          IF MASK [0] LAN CSOWORD [INDEX] EQ MASK [0] THEN
            BEGIN 
              IF RIGHTCOL EQ 0 THEN  #POSITION MASK FOR LEFT/RIGHT COL# 
                BEGIN 
                  APLX = CSOLPORD[INDEX]; 
                END 
              ELSE
                BEGIN 
                  APLX = CSORPORD[INDEX]; 
                END 
  
              IF DBPENTR LQ DFDPACLS THEN 
                BEGIN 
  
                CONTROL IFGR DFFLOP,0;
                  DB$FLOP("DPIF-SC"); 
                CONTROL ENDIF;
  
                DB$CALL((ADDRDBP),DBPENTR,DBPRTN,ERRSTAT,FIT, 
                                   TQPRNAME[0],DB$RA0); 
                END 
              ORIF DBPENTR LQ DFDPADEL THEN 
                CALLRDBP; 
  
              CKRTN;               #CHECK THE RETURN CODE#
            END 
        END 
      END 
  
  
#     E N D   O F   I N T E R N A L   P R O C E D U R E S .            #
  
#**********************************************************************#
  
  
  
  
#     B E G I N   D B $ D P I F   E X E C U T A B L E   C O D E .      #
  
  
 #
* 
* DC  DESCRIPTION 
* 
*     OBTAIN DBP MASKS FOR THIS TYPE OF CALL.  DETERMINE LEVEL OF CALL
*     (AREA, RECORD, ETC). CHECK FILTERS IF APPROPRIATE, AND SEARCH FOR 
*     PROCEDURES TO EXECUTE 
 #
      DB$DPIF = 0;
      MASK[0] = MASK[DBPENTR];
      P<APL> = SADBPPTR [SALX]; 
      IF P<APL> EQ 0 THEN 
        BEGIN 
  
        CONTROL IFGR DFFLOP,1;
          DB$FLOP("DPIF-1");
        CONTROL ENDIF;
  
        RETURN;                    #SCHEMA HAS NO DB PROCS# 
        END 
  
      CONTROL IFGR DFFLOP,0;
        DB$FLOP("DPIF");
      CONTROL ENDIF;
  
      DBPRTN = 2; 
      ERRSTAT = RCPKERR[0]; 
      P<CSAREBLK> = P<CSFIXED> + RSARCSTP[0]; 
  
#     IF THE OFT POINTER HAS A VALUE BUT THE UFT DOES NOT,             #
#     CALL DB$FSET TO SET UP THE UFT.                                  #
  
      P<FIT> = DFNPTR;
      IF P<OFT> GR 0
      THEN
        BEGIN 
        IF P<UFT> GR 0
        THEN
          BEGIN                    # USE THE EXISTING UFT POINTER      #
          P<FIT> = LOC(UFFIT[0]); 
          END 
        ELSE
          BEGIN 
          IF OFUFT[0] NQ DFNPTR 
            AND P<FPT> GR 0 
          THEN                     # GET A UFT                         #
            BEGIN 
            DB$FSET;
            P<FIT> = LOC(UFFIT[0]); 
            END 
          ELSE                     # USE THE FIT FROM THE OFT          #
            BEGIN 
            P<FIT> = LOC(OFFIT[0]); 
            END 
          END 
        END 
#**********************************************************************#
  
#     PROCESS AN AREA LEVEL CALL.                                      #
  
      IF DBPENTR LQ DFDPACLS
      THEN
        BEGIN 
  
          CONTROL IFGR DFFLOP,0;
            DB$FLOP("DPIF-2");
          CONTROL ENDIF;
  
          IF DBPENTR LQ DFDPAOPN AND UFFITPD [0] LS 2 THEN
            MASK [0] = OPINPMASK [DBPENTR]; 
          IF AREAFLTR [0] LAN CSAPOPTN [0] NQ 0 THEN
            BEGIN 
              SCANDBP(CSAPOPNT[0]); 
            END 
          RETURN; 
  
        END 
#**********************************************************************#
  
#     IF A READ RELATION IS BEING PERFORMED,GET THE RELATION NAME.     #
  
      IF RCFUNC[0] EQ DFREL OR RCFUNC[0] EQ DFRLS THEN
        BEGIN 
        P<CSRLNSER> = LOC(CSFIXED) + RSNCSPTR[0]; 
        RELNAME = C<0,CSNNAMLW[0]*10>CSNNAME[0];
        END 
      ELSE
        BEGIN 
        RELNAME = " ";
        END 
#**********************************************************************#
  
#     PROCESS A RECORD LEVEL CALL                                      #
  
      IF DBPENTR LQ DFDPADEL
      THEN
        BEGIN 
  
          CONTROL IFGR DFFLOP,0;
            DB$FLOP("DPIF-3");
          CONTROL ENDIF;
  
          IF RSFCRORD[0] NQ 0      # IF A RECORD EXISTS (RECORD ORDINAL#
          THEN                     # NQ 0), SET UP AND CALL RECORD     #
            BEGIN                  # LEVEL DBP                         #
            SETRSRECBLK;
            P<CSRECBLK> = P<CSFIXED> + RSRCCSTP[0]; 
            IF RECFLTR[0] LAN CSRPOPTN[0] NQ 0
            THEN
              BEGIN 
              GETPARMS; 
              SCANDBP(CSRPOPNT[0]); 
              END 
            END 
          RETURN; 
  
        END 
#**********************************************************************#
      IF DBPENTR EQ DFDPRECCODE THEN     #RECORD CODE DBP#
        BEGIN 
  
          CONTROL IFGR DFFLOP,0;
            DB$FLOP("DPIF-4");
          CONTROL ENDIF;
  
          P<CSACODTB> = P<CSAREBLK> + CSACODPT[0];
          APLX = CSACPORD[0]; 
          GETPARMS; 
          CALLRDBP; 
          CKRTN;
  
# SEARCH THRU THE PROCEDURE ENTRIES TO SEE IF THERE IS A MATCH WITH    #
# THE INTEGER RETURNED BY THE DATA BASE PROCEDURE                      #
  
 LOOP1: 
          P<CSACODTB> = P<CSACODTB> + 1;
          IF CSACINTG [0] EQ RECCODE AND CSACRORD [0] NQ 0 THEN 
  
# MATCH OCCURRED -- SET RECORD ORDINAL                                 #
  
              BEGIN 
              RSFCRORD [0] = CSACRORD [0];
              RSARRORD[0] = CSACRORD[0];
              RETURN; 
              END 
  
          IF CSACNEXT [0]  THEN         # IF ANOTHER ENTRY CHECK IT    #
              GOTO LOOP1; 
          DB$ERR(24);              #INVALID RECORD TYPE#
        END 
#**********************************************************************#
      IF DBPENTR EQ DFDPHASH THEN  #DA HASHING DBP# 
        BEGIN 
  
          CONTROL IFGR DFFLOP,0;
            DB$FLOP("DPIF-5");
          CONTROL ENDIF;
  
 #
*     FOR A HASHING DBP, WE LOAD THE PROCEDURE AND STORE ITS ENTRY
*     ADDRESS IN THE FIT.  THE PROCEDURE IS LOCKED INTO MM BY INCRE-
*     MENTING ITS USER COUNT. IT WILL NOT BE UNLOADED UNTIL THE USER
*     COUNT GOES TO ZERO. 
 #
          APLX = CSAHSORD[0]; 
         IF APLX NQ 0 THEN
            BEGIN 
              UFFITHRL[0] = ADDRDBP;
  
#  NOTE - FUNC ADDRDBP WILL NOT RETURN IF AN ERROR IS DETECTED         #
  
              APNUSERS[APLX] = APNUSERS[APLX] + 1;
            END 
        RETURN; 
        END 
#**********************************************************************#
      IF DBPENTR EQ DFDPCOMP THEN  # COMPRESSION/DECOMP ROUTINES       #
        BEGIN 
  
        CONTROL IFGR DFFLOP,0;
          DB$FLOP("DPIF-6");
        CONTROL ENDIF;
  
 #
*     IF SAME ROUTINE USED FOR COMPRESSION AND DECOMP THEN LOAD PROC
*     STORE ADDRESS INTO FIT FIELDS AND RETURN.  ELSE LOAD THE TWO
*     PROCS, STORE THEIR ADDRESSES IN THE FIT AND RETURN. 
 #
        APLX = CSACMORD[0]; 
        IF APLX NQ 0 THEN 
          BEGIN 
          UFFITCPA[0] = ADDRDBP;
          APNUSERS[APLX] = APNUSERS[APLX] + 1;
          IF CSADEORD[0] EQ CSACMORD[0] THEN   # SAME ROUTINE USED #
            BEGIN 
            UFFITDCA[0] = UFFITCPA[0];
            END 
          ELSE
            BEGIN 
            APLX = CSADEORD[0]; 
            UFFITDCA[0] = ADDRDBP;
            APNUSERS[APLX] = APNUSERS[APLX] + 1;
            END 
          END 
        RETURN; 
        END 
#**********************************************************************#
      IF DBPENTR EQ DFDPPRIV THEN  #PRIVACY DBP#
        BEGIN 
  
        CONTROL IFGR DFFLOP,0;
          DB$FLOP("DPIF-7");
        CONTROL ENDIF;
  
        LOCKTYPE = CSLKTYPE[0]; 
        IF LOCKTYPE EQ DFPVTYPA THEN #AREA LEVEL PRIVACY CHECK# 
          LOCKNAME = C<0,CSANAMLW[0]*10>CSANAME[0]; 
        ORIF LOCKTYPE EQ DFPVTYPR THEN #RECORD LEVEL PRIVACY CHECK# 
          BEGIN 
          P<CSRECBLK> = P<CSFIXED> + RSRCCSTP[0]; 
          LOCKNAME = C<0,CSRNAMLW[0]*10>CSRNAME[0]; 
          END 
        ELSE                          #ITEM LEVEL PRIVACY CHECK#
          LOCKNAME = " "; 
        APLX = CSLKPORD[0]; 
        DB$CALL((ADDRDBP),DBPENTR,DBPRTN,ERRSTAT,RCPPRKEY,LOCKTYPE, 
               LOCKNAME,CSLKLORD[0],TQPRNAME[0],DB$RA0);
        IF DBPRTN NQ 3
        THEN
          BEGIN 
          CKRTN;
          END 
        DB$DPIF = DBPRTN;      # DB$PVC$ EXPECTS FUNCTION VALUE 0 OR 3 #
        RETURN; 
        END 
#**********************************************************************#
      DB$PUNT("DB$DPIF  1");
  
  
  
  
#     E M B E D D E D   P R O C E D U R E   -   D B $ D P I I .        #
  
  
      XDEF PROC DB$DPII;
      PROC DB$DPII(DBPLIST,(NUMDBP),(ENTRCOD),(TARGFWA),(TARGBBP),
                 (TARGSZ),(TARGCLS),(SRCFWA),(SRCBBP),(SRCSZ),(SRCCLS));
      BEGIN 
 #
* *   DB$DPIF                                    PAGE  1
* *   DB$DPII - DATABASE PROCEDURE ITEM LEVEL INTERFACE 
* *   J E ESLER                                  DATE  3/11/77
* 
* DC  PURPOSE 
* 
*     EXECUTE ITEM LEVEL DATABASE PROCEDURES. 
*     CHECK THE RETURN CODES AND ABORT FUNCTIONS OR TASKS WHEN REQUIRED.
* 
* DC  ENTRY CONDITIONS
* 
*     BASED ARRAY POINTERS SET FOR
*         SAL 
*         ASL 
*         CSFIXED 
*         UFT 
*         RCB 
*         TQT 
* 
*     PARAMETERS   (DB$DPIS MUST BE CHANGED IF THIS LIST CHANGES) 
# 
      ARRAY DBPLIST S (1);
        BEGIN 
        ITEM DBPNAME U(0,0,42);    #DATABASE PROCEDURE NAME#
        ITEM DBPORD  U(0,42,18);   #DATABASE PROCEDURE ORDINAL# 
        END 
      ITEM NUMDBP;                 #NUMBER OF DATABASE PROCEDURES#
      ITEM ENTRCOD;                #DBP ENTRY CODE# 
      ITEM TARGFWA I;              #TARGET ITEM FWA (-1 = NO TARGET)# 
      ITEM TARGBBP;                #TARGET BEGINNING BIT POSITION#
      ITEM TARGSZ;                 #TARGET ITEM SIZE# 
      ITEM TARGCLS;                #TARGET ITEM CLASS#
      ITEM SRCFWA I;               #SOURCE ITEM FWA (-1 = NO SOURCE)# 
      ITEM SRCBBP;                 #SOURCE BEGINNING BIT POSITION#
      ITEM SRCSZ;                  #SOURCE ITEM SIZE# 
      ITEM SRCCLS;                 #SOURCE ITEM CLASS#
# 
* DC  EXIT CONDITIONS 
* 
*     NORMAL EXIT - ALL PROCEDURES IN LIST HAVE BEEN EXECUTED AND THE 
*     RETURN CODES CHECKED. 
* 
*     ABNORMAL EXIT - IF AN ITEM-LEVEL ERROR OCCURS, AND THE RUN-UNIT 
*     HAS ESTABLISHED A DBST THAT IS LONG ENOUGH TO INCLUDE THE SECTION 
*     OF AUXILIARY STATUS INFORMATION, THEN THE SUBSCHEMA ITEM ORDINAL
*     IS SAVED IN THE RCB ENTRY.  AN ERROR MESSAGE IS GENERATED, AND
*     THE FUNCTION OR TASK IS ABORTED.
* 
* DC  CALLING ROUTINES
* 
*     MAPPING CAPSULES EXECUTED BY DB$RMIF AND DB$KMIF
* 
* DC  CALLED ROUTINES 
* 
*     DB$DPIF LOCAL PROCEDURES. 
*     DB$ERR - CDCS ERROR PROCESSOR.
*     DB$FLOP - GENERATE FLOW POINT 
* 
* DC  NON-LOCAL VARIABLES 
* 
*     CDCS COMMON 
# 
      XREF ITEM DB$MMOD;           #MAPPING TYPE:                      #
                                   #0=STORE, 1=MODIFY, 2=GET, 3=KEY    #
      XREF ITEM DB$MSUB;           # WSA ADDRESS FOR SUBSCHEMA RECORD  #
      XREF ITEM DB$MBUF;           #SCRATCH BUFFER ADDRESS# 
      XREF ITEM DB$MSSO;           # SS ITEM ORD FOR ITEM-LEVEL ERROR  #
 #
*     LOCAL VARIABLES 
# 
*CALL DBSTDCLS
      ITEM INDEX;                  #LOOP INDEX# 
      BASED ARRAY SRCBUF;;   #SOURCE ITEM BUFFER                       #
      ITEM SRCWSA;                 #SOURCE RECORD WSA#
      BASED ARRAY TARGBUF;;  #TARGET ITEM BUFFER                       #
      ITEM TARGWSA;                #TARGET RECORD WSA#
 #
* 
* DC  DESCRIPTION 
* 
 #
  
  
  
#     B E G I N   D B $ D P I I   E X E C U T A B L E   C O D E .      #
  
  
      CONTROL IFGR DFFLOP,0;
        DB$FLOP("DPII");
      CONTROL ENDIF;
  
 #
*     FIND THE ABSOLUTE ADDRESSES OF THE SOURCE AND TARGET WORKING
*     STORAGE AREAS AS FOLLOWS -
*         STORE/MODIFY - SOURCE = SUBSCHEMA WSA 
*                        TARGET = FIT WSA 
*         GET          - SOURCE = FIT WSA 
*                        TARGET = SUBSCHEMA WSA 
*         KEY (ITEM)    - SOURCE = SUBSCHEMA WSA
*                         TARGET = SCRATCH BUFFER 
 #
  
#     IF THE OFT POINTER HAS A VALUE BUT THE UFT DOES NOT,             #
#     CALL DB$FSET TO SET UP THE UFT.                                  #
  
      IF P<OFT> GR 0
        AND OFUFT[0] NQ DFNPTR
        AND P<UFT> LQ 0 
      THEN
        BEGIN 
        DB$FSET;
        END 
  
      DBPENTR = ENTRCOD;
      P<APL> = SADBPPTR[SALX];
      IF P<APL> EQ 0 THEN 
        DB$ERR(15);  #NO PROC LIBRARY - ABORT  #
      IF DB$MMOD EQ 2 THEN   #GET#
        BEGIN 
        SRCWSA = UFFITWSA[0]; 
        TARGWSA = DB$MSUB;
        END 
      ELSE IF DB$MMOD EQ 3 THEN #KEY# 
        BEGIN 
        SRCWSA = DB$MSUB; 
        TARGWSA = DB$MBUF;
        END 
      ELSE                   #PUT#
        BEGIN 
        SRCWSA = DB$MSUB; 
        TARGWSA = UFFITWSA[0];
        END 
  
#     BIAS TARGET AND SOURCE ADDRESSES TO START OF WORKING STORAGE     #
#     BUFFERS.                                                         #
  
        IF TARGFWA EQ -1 THEN 
          TARGFWA = O"400000";     #UNDEFINED#
        ELSE
          TARGFWA = TARGFWA + TARGWSA;
        IF SRCFWA EQ -1 THEN
          SRCFWA = O"400000";      #UNDEFINED#
        ELSE
          SRCFWA = SRCFWA + SRCWSA; 
      P<SRCBUF> = SRCFWA; 
      P<TARGBUF> = TARGFWA; 
 #
*     FOR EACH PROCEDURE IN THE LIST: 
*       FIND THE PROCEDURE IN THE SCHEMA PROCEDURE LIST.
*       LOAD AND EXECUTE THE PROCEDURE. 
*       IF AN ITEM-LEVEL ERROR OCCURS, AND THE RUN-UNIT HAS ESTABLISHED 
*       A DBST THAT CONTAINS THE AUXILIARY STATUS SECTION, THEN STORE 
*       THE SUBSCHEMA ITEM ORDINAL IN THE RCB ENTRY.
*       CHECK THE RETURN CODE FROM THE PROCEDURE. 
 #
      ERRSTAT = RCPKERR[0]; 
      P<FIT> = LOC(UFFIT[0]); 
      GETPARMS; 
      FOR INDEX = 0 STEP 1 UNTIL NUMDBP-1 DO
        BEGIN 
        APLX = DBPORD[INDEX]; 
        IF APLX GR APDBPSZ[0] OR   #CAPSULE ORDINAL BAD  #
          APDBPNAM[APLX] NQ DBPNAME[INDEX]  THEN
          BEGIN                                  #SCAN APL FOR PROC#
          APLL = APDBPSZ[0];
          FOR APLX = 1 STEP 1 UNTIL APLL DO 
            BEGIN 
            IF APDBPNAM[APLX] EQ DBPNAME[INDEX] THEN
              GOTO FOUNDDBP;
  
            END 
          APLX = 0;          #POINT TO PROC NAME FOR DB$ERR#
          P<APL> = LOC(DBPNAME[INDEX]); 
          DB$ERR(43);              #ABORT RUN UNIT - INVALID PROC NAME# 
          END 
FOUNDDBP: 
        DB$MSSO = 0;               # ZERO SS ITEM ORD OF ITEM-LEVEL ERR#
  
        CONTROL IFGR DFFLOP,0;
          DB$FLOP("DPII-1");
        CONTROL ENDIF;
  
        DB$CALL((ADDRDBP),DBPENTR,DBPRTN,ERRSTAT,FIT,WSA,RL,KA,KP,KL, 
          TARGBUF,TARGBBP,TARGSZ,TARGCLS, 
          SRCBUF,SRCBBP,SRCSZ,SRCCLS, 
          TQPRNAME[0],DB$RA0);
        IF DB$MSSO NQ 0 
          AND TQDBSTLW[0] GQ DFDBSTAUX
        THEN
          BEGIN 
          RCMSSO[0] = DB$MSSO;
          END 
        CKRTN;
        END 
      RETURN; 
      END   #DB$DPII# 
  
  
  
  
#     E M B E D D E D   P R O C E D U R E   -   D B $ D P I R .        #
  
  
      XDEF PROC DB$DPIR;
      PROC DB$DPIR; 
      BEGIN 
 #
* *   DB$DPIF                                    PAGE  1
* *   DB$DPIR - DB PROC ITEM INTERFACE PARAMETER RESTORE
* *   C F RICHARDS                               DATE  10/16/78 
* 
* DC  PURPOSE 
* 
*     PERFORM A DEFERRED CALL TO DB$DPII WITH THE PARAMETERS WHICH WERE 
*     EARLIER SAVED FOR THIS USER.  THE CALL IS NOT MADE IF PARAMETERS
*     WERE NOT SAVED. 
* 
* DC  ENTRY CONDITIONS
* 
*     PARAMETERS
* 
*     NONE
* 
*     ASSUMPTIONS 
* 
*     PARAMS - POINTER SET TO FWA OF THE PARAMETER BLOCK.  (THE SETTING 
*              OF THIS POINTER IS DONE BY DB$MBS WHEN THE RCB IS
*              CRANKED UP BY DB$SCHD.)
*     RCB    - POINTER SET.  RCMERP TRUE IF PARAMETERS SAVED. 
* 
* DC  EXIT CONDITIONS 
* 
*     RCMERP SET FALSE.  IF A PARAMETER BLOCK EXISTED, IT WAS RELEASED
*     AFTER DB$DPII EXECUTION WAS COMPLETE. 
* 
* DC  CALLING ROUTINES
* 
*     DB$ERR - PROCESSOR OF ERRORS AND INFORMATIVE MESSAGES.
* 
* DC  CALLED ROUTINES 
* 
*     PROC DB$DPII - DATABASE PROCEDURE ITEM LEVEL INTERFACE
# 
      XREF PROC DB$FLOP;           # GENERATE FLOW POINT               #
      XREF PROC DB$MBF;            # FREE A MANAGED BLOCK              #
# 
* DC  NON-LOCAL VARIABLES 
* 
*     DB$MMOD - MAPPING MODE (RESTORED) 
*     DB$MSUB - SUBSCHEMA-FORMAT RECORD FWA (RESTORED)
*     PARAMS  - A BASED ARRAY GLOBAL TO DB$DPIS AND DB$DPIR WHICH 
*               CONTAINS THE SAVED PARAMETERS.  IT IS USED AS THE 
*               POINTER WORD FOR THE BLOCK ALLOCATED BY DB$MBA, SO
*               ITS VALUE IS INITIALIZED EACH TIME AN OWNER-RCB IS
*               STARTED BY DB$SCHD.  THAT IS HOW DB$DPIS COMMUNICATES 
*               THE LOCATION OF THE PARAMETERS. 
*     RCB     - RCMERP SET FALSE IF PARAMETERS HAD BEEN SAVED, BUT
*               WERE RELEASED BY THIS PROC. 
* 
* DC  DESCRIPTION 
* 
*     USE A LOCAL BASED ARRAY TO POINT TO THE LIST OF DBP'S AT THE
*     END OF THE PARAMETER BLOCK. 
*     CALL DB$DPII TO EXECUTE THE DBP'S.
*     UPON RETURN FROM DB$DPII, RELEASE THE PARAMETER BLOCK AND CLEAR 
*     THE FLAG WHICH TOLD OF ITS EXISTENCE. 
 #
#     XREF VARIABLES                                                   #
  
      XREF ITEM DB$MMOD I;         # MAPPING MODE                      #
      XREF ITEM DB$MSUB I;         # SUBSCHEMA-FORMAT RECORD FWA       #
  
#     LOCAL VARIABLES                                                  #
  
      BASED ARRAY LIST;;           # USED TO POSITION TO DBP LIST IN   #
                                   # SAVED PARAMETER BLOCK             #
  
  
  
#     B E G I N   D B $ D P I R   E X E C U T A B L E   C O D E .      #
  
  
      CONTROL IFGR DFFLOP,0;
        DB$FLOP("DPIR");
      CONTROL ENDIF;
  
      DB$MMOD = PRMMOD[0];
      DB$MSUB = PRMSUB[0];
      P<LIST> = LOC(PRDBPWORD[0]);
      DB$DPII(LIST,PRNDBP[0],PRECOD[0], 
              PRTFWA[0],PRTBBP[0],PRTSZ[0],PRTCLS[0], 
              PRSFWA[0],PRSBBP[0],PRSSZ[0],PRSCLS[0]);
      DB$MBF(P<PARAMS>);           # RELEASE THE PARAMETER BLOCK       #
      RCMERP[0] = FALSE;           # NO PARAMETER BLOCK EXISTS         #
      RETURN; 
      END     # DB$DPIR # 
  
  
  
  
#     E M B E D D E D   P R O C E D U R E   -   D B $ D P I S .        #
  
  
      XDEF PROC DB$DPIS;
      PROC DB$DPIS(DBPLIST,(NUMDBP),(ENTRCOD),(TARGFWA),(TARGBBP),
                 (TARGSZ),(TARGCLS),(SRCFWA),(SRCBBP),(SRCSZ),(SRCCLS));
      BEGIN 
 #
* *   DB$DPIF                                    PAGE  1
* *   DB$DPIS - DB PROC ITEM INTERFACE PARAMETER SAVING 
* *   C F RICHARDS                               DATE  10/16/78 
* 
* DC  PURPOSE 
* 
*     SAVE A COPY OF THE ACTUAL PARAMETERS (TO DB$DPII) FOR AN ITEM 
*     LEVEL DBP CALLED FROM RECORD OR KEY MAPPING. THIS ALLOWS THE KEY
*     OR RECORD MAPPING ROUTINES TO BE REUSED OR RELEASED PRIOR TO THE
*     COMPLETION OF THE ITEM LEVEL DBP. ASIDE FROM THE PARAMETERS, THE
*     VALUES OF ITEMS DB$MMOD AND DB$MSUB MUST ALSO BE PRESERVED. 
* 
*  DC ENTRY CONDITIONS
* 
*     PARAMETERS  (MUST MATCH CALLING SEQUENCE OF DB$DPII)
# 
      ARRAY DBPLIST S(1);          # LIST OF DBPS TO BE CALLED         #
        BEGIN 
        ITEM DBPWORD I(00,00,60);  # DECLARATION FOR WHOLE WORD ACCESS #
        END 
  
      ITEM NUMDBP I;               # NUMBER OF ENTRIES IN DBPLIST      #
      ITEM ENTRCOD I;              # DBP ENTRY CODE                    #
      ITEM TARGFWA I;              # FWA OF TARGET ITEM                #
      ITEM TARGBBP I;              # BEGINNING BIT POS OF TARGET ITEM  #
      ITEM TARGSZ I;               # SIZE OF TARGET ITEM (BITS)        #
      ITEM TARGCLS I;              # CLASS OF TARGET ITEM              #
      ITEM SRCFWA I;               # FWA OF SOURCE ITEM                #
      ITEM SRCBBP I;               # BEGINNING BIT POS OF SOURCE ITEM  #
      ITEM SRCSZ I;                # SIZE OF SOURCE ITEM (BITS)        #
      ITEM SRCCLS I;               # CLASS OF SOURCE ITEM              #
# 
*     ASSUMPTIONS 
* 
*     DB$MMOD - MAPPING MODE
*     DB$MSUB - SUBSCHEMA-FORMAT RECORD FWA 
*     RCB     - POSITIONED TO USER REQUIRING THE ITEM LEVEL DBP 
* 
* DC  EXIT CONDITIONS 
* 
*     RCMERP SET TRUE TO INDICATE MAPPING ERROR DBP PARAMETERS HAVE BEEN
*     SAVED. A BUFFER WAS ALLOCATED IN MANAGED MEMORY (VIA DB$MBA) TO 
*     CONTAIN THE PARAMETERS. THE ORDER OF PARAMETERS IN THE BUFFER IS
*     THE SAME AS THE CALLING SEQUENCE TO DB$DPII WITH ONE EXCEPTION -
*     THE VARIABLE LENGTH DBPLIST IS PLACED AFTER ALL OTHER PARAMETERS. 
*     THE BASED ARRAY *PARAMS* (GLOBAL TO DB$DPIS AND DB$DPIR) IS 
*     IDENTIFIED TO DB$MBA AS THE POINTER WORD FOR THE MANAGED BLOCK. 
*     THUS, WHEN DB$DPIR IS CALLED, THE BASED ARRAY POINTER WILL ALREADY
*     BE PROPERLY SET.
* 
* DC  CALLING ROUTINES
* 
*     DB$CEDP - (ARRANGE TO) CALL ERROR DATABASE PROCEDURES 
* 
* DC  CALLED ROUTINES 
# 
      XREF PROC DB$FLOP;           # GENERATE FLOW POINT               #
      XREF PROC DB$MBA;            # MANAGED MEMORY BLOCK ALLOCATION   #
# 
* DC  NON-LOCAL VARIABLES 
* 
*     DB$MMOD - MAPPING MODE
*     DB$MSUB - SUBSCHEMA-FORMAT RECORD FWA 
*     PARAMS  - A BASED ARRAY WHICH WILL CONTAIN THE SAVED PARAMETERS.
*               IT IS GLOBAL TO DB$DPIS AND DB$DPIR. IT IS USED AS THE
*               POINTER WORD FOR THE BLOCK ALLOCATED BY DB$MBA, SO ITS
*               VALUE IS INITIALIZED EACH TIME THE OWNER-RCB IS STARTED 
*               UP BY DB$SCHD. THAT IS HOW DB$DPIR IS GIVEN THE LOCATION
*               OF THE PROPER PARAMETER BLOCK.
*     RCB     - ITEM RCMERP SET TRUE TO INDICATE MAPPING ERROR DBP
*               PARAMETERS HAVE BEEN SAVED. 
* 
* DC  DESCRIPTION 
* 
*     ALLOCATE A MANAGED BLOCK TO CONTAIN ALL THE PARAMETERS. SET RCMERP
*     TRUE TO INDICATE MAPPING ERROR DBP PARAMETERS HAVE BEEN SAVED.
*     MOVE THE PARAMETER VALUES INTO THE BLOCK, THEN RETURN.
 #
#     XREF VARIABLES                                                   #
  
      XREF ITEM DB$MMOD I;         # MAPPING MODE                      #
      XREF ITEM DB$MSUB I;         # SUBSCHEMA-FORMAT RECORD FWA       #
  
#     LOCAL VARIABLES                                                  #
  
      ITEM INDEX I;                # LOOP INDEX                        #
  
      DEF DFDPIIPLL # 11 #;        # DB$DPII PARAMETER LIST LENGTH     #
  
  
  
  
#     B E G I N   D B $ D P I S   E X E C U T A B L E   C O D E .      #
  
  
      CONTROL IFGR DFFLOP,0;
        DB$FLOP("DPIS");
      CONTROL ENDIF;
  
#     ALLOCATE A BLOCK TO CONTAIN ALL THE PARAMETERS -                 #
#       ONE WORD FOR EACH PARAMETER IN DB$DPII"S PARAMETER LIST (EXCEPT#
#       FOR THE DBPLIST), ONE FOR EACH OF THE DBP ENTRIES, AND ONE     #
#       EACH FOR ITEMS DB$MMOD AND DB$MSUB.                            #
  
      DB$MBA((DFDPIIPLL - 1) + NUMDBP + 2, P<PARAMS>);
  
      RCMERP[0] = TRUE;            # PARAMETERS HAVE BEEN SAVED        #
      PRNDBP[0] = NUMDBP; 
      PRECOD[0] = ENTRCOD;
      PRTFWA[0] = TARGFWA;
      PRTBBP[0] = TARGBBP;
      PRTSZ[0] = TARGSZ;
      PRTCLS[0] = TARGCLS;
      PRSFWA[0] = SRCFWA; 
      PRSBBP[0] = SRCBBP; 
      PRSSZ[0] = SRCSZ; 
      PRSCLS[0] = SRCCLS; 
      PRMMOD[0] = DB$MMOD;         # PRESERVE CURRENT MAPPING MODE     #
      PRMSUB[0] = DB$MSUB;         # PRESERVE LOCATION OF THE SUBSCHEMA#
                                   # FORMAT RECORD                     #
      FOR INDEX = NUMDBP - 1 STEP - 1  # FOR EACH DBPLIST ENTRY        #
      UNTIL 0                          # UNTIL NONE ARE LEFT UNMOVED   #
      DO
        BEGIN 
        PRDBPWORD[INDEX] = DBPWORD[INDEX];  # COPY THE DBPLIST ENTRY   #
        END 
  
      RETURN; 
      END     # DB$DPIS # 
      END 
      TERM
