*DECK DDLDIAG                                                           045140
  PROC DLDIAG;                                                          000087
    BEGIN                                                               045160
      XDEF   ITEM FATALERR; 
      XDEF ITEM DBIIND;      # 0 = SOURCE DBI                          #
                             # 1 = TARGET DBI                          #
                             # USED FOR RELATION DIAGNOSTIC PROCESSING #
      XDEF ITEM RLDIAGFLG B; # TRUE = INSERT DBI TYPE---USED EXPRESSLY #
                             # FOR RELATION DIAGNOSTICS.               #
      ARRAY RELDBITYP [0:1];
        ITEM DBITYP C(0,0,10) = ["SOURCE    ","TARGET    "];
      XREF                                                              045170
        BEGIN                                                           045180
          ITEM NBRLINE;   # DISPLAY CODED SOURCE LINE NUMBER.          #045190
          ITEM NOLIST;    # LIST OPTION--- 1 = NO LIST, 0 = LIST.      #
          ITEM BLKLINE;   # ADDRESS TO PICK UP SOURCE INFO TO PRINT.   #
          PROC CLSEOUT; 
          PROC CLSESC;
          PROC DDLABT;
          PROC DDLPRNT;   # PRINTS FIXED LENGTH DIAGNOSTICS.           #045200
          ITEM ERRCNTR;                                                 000830
          PROC SNATCHO;                                                 045220
          PROC SNATCHF;                                                 045230
          ARRAY CWORD [0:2];
            ITEM CURWORD U(0,0,60); 
          ARRAY NEXWORD [0:2];
            ITEM NEXWRD U(0,0,60);
          ITEM CURLENG; 
          ITEM CURLENW; 
          ITEM NEXLENG; 
          ITEM NEXLENW; 
        END                                                             045240
  ENTRY PROC DIAGDL(DIAGNBR);                                           045250
      ITEM DIAGNBR;                                                     045260
      ITEM DPTR;    # SUBSCRIPT IN THE DIAG MSGS.                      #045270
      ITEM ERRORTYPE;                                                   045280
      ITEM P1;     # FIRST PARAMETER PASSED TO THE PRINT ROUTINE.      #045290
      ITEM P2;     # SECOND PARAMETER PASSED TO THE PRINT ROUTINE.     #045300
      ITEM I, J, K;      # TEMPORARY CELLS #
      XREF ARRAY DIAG100 [0];  # POINTS TO THE DIAGNOSTICS MSGS.       #045330
        ITEM DMSGPTR U(0,0,60);                                         045340
      XREF ARRAY DIAGPTR [0];  # DIAGNOSTICS MSGS.                     #045350
        ITEM MSGPTR U(0,0,60);                                          045360
      BASED ARRAY RA [0];                                               045370
        BEGIN 
        ITEM RELADR U(0,0,60);
        END 
      BASED ARRAY DIAGNBRSTD [0];                                       045390
        ITEM DIAGSTDNBR U(0,0,60);                                      045400
      BASED ARRAY PARM [0];;                                            045410
  CONTDIAG:                                                             045420
      IF FATALERR GQ 200  THEN DIAGNBR = 280;  #ABORT IF TOO MANY DIAGS#
      P<RA> = 0;                                                        045430
      ERRCNTR = ERRCNTR + 1;                                            000140
      DPTR = (DIAGNBR-100) / 2;                                         045490
      IF B<59,1>DIAGNBR EQ 1 THEN   # CHECK IF EVEN OR ODD DIAG NUMBER.#045500
        BEGIN      # GET THE WORD ADDRESS OF THE DIAG MSG FROM THE 2ND #045510
          P1 = B<42,18>MSGPTR[DPTR]; # HALF OF THE MSG PTR WRD.      #  045520
          P2 = B<34,8>MSGPTR[DPTR]; # GET THE LENGTH OF THE DIAG.    #  045530
          ERRORTYPE = B<30,4>MSGPTR [DPTR]; 
        END                                                             045550
      ELSE                                                              045560
        BEGIN      # GET THE WRD ADDR OF THE DIAG MSG FROM THE FIRST   #045570
          P1 = B<12,18>MSGPTR[DPTR]; #HALF OF THE MSG PTR WORD.#        045580
       P2 = B<4,8>MSGPTR[DPTR]; #GET THE LENGTH OF DIAG.#               045590
          ERRORTYPE = B<0,4>MSGPTR [DPTR];  #GET THE ERROR TYPE # 
        END                                                             045610
      IF ERRORTYPE EQ 0 
        THEN FATALERR = FATALERR + 1; 
      RELADR[P1+1] = NBRLINE;  # STORE DISPLAY CODED LINE NBR IN DIAG. #045630
          P<PARM> = P1;                                                 045640
      IF DIAGNBR EQ 200 OR DIAGNBR EQ 334 OR DIAGNBR EQ 335 
        THEN     # STORE NEXWORD IN ABOVE DIAGS.   #
        BEGIN 
        IF DIAGNBR EQ 200 THEN
          BEGIN 
          K = NEXLENG;
          J = NEXLENW;
          END 
        ELSE
          BEGIN 
          K = CURLENG;
          J = CURLENW;
          END 
      FOR I = 0  STEP 1  UNTIL 2  DO
        BEGIN 
        IF J GR 0 THEN
          BEGIN 
          IF DIAGNBR EQ 200 
          THEN RELADR [P1 + 3 + I] = NEXWRD [I];
          ELSE RELADR[P1 + 3 + I] = CURWORD[I]; 
          END 
          ELSE RELADR [P1 + 3 + I] = O"55555555555555555555"; 
        J = J - 1;
        K = K - 10; 
        IF J GQ 0  AND  K LS 0
          THEN
          BEGIN 
          K = 6 * (-K); 
        B<60-K,K>RELADR [P1 + 3 + I] = O"55555555555555555555"; 
          END 
        END 
        END 
      IF RLDIAGFLG  THEN     # IF DBI TYPE(RELATION ENTRY) IS TO BE    #
        BEGIN                # INSERTED,                               #
        RELADR[P1 + 3] = DBITYP[DBIIND];  # INSERT DBI TYPE IN DIAG-   #
        END                               # NOSTIC.                    #
      RLDIAGFLG = FALSE;
      IF NOLIST EQ 1 THEN 
        BEGIN 
        DDLPRNT( BLKLINE, 120 );
        END 
      DDLPRNT(PARM,P2);                                                 045650
      IF DIAGNBR EQ 280     # ABORT IF MORE THAN 25 DIAGNOSTICS # 
        THEN
        BEGIN 
        CLSESC; 
        CLSEOUT;
        DDLABT (0); 
        END 
      RETURN;                                                           045660
  ENTRY PROC DIAGSTD(DIAGNBR);                                          045670
      P<DIAGNBRSTD> = LOC(DIAGNBR);                                     045680
      DIAGNBR = DIAGSTDNBR[0];                                          045690
      GOTO CONTDIAG;                                                    045700
    END                                                                 045710
  TERM;                                                                 045720
