DIVR.m

DIVR ;OIFO/GFT - VERIFY FIELD DIFLD, DATA DICTIONARY A ; Aug 09, 2022@08:21

 ;;22.2;VA FileMan;**2,5,23**;Jan 05, 2016;Build 2

 ;;Per VA Directive 6402, this routine should not be modified.

 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.

 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.

 ;;Licensed under the terms of the Apache License, Version 2.0.

 ;;GFT;**7,999,1004,1014,1015,1038,1041,1053,1054**

 ;

 ;'DQI' PARAMETER IS '1' WHEN CALLED FROM ALLFLDS+4^DIV

BEGIN I $D(DIVFIL)[0 N DIVDAT,DIVFIL,DIVMODE,DIVPG,POP D  G:$G(POP) Q^DIV

 . S DIVMODE="C"

 . D DEVSEL^DIV Q:$G(POP)

 . D INIT^DIV

 N W,I,J,V,DIVREQK,DIVTYPE,DIVTMP,DG,DIVRIX,T,TYP,E,DDC,DIVZ,DE,DR,P4,M,DIDANGL,DIVROUTT,DIPA

 S TYP=$P($G(^DD(A,DIFLD,0)),U,2) I TYP="" Q

 D IJ^DIUTL(A) S V=$O(J(""),-1)

 F T="N","D","P","S","V","F" Q:TYP[T

 F W="FREE TEXT","SET OF CODES","DATE","NUMERIC","POINTER","VARIABLE POINTER","K","" I TYP[$E(W) S:W="K" T=W,W="MUMPS" Q

 I TYP["C" Q

TYPE S %=+$P(TYP,"t",2) I %,$D(^DI(.81,%,0)) S T="F",W=$P(^(0),U)_" Data Type"

 W "--FIELD #",DIFLD," ",$$LABEL^DIALOGZ(A,DIFLD),"--  (",W,")"

 S W="W !,""ENTRY#"_$S(V:"'S",1:"")_""",?10,"""_$$LABEL^DIALOGZ(A,.01)_""",?40,""ERROR"",!"

 D LF Q:$D(DIRUT)  S T=$E(T),DIVZ=$P(^DD(A,DIFLD,0),U,3),DDC=$P(^(0),U,5,999),DR=$P(^(0),U,2),P4=$P(^(0),U,4)

 I DR["t" S DDC="N DIQUIET S DIQUIET=1 "_$$VALINT^DIETLIBF(A,DIFLD),DIVROUTT=$$OUTPUT^DIETLIBF(A,DIFLD)

OUTT E  I $G(^DD(A,DIFLD,2))]"" S DIVROUTT=^(2)

 S DIVREQK=$D(^DD("KEY","F",A,DIFLD))>9

 I $D(^DD("IX","F",A,DIFLD)) D

 . S DIVTYPE=T,T="INDEX",DIVROOT=$$FROOTDA^DIKCU(A)

 . D LOADVER^DIVC(A,DIFLD,"DIVTMP")

 F %=0:0 S %=$O(^DD(A,DIFLD,1,%)) Q:%'>0  I $D(^(%,1)) D

 .N X S X=$P(^(0),U,2,9) Q:X'?1.A

 .I ^(2)?1"K ^".E1")",^(1)?1"S ^".E D

 ..S DG(%)="I $D("_$E(^(2),3,99)_"),"_$E(^(1),3,99) I 'V S DIVRIX(X)="" ;Only looks at top-level X-refs

UNIQ ..I DR["U",DIFLD=.01,X="B" S DDC="K % M %="_DIU_"""B"",X) K %(DA) K:$O(%(0)) X I $D(X) "_DDC

 I T'="INDEX",'$D(^(+$O(^DD(A,DIFLD,1,0)),1)) G E

 I T'="INDEX",'$D(DG) W $C(7)_"(CANNOT CHECK"

 E  W "(CHECKING"

 W " CROSS-REFERENCE)" D LF I $D(DIRUT) Q:$D(DQI)  G Q

 I $D(DG) D

 . I T="INDEX" S E=DIVTYPE,DIVTYPE="IX"

 . E  S E=T,T="IX"

E F Y=$F(DDC,"%DT="""):1 S X=$E(DDC,Y) Q:""""[X  I X="E" S $E(DDC,Y)="" Q  ;Take out "E"

 I DR["*" S DDC="Q" I $D(^DD(A,DIFLD,12.1)) X ^(12.1) I $D(DIC("S")) S DDC(1)=DIC("S"),DDC="X DDC(1) E  K X"

 D 0 S X=P4,Y=$P(X,";",2),X=$P(X,";")

 I +X'=X S X=""""_X_"""" I Y="" S DE=DE_"S X=DA D R" G XEC

 S DIDANGL="S X=$S($D(^(DA,"_X_")):$"_$S(Y:"P(^("_X_"),U,"_Y,1:"E(^("_X_"),"_$E(Y,2,9))_"),1:"""")",M=DIDANGL_" D R"

 I $L(M)+$L(DE)>250 S DE=DE_"X DE(1)",DE(1)=M

 E  S DE=DE_M

XEC K DIC,M,Y XECUTE DE_"  Q:$G(DIRUT)" Q:$G(DIRUT)

 ;

DANGL S DIVRIX="A" F  S DIVRIX=$O(DIVRIX(DIVRIX)) Q:DIVRIX=""  D  Q:$G(DIRUT)  ;LOOK FOR BAD CROSS-REFERENCES

 .N IX,SN,SX,DA

 .S IX=I(0)_""""_DIVRIX_""")",SN=$QL(IX)

 .K ^UTILITY("DIVRIX",$J)

 .F  S IX=$Q(@IX) Q:IX=""  Q:$QS(IX,SN)'=DIVRIX  D  Q:$G(DIRUT)

 ..I @IX]"" Q

 ..S DA=$QS(IX,SN+2),SX=" """_DIVRIX_""" CROSS-REF '"_$QS(IX,SN+1)_"'"

 ..I '$D(@(I(0)_DA_")")) S M="DANGLING"_SX D X Q

 ..X DIDANGL I $E($QS(IX,SN+1),1,30)'=$E(X,1,30) S M="WRONG"_SX D X Q

 ..I $D(^UTILITY("DIVRIX",$J,DA)) S M="DUPLICATE"_SX D X

 ..S ^(DA)=""

 Q:$D(DQI)

 W:'$D(M) $C(7),!,"NO PROBLEMS"

Q S M=$O(^UTILITY("DIVR",$J,0)),E=$O(^(M)),DK=J(0)

 I $D(ZTQUEUED) S ZTREQ="@"

 E  I $T(^%ZISC)]"" D

 . D ^%ZISC

 E  X $G(^%ZIS("C"))

 G:'E!$D(DIRUT)!$D(ZTQUEUED) QX K DIBT,DISV D

 . N C,D,I,J,L,O,Q,S,D0,DDA,DICL,DIFLD,DIU0

 . W ! D S2^DIBT1 Q  ;STORE ENTRIES IN TEMPLATE??

 S DDC=0 I '$D(DIRUT) G Q:Y<0 F E=0:0 S E=$O(^UTILITY("DIVR",$J,E)) Q:E=""  S DDC=DDC+1,^DIBT(+Y,1,E)=""

 S:DDC>0 ^DIBT(+Y,"QR")=DT_U_DDC

QX K DIVINDEX,DIVKEY,DIVREQK,DIVROOT,DIVTMP,DIVTYPE

 K ^UTILITY("DIVR",$J),^UTILITY("DIVRIX",$J),DIRUT,DIROUT,DTOUT,DUOUT,DK,DQ,P,DR Q

 ;

R Q:$D(DIRUT)  ;Tag XEC will send us here, for every entry in the file

 I X?." " Q:DR'["R"&'DIVREQK  D  G X

 . I X="" S M="Missing"_$S(DIVREQK:" key value",1:"")

 . E  S M="Equals only 1 or more spaces"

DOTYPE D @T ;WAS A GOTO   'T' = 'N' or 'F' or 'S', etc

 I $Y+4>IOSL D LF

 Q

 ;

P I @("$D(^"_DIVZ_"X,0))") S Y=X G F

 S M="No '"_X_"' in pointed-to File" G X

 ;

S S Y=X X DDC I '$D(X) S M=""""_Y_""" fails screen" G X

 Q:";"_DIVZ[(";"_X_":")  S M=""""_X_""" not in Set" G X

 ;

D I X'=+X S M=""""_X_""" not an internal date" G X ;p23

 S X=$$DATE^DIUTL(X)

N ;

K ;

F S DQ=X I X'?.ANP S M="Non-printing character" G X ;ALL DATA TYPES FALL THRU TO HERE

 X DDC Q:$D(X)  ;TRY INPUT TRANSFORM

 I $G(DIVROUTT)]"" D  Q:$D(X)

 .N Y S Y=DQ X DIVROUTT S X=Y X DDC ;TRY OUTPUT-TRANSFORMING, THEN INPUT TRANSFORM (AS WITH ^DD(2,.117), 'COUNTY')

 S M=""""_DQ_$S($G(DR)["t":""" is not a valid value",1:""" fails Input Transform")

X I $O(^UTILITY("DIVR",$J,0))="" X W

 S X=$S(V:DA(V),1:DA),^UTILITY("DIVR",$J,X)=""

 S X=V I @(I(0)_"0)")

DA I 'X D  Q

 . D LF Q:$D(DIRUT)

 . W DA,?10,$S($D(^(DA,0)):$E($P(^(0),U),1,30),1:DA),?40,$E(M,1,IOM-40) ;'M' is the message!

 . D:V LF

 D LF Q:$D(DIRUT)  W DA(X),?10,$S($G(^(DA(X),0))]"":$P(^(0),U),1:"***NO ZERO NODE***") S X=X-1,@("Y=$D(^("_I(V-X)_",0))") G DA

 ;

0 ;

 S Y=I(0),DE="",X=V

L S DA="DA" S:X DA=DA_"("_X_")" S Y=Y_DA,DE=DE_"F "_DA_"=0:0 ",%="S "_DA_"=$O("_Y_"))" I V>2 S DE(X+X)=%,DE=DE_"X DE("_(X+X)_")"

 E  S DE=DE_%

 S DE=DE_" Q:"_DA_"'>0  S D"_(V-X)_"="_DA_" "

 ;I X=1,DIFLD=.01 S DE=DE_"X P:$D(^(DA(1),"_I(V)_",0)) ",P="S $P(^(0),U,2)="""_$P(^DD(J(V-1),P,0),U,2)_Q

 S X=X-1 Q:X<0  S Y=Y_","_I(V-X)_"," G L

 ;

IX F %=0:0 S %=$O(DG(%)) Q:+%'>0  X DG(%) I '$T S M=""""_X_""" not properly Cross-referenced" G X

 G @E

 ;

V I $P(X,";",2)'?1A.AN1"(".ANP,$P(X,";",2)'?1"%".AN1"(".ANP S M=""""_X_""""_" has the wrong format" G X

 S M=$S($D(@(U_$P(X,";",2)_"0)")):^(0),1:"")

 I '$D(^DD(A,DIFLD,"V","B",+$P(M,U,2))) S M=$P(M,U)_" FILE not in the DD" G X

 I '$D(@(U_$P(X,";",2)_+X_",0)")) S M=U_$P(X,";",2)_+X_",0) does not exist" G X

 G F

 ;

INDEX ;Check new indexes

 ;

 ;Set DIVINDEX(indexName,index#) = "" for indexes aren't set

 ;Set DIVKEY(file#,keyName,uiNumber) = "null" : if key field is null

 ;                                     "uniq" : if key is not unique

 K DIVKEY,DIINDEX

 D VER^DIVC(A,DIVROOT,.DA,"DIVTMP",.DIVINDEX,.DIVKEY)

 ;

 ;If some indexes aren't set properly, print index info

 I $D(DIVINDEX) D  K DIVINDEX Q:$D(DIRUT)

 . N DIVNAME,DIVNUM

 . S DIVNAME="" F  S DIVNAME=$O(DIVINDEX(DIVNAME)) Q:DIVNAME=""  D  Q:$D(DIRUT)

 .. S DIVNUM=0 F  S DIVNUM=$O(DIVINDEX(DIVNAME,DIVNUM)) Q:'DIVNUM  D  Q:$D(DIRUT)

 ... S M=""""_X_""": "_DIVNAME_" index (#"_DIVNUM_") not properly set"

 ... D IER

 ;

 ;If keys integrity is violated, print key info

 I $D(DIVKEY) D  K DIVKEY Q:$D(DIRUT)

 . N DIVFILE,DIVKNM,DIVPROB,DIVXRNM

 . S DIVFILE="" F  S DIVFILE=$O(DIVKEY(DIVFILE)) Q:DIVFILE=""  D  Q:$D(DIRUT)

 .. S DIVKNM="" F  S DIVKNM=$O(DIVKEY(DIVFILE,DIVKNM)) Q:DIVKNM=""  D  Q:$D(DIRUT)

 ... S DIVXRNM="" F  S DIVXRNM=$O(DIVKEY(DIVFILE,DIVKNM,DIVXRNM)) Q:DIVXRNM=""  D  Q:$D(DIRUT)

 .... S DIVPROB=DIVKEY(DIVFILE,DIVKNM,DIVXRNM)

 .... S M=""""_X_""": "_$S(DIVPROB="null":"Key values are missing.",1:"Key is not unique.")

 .... S M=M_" (File #"_DIVFILE_", Key "_DIVKNM_", Index "_DIVXRNM_")"

 .... D IER

 ;

 ;Continue with checking traditional xrefs (if any) and data type

 G @DIVTYPE

 ;

IER ;Print info about invalid indexes. (Modeled after DA subroutine above)

 N DIVTXT,DIVI,X

 ;

 ;Wrap message M to within 40 columns

 S DIVTXT(0)=M D WRAP^DIKCU2(.DIVTXT,40)

 ;

 ;If nothing was written yet, write column headers

 I $O(^UTILITY("DIVR",$J,0))="" X W

 ;

 ;Set ^UTILITY("DIVR",$J,topIen)="", X = level#, naked = top level root

 S X=$S(V:DA(V),1:DA),^UTILITY("DIVR",$J,X)=""

 S X=V I @(I(0)_"0)")

 ;

IER1 ;If top level, write record info and message

 I 'X D  Q

 . D LF Q:$D(DIRUT)  W DA,?10,$S($D(^(DA,0)):$P(^(0),U),1:DA)

 . F DIVI=0:1 Q:$D(DIVTXT(DIVI))[0  D  Q:$D(DIRUT)

 .. I DIVI D LF Q:$D(DIRUT)

 .. W ?40,DIVTXT(DIVI)

 . D:V LF

 ;

 ;Else write subrecord info, decrement level, set naked = ^naked(node,0)

 D LF Q:$D(DIRUT)

 W DA(X),?10,$P(^(DA(X),0),U) S X=X-1,@("Y=$D(^("_I(V-X)_",0))")

 G IER1

 ;

LF ;Issue a line feed or EOP read    CALLED FROM DIV

 I $Y+3<IOSL W ! Q

 N DINAKED S DINAKED=$NA(^(0))

 I IOST?1"C-".E D

 . N DIR,X,Y

 . S DIR(0)="E" W ! D ^DIR

 ;

 I '$D(DIRUT) D

 . I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DIRUT)=1

 . E  W @IOF D HDR

 S:DINAKED]"" DINAKED=$S(DINAKED["""""":$O(@DINAKED),1:$D(@DINAKED))

 Q

 ;

HDR ;Print header

 N DIVTAB

 S DIVPG=$G(DIVPG)+1

 W "VERIFY FIELDS REPORT"

 ;

 S DIVTAB=IOM-1-$L(DIVFIL)-$L(DIVDAT)-$L(DIVPG)

 I DIVTAB>1 W !,DIVFIL_$J("",DIVTAB)_DIVDAT_DIVPG

 E  W !,DIVFIL,!,$J("",IOM-1-$L(DIVDAT)-$L(DIVPG))_DIVDAT_DIVPG

 W !,$TR($J("",IOM-1)," ","-"),!

 Q

 ;

 ;

 ;

EN(A,DIFLD,DQI) ;Main Entry Point for VEN version

 G BEGIN

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DIVR   8961     printed  Mar 13, 2025@21:59:37                                                                                                                                                                                                        Page 2

DIVR      ;OIFO/GFT - VERIFY FIELD DIFLD, DATA DICTIONARY A ; Aug 09, 2022@08:21

 +1       ;;22.2;VA FileMan;**2,5,23**;Jan 05, 2016;Build 2

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.

 +4       ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.

 +5       ;;Licensed under the terms of the Apache License, Version 2.0.

 +6       ;;GFT;**7,999,1004,1014,1015,1038,1041,1053,1054**

 +7       ;

 +8       ;'DQI' PARAMETER IS '1' WHEN CALLED FROM ALLFLDS+4^DIV

BEGIN      IF $DATA(DIVFIL)[0

               NEW DIVDAT,DIVFIL,DIVMODE,DIVPG,POP

               Begin DoDot:1

 +1                SET DIVMODE="C"

 +2                DO DEVSEL^DIV

                   if $GET(POP)

                       QUIT 

 +3                DO INIT^DIV

               End DoDot:1

               if $GET(POP)

                   GOTO Q^DIV

 +4        NEW W,I,J,V,DIVREQK,DIVTYPE,DIVTMP,DG,DIVRIX,T,TYP,E,DDC,DIVZ,DE,DR,P4,M,DIDANGL,DIVROUTT,DIPA

 +5        SET TYP=$PIECE($GET(^DD(A,DIFLD,0)),U,2)

           IF TYP=""

               QUIT 

 +6        DO IJ^DIUTL(A)

           SET V=$ORDER(J(""),-1)

 +7        FOR T="N","D","P","S","V","F"

               if TYP[T

                   QUIT 

 +8        FOR W="FREE TEXT","SET OF CODES","DATE","NUMERIC","POINTER","VARIABLE POINTER","K",""

               IF TYP[$EXTRACT(W)

                   if W="K"

                       SET T=W

                       SET W="MUMPS"

                   QUIT 

 +9        IF TYP["C"

               QUIT 

TYPE       SET %=+$PIECE(TYP,"t",2)

           IF %

               IF $DATA(^DI(.81,%,0))

                   SET T="F"

                   SET W=$PIECE(^(0),U)_" Data Type"

 +1        WRITE "--FIELD #",DIFLD," ",$$LABEL^DIALOGZ(A,DIFLD),"--  (",W,")"

 +2        SET W="W !,""ENTRY#"_$SELECT(V:"'S",1:"")_""",?10,"""_$$LABEL^DIALOGZ(A,.01)_""",?40,""ERROR"",!"

 +3        DO LF

           if $DATA(DIRUT)

               QUIT 

           SET T=$EXTRACT(T)

           SET DIVZ=$PIECE(^DD(A,DIFLD,0),U,3)

           SET DDC=$PIECE(^(0),U,5,999)

           SET DR=$PIECE(^(0),U,2)

           SET P4=$PIECE(^(0),U,4)

 +4        IF DR["t"

               SET DDC="N DIQUIET S DIQUIET=1 "_$$VALINT^DIETLIBF(A,DIFLD)

               SET DIVROUTT=$$OUTPUT^DIETLIBF(A,DIFLD)

OUTT      IF '$TEST

               IF $GET(^DD(A,DIFLD,2))]""

                   SET DIVROUTT=^(2)

 +1        SET DIVREQK=$DATA(^DD("KEY","F",A,DIFLD))>9

 +2        IF $DATA(^DD("IX","F",A,DIFLD))

               Begin DoDot:1

 +3                SET DIVTYPE=T

                   SET T="INDEX"

                   SET DIVROOT=$$FROOTDA^DIKCU(A)

 +4                DO LOADVER^DIVC(A,DIFLD,"DIVTMP")

               End DoDot:1

 +5        FOR %=0:0

               SET %=$ORDER(^DD(A,DIFLD,1,%))

               if %'>0

                   QUIT 

               IF $DATA(^(%,1))

                   Begin DoDot:1

 +6                    NEW X

                       SET X=$PIECE(^(0),U,2,9)

                       if X'?1.A

                           QUIT 

 +7                    IF ^(2)?1"K ^".E1")"

                           IF ^(1)?1"S ^".E

                               Begin DoDot:2

 +8       ;Only looks at top-level X-refs

                                   SET DG(%)="I $D("_$EXTRACT(^(2),3,99)_"),"_$EXTRACT(^(1),3,99)

                                   IF 'V

                                       SET DIVRIX(X)=""

UNIQ                               IF DR["U"

                                       IF DIFLD=.01

                                           IF X="B"

                                               SET DDC="K % M %="_DIU_"""B"",X) K %(DA) K:$O(%(0)) X I $D(X) "_DDC

                               End DoDot:2

                   End DoDot:1

 +1        IF T'="INDEX"

               IF '$DATA(^(+$ORDER(^DD(A,DIFLD,1,0)),1))

                   GOTO E

 +2        IF T'="INDEX"

               IF '$DATA(DG)

                   WRITE $CHAR(7)_"(CANNOT CHECK"

 +3       IF '$TEST

               WRITE "(CHECKING"

 +4        WRITE " CROSS-REFERENCE)"

           DO LF

           IF $DATA(DIRUT)

               if $DATA(DQI)

                   QUIT 

               GOTO Q

 +5        IF $DATA(DG)

               Begin DoDot:1

 +6                IF T="INDEX"

                       SET E=DIVTYPE

                       SET DIVTYPE="IX"

 +7               IF '$TEST

                       SET E=T

                       SET T="IX"

               End DoDot:1

E         ;Take out "E"

           FOR Y=$FIND(DDC,"%DT="""):1

               SET X=$EXTRACT(DDC,Y)

               if """"[X

                   QUIT 

               IF X="E"

                   SET $EXTRACT(DDC,Y)=""

                   QUIT 

 +1        IF DR["*"

               SET DDC="Q"

               IF $DATA(^DD(A,DIFLD,12.1))

                   XECUTE ^(12.1)

                   IF $DATA(DIC("S"))

                       SET DDC(1)=DIC("S")

                       SET DDC="X DDC(1) E  K X"

 +2        DO 0

           SET X=P4

           SET Y=$PIECE(X,";",2)

           SET X=$PIECE(X,";")

 +3        IF +X'=X

               SET X=""""_X_""""

               IF Y=""

                   SET DE=DE_"S X=DA D R"

                   GOTO XEC

 +4        SET DIDANGL="S X=$S($D(^(DA,"_X_")):$"_$SELECT(Y:"P(^("_X_"),U,"_Y,1:"E(^("_X_"),"_$EXTRACT(Y,2,9))_"),1:"""")"

           SET M=DIDANGL_" D R"

 +5        IF $LENGTH(M)+$LENGTH(DE)>250

               SET DE=DE_"X DE(1)"

               SET DE(1)=M

 +6       IF '$TEST

               SET DE=DE_M

XEC        KILL DIC,M,Y

           XECUTE DE_"  Q:$G(DIRUT)"

           if $GET(DIRUT)

               QUIT 

 +1       ;

DANGL     ;LOOK FOR BAD CROSS-REFERENCES

           SET DIVRIX="A"

           FOR 

               SET DIVRIX=$ORDER(DIVRIX(DIVRIX))

               if DIVRIX=""

                   QUIT 

               Begin DoDot:1

 +1                NEW IX,SN,SX,DA

 +2                SET IX=I(0)_""""_DIVRIX_""")"

                   SET SN=$QLENGTH(IX)

 +3                KILL ^UTILITY("DIVRIX",$JOB)

 +4                FOR 

                       SET IX=$QUERY(@IX)

                       if IX=""

                           QUIT 

                       if $QSUBSCRIPT(IX,SN)'=DIVRIX

                           QUIT 

                       Begin DoDot:2

 +5                        IF @IX]""

                               QUIT 

 +6                        SET DA=$QSUBSCRIPT(IX,SN+2)

                           SET SX=" """_DIVRIX_""" CROSS-REF '"_$QSUBSCRIPT(IX,SN+1)_"'"

 +7                        IF '$DATA(@(I(0)_DA_")"))

                               SET M="DANGLING"_SX

                               DO X

                               QUIT 

 +8                        XECUTE DIDANGL

                           IF $EXTRACT($QSUBSCRIPT(IX,SN+1),1,30)'=$EXTRACT(X,1,30)

                               SET M="WRONG"_SX

                               DO X

                               QUIT 

 +9                        IF $DATA(^UTILITY("DIVRIX",$JOB,DA))

                               SET M="DUPLICATE"_SX

                               DO X

 +10                       SET ^(DA)=""

                       End DoDot:2

                       if $GET(DIRUT)

                           QUIT 

               End DoDot:1

               if $GET(DIRUT)

                   QUIT 

 +11       if $DATA(DQI)

               QUIT 

 +12       if '$DATA(M)

               WRITE $CHAR(7),!,"NO PROBLEMS"

Q          SET M=$ORDER(^UTILITY("DIVR",$JOB,0))

           SET E=$ORDER(^(M))

           SET DK=J(0)

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +2       IF '$TEST

               IF $TEXT(^%ZISC)]""

                   Begin DoDot:1

 +3                    DO ^%ZISC

                   End DoDot:1

 +4       IF '$TEST

               XECUTE $GET(^%ZIS("C"))

 +5        if 'E!$DATA(DIRUT)!$DATA(ZTQUEUED)

               GOTO QX

           KILL DIBT,DISV

           Begin DoDot:1

 +6            NEW C,D,I,J,L,O,Q,S,D0,DDA,DICL,DIFLD,DIU0

 +7       ;STORE ENTRIES IN TEMPLATE??

               WRITE !

               DO S2^DIBT1

               QUIT 

           End DoDot:1

 +8        SET DDC=0

           IF '$DATA(DIRUT)

               if Y<0

                   GOTO Q

               FOR E=0:0

                   SET E=$ORDER(^UTILITY("DIVR",$JOB,E))

                   if E=""

                       QUIT 

                   SET DDC=DDC+1

                   SET ^DIBT(+Y,1,E)=""

 +9        if DDC>0

               SET ^DIBT(+Y,"QR")=DT_U_DDC

QX         KILL DIVINDEX,DIVKEY,DIVREQK,DIVROOT,DIVTMP,DIVTYPE

 +1        KILL ^UTILITY("DIVR",$JOB),^UTILITY("DIVRIX",$JOB),DIRUT,DIROUT,DTOUT,DUOUT,DK,DQ,P,DR

           QUIT 

 +2       ;

R         ;Tag XEC will send us here, for every entry in the file

           if $DATA(DIRUT)

               QUIT 

 +1        IF X?." "

               if DR'["R"&'DIVREQK

                   QUIT 

               Begin DoDot:1

 +2                IF X=""

                       SET M="Missing"_$SELECT(DIVREQK:" key value",1:"")

 +3               IF '$TEST

                       SET M="Equals only 1 or more spaces"

               End DoDot:1

               GOTO X

DOTYPE    ;WAS A GOTO   'T' = 'N' or 'F' or 'S', etc

           DO @T

 +1        IF $Y+4>IOSL

               DO LF

 +2        QUIT 

 +3       ;

P          IF @("$D(^"_DIVZ_"X,0))")

               SET Y=X

               GOTO F

 +1        SET M="No '"_X_"' in pointed-to File"

           GOTO X

 +2       ;

S          SET Y=X

           XECUTE DDC

           IF '$DATA(X)

               SET M=""""_Y_""" fails screen"

               GOTO X

 +1        if ";"_DIVZ[(";"_X_"

               QUIT 

           SET M=""""_X_""" not in Set"

           GOTO X

 +2       ;

D         ;p23

           IF X'=+X

               SET M=""""_X_""" not an internal date"

               GOTO X

 +1        SET X=$$DATE^DIUTL(X)

N         ;

K         ;

F         ;ALL DATA TYPES FALL THRU TO HERE

           SET DQ=X

           IF X'?.ANP

               SET M="Non-printing character"

               GOTO X

 +1       ;TRY INPUT TRANSFORM

           XECUTE DDC

           if $DATA(X)

               QUIT 

 +2        IF $GET(DIVROUTT)]""

               Begin DoDot:1

 +3       ;TRY OUTPUT-TRANSFORMING, THEN INPUT TRANSFORM (AS WITH ^DD(2,.117), 'COUNTY')

                   NEW Y

                   SET Y=DQ

                   XECUTE DIVROUTT

                   SET X=Y

                   XECUTE DDC

               End DoDot:1

               if $DATA(X)

                   QUIT 

 +4        SET M=""""_DQ_$SELECT($GET(DR)["t":""" is not a valid value",1:""" fails Input Transform")

X          IF $ORDER(^UTILITY("DIVR",$JOB,0))=""

               XECUTE W

 +1        SET X=$SELECT(V:DA(V),1:DA)

           SET ^UTILITY("DIVR",$JOB,X)=""

 +2        SET X=V

           IF @(I(0)_"0)")

DA         IF 'X

               Begin DoDot:1

 +1                DO LF

                   if $DATA(DIRUT)

                       QUIT 

 +2       ;'M' is the message!

                   WRITE DA,?10,$SELECT($DATA(^(DA,0)):$EXTRACT($PIECE(^(0),U),1,30),1:DA),?40,$EXTRACT(M,1,IOM-40)

 +3                if V

                       DO LF

               End DoDot:1

               QUIT 

 +4        DO LF

           if $DATA(DIRUT)

               QUIT 

           WRITE DA(X),?10,$SELECT($GET(^(DA(X),0))]"":$PIECE(^(0),U),1:"***NO ZERO NODE***")

           SET X=X-1

           SET @("Y=$D(^("_I(V-X)_",0))")

           GOTO DA

 +5       ;

0         ;

 +1        SET Y=I(0)

           SET DE=""

           SET X=V

L          SET DA="DA"

           if X

               SET DA=DA_"("_X_")"

           SET Y=Y_DA

           SET DE=DE_"F "_DA_"=0:0 "

           SET %="S "_DA_"=$O("_Y_"))"

           IF V>2

               SET DE(X+X)=%

               SET DE=DE_"X DE("_(X+X)_")"

 +1       IF '$TEST

               SET DE=DE_%

 +2        SET DE=DE_" Q:"_DA_"'>0  S D"_(V-X)_"="_DA_" "

 +3       ;I X=1,DIFLD=.01 S DE=DE_"X P:$D(^(DA(1),"_I(V)_",0)) ",P="S $P(^(0),U,2)="""_$P(^DD(J(V-1),P,0),U,2)_Q

 +4        SET X=X-1

           if X<0

               QUIT 

           SET Y=Y_","_I(V-X)_","

           GOTO L

 +5       ;

IX         FOR %=0:0

               SET %=$ORDER(DG(%))

               if +%'>0

                   QUIT 

               XECUTE DG(%)

               IF '$TEST

                   SET M=""""_X_""" not properly Cross-referenced"

                   GOTO X

 +1        GOTO @E

 +2       ;

V          IF $PIECE(X,";",2)'?1A.AN1"(".ANP

               IF $PIECE(X,";",2)'?1"%".AN1"(".ANP

                   SET M=""""_X_""""_" has the wrong format"

                   GOTO X

 +1        SET M=$SELECT($DATA(@(U_$PIECE(X,";",2)_"0)")):^(0),1:"")

 +2        IF '$DATA(^DD(A,DIFLD,"V","B",+$PIECE(M,U,2)))

               SET M=$PIECE(M,U)_" FILE not in the DD"

               GOTO X

 +3        IF '$DATA(@(U_$PIECE(X,";",2)_+X_",0)"))

               SET M=U_$PIECE(X,";",2)_+X_",0) does not exist"

               GOTO X

 +4        GOTO F

 +5       ;