*DECK DB$ERR
USETEXT CDCSCTX 
      PROC DB$ERR((NUM)); 
      BEGIN 
 #
* *   DB$ERR -- CDCS ERROR HANDLER               PAGE  1
* *   C O GIMBER                                 2/9/76 
* *   W.P. CEAGLIO                               DATE  11/17/78 
* 
* DC  PURPOSE 
* 
*     THIS ROUTINE HANDLES ERRORS AND INFORMATIVE MESSAGES TO BE
*     DAYFILED AT THE UCP (AND POSSIBLY LISTED ON THE CDCS OUTPUT FILE).
*     IF A DBST HAS BEEN ESTABLISHED FOR THIS RUN UNIT, IT IS UPDATED 
*     AND WRITTEN TO THE UCP. 
* 
* DC  ENTRY CONDITIONS
* 
*     PARAMETERS
# 
      ITEM NUM;              #INTERNAL NUMBER FOR EXTERNAL ERROR# 
# 
*     ASSUMPTIONS 
* 
*     THE TQT POINTER IS SET. 
*     RSB AREA BLOCK BASED ARRAY MUST REFERENCE AREA (FOR "C" TYPE
*     INSERTION). 
*     RSB RECORD CONTROL BLOCK POINTER IS SET (FOR "H" TYPE INSERTION). 
* 
* DC  CALLED ROUTINES 
# 
      XREF PROC DB$CALL;     #CALL A PROCEDURE                         # CD2A048
      XREF PROC DB$CLSA;     #CLOSE THE AREA (FILE)                    #
      XREF PROC DB$DPIF;     #DATA BASE PROCEDURE INTERFACE PROCESSOR#
      XREF PROC DB$DPIR;     # CALL ITEM LEVEL ERROR DBPS              #
      XREF PROC DB$ERSF;     #LONG ERROR MSG SFCALL PROCESSOR      #
      XREF FUNC DB$ERRE U;   #LOCATE AND EDIT THE ERROR MESSAGE        #
      XREF PROC DB$FLOP;     # GENERATE FLOW POINT                     #
      XREF PROC DB$FTDX;     #END OF DATA ROUTINE                      #
      XREF PROC DB$MBA;      #ALLOCATE TEMPORARY BUFFER#
      XREF PROC DB$MBF;      #FREE TEMPORARY BUFFER#
      XREF PROC DB$MFO9;     #MEMORY OVERFLOW OPTION,  ABORT CDCS      #
      XREF PROC DB$OFTR;     #RELEASE OFT                              #
      XREF PROC DB$POP;      #POP ENTRY FROM STACK# 
      XREF PROC DB$PROF;     #ROUTE OUTPUT FILE TO A PRINTER           #
      XREF PROC DB$PUSH;     #PUSH ENTRY INTO STACK#
      XREF PROC DB$SFCL;     #SF CALL PROCESSOR#
      XREF PROC DB$TQTD;     #DELETE TQT ENTRY# 
      XREF PROC DB$TRU;      #TERMINATE RUN UNIT# 
      XREF PROC DB$WRP;      #REQUEST END PROCESSOR#
# 
* DC  NON-LOCAL VARIABLES 
# 
      XREF ITEM DB$MERP;     #APLIST FWA FOR ITEM LEVEL ERROR DBP"S#
      XREF ITEM DB$MFPA;     #MEMORY OVERFLOW OPTION PROCEDURE ADDRESS #
      XREF ITEM DB$SFDF;     #DAYFILE FLAG VALUE (DEFINED IN DB$SFCM)#
      XREF ITEM DB$SFDR;     #DROP FLAG VALUE (DEFINED IN DB$SFCM)# 
      XREF ARRAY DB$SYMB;    # FUNCTION FLAGS ARRAY                    #
        BEGIN 
        ITEM FCFILPOS B(00,00,01);  # TRUE IF FUNCTION CHANGES FILE POS#
        END 
# 
* DC  EXTERNALLY DEFINED LOCAL VARIABLES
# 
      XDEF ITEM DB$ERDN I=0;    # NUMBER TO BE INSERTED AS DECIMAL STR #
      XDEF ITEM DB$ERIN C(30);  # INSERTION TEXT FOR ERROR MESSAGE     #
      XDEF ITEM DB$ERLC I=0;    # ERROR MESSAGE LINE COUNT             #
      XDEF ITEM DB$ERSO I=0;    # MESSAGE SEVERITY LEVEL OVERRIDE      #
# 
 #
        CONTROL PRESET; 
  
*CALL DB$FUNC 
*CALL DBSTDCLS
  
      DEF DFPROFI #1448#;    # NUMBER OF ERROR LINES BEFORE PRINTING   #
                             # THERE ARE 58 LINES PER PAGE             #
# 
*     TABLE OF "ON ERROR" CODES AND FUNCTION CODES. 
# 
      DEF DFFCTSIZ #9# ;           # (SIZE-1) FUNCTION CODE TABLE#
      ARRAY FCODES [0:DFFCTSIZ] S(1); 
        BEGIN 
        ITEM FCDPCODE  I(0,0,6) = [DFDPERGET, 
                                   DFDPERGET, 
                                   DFDPERGET, 
                                   DFDPERGET, 
                                   DFDPERSTO, 
                                   DFDPERMOD, 
                                   DFDPEDEL,
                                   DFDPEOPN,
                                   DFDPECLS,
                                   DFDPEFIND];
        ITEM FCTQCODE I(0,54,6) = [DFRD2, 
                                   DFRD1, 
                                   DFREL, 
                                   DFRLS, 
                                   DFWR2, 
                                   DFREW, 
                                   DFDEL, 
                                   DFOPN, 
                                   DFCLS, 
                                   DFSTR];
        END 
# 
      LOCAL VARIABLES.
# 
      ITEM INDEX I;          #INDUCTION VARIABLE                       #
      ITEM MSGLG I;          #ERROR MESSAGE LENGTH                   #
      ITEM NUMBERX U;        #EXTERNAL ERROR NUMBER                  #
  
      BASED ARRAY MSGARRAY; 
        BEGIN 
        ITEM MSG    C(00,00,140);  # MESSAGE FOR CDCS OUTPUT FILE      #
        ITEM MSGUCP C(02,00,120);  # MESSAGE FOR UCP                   #
        END 
  
  
  
#     B E G I N   D B $ E R R   E X E C U T A B L E   C O D E .        #
  
  
#     GENERATE A FLOW POINT.                                           #
  
      CONTROL IFGR DFFLOP,0;
        DB$FLOP ("ERR  ");
      CONTROL ENDIF;
  
 #
*     GET TEMPORARY BUFFER FOR ERROR MESSAGE. 
 #
      DB$MFPA = LOC(DB$MFO9);  # ON MEMORY OVERFLOW,  ABORT CDCS       #
      DB$MBA (14,P<MSGARRAY>);
 #
* 
*     CALL DB$ERRE TO 
* 
*     SELECT THE ERROR MESSAGE FROM THE TABLE, DB$ERRM. 
*     MAKE THE NECESSARY INSERTIONS INTO THE MESSAGE. 
*     RETURN THE COMPLETED MESSAGE IN MSGARRAY. 
*     RETURN THE EXTERNAL ERROR NUMBER AS A FUNCTION VALUE. 
* 
 #
      NUMBERX = DB$ERRE(NUM, MSGARRAY, MSGLG);
 #
*     WHEN *DFPROFI* LINES HAVE BEEN OUTPUT, CALL DB$PROF TO ROUTE
*     THE OUTPUT TO A PRINTER.
 #
      IF DB$ERLC GQ DFPROFI 
      THEN
        BEGIN 
        DB$PROF;
        END 
 #
*     IF TQT NOT ASSOCIATED WITH A USER THEN
*       RETURN TEMPORARY MESSAGE BUFFER.
*       RETURN. 
 #
      IF NOT TQLTCF[0] THEN 
        BEGIN 
        DB$MBF(P<MSGARRAY>);
        RETURN; 
  
        END 
 #
*     IF THERE IS A UFT AND AN FPT, SAVE FILE POSITION AND OPEN CODE
 #
      IF LOC(UFT) GR 0
        AND LOC(RSARBLK) GR 0 
        AND RSARFPT[0] NQ 0 
      THEN
        BEGIN 
        FPFITFP[0] = UFFITFP[0];
        END 
 #
*     FOR AN ERROR EXIT DURING INDEX FILE PROCESSING, 
*     MUST RESET THE FPFTDX OF THE FPT AND UFFITNDX OF
*     THE UFT FOR ANY SUBSEQUENT REQUESTS.
 #
  
      IF LOC(UFT) GR 0
        AND ( RCIRFUNC[0] EQ DFSTX
              OR RCIRFUNC[0] EQ DFRX1 
              OR RCIRFUNC[0] EQ DFRX2 
              OR RCIRFUNC[0] EQ DFRWX ) 
      THEN
        BEGIN 
        FPFTDX[0] = DFFTDX1;       # RESTORE NORMAL DB$FTDX PROCESSING #
        UFFITNDX[0] = FALSE;
        P<OFT> = RSAROFIT [0];
        UFFITMRL [0] = OFFITMRL [0];
        END 
 #
*     IF EXTERNAL ERROR OR FATAL ERROR
*       FLUSH STACK SINCE USER REQUEST WILL BE TERMINATED.
 #
      IF RCPKERR[0] NQ 0           # IF EXTERNAL ERROR                 #
        OR RCIRRC[0] EQ DFERRFAT   # OR ERROR IS FATAL                 #
      THEN
        BEGIN 
        RCSTACKX[0] = LOC(RCB) + DFRCIR0;  # RESET STACK TO EMPTY      #
        END 
 #
*     IF FILE COULD NOT BE OPENED DUE TO ERRORS IN OPEN PROCESSING
*     THEN CALL DB$CLSA TO DELINK THE UFT AND DECREMENT DBP USER COUNTS.
*     SINCE THE FILE IS NOT OPEN, CLOSEM IS NOT CALLED. 
 #
      IF LOC(UFT) GR 0
        AND RCIRFUNC[0] NQ DFINV
        AND UFFITOC[0] NQ DFFITOCOPEN  # IF FILE IS NOT OPENED...      #
      THEN
        BEGIN 
        DB$CLSA;
        END 
 #
*     PUSH ENTRY POINT. 
*     PUSH AND REINITIALIZE DB$MERP.
 #
      DB$PUSH(DB$ERR);
      DB$PUSH(DB$MERP);      #NOTE - "0 ONLY ON NONFATAL ERRORS 39, 40 #
      DB$MERP = 0;           # AND FATAL ERRORS 18, 19, 20             #
 #
*     IF EXTERNAL ERROR OR IMMEDIATE RETURN THEN
*       WRITE ERROR TO UCP ERROR BUFFER.
*       WRITE ERROR FLAG AND NUMBER TO UCP CDCS REQUEST.
*     ELSE
*       WRITE MESSAGE TO UCP DAYFILE. 
*       IF FATAL ERROR THEN 
*         SET ERROR FLAG
*         TERMINATE RUN-UNIT UNLESS MUJ-TYPE
 #
      IF NUMBERX NQ 0 
        OR TQIMRTN[0] 
      THEN
        BEGIN 
        DB$SFCL(DFSFWRIT,11,RCPKEBUF[0],LOC(MSGUCP[0]));
        DB$SFCL(DFSFWRIT,2,RCIRUCPA[0],LOC(RCIRES[0])); 
        END 
      ELSE
        BEGIN 
        IF RCIRRC[0] EQ DFERRFAT THEN 
          BEGIN 
          DB$ERSF(DFSFREGR,DB$SFDF,DB$SFDR,LOC(MSGUCP),MSGLG);
          DB$TRU;            # TERMINATE RUN UNIT, DOES NOT RETURN.    #
  
          END 
        DB$ERSF(DFSFREGR,0,0,LOC(MSGUCP[0]),MSGLG); 
        END 
      DB$POP(DB$MERP);                                                   CD2A049
      DB$POP(DB$ERR);                                                    CD2A049
 #
*     IF INFORMATIVE ERROR MESSAGE THEN 
*       RETURN TEMPORARY MESSAGE BUFFER.
*       RETURN. 
 #
      IF RCIRRC[0] EQ DFERRINF THEN 
        BEGIN 
        DB$MBF(P<MSGARRAY>);
        RETURN; 
  
        END 
  
#     GENERATE A FLOW POINT - TO DOCUMENT THAT THE                     #
#     ERROR IS EITHER FATAL OF NONFATAL.                               #
  
      CONTROL IFGR DFFLOP,0;
        DB$FLOP ("ERR-1");
      CONTROL ENDIF;
  
 #
*     CALL ERROR PROCEDURE IF ONE IS SPECIFIED IN THE RCB.               CD2A048
 #                                                                       CD2A048
      IF RCEREX[0] NQ 0 THEN                                             CD2A048
        BEGIN 
  
        CONTROL IFGR DFFLOP,0;
          DB$FLOP ("ERR-2");       # GENERATE A FLOW POINT.            #
        CONTROL ENDIF;
  
        DB$CALL(RCEREX[0]);                                              CD2A048
        END 
 #
*     RESTORE OFT POINTER. (PERHAPS DB$LKRU HAS CHANGED IT.)
 #
      IF P<RSARBLK> GR 0
      THEN
        BEGIN 
        P<OFT> = RSAROFIT[0]; 
        RCOFTLOC[0] = RSAROFIT[0];
        END 
 #
*     IF NON-FATAL ERROR THEN 
*       CALL DB$DPIR TO EXECUTE ANY ITEM LEVEL DBPS.
*       SEARCH ON ERROR CODES TABLE TO CALL DBP INTERFACE IF REQUIRED 
*       FOR CURRENT FUNCTION CODE.
 #
      IF RCIRRC[0] EQ DFERRNON THEN 
        BEGIN 
        IF RCMERP[0]
        THEN
          BEGIN 
          DB$DPIR;
          END 
  
        FOR INDEX=0 STEP 1 UNTIL DFFCTSIZ  DO 
          BEGIN 
          IF FCTQCODE[INDEX] EQ RCFUNC[0] THEN
            BEGIN 
            IF RSFCRORD[0] NQ 0    # IF A RECORD EXISTS,               #
            THEN                   # SET RSRECBLK                      #
              BEGIN 
              SETRSRECBLK;
              END 
  
            IF SADBPPTR[SALX] NQ 0
            THEN
              BEGIN 
              DB$DPIF(FCDPCODE[INDEX]); 
              END 
            INDEX = DFFCTSIZ; 
            END 
          END 
        END                        # OF PROCESSING A NONFATAL ERROR    #
                                   # WITH AN EXTERNAL ERROR NUMBER     #
                                   # ASSIGNED                          #
  
 #
*     IF A DBST HAS BEEN ESTABLISHED FOR THIS RUN-UNIT, THEN UPDATE 
*     THE ERROR STATUS INFORMATION IN THE DBST. 
 #
      IF TQDBSTSCP[0] NQ 0
      THEN
        BEGIN 
 #
*       POINT THE DBST BASED ARRAY TO THE SCP-SIDE DBST BUFFER, 
*       AND STORE THE ERROR CODE. 
 #
        P<DBST> = TQDBSTSCP[0]; 
        DBERRCODE[0] = RCPKERR[0];
 #
*       IF THE DBST CONTAINS THE AUXILIARY STATUS SECTION, THEN STORE 
*       THE SUBSCHEMA ITEM ORDINAL OF AN ITEM-LEVEL ERROR FROM THE
*       RCB ENTRY.  IF NO ERROR OCCURRED, THE RCB VALUE OF THE
*       SUBSCHEMA ITEM ORDINAL IS ZERO. 
 #
        IF TQDBSTLW[0] GQ DFDBSTAUX 
        THEN
          BEGIN 
          DBSSITMORD[0] = RCMSSO[0];
 #
*         IF THE ERROR IS FATAL, THEN STORE THE DBST FATAL ERROR CODE 
*         INTO THE ERROR FATALITY FIELD OF THE DBST. OTHERWISE THE
*         ERROR FATALITY FIELD REMAINS ZERO.
 #
          IF RCIRRC[0] EQ DFERRFAT
          THEN
            BEGIN 
            DBERRFAT[0] = 1;
            END 
 #
*         IF AN I/O SYMBIONT WHICH CHANGES THE FILE POSITION WAS JUST 
*         PROCESSED, AND HAD NOT STORED THE FILE POSITION IN THE DBST,
*         AND IF A FPT EXISTS, THEN STORE THE FILE POSITION FROM THE
*         FPT IN THE DBST.
 #
          IF FCFILPOS[RCFUNC[0]]
            AND P<FPT> GR 0 AND DBFILPOS[0] EQ 0
          THEN
            BEGIN 
            DBFILPOS[0] = FPFITFP[0]; 
            END 
 #
*         IF THE DBST CONTAINS THE FUNCTION DESCRIPTION, THEN STORE 
*         THE FUNCTION NAME IN THE DBST.
 #
          IF TQDBSTLW[0] GQ DFDBSTFUNC
          THEN
            BEGIN 
            DBFUNCTION[0] = FUNCODE[RCFUNC[0]]; 
            END 
          END 
 #
*       ISSUE A SUBSYSTEM REQUEST TO COPY THE ERROR STATUS INFORMATION
*       STORED IN THE SCP-SIDE DBST TO THE DBST RESERVED IN THE USER"S
*       FIELD LENGTH.  SINCE EXIT IS TO DB$WRP, THE ENTRY POINT DOES
*       NOT HAVE TO BE PUSHED AND POPPED. 
 #
        DB$SFCL(DFSFWRIT,TQDBSTLW[0],TQDBSTUCP[0],TQDBSTSCP[0]);
 #
*       CLEAR ERROR CODE. 
*       CLEAR AUXILIARY STATUS AND RANK OF ERROR, IF THE DBST INCLUDES
*       THESE VALUES. 
 #
        P<DBST> = TQDBSTSCP[0]; 
        DBERRCODE[0] = 0; 
        IF TQDBSTLW[0] GQ DFDBSTAUX 
        THEN
          BEGIN 
          DBSSITMORD[0] = 0;
          DBFILPOS[0] = 0;
          DBERRFAT[0] = 0;
          IF TQDBSTLW[0] GQ DFDBSTREL 
          THEN
            BEGIN 
            DBRKRELERR[0] = 0;
            END 
          END 
        END                        # OF UPDATING THE DBST              #
 #
*     IF FATAL ERROR
*       OR ERROR DURING INVOKE
*     THEN
*       TERMINATE USER (DB$TQTD). 
 #
      IF RCIRRC[0] EQ DFERRFAT
        OR RCIRFUNC [0] EQ DFINV
      THEN
        BEGIN 
        DB$TQTD;
        END 
 #
* 
*     IF A NON-FATAL ERROR OCCURS DURING A VERSION CHANGE (FOR
*     EXAMPLE, ERROR 56 FOR TAF USER), THEN ALL THE FILES FOR 
*     THE RUN-UNIT (IN BOTH THE OLD AND NEW VERSION) ARE RETURNED.
* 
*     IF NON-FATAL ERROR ON A VERSION CHANGE
*     THEN
*       LOOP THROUGH AREA CONTROL BLOCKS FOR THIS RUN-UNIT
*         BEGIN 
*         DELINK RUN-UNIT FROM OFT. 
*         IF OFT HAS NO MORE USERS
*         THEN
*           DO OFT RELEASE PROCESSING (DB$OFTR).
*         END 
*       SET CURRENT VERSION NAME IN RSB TO BLANKS.
 #
      IF RCIRRC[0] EQ DFERRNON     # IF NON-FATAL ERROR                #
        AND RCIRFUNC[0] EQ DFVER   # DURING VERSION CHANGE...          #
      THEN
        BEGIN 
        FOR INDEX = 1 STEP 1       # LOOP THRU AREAS FOR RUN-UNIT      #
          UNTIL CSFARENO[0] 
        DO
          BEGIN 
          P<RSARBLK> = LOC(RSB) + DFRSBFIX + (INDEX - 1)*DFARECON;
          IF RSAROFIT[0] NQ 0      # IF THERE IS AN OFT...             #
          THEN
            BEGIN 
            P<OFT> = RSAROFIT[0]; 
            OFUSERS[0] = OFUSERS[0] - 1;
            RSAROFIT[0] = 0;
            IF OFUSERS[0] EQ 0     # IF NO MORE USERS...               #
            THEN
              DB$OFTR;             # RELEASE OFT, IF ATTACHED.         #
            END 
          END 
        RSFVENAME[0] = DFCLRVENM;  # INDICATE NO ACTIVE VERSION.       #
        TQVENAME [0] = DFCLRVENM; 
        END 
 #
*     CALL DB$WRP TO COMPLETE COMMAND PROCESSING. 
 #
      DB$WRP; 
  
  
      END 
      TERM; 
