- 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 Jan 18, 2025@03:49:56 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