75 lines
2.1 KiB
Mathematica
75 lines
2.1 KiB
Mathematica
XPDGCDEL ;SFISC.SEA/JLI - Delete specified Objects (if not required) ; 3 Feb 95 09:14
|
|
;;8.0;KERNEL;;Jul 10, 1995
|
|
;
|
|
EN(XGCROOT) ; Entry is with the root under which IENs for the objects to be
|
|
; deleted will be found.
|
|
N TMPROOT,DAXGC,TMPEVNT,DA,I,J,K,X,XGCOBJ,XGEVNT,XQUIT,DIE,DR
|
|
S TMPROOT=$NA(^TMP("XPDGCDEL",$J))
|
|
S TMPEVNT=$NA(^TMP("XPDGCEVN",$J))
|
|
K @TMPROOT ; array to save those currently in use
|
|
K @TMPEVNT
|
|
S XGCOBJ=""
|
|
D OBJECTS
|
|
I $D(@TMPROOT) S XGCROOT=TMPROOT D OBJECTS
|
|
D EVENTS
|
|
K @TMPROOT
|
|
K @TMPEVNT
|
|
Q
|
|
;
|
|
OBJECTS ;
|
|
F S XGCOBJ=$O(@XGCROOT@(XGCOBJ)) Q:XGCOBJ="" D
|
|
. S DAXGC=XGCOBJ
|
|
. S XQUIT=0
|
|
. F I=0:0 S I=$O(^XTV(8995,I)) Q:I'>0 I $O(^(I,2,0))>0 D Q:XQUIT
|
|
. . F J=0:0 S J=$O(^XTV(8995,I,2,J)) Q:J'>0 I $P(^(J,0),U,2)=DAXGC D Q:XQUIT
|
|
. . . I $D(@XGCROOT@($P(^XTV(8995,I,0),U))) S @TMPROOT@(XGCOBJ)=""
|
|
. . . S XQUIT=1 ; Mark as currently used
|
|
. . Q:XQUIT
|
|
. Q:XQUIT
|
|
. D CHKEVNTS
|
|
. D CHKPARNT
|
|
. S DA=DAXGC
|
|
. S DIK="^XTV(8995,"
|
|
. D ^DIK
|
|
. K DIK
|
|
Q
|
|
;
|
|
CHKEVNTS ;
|
|
F I=0:0 S I=$O(^XTV(8995,DAXGC,1,I)) Q:I'>0 S X=^(I,0) D
|
|
. S X=+$P(X,U,2)
|
|
. S X=$P(^XTV(8995.8,X,0),U)
|
|
. S @TMPEVNT@(X)=""
|
|
F I=0:0 S I=$O(^XTV(8995,DAXGC,2,I)) Q:I'>0 D
|
|
. F J=0:0 S J=$O(^XTV(8995,DAXGC,2,I,1,J)) Q:J'>0 S X=^(J,0) D
|
|
. . S X=+$P(X,U,2)
|
|
. . S X=$P(^XTV(8995.8,X,0),U)
|
|
. . S @TMPEVNT@(X)=""
|
|
F I=0:0 S I=$O(^XTV(8995,DAXGC,3,I)) Q:I'>0 S X=^(I,0) D
|
|
. S X=+$P(X,U,4)
|
|
. S X=$P(^XTV(8995.8,X,0),U)
|
|
. S @TMPEVNT@(X)=""
|
|
Q
|
|
;
|
|
CHKPARNT ;
|
|
F I=0:0 S I=$O(^XTV(8995,I)) Q:I'>0 I I'=DAXGC,$P(^(I,0),U,2)=DAXGC D
|
|
. S DR=".02///@;",DIE="^XTV(8995,",DA=DAXGC
|
|
. D ^DIE
|
|
. K DIE,DR
|
|
Q
|
|
;
|
|
EVENTS ;
|
|
S XGEVNT=""
|
|
F S XGEVNT=$O(@TMPEVNT@(XGEVNT)) Q:XGEVNT="" D
|
|
. S DAXGC=$O(^XTV(8995.8,"B",XGEVNT)) Q:DAXGC'>0
|
|
. S XQUIT=0
|
|
. F I=0:0 Q:XQUIT S I=$O(^XTV(8995,I)) Q:I'>0 D
|
|
. . F J=0:0 S J=$O(^XTV(8995,I,1,J)) Q:J'>0 I $P(^(J,0),U,2)=DAXGC S XQUIT=1 Q
|
|
. . F J=0:0 Q:XQUIT S J=$O(^XTV(8995,I,2,J)) Q:J'>0 D
|
|
. . . F K=0:0 S K=$O(^XTV(8995,I,2,J,1,K)) Q:K'>0 I $P(^(K,0),U,2)=DAXGC S XQUIT=1 Q
|
|
. . F J=0:0 S J=$O(^XTV(8995,I,3,J)) Q:J'>0 I $P(^(J,0),U,4)=DAXGC S XQUIT=1 Q
|
|
. S DA=DAXGC
|
|
. S DIK="^XTV(8995.9,"
|
|
. D ^DIK
|
|
. K DIK
|
|
Q
|