- 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 Feb 18, 2025@23:29:52 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
