XPDUTL1 ;SFISC/RWF - KIDS utilities (Delete pointers) ;10/28/2002 09:33
;;8.0;KERNEL;**229**;Jul 10,1995
Q
;New with patch 229
;DELPTR will go thru all the files that point to a given file and
;delete any pointer to a set of deleted entries.
;FILE is the file number that the entries are being deleted from.
;DELRT is the closed root of an array of IEN values being deleted.
;SKIP is an array of files to skip from deleting
DELPTR(FILE,DELRT,SKIP) ;
N DA,FDA,IENS,PFL,PFE,EXE
S PFL=0
F S PFL=$O(^DD(FILE,0,"PT",PFL)),PFE=0 Q:PFL'>0 D
. I $D(SKIP(PFL)) Q ;Skip this File
. F S PFE=$O(^DD(FILE,0,"PT",PFL,PFE)) Q:PFE'>0 D
. . D BUILD(PFL,PFE) Q
. Q
Q
;
BUILD(FL,FE) ;BUILD and Execute SCAN
N DIC,CNT,FLD,LV,EX,ND,QUIT
S LV=0,EX=0,QUIT=0,FLD=$G(^DD(FL,FE,0)) Q:'$L(FLD)
;Get the pointing field
S EX(LV,1)=FLD,FLD(0)=$P(FLD,"^",4),FLD(1)=$P(FLD(0),";"),FLD(2)=$P(FLD(0),";",2)
S EX(LV,2)=FLD(1) ;Save the node
;find the path to this field
S DIC=$$PATH(LV+1,FL,FE) ;Leave EX as global
I QUIT Q ;Couldn't build the path
;Build the code to check this pointer value
S ND=FLD(1)
S EX(LV)="S X=$P($G("_DIC_"ND)),U,"_FLD(2)_") I $L(X),$D(@DELRT@(X)) S IEN=$$IENS^DILF(.DA),CNT=CNT+1,FDA("_PFL_",IEN,"_PFE_")=""@"" D:CNT>10 FILE^XPDUTL1"
;Run the scan
D SCAN
Q
;
PATH(LV,FL,FE) ;Return path to node
N DIC,DA,FLD,FL2,FE2
;At the root of the file
S DA=$S(LV>1:"DA("_(LV-1)_")",1:"DA")
I $D(^DIC(FL,0,"GL")) D Q DIC_DA_","
. S DIC=$G(^DIC(FL,0,"GL"))
. S EX(LV,1)=DIC,EX=LV
. S EX(LV)="S "_DA_"=0 F S "_DA_"=$O("_DIC_DA_")) Q:"_DA_"'>0 X EX("_(LV-1)_")"
. Q
;In a sub-file
S FL2=$G(^DD(FL,0,"UP")) I 'FL2 S QUIT=1 Q ""
S FE2=$O(^DD(FL2,"SB",FL,0)) I 'FE2 S QUIT=1 Q ""
S FLD=$G(^DD(FL2,FE2,0)),FLD(0)=$P(FLD,"^",4),FLD(1)=$P(FLD(0),";"),FLD(2)=$P(FLD(0),";",2)
S ND(LV)=FLD(1) ;Use a variable for nodes
S DIC=$$PATH(LV+1,FL2,FE2)_"ND("_LV_"),"_DA
S EX(LV,1)=DIC
S EX(LV)="S "_DA_"=0 F S "_DA_"=$O("_DIC_")) Q:"_DA_"'>0 X EX("_(LV-1)_")"
Q DIC_","
;
SCAN ;Manage the scan of a file
N CNT,DA,FDA
S CNT=0
X EX(EX)
I CNT>0 D FILE
Q
FILE ;File a FDA
N MSG S CNT=0
D FILE^DIE("KS","FDA","MSG")
;I $D(MSG) ZW MSG ;***DEBUG***
Q
;
DELIEN(FL,RT) ;Delete the iens in RT from file FL
N DA,DIK,XPDI
S DIK=$G(^DIC(FL,0,"GL")),XPDI=0 Q:'$L(DIK)
F S XPDI=$O(@RT@(XPDI)) Q:'XPDI S DA=XPDI D ^DIK
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDUTL1 2420 printed Apr 09, 2024@21:10:02 Page 2
XPDUTL1 ;SFISC/RWF - KIDS utilities (Delete pointers) ;10/28/2002 09:33
+1 ;;8.0;KERNEL;**229**;Jul 10,1995
+2 QUIT
+3 ;New with patch 229
+4 ;DELPTR will go thru all the files that point to a given file and
+5 ;delete any pointer to a set of deleted entries.
+6 ;FILE is the file number that the entries are being deleted from.
+7 ;DELRT is the closed root of an array of IEN values being deleted.
+8 ;SKIP is an array of files to skip from deleting
DELPTR(FILE,DELRT,SKIP) ;
+1 NEW DA,FDA,IENS,PFL,PFE,EXE
+2 SET PFL=0
+3 FOR
SET PFL=$ORDER(^DD(FILE,0,"PT",PFL))
SET PFE=0
if PFL'>0
QUIT
Begin DoDot:1
+4 ;Skip this File
IF $DATA(SKIP(PFL))
QUIT
+5 FOR
SET PFE=$ORDER(^DD(FILE,0,"PT",PFL,PFE))
if PFE'>0
QUIT
Begin DoDot:2
+6 DO BUILD(PFL,PFE)
QUIT
End DoDot:2
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
BUILD(FL,FE) ;BUILD and Execute SCAN
+1 NEW DIC,CNT,FLD,LV,EX,ND,QUIT
+2 SET LV=0
SET EX=0
SET QUIT=0
SET FLD=$GET(^DD(FL,FE,0))
if '$LENGTH(FLD)
QUIT
+3 ;Get the pointing field
+4 SET EX(LV,1)=FLD
SET FLD(0)=$PIECE(FLD,"^",4)
SET FLD(1)=$PIECE(FLD(0),";")
SET FLD(2)=$PIECE(FLD(0),";",2)
+5 ;Save the node
SET EX(LV,2)=FLD(1)
+6 ;find the path to this field
+7 ;Leave EX as global
SET DIC=$$PATH(LV+1,FL,FE)
+8 ;Couldn't build the path
IF QUIT
QUIT
+9 ;Build the code to check this pointer value
+10 SET ND=FLD(1)
+11 SET EX(LV)="S X=$P($G("_DIC_"ND)),U,"_FLD(2)_") I $L(X),$D(@DELRT@(X)) S IEN=$$IENS^DILF(.DA),CNT=CNT+1,FDA("_PFL_",IEN,"_PFE_")=""@"" D:CNT>10 FILE^XPDUTL1"
+12 ;Run the scan
+13 DO SCAN
+14 QUIT
+15 ;
PATH(LV,FL,FE) ;Return path to node
+1 NEW DIC,DA,FLD,FL2,FE2
+2 ;At the root of the file
+3 SET DA=$SELECT(LV>1:"DA("_(LV-1)_")",1:"DA")
+4 IF $DATA(^DIC(FL,0,"GL"))
Begin DoDot:1
+5 SET DIC=$GET(^DIC(FL,0,"GL"))
+6 SET EX(LV,1)=DIC
SET EX=LV
+7 SET EX(LV)="S "_DA_"=0 F S "_DA_"=$O("_DIC_DA_")) Q:"_DA_"'>0 X EX("_(LV-1)_")"
+8 QUIT
End DoDot:1
QUIT DIC_DA_","
+9 ;In a sub-file
+10 SET FL2=$GET(^DD(FL,0,"UP"))
IF 'FL2
SET QUIT=1
QUIT ""
+11 SET FE2=$ORDER(^DD(FL2,"SB",FL,0))
IF 'FE2
SET QUIT=1
QUIT ""
+12 SET FLD=$GET(^DD(FL2,FE2,0))
SET FLD(0)=$PIECE(FLD,"^",4)
SET FLD(1)=$PIECE(FLD(0),";")
SET FLD(2)=$PIECE(FLD(0),";",2)
+13 ;Use a variable for nodes
SET ND(LV)=FLD(1)
+14 SET DIC=$$PATH(LV+1,FL2,FE2)_"ND("_LV_"),"_DA
+15 SET EX(LV,1)=DIC
+16 SET EX(LV)="S "_DA_"=0 F S "_DA_"=$O("_DIC_")) Q:"_DA_"'>0 X EX("_(LV-1)_")"
+17 QUIT DIC_","
+18 ;
SCAN ;Manage the scan of a file
+1 NEW CNT,DA,FDA
+2 SET CNT=0
+3 XECUTE EX(EX)
+4 IF CNT>0
DO FILE
+5 QUIT
FILE ;File a FDA
+1 NEW MSG
SET CNT=0
+2 DO FILE^DIE("KS","FDA","MSG")
+3 ;I $D(MSG) ZW MSG ;***DEBUG***
+4 QUIT
+5 ;
DELIEN(FL,RT) ;Delete the iens in RT from file FL
+1 NEW DA,DIK,XPDI
+2 SET DIK=$GET(^DIC(FL,0,"GL"))
SET XPDI=0
if '$LENGTH(DIK)
QUIT
+3 FOR
SET XPDI=$ORDER(@RT@(XPDI))
if 'XPDI
QUIT
SET DA=XPDI
DO ^DIK
+4 QUIT
+5 ;
