DDFIX ;SFCIOFO/S0/MKO - VARIOUS DD AND DIC FIXES ;15 Mar 1999 9:17 AM
;;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.
;
FIXPT ; ==> Fix Bad "PT" Nodes <==
;
N EP,ESC
I '$D(XPDNM) S EP="PT" D DEVICE
I $D(ESC) G EXIT
DEQPT N DICFILE,DDFILE,DDFIELD,PGLEN,PG,RPTDT,X
U IO
D RPTDT
S PGLEN=IOSL-5,PG=0
I '$D(XPDNM) D PTHDR
; Loop thru DIC(<file #>,
S DICFILE=1.99999
F S DICFILE=$O(^DIC(DICFILE)) Q:DICFILE'>1.99999!$D(ESC) D
. ; Loop thru DD(DICFILE,0,"PT",<file #>
. S DDFILE=1.99999
. F S DDFILE=$O(^DD(DICFILE,0,"PT",DDFILE)) Q:DDFILE'>1.99999!$D(ESC) D
.. I $D(^DD(DDFILE,0))#2 D Q ; File Exists
... ; Check Fields Exists
... S DDFIELD=0
... F S DDFIELD=$O(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) Q:'DDFIELD!$D(ESC) D
.... I $D(^DD(DDFILE,DDFIELD,0))#2 D Q ; Field is still in DD
..... I ($P(^(0),U,2)'["P")&($P(^(0),U,2)'["V") D Q ; Field Still A Pointer?
...... S X="*File: "_DDFILE_" Field: "_DDFIELD_" is Not a Pointer Type." D RPTOUT
...... S X=" Deleting ""PT"" node: "_$NA(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) D RPTOUT,K1 Q
..... I $P(^(0),U,2)["P",+$P($P(^(0),U,2),"P",2)'=DICFILE D Q ; Field Still Point To Same File?
...... S X="*File: "_DDFILE_" Field: "_DDFIELD_" Does Not Point To File: "_DICFILE_"." D RPTOUT
...... S X=" Deleting ""PT"" Node: "_$NA(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) D RPTOUT,K1 Q
.... ; **Field No Longer Exists
.... S X="*Field: "_DDFIELD_" in File: "_DDFILE_" does Not Exist." D RPTOUT
.... S X=" Deleting ""PT"" node: "_$NA(^DD(DICFILE,0,"PT",DDFILE,DDFIELD)) D RPTOUT,K1 Q
.. ; **File No Longer Exists
.. S X="*File: "_DDFILE_" Does Not Exist." D RPTOUT
.. S X=" Deleting ""PT"" node: "_$NA(^DD(DICFILE,0,"PT",DDFILE)) D RPTOUT
.. K ^DD(DICFILE,0,"PT",DDFILE)
G EXIT ; GoTo Common Exit
K1 ; Kill at Field Level
K ^DD(DICFILE,0,"PT",DDFILE,DDFIELD)
Q
PTHDR ; Fix "PT" nodes Report Header
I $E(IOST,1,2)="C-" D Q:$D(ESC)
. I PG D PAUSE Q:$D(ESC)
. W @IOF
I PG W @IOF
S PG=PG+1
W "Fix ""PT"" Nodes Report "_RPTDT,?(IOM-10),"Page: "_PG,!
N X
S X="",$P(X,"-",(IOM-1))="" W X,!
Q
;
FIXNM ; ==> Fix Duplicate 'NM' Nodes <==
; From patch DI*21*50, routine DIPR50
;
N EP,ESC
I '$D(XPDNM) S EP="NM" D DEVICE
I $D(ESC) G EXIT
DEQNM N DDFILE,DDNAME,DDNEW,PGLEN,PG,RPTDT,X
U IO
D RPTDT
S PGLEN=IOSL-5,PG=0
I '$D(XPDNM) D NMHDR
S DDFILE=1.99999
F S DDFILE=$O(^DD(DDFILE)) Q:'DDFILE!$D(ESC) D
. ; Check and repair duplicate "NM" nodes
. S DDNAME=$O(^DD(DDFILE,0,"NM","")) Q:DDNAME=""
. I $O(^DD(DDFILE,0,"NM",DDNAME))="" Q
. S X="*File/Subfile: "_DDFILE_" has duplicate 'NM' nodes."
. D RPTOUT
. S DDNEW=$S($D(^DIC(DDFILE,0))#2:$P(^(0),U),1:$P(^DD(DDFILE,0)," SUB-FIELD"))
. Q:DDNEW=""
. K ^DD(DDFILE,0,"NM")
. S ^DD(DDFILE,0,"NM",DDNEW)=""
. S X=" ""NM"" node will be set to: "_DDNEW
. D RPTOUT
G EXIT ; GoTo Common Exit Point
NMHDR ; Fix "NM" nodes Report Header
I $E(IOST,1,2)="C-" D Q:$D(ESC)
. I PG D PAUSE Q:$D(ESC)
. W @IOF
I PG W @IOF
S PG=PG+1
W "Fix Duplicate ""NM"" Nodes Report "_RPTDT,?(IOM-10),"Page: "_PG,!
N X
S X="",$P(X,"-",(IOM-1))="" W X,!
Q
;
FIXAG ; ==> Application Group Multiple Bad Xrefs <==
; From patch DI*21*58, routine DIPR58
;
N EP,ESC
I '$D(XPDNM) S EP="AG" D DEVICE
I $D(ESC) G EXIT
DEQAG N DDAGPKG,DDFILE,IEN,PGLEN,PG,RPTDT,X
U IO
D RPTDT
S PGLEN=IOSL-5,PG=0
I '$D(XPDNM) D AGHDR
S DDFILE=1.99999
F S DDFILE=$O(^DIC(DDFILE)) Q:DDFILE<1.99999 D
. I '$D(^DIC(DDFILE,"%")) Q ; No App. Group Multiple
. S DDAGPKG=""
. F S DDAGPKG=$O(^DIC(DDFILE,"%","B",DDAGPKG)) Q:DDAGPKG="" D
.. S IEN=0
.. F S IEN=$O(^DIC(DDFILE,"%","B",DDAGPKG,IEN)) Q:'IEN D
... I $P($G(^DIC(DDFILE,"%",IEN,0)),U)=DDAGPKG Q
... S X="Deleting App. Group "_DDAGPKG_" ""B"" xref: "_$NA(^DIC(DDFILE,"%","B",DDAGPKG,IEN))
... D RPTOUT
... K ^DIC(DDFILE,"%","B",DDAGPKG,IEN)
AC ; Loop Thru "AC" xref and Remove Any Entries That Point to
; Files That Do Not Exist
S DDAGPKG=""
F S DDAGPKG=$O(^DIC("AC",DDAGPKG)) Q:DDAGPKG="" D
. S DDFILE=1.99999
. F S DDFILE=$O(^DIC("AC",DDAGPKG,DDFILE)) Q:DDFILE<1.99999 D
.. I $D(^DIC(DDFILE,0))[0 D Q
... S X="Deleting ""AC"" xref: "_$NA(^DIC("AC",DDAGPKG,DDFILE))
... D RPTOUT
... K ^DIC("AC",DDAGPKG,DDFILE)
.. S IEN=0
.. F S IEN=$O(^DIC("AC",DDAGPKG,DDFILE,IEN)) Q:'IEN D
... I $P($G(^DIC(DDFILE,"%",IEN,0)),U)'=DDAGPKG D
.... S X="Deleting ""AC"" xref: "_$NA(^DIC("AC",DDAGPKG,DDFILE,IEN))
.... D RPTOUT
.... K ^DIC("AC",DDAGPKG,DDFILE,IEN)
G EXIT ; GoTo Common Exit Point
AGHDR ; Fix Application Group Xrefs Report Header
I $E(IOST,1,2)="C-" D Q:$D(ESC)
. I PG D PAUSE Q:$D(ESC)
. W @IOF
I PG W @IOF
S PG=PG+1
W "Fix Application Group Xrefs Report "_RPTDT,?(IOM-10),"Page: "_PG,!
N X
S X="",$P(X,"-",(IOM-1))="" W X,!
Q
;
; Common For All Entry Points
;
DEVICE ; Output Device Selection
S %ZIS="MQ"
D ^%ZIS
I POP S ESC=1 Q ;User Escaped Device Selection
I $D(IO("Q")) D
. S ZTDESC=$S(EP="PT":"FIX PT NODES",EP="NM":"FIX DUPLICATE 'NM' NODES",EP="AG":"FIX APPLICATION GROUP XREFS",1:"")
. S ZTRTN=$S(EP="PT":"DEQPT",EP="NM":"DEQNM",EP="AG":"DEQAG",1:"")_"^DDFIX"
. S ZTSAVE("EP")=""
. D ^%ZTLOAD
. I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),!
. S ESC=1
. K ZTSK,ZTDESC,ZTRTN,ZTSAVE
. D HOME^%ZIS
Q
RPTDT ; Get Report Date/Time
N %,%H,X,Y
S %H=$H
D YX^%DTC
S RPTDT=$P(Y,"@")_"@"_$E($P(Y,"@",2),1,5)
Q
RPTOUT ; Print Messages
I $D(XPDNM) D MES^XPDUTL(X) Q ; KIDS install being used
W X,! ; KIDS install not being used
I $Y'>PGLEN Q
I EP="PT" D PTHDR Q
I EP="NM" D NMHDR Q
I EP="AG" D AGHDR Q
Q
PAUSE ; End of Page Pause
N DIR,Y
S DIR(0)="E"
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) K DTOUT,DUOUT,DIRUT,DIROUT S ESC=1 Q
Q
EXIT ; Common Exit Point
I $E(IOST,1,2)="P-" D ^%ZISC
I $D(ZTQUEUED) S ZTREQ="@"
K EP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDFIX 6238 printed Sep 23, 2025@20:18:14 Page 2
DDFIX ;SFCIOFO/S0/MKO - VARIOUS DD AND DIC FIXES ;15 Mar 1999 9:17 AM
+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 ;
FIXPT ; ==> Fix Bad "PT" Nodes <==
+1 ;
+2 NEW EP,ESC
+3 IF '$DATA(XPDNM)
SET EP="PT"
DO DEVICE
+4 IF $DATA(ESC)
GOTO EXIT
DEQPT NEW DICFILE,DDFILE,DDFIELD,PGLEN,PG,RPTDT,X
+1 USE IO
+2 DO RPTDT
+3 SET PGLEN=IOSL-5
SET PG=0
+4 IF '$DATA(XPDNM)
DO PTHDR
+5 ; Loop thru DIC(<file #>,
+6 SET DICFILE=1.99999
+7 FOR
SET DICFILE=$ORDER(^DIC(DICFILE))
if DICFILE'>1.99999!$DATA(ESC)
QUIT
Begin DoDot:1
+8 ; Loop thru DD(DICFILE,0,"PT",<file #>
+9 SET DDFILE=1.99999
+10 FOR
SET DDFILE=$ORDER(^DD(DICFILE,0,"PT",DDFILE))
if DDFILE'>1.99999!$DATA(ESC)
QUIT
Begin DoDot:2
+11 ; File Exists
IF $DATA(^DD(DDFILE,0))#2
Begin DoDot:3
+12 ; Check Fields Exists
+13 SET DDFIELD=0
+14 FOR
SET DDFIELD=$ORDER(^DD(DICFILE,0,"PT",DDFILE,DDFIELD))
if 'DDFIELD!$DATA(ESC)
QUIT
Begin DoDot:4
+15 ; Field is still in DD
IF $DATA(^DD(DDFILE,DDFIELD,0))#2
Begin DoDot:5
+16 ; Field Still A Pointer?
IF ($PIECE(^(0),U,2)'["P")&($PIECE(^(0),U,2)'["V")
Begin DoDot:6
+17 SET X="*File: "_DDFILE_" Field: "_DDFIELD_" is Not a Pointer Type."
DO RPTOUT
+18 SET X=" Deleting ""PT"" node: "_$NAME(^DD(DICFILE,0,"PT",DDFILE,DDFIELD))
DO RPTOUT
DO K1
QUIT
End DoDot:6
QUIT
+19 ; Field Still Point To Same File?
IF $PIECE(^(0),U,2)["P"
IF +$PIECE($PIECE(^(0),U,2),"P",2)'=DICFILE
Begin DoDot:6
+20 SET X="*File: "_DDFILE_" Field: "_DDFIELD_" Does Not Point To File: "_DICFILE_"."
DO RPTOUT
+21 SET X=" Deleting ""PT"" Node: "_$NAME(^DD(DICFILE,0,"PT",DDFILE,DDFIELD))
DO RPTOUT
DO K1
QUIT
End DoDot:6
QUIT
End DoDot:5
QUIT
+22 ; **Field No Longer Exists
+23 SET X="*Field: "_DDFIELD_" in File: "_DDFILE_" does Not Exist."
DO RPTOUT
+24 SET X=" Deleting ""PT"" node: "_$NAME(^DD(DICFILE,0,"PT",DDFILE,DDFIELD))
DO RPTOUT
DO K1
QUIT
End DoDot:4
End DoDot:3
QUIT
+25 ; **File No Longer Exists
+26 SET X="*File: "_DDFILE_" Does Not Exist."
DO RPTOUT
+27 SET X=" Deleting ""PT"" node: "_$NAME(^DD(DICFILE,0,"PT",DDFILE))
DO RPTOUT
+28 KILL ^DD(DICFILE,0,"PT",DDFILE)
End DoDot:2
End DoDot:1
+29 ; GoTo Common Exit
GOTO EXIT
K1 ; Kill at Field Level
+1 KILL ^DD(DICFILE,0,"PT",DDFILE,DDFIELD)
+2 QUIT
PTHDR ; Fix "PT" nodes Report Header
+1 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+2 IF PG
DO PAUSE
if $DATA(ESC)
QUIT
+3 WRITE @IOF
End DoDot:1
if $DATA(ESC)
QUIT
+4 IF PG
WRITE @IOF
+5 SET PG=PG+1
+6 WRITE "Fix ""PT"" Nodes Report "_RPTDT,?(IOM-10),"Page: "_PG,!
+7 NEW X
+8 SET X=""
SET $PIECE(X,"-",(IOM-1))=""
WRITE X,!
+9 QUIT
+10 ;
FIXNM ; ==> Fix Duplicate 'NM' Nodes <==
+1 ; From patch DI*21*50, routine DIPR50
+2 ;
+3 NEW EP,ESC
+4 IF '$DATA(XPDNM)
SET EP="NM"
DO DEVICE
+5 IF $DATA(ESC)
GOTO EXIT
DEQNM NEW DDFILE,DDNAME,DDNEW,PGLEN,PG,RPTDT,X
+1 USE IO
+2 DO RPTDT
+3 SET PGLEN=IOSL-5
SET PG=0
+4 IF '$DATA(XPDNM)
DO NMHDR
+5 SET DDFILE=1.99999
+6 FOR
SET DDFILE=$ORDER(^DD(DDFILE))
if 'DDFILE!$DATA(ESC)
QUIT
Begin DoDot:1
+7 ; Check and repair duplicate "NM" nodes
+8 SET DDNAME=$ORDER(^DD(DDFILE,0,"NM",""))
if DDNAME=""
QUIT
+9 IF $ORDER(^DD(DDFILE,0,"NM",DDNAME))=""
QUIT
+10 SET X="*File/Subfile: "_DDFILE_" has duplicate 'NM' nodes."
+11 DO RPTOUT
+12 SET DDNEW=$SELECT($DATA(^DIC(DDFILE,0))#2:$PIECE(^(0),U),1:$PIECE(^DD(DDFILE,0)," SUB-FIELD"))
+13 if DDNEW=""
QUIT
+14 KILL ^DD(DDFILE,0,"NM")
+15 SET ^DD(DDFILE,0,"NM",DDNEW)=""
+16 SET X=" ""NM"" node will be set to: "_DDNEW
+17 DO RPTOUT
End DoDot:1
+18 ; GoTo Common Exit Point
GOTO EXIT
NMHDR ; Fix "NM" nodes Report Header
+1 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+2 IF PG
DO PAUSE
if $DATA(ESC)
QUIT
+3 WRITE @IOF
End DoDot:1
if $DATA(ESC)
QUIT
+4 IF PG
WRITE @IOF
+5 SET PG=PG+1
+6 WRITE "Fix Duplicate ""NM"" Nodes Report "_RPTDT,?(IOM-10),"Page: "_PG,!
+7 NEW X
+8 SET X=""
SET $PIECE(X,"-",(IOM-1))=""
WRITE X,!
+9 QUIT
+10 ;
FIXAG ; ==> Application Group Multiple Bad Xrefs <==
+1 ; From patch DI*21*58, routine DIPR58
+2 ;
+3 NEW EP,ESC
+4 IF '$DATA(XPDNM)
SET EP="AG"
DO DEVICE
+5 IF $DATA(ESC)
GOTO EXIT
DEQAG NEW DDAGPKG,DDFILE,IEN,PGLEN,PG,RPTDT,X
+1 USE IO
+2 DO RPTDT
+3 SET PGLEN=IOSL-5
SET PG=0
+4 IF '$DATA(XPDNM)
DO AGHDR
+5 SET DDFILE=1.99999
+6 FOR
SET DDFILE=$ORDER(^DIC(DDFILE))
if DDFILE<1.99999
QUIT
Begin DoDot:1
+7 ; No App. Group Multiple
IF '$DATA(^DIC(DDFILE,"%"))
QUIT
+8 SET DDAGPKG=""
+9 FOR
SET DDAGPKG=$ORDER(^DIC(DDFILE,"%","B",DDAGPKG))
if DDAGPKG=""
QUIT
Begin DoDot:2
+10 SET IEN=0
+11 FOR
SET IEN=$ORDER(^DIC(DDFILE,"%","B",DDAGPKG,IEN))
if 'IEN
QUIT
Begin DoDot:3
+12 IF $PIECE($GET(^DIC(DDFILE,"%",IEN,0)),U)=DDAGPKG
QUIT
+13 SET X="Deleting App. Group "_DDAGPKG_" ""B"" xref: "_$NAME(^DIC(DDFILE,"%","B",DDAGPKG,IEN))
+14 DO RPTOUT
+15 KILL ^DIC(DDFILE,"%","B",DDAGPKG,IEN)
End DoDot:3
End DoDot:2
End DoDot:1
AC ; Loop Thru "AC" xref and Remove Any Entries That Point to
+1 ; Files That Do Not Exist
+2 SET DDAGPKG=""
+3 FOR
SET DDAGPKG=$ORDER(^DIC("AC",DDAGPKG))
if DDAGPKG=""
QUIT
Begin DoDot:1
+4 SET DDFILE=1.99999
+5 FOR
SET DDFILE=$ORDER(^DIC("AC",DDAGPKG,DDFILE))
if DDFILE<1.99999
QUIT
Begin DoDot:2
+6 IF $DATA(^DIC(DDFILE,0))[0
Begin DoDot:3
+7 SET X="Deleting ""AC"" xref: "_$NAME(^DIC("AC",DDAGPKG,DDFILE))
+8 DO RPTOUT
+9 KILL ^DIC("AC",DDAGPKG,DDFILE)
End DoDot:3
QUIT
+10 SET IEN=0
+11 FOR
SET IEN=$ORDER(^DIC("AC",DDAGPKG,DDFILE,IEN))
if 'IEN
QUIT
Begin DoDot:3
+12 IF $PIECE($GET(^DIC(DDFILE,"%",IEN,0)),U)'=DDAGPKG
Begin DoDot:4
+13 SET X="Deleting ""AC"" xref: "_$NAME(^DIC("AC",DDAGPKG,DDFILE,IEN))
+14 DO RPTOUT
+15 KILL ^DIC("AC",DDAGPKG,DDFILE,IEN)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 ; GoTo Common Exit Point
GOTO EXIT
AGHDR ; Fix Application Group Xrefs Report Header
+1 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+2 IF PG
DO PAUSE
if $DATA(ESC)
QUIT
+3 WRITE @IOF
End DoDot:1
if $DATA(ESC)
QUIT
+4 IF PG
WRITE @IOF
+5 SET PG=PG+1
+6 WRITE "Fix Application Group Xrefs Report "_RPTDT,?(IOM-10),"Page: "_PG,!
+7 NEW X
+8 SET X=""
SET $PIECE(X,"-",(IOM-1))=""
WRITE X,!
+9 QUIT
+10 ;
+11 ; Common For All Entry Points
+12 ;
DEVICE ; Output Device Selection
+1 SET %ZIS="MQ"
+2 DO ^%ZIS
+3 ;User Escaped Device Selection
IF POP
SET ESC=1
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTDESC=$SELECT(EP="PT":"FIX PT NODES",EP="NM":"FIX DUPLICATE 'NM' NODES",EP="AG":"FIX APPLICATION GROUP XREFS",1:"")
+6 SET ZTRTN=$SELECT(EP="PT":"DEQPT",EP="NM":"DEQNM",EP="AG":"DEQAG",1:"")_"^DDFIX"
+7 SET ZTSAVE("EP")=""
+8 DO ^%ZTLOAD
+9 IF $DATA(ZTSK)#2
WRITE !,"Report queued!",!,"Task number: "_$GET(ZTSK),!
+10 SET ESC=1
+11 KILL ZTSK,ZTDESC,ZTRTN,ZTSAVE
+12 DO HOME^%ZIS
End DoDot:1
+13 QUIT
RPTDT ; Get Report Date/Time
+1 NEW %,%H,X,Y
+2 SET %H=$HOROLOG
+3 DO YX^%DTC
+4 SET RPTDT=$PIECE(Y,"@")_"@"_$EXTRACT($PIECE(Y,"@",2),1,5)
+5 QUIT
RPTOUT ; Print Messages
+1 ; KIDS install being used
IF $DATA(XPDNM)
DO MES^XPDUTL(X)
QUIT
+2 ; KIDS install not being used
WRITE X,!
+3 IF $Y'>PGLEN
QUIT
+4 IF EP="PT"
DO PTHDR
QUIT
+5 IF EP="NM"
DO NMHDR
QUIT
+6 IF EP="AG"
DO AGHDR
QUIT
+7 QUIT
PAUSE ; End of Page Pause
+1 NEW DIR,Y
+2 SET DIR(0)="E"
+3 DO ^DIR
+4 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
KILL DTOUT,DUOUT,DIRUT,DIROUT
SET ESC=1
QUIT
+5 QUIT
EXIT ; Common Exit Point
+1 IF $EXTRACT(IOST,1,2)="P-"
DO ^%ZISC
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 KILL EP
+4 QUIT
