- 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 Jan 18, 2025@03:05:47 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 ;