DDUCHK2 ;SFISC/RWF/SO-CHECK DD (FIELDS) ;20MAR2014
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;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.
;
CHK6 ;W !?5,"Checking FIELDs"
F DDUCFE=0:0 S DDUCFE=+$O(^DD(DDUCFI,DDUCFE)) Q:DDUCFE'>0 D FIELD Q:$D(DIRUT) D FIVE,DXREF^DDUCHK3,XREF^DDUCHK3,COMP^DDUCHK3
;D CHKSB,CHKGL
Q
FIELD ;W "."
I $D(^DD(DDUCFI,DDUCFE,0))[0 W !?5,"*Field: ",DDUCFE," is missing its zero node." Q ;22*100,22*130
S DDUCX=^DD(DDUCFI,DDUCFE,0),DDUCX2=$P(DDUCX,U,2),DDUCX4=$P(DDUCX,U,4),DDUCXN=$P(DDUCX,U)
I $P(DDUCX,U,5,999)["$N(",$P(DDUCX,U,5,999)'["$$N(" W !?5,"*Field: ",DDUCFE,"'s Input Transform contains $Next."
;I DDUCX2["F",DDUCX4[";E1",$S($D(^DD(DDUCFI,DDUCFE,9)):^(9),1:"")'="@" D WHO W "doesn't have the correct protection for a field with executable code." I DDUCFIX S ^DD(DDUCFI,DDUCFE,9)="@" W !?10,"^DD(",DDUCFI,",",DDUCFE,",9) = ""@"" was set."
D @$S(+DDUCX2:"MULT",DDUCX2["P":"PT",DDUCX2["V":"VP",1:"Q") Q
Q
FIVE K DDUCXX F DDUCY=0:0 S DDUCY=$O(^DD(DDUCFI,DDUCFE,5,DDUCY)) Q:DDUCY'>0 S DDUCX=^(DDUCY,0) I $D(^DD(+DDUCX,+$P(DDUCX,U,2),1,+$P(DDUCX,U,3),0))#2 S DDUCXX(DDUCX)=""
Q:'DDUCFIX
K ^DD(DDUCFI,DDUCFE,5)
S DDUCX="" F DDUCY=1:1 S DDUCX=$O(DDUCXX(DDUCX)) Q:DDUCX="" S ^DD(DDUCFI,DDUCFE,5,DDUCY,0)=DDUCX
Q
VP F DDUCY=0:0 S DDUCY=$O(^DD(DDUCFI,DDUCFE,"V",DDUCY)) Q:DDUCY'>0 S DDUCRFI=$S($D(^DD(DDUCFI,DDUCFE,"V",DDUCY,0)):^(0),1:"") I DDUCRFI D PT1
Q
PT N DDUERR S DDUCRFI=+$P(DDUCX2,"P",2),DDUERR=0 D Q:DDUERR
. I $D(^DD(DDUCRFI,0))[0 W !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to missing file: ",DDUCRFI S DDUERR=1 Q
. N DDUCGL,DDUCNA,DDUCHDR
. S DDUCGL=$G(^DIC(DDUCRFI,0,"GL"))
. I DDUCGL="" W !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to File: "_DDUCRFI_", is missing file's ""GL"" (Global Location) node." S DDUERR=1 Q
. S DDUCHDR=DDUCGL_"0)",DDUCHDR=$G(@DDUCHDR)
. I DDUCHDR="" W !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to File: "_DDUCRFI_", missing File header node." S DDUERR=1
. Q
PT1 I $D(^DD(+DDUCRFI,0,"PT",DDUCFI,DDUCFE))[0 D WHO W "is missing its 'PT' node in the pointed-to-file." I DDUCFIX S ^DD(+DDUCRFI,0,"PT",DDUCFI,DDUCFE)="" W !?10,"^DD(",+DDUCRFI,",0,""PT"",",DDUCFI,",",DDUCFE,") = """" was set."
Q Q ;QUIT TAG
MULT ;Work subfile
D PAGE^DDUCHK Q:$D(DIRUT)
I $D(^DD(+DDUCX2,0))[0 W !?5,"*Field: ",DDUCFE," (",DDUCXN,") missing subfile: ",+DDUCX2 Q
S DDUCUP=$S($D(^DD(+DDUCX2,0,"UP")):^("UP"),1:"") I DDUCUP'=DDUCFI D WHO W "Bad 'UP' pointer in subfile #",+DDUCX2 I DDUCFIX S ^DD(+DDUCX2,0,"UP")=DDUCFI W !?10,"^DD(",+DDUCX2,",0,""UP"") = ",DDUCFI," was set."
D PUSH S DDUCFI=+DDUCX2 D CHK^DDUCHK,POP ;"Checking subfile" ;W !?3,"Returning to ",$S('DDUCSTK:"main ",1:"sub"),"file",$S('DDUCSTK:" "_DDUCFILE_".",1:" "_DDUCFI)
Q
PUSH S DDUCSTK=DDUCSTK+1,DDUCSTK(DDUCSTK,1)=DDUCFI,DDUCSTK(DDUCSTK,2)=DDUCFE Q
POP S DDUCFI=DDUCSTK(DDUCSTK,1),DDUCFE=DDUCSTK(DDUCSTK,2),DDUCSTK=DDUCSTK-1 Q
WHO W !?8,"Field: ",DDUCFE," (",DDUCXN,") " Q
;
CHKSB ;Check for duplicate "SB" x-refs ;22*130
N DDUCSB
S DDUCSB=0
F S DDUCSB=+$O(^DD(DDUCFI,"SB",DDUCSB)) Q:'DDUCSB D
. N DDUCFE,DDUCSAV,DDUNFE
. S DDUCFE=0
. F S DDUCFE=+$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE)) Q:'DDUCFE D CHKSBA I '$D(DDUNFE),$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE)) D
.. N DDUCFE1,DDUCX
.. ;Is the TYPE "WP"?
.. S DDUCX=$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE)) I $D(^DD(DDUCFI,DDUCX,0)),$P(^DD(DDUCFI,DDUCX,0),U,4)["WP" Q
.. S DDUCSAV(DDUCFE)=""
.. S DDUCFE1=DDUCFE
.. F S DDUCFE1=+$O(^DD(DDUCFI,"SB",DDUCSB,DDUCFE1)) Q:'DDUCFE1 S DDUCSAV(DDUCFE1)=""
. N X1,X2
. S X1=0
. F S X1=$O(DDUCSAV(X1)) Q:'X1 D
.. I '$D(X2) W !?5,"*Duplicate Fields represent Sub-file: "_DDUCSB,!?7 S X2=1
.. W "field: "_X1_"; "
Q
;
CHKSBA ;Check if Feidl exists
I '$D(^DD(DDUCFI,DDUCFE,0))#2 W !?7,"*Field: "_DDUCFE_", File: "_DDUCFI_", ""SB"" subscript for subfile: "_DDUCSB_" is missing." S DDUNFE=1 Q
Q
;
CHKGL ;Check for duplicate "GL" nodes ;22*130
N DDUCN
S DDUCN=""
F S DDUCN=$O(^DD(DDUCFI,"GL",DDUCN)) Q:DDUCN="" D
. N DDUCP
. S DDUCP=0
. F S DDUCP=+$O(^DD(DDUCFI,"GL",DDUCN,DDUCP)) Q:'DDUCP D
.. N DDUCFE2,DDUCSAV
.. S DDUCFE2=0
.. F S DDUCFE2=+$O(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2)) Q:'DDUCFE2 I $O(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2)) D
... S DDUCSAV(DDUCN_";"_DDUCP,DDUCFE2)=""
... N X
... S X=0
... S X=$O(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2)) Q:'X S DDUCSAV(DDUCN_";"_DDUCP,X)=""
.. N X1,X2
.. S X1="" ;Global Location
.. F S X1=$O(DDUCSAV(X1)) Q:X1="" D
... I '$D(X2) W !?5,"*Duplication at global location subscript: "_$P(X1,";")_", piece: "_$P(X1,";",2),!?9 S X2=1
... N X3
... S X3=0 ;Field #
... F S X3=$O(DDUCSAV(X1,X3)) Q:'X3 W "field: "_X3_"; "
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDUCHK2 4942 printed Apr 09, 2024@21:45:11 Page 2
DDUCHK2 ;SFISC/RWF/SO-CHECK DD (FIELDS) ;20MAR2014
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+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 ;
CHK6 ;W !?5,"Checking FIELDs"
+1 FOR DDUCFE=0:0
SET DDUCFE=+$ORDER(^DD(DDUCFI,DDUCFE))
if DDUCFE'>0
QUIT
DO FIELD
if $DATA(DIRUT)
QUIT
DO FIVE
DO DXREF^DDUCHK3
DO XREF^DDUCHK3
DO COMP^DDUCHK3
+2 ;D CHKSB,CHKGL
+3 QUIT
FIELD ;W "."
+1 ;22*100,22*130
IF $DATA(^DD(DDUCFI,DDUCFE,0))[0
WRITE !?5,"*Field: ",DDUCFE," is missing its zero node."
QUIT
+2 SET DDUCX=^DD(DDUCFI,DDUCFE,0)
SET DDUCX2=$PIECE(DDUCX,U,2)
SET DDUCX4=$PIECE(DDUCX,U,4)
SET DDUCXN=$PIECE(DDUCX,U)
+3 IF $PIECE(DDUCX,U,5,999)["$N("
IF $PIECE(DDUCX,U,5,999)'["$$N("
WRITE !?5,"*Field: ",DDUCFE,"'s Input Transform contains $Next."
+4 ;I DDUCX2["F",DDUCX4[";E1",$S($D(^DD(DDUCFI,DDUCFE,9)):^(9),1:"")'="@" D WHO W "doesn't have the correct protection for a field with executable code." I DDUCFIX S ^DD(DDUCFI,DDUCFE,9)="@" W !?10,"^DD(",DDUCFI,",",DDUCFE,",9) = ""@"" was set."
+5 DO @$SELECT(+DDUCX2:"MULT",DDUCX2["P":"PT",DDUCX2["V":"VP",1:"Q")
QUIT
+6 QUIT
FIVE KILL DDUCXX
FOR DDUCY=0:0
SET DDUCY=$ORDER(^DD(DDUCFI,DDUCFE,5,DDUCY))
if DDUCY'>0
QUIT
SET DDUCX=^(DDUCY,0)
IF $DATA(^DD(+DDUCX,+$PIECE(DDUCX,U,2),1,+$PIECE(DDUCX,U,3),0))#2
SET DDUCXX(DDUCX)=""
+1 if 'DDUCFIX
QUIT
+2 KILL ^DD(DDUCFI,DDUCFE,5)
+3 SET DDUCX=""
FOR DDUCY=1:1
SET DDUCX=$ORDER(DDUCXX(DDUCX))
if DDUCX=""
QUIT
SET ^DD(DDUCFI,DDUCFE,5,DDUCY,0)=DDUCX
+4 QUIT
VP FOR DDUCY=0:0
SET DDUCY=$ORDER(^DD(DDUCFI,DDUCFE,"V",DDUCY))
if DDUCY'>0
QUIT
SET DDUCRFI=$SELECT($DATA(^DD(DDUCFI,DDUCFE,"V",DDUCY,0)):^(0),1:"")
IF DDUCRFI
DO PT1
+1 QUIT
PT NEW DDUERR
SET DDUCRFI=+$PIECE(DDUCX2,"P",2)
SET DDUERR=0
Begin DoDot:1
+1 IF $DATA(^DD(DDUCRFI,0))[0
WRITE !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to missing file: ",DDUCRFI
SET DDUERR=1
QUIT
+2 NEW DDUCGL,DDUCNA,DDUCHDR
+3 SET DDUCGL=$GET(^DIC(DDUCRFI,0,"GL"))
+4 IF DDUCGL=""
WRITE !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to File: "_DDUCRFI_", is missing file's ""GL"" (Global Location) node."
SET DDUERR=1
QUIT
+5 SET DDUCHDR=DDUCGL_"0)"
SET DDUCHDR=$GET(@DDUCHDR)
+6 IF DDUCHDR=""
WRITE !?5,"*Field: ",DDUCFE," (",DDUCXN,") points to File: "_DDUCRFI_", missing File header node."
SET DDUERR=1
+7 QUIT
End DoDot:1
if DDUERR
QUIT
PT1 IF $DATA(^DD(+DDUCRFI,0,"PT",DDUCFI,DDUCFE))[0
DO WHO
WRITE "is missing its 'PT' node in the pointed-to-file."
IF DDUCFIX
SET ^DD(+DDUCRFI,0,"PT",DDUCFI,DDUCFE)=""
WRITE !?10,"^DD(",+DDUCRFI,",0,""PT"",",DDUCFI,",",DDUCFE,") = """" was set."
Q ;QUIT TAG
QUIT
MULT ;Work subfile
+1 DO PAGE^DDUCHK
if $DATA(DIRUT)
QUIT
+2 IF $DATA(^DD(+DDUCX2,0))[0
WRITE !?5,"*Field: ",DDUCFE," (",DDUCXN,") missing subfile: ",+DDUCX2
QUIT
+3 SET DDUCUP=$SELECT($DATA(^DD(+DDUCX2,0,"UP")):^("UP"),1:"")
IF DDUCUP'=DDUCFI
DO WHO
WRITE "Bad 'UP' pointer in subfile #",+DDUCX2
IF DDUCFIX
SET ^DD(+DDUCX2,0,"UP")=DDUCFI
WRITE !?10,"^DD(",+DDUCX2,",0,""UP"") = ",DDUCFI," was set."
+4 ;"Checking subfile" ;W !?3,"Returning to ",$S('DDUCSTK:"main ",1:"sub"),"file",$S('DDUCSTK:" "_DDUCFILE_".",1:" "_DDUCFI)
DO PUSH
SET DDUCFI=+DDUCX2
DO CHK^DDUCHK
DO POP
+5 QUIT
PUSH SET DDUCSTK=DDUCSTK+1
SET DDUCSTK(DDUCSTK,1)=DDUCFI
SET DDUCSTK(DDUCSTK,2)=DDUCFE
QUIT
POP SET DDUCFI=DDUCSTK(DDUCSTK,1)
SET DDUCFE=DDUCSTK(DDUCSTK,2)
SET DDUCSTK=DDUCSTK-1
QUIT
WHO WRITE !?8,"Field: ",DDUCFE," (",DDUCXN,") "
QUIT
+1 ;
CHKSB ;Check for duplicate "SB" x-refs ;22*130
+1 NEW DDUCSB
+2 SET DDUCSB=0
+3 FOR
SET DDUCSB=+$ORDER(^DD(DDUCFI,"SB",DDUCSB))
if 'DDUCSB
QUIT
Begin DoDot:1
+4 NEW DDUCFE,DDUCSAV,DDUNFE
+5 SET DDUCFE=0
+6 FOR
SET DDUCFE=+$ORDER(^DD(DDUCFI,"SB",DDUCSB,DDUCFE))
if 'DDUCFE
QUIT
DO CHKSBA
IF '$DATA(DDUNFE)
IF $ORDER(^DD(DDUCFI,"SB",DDUCSB,DDUCFE))
Begin DoDot:2
+7 NEW DDUCFE1,DDUCX
+8 ;Is the TYPE "WP"?
+9 SET DDUCX=$ORDER(^DD(DDUCFI,"SB",DDUCSB,DDUCFE))
IF $DATA(^DD(DDUCFI,DDUCX,0))
IF $PIECE(^DD(DDUCFI,DDUCX,0),U,4)["WP"
QUIT
+10 SET DDUCSAV(DDUCFE)=""
+11 SET DDUCFE1=DDUCFE
+12 FOR
SET DDUCFE1=+$ORDER(^DD(DDUCFI,"SB",DDUCSB,DDUCFE1))
if 'DDUCFE1
QUIT
SET DDUCSAV(DDUCFE1)=""
End DoDot:2
+13 NEW X1,X2
+14 SET X1=0
+15 FOR
SET X1=$ORDER(DDUCSAV(X1))
if 'X1
QUIT
Begin DoDot:2
+16 IF '$DATA(X2)
WRITE !?5,"*Duplicate Fields represent Sub-file: "_DDUCSB,!?7
SET X2=1
+17 WRITE "field: "_X1_"; "
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
CHKSBA ;Check if Feidl exists
+1 IF '$DATA(^DD(DDUCFI,DDUCFE,0))#2
WRITE !?7,"*Field: "_DDUCFE_", File: "_DDUCFI_", ""SB"" subscript for subfile: "_DDUCSB_" is missing."
SET DDUNFE=1
QUIT
+2 QUIT
+3 ;
CHKGL ;Check for duplicate "GL" nodes ;22*130
+1 NEW DDUCN
+2 SET DDUCN=""
+3 FOR
SET DDUCN=$ORDER(^DD(DDUCFI,"GL",DDUCN))
if DDUCN=""
QUIT
Begin DoDot:1
+4 NEW DDUCP
+5 SET DDUCP=0
+6 FOR
SET DDUCP=+$ORDER(^DD(DDUCFI,"GL",DDUCN,DDUCP))
if 'DDUCP
QUIT
Begin DoDot:2
+7 NEW DDUCFE2,DDUCSAV
+8 SET DDUCFE2=0
+9 FOR
SET DDUCFE2=+$ORDER(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2))
if 'DDUCFE2
QUIT
IF $ORDER(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2))
Begin DoDot:3
+10 SET DDUCSAV(DDUCN_";"_DDUCP,DDUCFE2)=""
+11 NEW X
+12 SET X=0
+13 SET X=$ORDER(^DD(DDUCFI,"GL",DDUCN,DDUCP,DDUCFE2))
if 'X
QUIT
SET DDUCSAV(DDUCN_";"_DDUCP,X)=""
End DoDot:3
+14 NEW X1,X2
+15 ;Global Location
SET X1=""
+16 FOR
SET X1=$ORDER(DDUCSAV(X1))
if X1=""
QUIT
Begin DoDot:3
+17 IF '$DATA(X2)
WRITE !?5,"*Duplication at global location subscript: "_$PIECE(X1,";")_", piece: "_$PIECE(X1,";",2),!?9
SET X2=1
+18 NEW X3
+19 ;Field #
SET X3=0
+20 FOR
SET X3=$ORDER(DDUCSAV(X1,X3))
if 'X3
QUIT
WRITE "field: "_X3_"; "
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
