XU8P698 ;BP/BDT - POST ROUTINE 698 CLEAN UP; 07/26/18
;;8.0;KERNEL;**698**;Jul 10, 1995;Build 7
;;Per VHA Directive 6402, this routine should not be modified.
Q
;
POST ;
Q:$$KSP^XUPARAM("INST")=12000 ;Quit if Forum account
;I $$PATCH^XPDUTL("XU*8.0*684")=0 Q
D CLEAN
D LOOP
Q
;
LIST ; List all duplicate PARENT FACILITY
N XUI,XUY
S XUI=0 F S XUI=$O(^DIC(4,XUI)) Q:XUI'>0 D
. IF $D(^DIC(4,XUI,7,"B","PARENT FACILITY"))>0 S XUY=$O(^DIC(4,XUI,7,"B","PARENT FACILITY",0)) W !,"ENTRY#: "_XUI," SUB-ENTRY#: "_XUY
Q
;
CLEAN ; Clean the dubplicate PARENT FACILITY
N XUI,XUY,X,Y
K ^XTMP("XU8P698")
S X=$$DT^XLFDT,Y=$$FMADD^XLFDT(X,30)
S ^XTMP("XU8P698",0)=Y_"^"_X_"^XU*8*698"
M ^XTMP("XU8P698",$J,4)=^DIC(4)
S XUI=0 F S XUI=$O(^DIC(4,XUI)) Q:XUI'>0 D
. IF $D(^DIC(4,XUI,7,"B","PARENT FACILITY"))>0 S XUY=$O(^DIC(4,XUI,7,"B","PARENT FACILITY",0)) D CLEAN1(XUI,XUY),REINDEX(XUI)
Q
;
CLEAN1(XUIEN,XUIEN1) ; delete one given entry in the subfile
N DIK,DA
S DA(1)=XUIEN,DA=XUIEN1,DIK="^DIC(4,"_DA(1)_",""7""," D ^DIK
Q
;
REINDEX(XUIEN) ; delete x-refs in the subfile for an top entry
N DIK,DA
S DA(1)=XUIEN,DIK(1)=".01^1",DIK="^DIC(4,"_DA(1)_",""7""," D ENALL2^DIK
S DA(1)=XUIEN,DIK(1)=".01^1",DIK="^DIC(4,"_DA(1)_",""7""," D ENALL^DIK
Q
LOOP ; fix nodes of ASSOCIATION
N XUI
S XUI=0 F S XUI=$O(^DIC(4,XUI)) Q:XUI'>0 D
. I $D(^DIC(4,XUI,7,1,0)),+$G(^DIC(4,XUI,7,1,0))'=1 D CLEAN1(XUI,1)
. I $D(^DIC(4,XUI,7,2,0)),+$G(^DIC(4,XUI,7,2,0))'=2 D CLEAN1(XUI,2)
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXU8P698 1541 printed Jan 29, 2026@15:07:09 Page 2
XU8P698 ;BP/BDT - POST ROUTINE 698 CLEAN UP; 07/26/18
+1 ;;8.0;KERNEL;**698**;Jul 10, 1995;Build 7
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
POST ;
+1 ;Quit if Forum account
if $$KSP^XUPARAM("INST")=12000
QUIT
+2 ;I $$PATCH^XPDUTL("XU*8.0*684")=0 Q
+3 DO CLEAN
+4 DO LOOP
+5 QUIT
+6 ;
LIST ; List all duplicate PARENT FACILITY
+1 NEW XUI,XUY
+2 SET XUI=0
FOR
SET XUI=$ORDER(^DIC(4,XUI))
if XUI'>0
QUIT
Begin DoDot:1
+3 IF $DATA(^DIC(4,XUI,7,"B","PARENT FACILITY"))>0
SET XUY=$ORDER(^DIC(4,XUI,7,"B","PARENT FACILITY",0))
WRITE !,"ENTRY#: "_XUI," SUB-ENTRY#: "_XUY
End DoDot:1
+4 QUIT
+5 ;
CLEAN ; Clean the dubplicate PARENT FACILITY
+1 NEW XUI,XUY,X,Y
+2 KILL ^XTMP("XU8P698")
+3 SET X=$$DT^XLFDT
SET Y=$$FMADD^XLFDT(X,30)
+4 SET ^XTMP("XU8P698",0)=Y_"^"_X_"^XU*8*698"
+5 MERGE ^XTMP("XU8P698",$JOB,4)=^DIC(4)
+6 SET XUI=0
FOR
SET XUI=$ORDER(^DIC(4,XUI))
if XUI'>0
QUIT
Begin DoDot:1
+7 IF $DATA(^DIC(4,XUI,7,"B","PARENT FACILITY"))>0
SET XUY=$ORDER(^DIC(4,XUI,7,"B","PARENT FACILITY",0))
DO CLEAN1(XUI,XUY)
DO REINDEX(XUI)
End DoDot:1
+8 QUIT
+9 ;
CLEAN1(XUIEN,XUIEN1) ; delete one given entry in the subfile
+1 NEW DIK,DA
+2 SET DA(1)=XUIEN
SET DA=XUIEN1
SET DIK="^DIC(4,"_DA(1)_",""7"","
DO ^DIK
+3 QUIT
+4 ;
REINDEX(XUIEN) ; delete x-refs in the subfile for an top entry
+1 NEW DIK,DA
+2 SET DA(1)=XUIEN
SET DIK(1)=".01^1"
SET DIK="^DIC(4,"_DA(1)_",""7"","
DO ENALL2^DIK
+3 SET DA(1)=XUIEN
SET DIK(1)=".01^1"
SET DIK="^DIC(4,"_DA(1)_",""7"","
DO ENALL^DIK
+4 QUIT
LOOP ; fix nodes of ASSOCIATION
+1 NEW XUI
+2 SET XUI=0
FOR
SET XUI=$ORDER(^DIC(4,XUI))
if XUI'>0
QUIT
Begin DoDot:1
+3 IF $DATA(^DIC(4,XUI,7,1,0))
IF +$GET(^DIC(4,XUI,7,1,0))'=1
DO CLEAN1(XUI,1)
+4 IF $DATA(^DIC(4,XUI,7,2,0))
IF +$GET(^DIC(4,XUI,7,2,0))'=2
DO CLEAN1(XUI,2)
+5 QUIT
End DoDot:1
+6 QUIT
