Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XU8P698

XU8P698.m

Go to the documentation of this file.
  1. XU8P698 ;BP/BDT - POST ROUTINE 698 CLEAN UP; 07/26/18
  1. ;;8.0;KERNEL;**698**;Jul 10, 1995;Build 7
  1. ;;Per VHA Directive 6402, this routine should not be modified.
  1. Q
  1. ;
  1. POST ;
  1. Q:$$KSP^XUPARAM("INST")=12000 ;Quit if Forum account
  1. ;I $$PATCH^XPDUTL("XU*8.0*684")=0 Q
  1. D CLEAN
  1. D LOOP
  1. Q
  1. ;
  1. LIST ; List all duplicate PARENT FACILITY
  1. N XUI,XUY
  1. S XUI=0 F S XUI=$O(^DIC(4,XUI)) Q:XUI'>0 D
  1. . 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
  1. Q
  1. ;
  1. CLEAN ; Clean the dubplicate PARENT FACILITY
  1. N XUI,XUY,X,Y
  1. K ^XTMP("XU8P698")
  1. S X=$$DT^XLFDT,Y=$$FMADD^XLFDT(X,30)
  1. S ^XTMP("XU8P698",0)=Y_"^"_X_"^XU*8*698"
  1. M ^XTMP("XU8P698",$J,4)=^DIC(4)
  1. S XUI=0 F S XUI=$O(^DIC(4,XUI)) Q:XUI'>0 D
  1. . 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)
  1. Q
  1. ;
  1. CLEAN1(XUIEN,XUIEN1) ; delete one given entry in the subfile
  1. N DIK,DA
  1. S DA(1)=XUIEN,DA=XUIEN1,DIK="^DIC(4,"_DA(1)_",""7""," D ^DIK
  1. Q
  1. ;
  1. REINDEX(XUIEN) ; delete x-refs in the subfile for an top entry
  1. N DIK,DA
  1. S DA(1)=XUIEN,DIK(1)=".01^1",DIK="^DIC(4,"_DA(1)_",""7""," D ENALL2^DIK
  1. S DA(1)=XUIEN,DIK(1)=".01^1",DIK="^DIC(4,"_DA(1)_",""7""," D ENALL^DIK
  1. Q
  1. LOOP ; fix nodes of ASSOCIATION
  1. N XUI
  1. S XUI=0 F S XUI=$O(^DIC(4,XUI)) Q:XUI'>0 D
  1. . I $D(^DIC(4,XUI,7,1,0)),+$G(^DIC(4,XUI,7,1,0))'=1 D CLEAN1(XUI,1)
  1. . I $D(^DIC(4,XUI,7,2,0)),+$G(^DIC(4,XUI,7,2,0))'=2 D CLEAN1(XUI,2)
  1. . Q
  1. Q