DDUCHK1 ;SFISC/RWF-CHECK DD part 2 ;3JUNE2011
;;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.
;
ID S DDUCRFE="" F DDUCZ=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"ID",DDUCRFE)) Q:DDUCRFE="" S DDUCX=$S($D(^DD(DDUCFI,0,"ID",DDUCRFE))#2:^(DDUCRFE),1:"") I DDUCX="Q" W !?5,"'ID' node for field ",DDUCRFE," = 'Q'" D:DDUCFIX ID1
Q
ID1 K ^DD(DDUCFI,0,"ID",DDUCRFE) D M1 W """ID"",",DDUCRFE D M2
Q
IX S DDUCXREF="" F DDUCZ=0:0 S DDUCXREF=$O(^DD(DDUCFI,0,"IX",DDUCXREF)) Q:DDUCXREF="" F DDUCRFI=0:0 S DDUCRFI=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI)) Q:DDUCRFI'>0 D IX1
Q
IX1 D IXDUP ;22*130
F DDUCRFE=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0 D
. I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D WFI W """IX"" Subscript: "_DDUCXREF_" " D WFE,WMS D:DDUCFIX IX2 Q
. I $D(^DD(DDUCRFI,DDUCRFE,1,0))=0,$D(^DD(DDUCRFI,DDUCRFE,1))=10 S:DDUCFIX ^DD(DDUCRFI,DDUCRFE,1,0)="^.1"
. S DDUCRFE1=0,DDUCRFEX="" F S DDUCRFE1=$O(^DD(DDUCRFI,DDUCRFE,1,DDUCRFE1)) Q:DDUCRFE1'>0 S DDUCRFEX=$G(^(DDUCRFE1,0)) I $P(DDUCRFEX,U,2)=DDUCXREF K DDUCRFEX Q
. I $D(DDUCRFEX) W !?5,"Cross-reference logic is missing for """,DDUCXREF,""" x-ref" D:DDUCFIX IX2 Q
K DDUCRFE1 Q
IX2 K ^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE) D M1 W """IX"",",DDUCXREF_","_DDUCRFI_","_DDUCRFE D M2
Q
PT F DDUCRFI=0:0 S DDUCRFI=$O(^DD(DDUCFI,0,"PT",DDUCRFI)) Q:DDUCRFI'>0 F DDUCRFE=0:0 S DDUCRFE=$O(^DD(DDUCFI,0,"PT",DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0 D PT1
Q
PT1 I $D(^DD(DDUCRFI,0))[0 D WFI,WMS I DDUCFIX K ^DD(DDUCFI,0,"PT",DDUCRFI) D M1 W """PT"",",DDUCRFI D M2 Q
I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D WFI W """PT"" Subscript " D WFE,WMS D:DDUCFIX PTM Q
I ($P(^(0),U,2)'["P")&($P(^(0),U,2)'["V") D WFI,WFE W "is not a pointer." D:DDUCFIX PTM Q
I $P(^(0),U,2)["P",+$P($P(^(0),U,2),"P",2)'=DDUCFI D WFI,WFE W "is not a pointer to file ",DDUCFI D:DDUCFIX PTM
Q
PTM K ^DD(DDUCFI,0,"PT",DDUCRFI,DDUCRFE)
D M1 W """PT"",",DDUCRFI,",",DDUCRFE D M2
Q
AC F DDUCFE=0:0 S DDUCFE=$O(^DD("ACOMP",DDUCFI,DDUCFE)) Q:DDUCFE'>0 D AC1
Q
AC1 F DDUCRFI=0:0 S DDUCRFI=$O(^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI)) Q:DDUCRFI'>0 F DDUCRFE=0:0 S DDUCRFE=$O(^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI,DDUCRFE)) Q:DDUCRFE'>0 D AC2
Q
AC2 I $D(^DD(DDUCRFI,DDUCRFE,0))[0 D:DDUCFIX ACM Q
S DDUCX=^(0) I $P(DDUCX,U,2)'["C" D:DDUCFIX ACM Q
I $P(DDUCX,U,2)["C" S DDUCX1=$S($D(^(9.01)):^(9.01),1:""),DDUCF=0 D AC3
Q
AC3 F DDUCZ=1:1 S DDUCX2=$P(DDUCX1,";",DDUCZ) Q:DDUCX2="" I DDUCX2=DDUCFI_U_DDUCFE S DDUCF=1 Q
I 'DDUCF D:DDUCFIX ACM
Q
ACM K ^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI,DDUCRFE)
Q
NM S DDUCRFI(1)=$S($D(^DIC(DDUCFI,0))#2:$P(^(0),U),1:$P(^DD(DDUCFI,0)," SUB-FIELD"))
Q:DDUCRFI(1)']"" K ^DD(DDUCFI,0,"NM") S ^DD(DDUCFI,0,"NM",DDUCRFI(1))="" W !?10,"Duplicate ""NM"" node was deleted."
Q
WHO W !?5,"Field: ",DDUCFE," (",$P(DDUCX,U),") " Q
WFI W !?5,"File: ",DDUCRFI," " Q
WFE W ?5,"Field: ",DDUCRFE," " Q
WMS W "is missing." Q
M1 W !?10,"^DD(",DDUCFI,",0," Q
M2 W ") was killed." Q
Q
;
IXDUP ;Check for duplicate fields for same xref ;22*130
N DDUCRFE,DDUCRFEP
S (DDUCRFE,DDUCRFEP)=0
S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCRFI,DDUCRFE)) ;HUH??
D
. F S DDUCRFE=$O(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE)) Q:'DDUCRFE D
.. I 'DDUCRFEP S DDUCRFEP=DDUCRFE Q
.. I DDUCRFE'=DDUCRFEP D
MN ...N I F I=0:0 S I=$O(^DD(DDUCRFI,DDUCRFE,1,I)) Q:'I I +$G(^(I,0))=DDUCFI,$P(^(0),U,2)=DDUCXREF,$P(^(0),U,3)="MNEMONIC" K I Q
...Q:'$D(I)
... W !?5,"*File: ",DDUCRFI," Index: """_DDUCXREF_""" has duplicate Fields."
... W !?21,"Field: ",DDUCRFEP," Field: ",DDUCRFE
.. S DDUCRFEP=DDUCRFE
.. Q
. S DDUCRFEP=0
. Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDUCHK1 3869 printed Nov 22, 2024@17:53:42 Page 2
DDUCHK1 ;SFISC/RWF-CHECK DD part 2 ;3JUNE2011
+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 ;
ID SET DDUCRFE=""
FOR DDUCZ=0:0
SET DDUCRFE=$ORDER(^DD(DDUCFI,0,"ID",DDUCRFE))
if DDUCRFE=""
QUIT
SET DDUCX=$SELECT($DATA(^DD(DDUCFI,0,"ID",DDUCRFE))#2:^(DDUCRFE),1:"")
IF DDUCX="Q"
WRITE !?5,"'ID' node for field ",DDUCRFE," = 'Q'"
if DDUCFIX
DO ID1
+1 QUIT
ID1 KILL ^DD(DDUCFI,0,"ID",DDUCRFE)
DO M1
WRITE """ID"",",DDUCRFE
DO M2
+1 QUIT
IX SET DDUCXREF=""
FOR DDUCZ=0:0
SET DDUCXREF=$ORDER(^DD(DDUCFI,0,"IX",DDUCXREF))
if DDUCXREF=""
QUIT
FOR DDUCRFI=0:0
SET DDUCRFI=$ORDER(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI))
if DDUCRFI'>0
QUIT
DO IX1
+1 QUIT
IX1 ;22*130
DO IXDUP
+1 FOR DDUCRFE=0:0
SET DDUCRFE=$ORDER(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE))
if DDUCRFE'>0
QUIT
Begin DoDot:1
+2 IF $DATA(^DD(DDUCRFI,DDUCRFE,0))[0
DO WFI
WRITE """IX"" Subscript: "_DDUCXREF_" "
DO WFE
DO WMS
if DDUCFIX
DO IX2
QUIT
+3 IF $DATA(^DD(DDUCRFI,DDUCRFE,1,0))=0
IF $DATA(^DD(DDUCRFI,DDUCRFE,1))=10
if DDUCFIX
SET ^DD(DDUCRFI,DDUCRFE,1,0)="^.1"
+4 SET DDUCRFE1=0
SET DDUCRFEX=""
FOR
SET DDUCRFE1=$ORDER(^DD(DDUCRFI,DDUCRFE,1,DDUCRFE1))
if DDUCRFE1'>0
QUIT
SET DDUCRFEX=$GET(^(DDUCRFE1,0))
IF $PIECE(DDUCRFEX,U,2)=DDUCXREF
KILL DDUCRFEX
QUIT
+5 IF $DATA(DDUCRFEX)
WRITE !?5,"Cross-reference logic is missing for """,DDUCXREF,""" x-ref"
if DDUCFIX
DO IX2
QUIT
End DoDot:1
+6 KILL DDUCRFE1
QUIT
IX2 KILL ^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE)
DO M1
WRITE """IX"",",DDUCXREF_","_DDUCRFI_","_DDUCRFE
DO M2
+1 QUIT
PT FOR DDUCRFI=0:0
SET DDUCRFI=$ORDER(^DD(DDUCFI,0,"PT",DDUCRFI))
if DDUCRFI'>0
QUIT
FOR DDUCRFE=0:0
SET DDUCRFE=$ORDER(^DD(DDUCFI,0,"PT",DDUCRFI,DDUCRFE))
if DDUCRFE'>0
QUIT
DO PT1
+1 QUIT
PT1 IF $DATA(^DD(DDUCRFI,0))[0
DO WFI
DO WMS
IF DDUCFIX
KILL ^DD(DDUCFI,0,"PT",DDUCRFI)
DO M1
WRITE """PT"",",DDUCRFI
DO M2
QUIT
+1 IF $DATA(^DD(DDUCRFI,DDUCRFE,0))[0
DO WFI
WRITE """PT"" Subscript "
DO WFE
DO WMS
if DDUCFIX
DO PTM
QUIT
+2 IF ($PIECE(^(0),U,2)'["P")&($PIECE(^(0),U,2)'["V")
DO WFI
DO WFE
WRITE "is not a pointer."
if DDUCFIX
DO PTM
QUIT
+3 IF $PIECE(^(0),U,2)["P"
IF +$PIECE($PIECE(^(0),U,2),"P",2)'=DDUCFI
DO WFI
DO WFE
WRITE "is not a pointer to file ",DDUCFI
if DDUCFIX
DO PTM
+4 QUIT
PTM KILL ^DD(DDUCFI,0,"PT",DDUCRFI,DDUCRFE)
+1 DO M1
WRITE """PT"",",DDUCRFI,",",DDUCRFE
DO M2
+2 QUIT
AC FOR DDUCFE=0:0
SET DDUCFE=$ORDER(^DD("ACOMP",DDUCFI,DDUCFE))
if DDUCFE'>0
QUIT
DO AC1
+1 QUIT
AC1 FOR DDUCRFI=0:0
SET DDUCRFI=$ORDER(^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI))
if DDUCRFI'>0
QUIT
FOR DDUCRFE=0:0
SET DDUCRFE=$ORDER(^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI,DDUCRFE))
if DDUCRFE'>0
QUIT
DO AC2
+1 QUIT
AC2 IF $DATA(^DD(DDUCRFI,DDUCRFE,0))[0
if DDUCFIX
DO ACM
QUIT
+1 SET DDUCX=^(0)
IF $PIECE(DDUCX,U,2)'["C"
if DDUCFIX
DO ACM
QUIT
+2 IF $PIECE(DDUCX,U,2)["C"
SET DDUCX1=$SELECT($DATA(^(9.01)):^(9.01),1:"")
SET DDUCF=0
DO AC3
+3 QUIT
AC3 FOR DDUCZ=1:1
SET DDUCX2=$PIECE(DDUCX1,";",DDUCZ)
if DDUCX2=""
QUIT
IF DDUCX2=DDUCFI_U_DDUCFE
SET DDUCF=1
QUIT
+1 IF 'DDUCF
if DDUCFIX
DO ACM
+2 QUIT
ACM KILL ^DD("ACOMP",DDUCFI,DDUCFE,DDUCRFI,DDUCRFE)
+1 QUIT
NM SET DDUCRFI(1)=$SELECT($DATA(^DIC(DDUCFI,0))#2:$PIECE(^(0),U),1:$PIECE(^DD(DDUCFI,0)," SUB-FIELD"))
+1 if DDUCRFI(1)']""
QUIT
KILL ^DD(DDUCFI,0,"NM")
SET ^DD(DDUCFI,0,"NM",DDUCRFI(1))=""
WRITE !?10,"Duplicate ""NM"" node was deleted."
+2 QUIT
WHO WRITE !?5,"Field: ",DDUCFE," (",$PIECE(DDUCX,U),") "
QUIT
WFI WRITE !?5,"File: ",DDUCRFI," "
QUIT
WFE WRITE ?5,"Field: ",DDUCRFE," "
QUIT
WMS WRITE "is missing."
QUIT
M1 WRITE !?10,"^DD(",DDUCFI,",0,"
QUIT
M2 WRITE ") was killed."
QUIT
+1 QUIT
+2 ;
IXDUP ;Check for duplicate fields for same xref ;22*130
+1 NEW DDUCRFE,DDUCRFEP
+2 SET (DDUCRFE,DDUCRFEP)=0
+3 ;HUH??
SET DDUCRFE=$ORDER(^DD(DDUCFI,0,"IX",DDUCRFI,DDUCRFE))
+4 Begin DoDot:1
+5 FOR
SET DDUCRFE=$ORDER(^DD(DDUCFI,0,"IX",DDUCXREF,DDUCRFI,DDUCRFE))
if 'DDUCRFE
QUIT
Begin DoDot:2
+6 IF 'DDUCRFEP
SET DDUCRFEP=DDUCRFE
QUIT
+7 IF DDUCRFE'=DDUCRFEP
Begin DoDot:3
MN NEW I
FOR I=0:0
SET I=$ORDER(^DD(DDUCRFI,DDUCRFE,1,I))
if 'I
QUIT
IF +$GET(^(I,0))=DDUCFI
IF $PIECE(^(0),U,2)=DDUCXREF
IF $PIECE(^(0),U,3)="MNEMONIC"
KILL I
QUIT
+1 if '$DATA(I)
QUIT
+2 WRITE !?5,"*File: ",DDUCRFI," Index: """_DDUCXREF_""" has duplicate Fields."
+3 WRITE !?21,"Field: ",DDUCRFEP," Field: ",DDUCRFE
End DoDot:3
+4 SET DDUCRFEP=DDUCRFE
+5 QUIT
End DoDot:2
+6 SET DDUCRFEP=0
+7 QUIT
End DoDot:1
