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 ---[H[J[2J[HDIVR 8961 printed Oct 16, 2024@18:55:18 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 ;
INDEX ;Check new indexes
+1 ;
+2 ;Set DIVINDEX(indexName,index#) = "" for indexes aren't set
+3 ;Set DIVKEY(file#,keyName,uiNumber) = "null" : if key field is null
+4 ; "uniq" : if key is not unique
+5 KILL DIVKEY,DIINDEX
+6 DO VER^DIVC(A,DIVROOT,.DA,"DIVTMP",.DIVINDEX,.DIVKEY)
+7 ;
+8 ;If some indexes aren't set properly, print index info
+9 IF $DATA(DIVINDEX)
Begin DoDot:1
+10 NEW DIVNAME,DIVNUM
+11 SET DIVNAME=""
FOR
SET DIVNAME=$ORDER(DIVINDEX(DIVNAME))
if DIVNAME=""
QUIT
Begin DoDot:2
+12 SET DIVNUM=0
FOR
SET DIVNUM=$ORDER(DIVINDEX(DIVNAME,DIVNUM))
if 'DIVNUM
QUIT
Begin DoDot:3
+13 SET M=""""_X_""": "_DIVNAME_" index (#"_DIVNUM_") not properly set"
+14 DO IER
End DoDot:3
if $DATA(DIRUT)
QUIT
End DoDot:2
if $DATA(DIRUT)
QUIT
End DoDot:1
KILL DIVINDEX
if $DATA(DIRUT)
QUIT
+15 ;
+16 ;If keys integrity is violated, print key info
+17 IF $DATA(DIVKEY)
Begin DoDot:1
+18 NEW DIVFILE,DIVKNM,DIVPROB,DIVXRNM
+19 SET DIVFILE=""
FOR
SET DIVFILE=$ORDER(DIVKEY(DIVFILE))
if DIVFILE=""
QUIT
Begin DoDot:2
+20 SET DIVKNM=""
FOR
SET DIVKNM=$ORDER(DIVKEY(DIVFILE,DIVKNM))
if DIVKNM=""
QUIT
Begin DoDot:3
+21 SET DIVXRNM=""
FOR
SET DIVXRNM=$ORDER(DIVKEY(DIVFILE,DIVKNM,DIVXRNM))
if DIVXRNM=""
QUIT
Begin DoDot:4
+22 SET DIVPROB=DIVKEY(DIVFILE,DIVKNM,DIVXRNM)
+23 SET M=""""_X_""": "_$SELECT(DIVPROB="null":"Key values are missing.",1:"Key is not unique.")
+24 SET M=M_" (File #"_DIVFILE_", Key "_DIVKNM_", Index "_DIVXRNM_")"
+25 DO IER
End DoDot:4
if $DATA(DIRUT)
QUIT
End DoDot:3
if $DATA(DIRUT)
QUIT
End DoDot:2
if $DATA(DIRUT)
QUIT
End DoDot:1
KILL DIVKEY
if $DATA(DIRUT)
QUIT
+26 ;
+27 ;Continue with checking traditional xrefs (if any) and data type
+28 GOTO @DIVTYPE
+29 ;
IER ;Print info about invalid indexes. (Modeled after DA subroutine above)
+1 NEW DIVTXT,DIVI,X
+2 ;
+3 ;Wrap message M to within 40 columns
+4 SET DIVTXT(0)=M
DO WRAP^DIKCU2(.DIVTXT,40)
+5 ;
+6 ;If nothing was written yet, write column headers
+7 IF $ORDER(^UTILITY("DIVR",$JOB,0))=""
XECUTE W
+8 ;
+9 ;Set ^UTILITY("DIVR",$J,topIen)="", X = level#, naked = top level root
+10 SET X=$SELECT(V:DA(V),1:DA)
SET ^UTILITY("DIVR",$JOB,X)=""
+11 SET X=V
IF @(I(0)_"0)")
+12 ;
IER1 ;If top level, write record info and message
+1 IF 'X
Begin DoDot:1
+2 DO LF
if $DATA(DIRUT)
QUIT
WRITE DA,?10,$SELECT($DATA(^(DA,0)):$PIECE(^(0),U),1:DA)
+3 FOR DIVI=0:1
if $DATA(DIVTXT(DIVI))[0
QUIT
Begin DoDot:2
+4 IF DIVI
DO LF
if $DATA(DIRUT)
QUIT
+5 WRITE ?40,DIVTXT(DIVI)
End DoDot:2
if $DATA(DIRUT)
QUIT
+6 if V
DO LF
End DoDot:1
QUIT
+7 ;
+8 ;Else write subrecord info, decrement level, set naked = ^naked(node,0)
+9 DO LF
if $DATA(DIRUT)
QUIT
+10 WRITE DA(X),?10,$PIECE(^(DA(X),0),U)
SET X=X-1
SET @("Y=$D(^("_I(V-X)_",0))")
+11 GOTO IER1
+12 ;
LF ;Issue a line feed or EOP read CALLED FROM DIV
+1 IF $Y+3<IOSL
WRITE !
QUIT
+2 NEW DINAKED
SET DINAKED=$NAME(^(0))
+3 IF IOST?1"C-".E
Begin DoDot:1
+4 NEW DIR,X,Y
+5 SET DIR(0)="E"
WRITE !
DO ^DIR
End DoDot:1
+6 ;
+7 IF '$DATA(DIRUT)
Begin DoDot:1
+8 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,DIRUT)=1
+9 IF '$TEST
WRITE @IOF
DO HDR
End DoDot:1
+10 if DINAKED]""
SET DINAKED=$SELECT(DINAKED["""""":$ORDER(@DINAKED),1:$DATA(@DINAKED))
+11 QUIT
+12 ;
HDR ;Print header
+1 NEW DIVTAB
+2 SET DIVPG=$GET(DIVPG)+1
+3 WRITE "VERIFY FIELDS REPORT"
+4 ;
+5 SET DIVTAB=IOM-1-$LENGTH(DIVFIL)-$LENGTH(DIVDAT)-$LENGTH(DIVPG)
+6 IF DIVTAB>1
WRITE !,DIVFIL_$JUSTIFY("",DIVTAB)_DIVDAT_DIVPG
+7 IF '$TEST
WRITE !,DIVFIL,!,$JUSTIFY("",IOM-1-$LENGTH(DIVDAT)-$LENGTH(DIVPG))_DIVDAT_DIVPG
+8 WRITE !,$TRANSLATE($JUSTIFY("",IOM-1)," ","-"),!
+9 QUIT
+10 ;
+11 ;
+12 ;
EN(A,DIFLD,DQI) ;Main Entry Point for VEN version
+1 GOTO BEGIN
