DIKD1 ;SFISC/MKO-DELETE XREF DATA ;1:03 PM 20 Aug 1999
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
KILL(DIFIL,DIFLD,DIXR,DIFLG,DIKDMSG) ;Delete xref data
N DA,DIDEC,DIF,DIFILR,DIKILL,DIMF,DINAM,DIQUIT,DIROOT,DITOPF,DITYP
;
;Init
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
S DIFLG=$G(DIFLG)
S DIF=$E("D",DIFLG'["d")
I DIFLG'["c" D CHK G:$G(DIQUIT) END
D INIT G:$D(DIQUIT) END
;
;Fire the kill logic
D:$G(DIFLG)["W"
. I DITYP="BULLETIN"!(DITYP="MUMPS")!(DITYP="TRIGGER") D
.. W !,"Executing kill logic ..."
. E W !,"Removing index ..."
D FIRE(DITOPF,DIROOT)
;
END ;Move error message if necessary and quit
D:$G(DIKDMSG)]"" CALLOUT^DIEFU(DIKDMSG)
Q
;
FIRE(DIFILE,DIROOT) ;Fire the kill logic
N DICNT,DILAST,DIMULTF,DISBROOT,X
;
;If we're at the level where the index resides,
;check whether we can delete the entire index with one kill
I DIFILE=DIFILR,DINAM?1.E,DITYP'="MNEMONIC",DITYP'="MUMPS" D
. K @DIROOT@(DINAM)
;
;Else, if we're at the level where the index is defined,
;execute the kill logic for each entry
E I DIFILE=DIFIL S (DICNT,DA)=0 F S DA=$O(@DIROOT@(DA)) Q:DA'=+DA D
. N X
. S DICNT=DICNT+1
. X DIDEC X:X]"" DIKILL
;
;Else, for all entries, descend into multiple
E S DIMULTF=$O(DIMF(DIFILE,0)) I DIMULTF S (DICNT,DA)=0 F S DA=$O(@DIROOT@(DA)) Q:DA'=+DA D
. S DICNT=DICNT+1
. S DISBROOT=$NA(@DIROOT@(DA,DIMF(DIFILE,DIMULTF))) Q:'$D(@DISBROOT)
. D PUSHDA^DIKCU(.DA)
. D FIRE(DIMF(DIFILE,DIMULTF,0),DISBROOT)
. D POPDA^DIKCU(.DA)
;
I $D(DICNT),$D(@DIROOT@(0))#2 D
. S DILAST=$O(@DIROOT@(" "),-1)
. S:'DILAST DILAST="" S:'DICNT DICNT=""
. S $P(@DIROOT@(0),U,3,4)=DILAST_U_DICNT
Q
;
CHK ;Check input parameters
I '$G(DIFIL) D:DIF["D" ERR^DIKCU2(202,"","","","FILE") D QUIT
I '$G(DIFLD) D:DIF["D" ERR^DIKCU2(202,"","","","FIELD") D QUIT
I '$G(DIQUIT),'$$VFLD^DIKCU1($G(DIFIL),$G(DIFLD),DIF) D QUIT
I '$G(DIXR) D:DIF["D" ERR^DIKCU2(202,"","","","CROSS-REFERENCE") D QUIT
D:'$$VFLAG^DIKCU1(DIFLG,"Wcd",DIF) QUIT
Q
;
INIT ;Get xref info and subfile info
N DIXR0
S DIXR0=$G(^DD(DIFIL,DIFLD,1,DIXR,0)) G:DIXR0="" QUIT
S DIFILR=$P(DIXR0,U),DINAM=$P(DIXR0,U,2),DITYP=$P(DIXR0,U,3)
G:DITYP="BULLETIN" QUIT
;
S DIKILL=$G(^DD(DIFIL,DIFLD,1,DIXR,2))
G:DIKILL="Q"!(DIKILL?."^") QUIT
;
D SBINFO^DIKCU(DIFIL,.DIMF)
I '$D(DIMF) S DITOPF=DIFIL
E S DITOPF=0 F S DITOPF=$O(DIMF(DITOPF)) Q:'$G(^DD(DITOPF,0,"UP"))
;
S DIROOT=$$CREF^DILF($G(^DIC(DITOPF,0,"GL")))
S DIDEC=$$DEC^DIKC2(DIFIL,DIFLD)
G:DIROOT=""!(DIDEC="") QUIT
Q
;
QUIT ;Set flag to quit
S DIQUIT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKD1 2879 printed Dec 13, 2024@02:48:58 Page 2
DIKD1 ;SFISC/MKO-DELETE XREF DATA ;1:03 PM 20 Aug 1999
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
KILL(DIFIL,DIFLD,DIXR,DIFLG,DIKDMSG) ;Delete xref data
+1 NEW DA,DIDEC,DIF,DIFILR,DIKILL,DIMF,DINAM,DIQUIT,DIROOT,DITOPF,DITYP
+2 ;
+3 ;Init
+4 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+5 SET DIFLG=$GET(DIFLG)
+6 SET DIF=$EXTRACT("D",DIFLG'["d")
+7 IF DIFLG'["c"
DO CHK
if $GET(DIQUIT)
GOTO END
+8 DO INIT
if $DATA(DIQUIT)
GOTO END
+9 ;
+10 ;Fire the kill logic
+11 if $GET(DIFLG)["W"
Begin DoDot:1
+12 IF DITYP="BULLETIN"!(DITYP="MUMPS")!(DITYP="TRIGGER")
Begin DoDot:2
+13 WRITE !,"Executing kill logic ..."
End DoDot:2
+14 IF '$TEST
WRITE !,"Removing index ..."
End DoDot:1
+15 DO FIRE(DITOPF,DIROOT)
+16 ;
END ;Move error message if necessary and quit
+1 if $GET(DIKDMSG)]""
DO CALLOUT^DIEFU(DIKDMSG)
+2 QUIT
+3 ;
FIRE(DIFILE,DIROOT) ;Fire the kill logic
+1 NEW DICNT,DILAST,DIMULTF,DISBROOT,X
+2 ;
+3 ;If we're at the level where the index resides,
+4 ;check whether we can delete the entire index with one kill
+5 IF DIFILE=DIFILR
IF DINAM?1.E
IF DITYP'="MNEMONIC"
IF DITYP'="MUMPS"
Begin DoDot:1
+6 KILL @DIROOT@(DINAM)
End DoDot:1
+7 ;
+8 ;Else, if we're at the level where the index is defined,
+9 ;execute the kill logic for each entry
+10 IF '$TEST
IF DIFILE=DIFIL
SET (DICNT,DA)=0
FOR
SET DA=$ORDER(@DIROOT@(DA))
if DA'=+DA
QUIT
Begin DoDot:1
+11 NEW X
+12 SET DICNT=DICNT+1
+13 XECUTE DIDEC
if X]""
XECUTE DIKILL
End DoDot:1
+14 ;
+15 ;Else, for all entries, descend into multiple
+16 IF '$TEST
SET DIMULTF=$ORDER(DIMF(DIFILE,0))
IF DIMULTF
SET (DICNT,DA)=0
FOR
SET DA=$ORDER(@DIROOT@(DA))
if DA'=+DA
QUIT
Begin DoDot:1
+17 SET DICNT=DICNT+1
+18 SET DISBROOT=$NAME(@DIROOT@(DA,DIMF(DIFILE,DIMULTF)))
if '$DATA(@DISBROOT)
QUIT
+19 DO PUSHDA^DIKCU(.DA)
+20 DO FIRE(DIMF(DIFILE,DIMULTF,0),DISBROOT)
+21 DO POPDA^DIKCU(.DA)
End DoDot:1
+22 ;
+23 IF $DATA(DICNT)
IF $DATA(@DIROOT@(0))#2
Begin DoDot:1
+24 SET DILAST=$ORDER(@DIROOT@(" "),-1)
+25 if 'DILAST
SET DILAST=""
if 'DICNT
SET DICNT=""
+26 SET $PIECE(@DIROOT@(0),U,3,4)=DILAST_U_DICNT
End DoDot:1
+27 QUIT
+28 ;
CHK ;Check input parameters
+1 IF '$GET(DIFIL)
if DIF["D"
DO ERR^DIKCU2(202,"","","","FILE")
DO QUIT
+2 IF '$GET(DIFLD)
if DIF["D"
DO ERR^DIKCU2(202,"","","","FIELD")
DO QUIT
+3 IF '$GET(DIQUIT)
IF '$$VFLD^DIKCU1($GET(DIFIL),$GET(DIFLD),DIF)
DO QUIT
+4 IF '$GET(DIXR)
if DIF["D"
DO ERR^DIKCU2(202,"","","","CROSS-REFERENCE")
DO QUIT
+5 if '$$VFLAG^DIKCU1(DIFLG,"Wcd",DIF)
DO QUIT
+6 QUIT
+7 ;
INIT ;Get xref info and subfile info
+1 NEW DIXR0
+2 SET DIXR0=$GET(^DD(DIFIL,DIFLD,1,DIXR,0))
if DIXR0=""
GOTO QUIT
+3 SET DIFILR=$PIECE(DIXR0,U)
SET DINAM=$PIECE(DIXR0,U,2)
SET DITYP=$PIECE(DIXR0,U,3)
+4 if DITYP="BULLETIN"
GOTO QUIT
+5 ;
+6 SET DIKILL=$GET(^DD(DIFIL,DIFLD,1,DIXR,2))
+7 if DIKILL="Q"!(DIKILL?."^")
GOTO QUIT
+8 ;
+9 DO SBINFO^DIKCU(DIFIL,.DIMF)
+10 IF '$DATA(DIMF)
SET DITOPF=DIFIL
+11 IF '$TEST
SET DITOPF=0
FOR
SET DITOPF=$ORDER(DIMF(DITOPF))
if '$GET(^DD(DITOPF,0,"UP"))
QUIT
+12 ;
+13 SET DIROOT=$$CREF^DILF($GET(^DIC(DITOPF,0,"GL")))
+14 SET DIDEC=$$DEC^DIKC2(DIFIL,DIFLD)
+15 if DIROOT=""!(DIDEC="")
GOTO QUIT
+16 QUIT
+17 ;
QUIT ;Set flag to quit
+1 SET DIQUIT=1
+2 QUIT
