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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDGCDEL 2230 printed Apr 09, 2024@21:10:49 Page 2
XPDGCDEL ;SFISC.SEA/JLI - Delete specified Objects (if not required) ; 3 Feb 95 09:14
+1 ;;8.0;KERNEL;;Jul 10, 1995
+2 ;
EN(XGCROOT) ; Entry is with the root under which IENs for the objects to be
+1 ; deleted will be found.
+2 NEW TMPROOT,DAXGC,TMPEVNT,DA,I,J,K,X,XGCOBJ,XGEVNT,XQUIT,DIE,DR
+3 SET TMPROOT=$NAME(^TMP("XPDGCDEL",$JOB))
+4 SET TMPEVNT=$NAME(^TMP("XPDGCEVN",$JOB))
+5 ; array to save those currently in use
KILL @TMPROOT
+6 KILL @TMPEVNT
+7 SET XGCOBJ=""
+8 DO OBJECTS
+9 IF $DATA(@TMPROOT)
SET XGCROOT=TMPROOT
DO OBJECTS
+10 DO EVENTS
+11 KILL @TMPROOT
+12 KILL @TMPEVNT
+13 QUIT
+14 ;
OBJECTS ;
+1 FOR
SET XGCOBJ=$ORDER(@XGCROOT@(XGCOBJ))
if XGCOBJ=""
QUIT
Begin DoDot:1
+2 SET DAXGC=XGCOBJ
+3 SET XQUIT=0
+4 FOR I=0:0
SET I=$ORDER(^XTV(8995,I))
if I'>0
QUIT
IF $ORDER(^(I,2,0))>0
Begin DoDot:2
+5 FOR J=0:0
SET J=$ORDER(^XTV(8995,I,2,J))
if J'>0
QUIT
IF $PIECE(^(J,0),U,2)=DAXGC
Begin DoDot:3
+6 IF $DATA(@XGCROOT@($PIECE(^XTV(8995,I,0),U)))
SET @TMPROOT@(XGCOBJ)=""
+7 ; Mark as currently used
SET XQUIT=1
End DoDot:3
if XQUIT
QUIT
+8 if XQUIT
QUIT
End DoDot:2
if XQUIT
QUIT
+9 if XQUIT
QUIT
+10 DO CHKEVNTS
+11 DO CHKPARNT
+12 SET DA=DAXGC
+13 SET DIK="^XTV(8995,"
+14 DO ^DIK
+15 KILL DIK
End DoDot:1
+16 QUIT
+17 ;
CHKEVNTS ;
+1 FOR I=0:0
SET I=$ORDER(^XTV(8995,DAXGC,1,I))
if I'>0
QUIT
SET X=^(I,0)
Begin DoDot:1
+2 SET X=+$PIECE(X,U,2)
+3 SET X=$PIECE(^XTV(8995.8,X,0),U)
+4 SET @TMPEVNT@(X)=""
End DoDot:1
+5 FOR I=0:0
SET I=$ORDER(^XTV(8995,DAXGC,2,I))
if I'>0
QUIT
Begin DoDot:1
+6 FOR J=0:0
SET J=$ORDER(^XTV(8995,DAXGC,2,I,1,J))
if J'>0
QUIT
SET X=^(J,0)
Begin DoDot:2
+7 SET X=+$PIECE(X,U,2)
+8 SET X=$PIECE(^XTV(8995.8,X,0),U)
+9 SET @TMPEVNT@(X)=""
End DoDot:2
End DoDot:1
+10 FOR I=0:0
SET I=$ORDER(^XTV(8995,DAXGC,3,I))
if I'>0
QUIT
SET X=^(I,0)
Begin DoDot:1
+11 SET X=+$PIECE(X,U,4)
+12 SET X=$PIECE(^XTV(8995.8,X,0),U)
+13 SET @TMPEVNT@(X)=""
End DoDot:1
+14 QUIT
+15 ;
CHKPARNT ;
+1 FOR I=0:0
SET I=$ORDER(^XTV(8995,I))
if I'>0
QUIT
IF I'=DAXGC
IF $PIECE(^(I,0),U,2)=DAXGC
Begin DoDot:1
+2 SET DR=".02///@;"
SET DIE="^XTV(8995,"
SET DA=DAXGC
+3 DO ^DIE
+4 KILL DIE,DR
End DoDot:1
+5 QUIT
+6 ;
EVENTS ;
+1 SET XGEVNT=""
+2 FOR
SET XGEVNT=$ORDER(@TMPEVNT@(XGEVNT))
if XGEVNT=""
QUIT
Begin DoDot:1
+3 SET DAXGC=$ORDER(^XTV(8995.8,"B",XGEVNT))
if DAXGC'>0
QUIT
+4 SET XQUIT=0
+5 FOR I=0:0
if XQUIT
QUIT
SET I=$ORDER(^XTV(8995,I))
if I'>0
QUIT
Begin DoDot:2
+6 FOR J=0:0
SET J=$ORDER(^XTV(8995,I,1,J))
if J'>0
QUIT
IF $PIECE(^(J,0),U,2)=DAXGC
SET XQUIT=1
QUIT
+7 FOR J=0:0
if XQUIT
QUIT
SET J=$ORDER(^XTV(8995,I,2,J))
if J'>0
QUIT
Begin DoDot:3
+8 FOR K=0:0
SET K=$ORDER(^XTV(8995,I,2,J,1,K))
if K'>0
QUIT
IF $PIECE(^(K,0),U,2)=DAXGC
SET XQUIT=1
QUIT
End DoDot:3
+9 FOR J=0:0
SET J=$ORDER(^XTV(8995,I,3,J))
if J'>0
QUIT
IF $PIECE(^(J,0),U,4)=DAXGC
SET XQUIT=1
QUIT
End DoDot:2
+10 SET DA=DAXGC
+11 SET DIK="^XTV(8995.9,"
+12 DO ^DIK
+13 KILL DIK
End DoDot:1
+14 QUIT
