DIKD ;SFISC/MKO-DELETE A CROSS REFERENCE ;11JUN2010
;;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.
;
;
DELIX(DIFIL,DIFLD,DIXR,DIFLG,DIKDOUT,DIKDMSG) ;Delete traditional xref
DELIXX ;Come here from DELIX^DDMOD
N %,DIC,X,Y,DIF,DIFINFO,DIQUIT
;
;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 FINFO^DIKCU1(DIFIL,.DIFINFO)
;
;Delete data in index
D:DIFLG["K" KILL^DIKD1(DIFIL,DIFLD,DIXR,$E("W",DIFLG["W")_DIF_"c")
;
;Audit, delete xref, recompile
D AUDIT ;:$G(^DD(+DIFINFO(0),0,"DDA"))["Y"
D DELDEF(DIFIL,DIFLD,DIXR,DIFLG)
D DIEZ(DIFIL,DIFLD,DIFLG,$G(DIKDOUT))
D DIKZ(+DIFINFO(0),DIFLG,$G(DIKDOUT))
;
END ;Move error message if necessary and quit
D:$G(DIKDMSG)]"" CALLOUT^DIEFU(DIKDMSG)
Q
;
DELDEF(DIFIL,DIFLD,DIXR,DIFLG) ;Delete index definition
N DIK,DA,DITYP
S DITYP=$P($G(^DD(DIFIL,DIFLD,1,DIXR,0)),U,3)
K:DITYP="SOUNDEX" ^DD(DIFIL,0,"LOOK"),^("QUES")
;
W:$G(DIFLG)["W" !,"Deleting cross-reference definition ..."
S ^DD(DIFIL,DIFLD,1,0)="^.1"
S DIK="^DD("_DIFIL_","_DIFLD_",1,"
S DA(2)=DIFIL,DA(1)=DIFLD,DA=DIXR
D ^DIK
Q
;
DIEZ(DIFIL,DIFLD,DIFLG,DIKDOUT,DIKTEML) ;Recompile input templates containing field
N DIERR,DITEM,DIMAX,DIRNM
S DIMAX=$$ROUSIZE^DILF
S DITEM=0 F S DITEM=$O(^DIE("AF",DIFIL,DIFLD,DITEM)) Q:'DITEM D
. N DIERR,DIEZMSG
. Q:$D(DIKTEML(DITEM))#2 S DIKTEML(DITEM)=""
. K ^DIE("AF",DIFIL,DIFLD,DITEM),^DIE(DITEM,"ROU")
. S DIRNM=$G(^DIE(DITEM,"ROUOLD")) Q:DIRNM=""
. D EN2^DIEZ(DITEM,$E("T",$G(DIFLG)["W"),DIRNM,"","DIEZMSG")
. I '$G(DIERR),$G(DIKDOUT)]"" D
.. S @DIKDOUT@("DIEZ",DITEM)=$P(^DIE(DITEM,0),U)_U_$P(^(0),U,4)_U_DIRNM
Q
;
DIKZ(Y,DIFLG,DIKDOUT) ;Recompile xrefs
Q:'$G(Y)
N DIERR,DIKZMSG,DMAX,DIRNM
S DIRNM=$G(^DD(Y,0,"DIK")) Q:DIRNM=""
S DMAX=$$ROUSIZE^DILF
D EN2^DIKZ(Y,$E("T",$G(DIFLG)["W"),DIRNM,"","DIKZMSG")
I '$G(DIERR),$G(DIKDOUT)]"" S @DIKDOUT@("DIKZ")=DIRNM
Q
;
AUDIT ;Audit DD change
N %,%D,%T,A0,A1,A2,B0,B1,B2,B3,DA,DDA,DL,DQ,J,N
S DDA="D",N=DIFINFO,J(0)=+DIFINFO(0),J(N)=DIFIL,DL=DIFLD,DQ=DIXR
D XA^DICATTA
S:$G(DIKDOUT)]"" @DIKDOUT@("DDAUD")=1
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),'$$VFNUM^DIKCU1(DIFIL,DIF) D QUIT
I '$G(DIQUIT),'$$VFLD^DIKCU1($G(DIFIL),$G(DIFLD),DIF) D QUIT
;
I $G(DIXR)="" D
. D:DIF["D" ERR^DIKCU2(202,"","","","CROSS-REFERENCE") D QUIT
E I '$G(DIQUIT) D
. I DIXR=+DIXR D
.. I $D(^DD(DIFIL,DIFLD,1,DIXR,0))[0 D:DIF["D" ERR^DIKCU2(202,"","","","CROSS-REFERENCE") D QUIT
. E D
.. N I,XR
.. S I=0 F S I=$O(^DD(DIFIL,DIFLD,1,I)) Q:'I S:$P($G(^(I,0)),U,2)=DIXR XR=$G(XR)+1,XR(XR)=I
.. I $G(XR)=1 S DIXR=XR(XR)
.. E D:DIF["D" ERR^DIKCU2(202,"","","","CROSS-REFERENCE") D QUIT
;
D:'$$VFLAG^DIKCU1(DIFLG,"KWcd",DIF) QUIT
Q
;
QUIT ;Set flag to quit
S DIQUIT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKD 3267 printed Dec 13, 2024@02:48:57 Page 2
DIKD ;SFISC/MKO-DELETE A CROSS REFERENCE ;11JUN2010
+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 ;
+7 ;
DELIX(DIFIL,DIFLD,DIXR,DIFLG,DIKDOUT,DIKDMSG) ;Delete traditional xref
DELIXX ;Come here from DELIX^DDMOD
+1 NEW %,DIC,X,Y,DIF,DIFINFO,DIQUIT
+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 FINFO^DIKCU1(DIFIL,.DIFINFO)
+9 ;
+10 ;Delete data in index
+11 if DIFLG["K"
DO KILL^DIKD1(DIFIL,DIFLD,DIXR,$EXTRACT("W",DIFLG["W")_DIF_"c")
+12 ;
+13 ;Audit, delete xref, recompile
+14 ;:$G(^DD(+DIFINFO(0),0,"DDA"))["Y"
DO AUDIT
+15 DO DELDEF(DIFIL,DIFLD,DIXR,DIFLG)
+16 DO DIEZ(DIFIL,DIFLD,DIFLG,$GET(DIKDOUT))
+17 DO DIKZ(+DIFINFO(0),DIFLG,$GET(DIKDOUT))
+18 ;
END ;Move error message if necessary and quit
+1 if $GET(DIKDMSG)]""
DO CALLOUT^DIEFU(DIKDMSG)
+2 QUIT
+3 ;
DELDEF(DIFIL,DIFLD,DIXR,DIFLG) ;Delete index definition
+1 NEW DIK,DA,DITYP
+2 SET DITYP=$PIECE($GET(^DD(DIFIL,DIFLD,1,DIXR,0)),U,3)
+3 if DITYP="SOUNDEX"
KILL ^DD(DIFIL,0,"LOOK"),^("QUES")
+4 ;
+5 if $GET(DIFLG)["W"
WRITE !,"Deleting cross-reference definition ..."
+6 SET ^DD(DIFIL,DIFLD,1,0)="^.1"
+7 SET DIK="^DD("_DIFIL_","_DIFLD_",1,"
+8 SET DA(2)=DIFIL
SET DA(1)=DIFLD
SET DA=DIXR
+9 DO ^DIK
+10 QUIT
+11 ;
DIEZ(DIFIL,DIFLD,DIFLG,DIKDOUT,DIKTEML) ;Recompile input templates containing field
+1 NEW DIERR,DITEM,DIMAX,DIRNM
+2 SET DIMAX=$$ROUSIZE^DILF
+3 SET DITEM=0
FOR
SET DITEM=$ORDER(^DIE("AF",DIFIL,DIFLD,DITEM))
if 'DITEM
QUIT
Begin DoDot:1
+4 NEW DIERR,DIEZMSG
+5 if $DATA(DIKTEML(DITEM))#2
QUIT
SET DIKTEML(DITEM)=""
+6 KILL ^DIE("AF",DIFIL,DIFLD,DITEM),^DIE(DITEM,"ROU")
+7 SET DIRNM=$GET(^DIE(DITEM,"ROUOLD"))
if DIRNM=""
QUIT
+8 DO EN2^DIEZ(DITEM,$EXTRACT("T",$GET(DIFLG)["W"),DIRNM,"","DIEZMSG")
+9 IF '$GET(DIERR)
IF $GET(DIKDOUT)]""
Begin DoDot:2
+10 SET @DIKDOUT@("DIEZ",DITEM)=$PIECE(^DIE(DITEM,0),U)_U_$PIECE(^(0),U,4)_U_DIRNM
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
DIKZ(Y,DIFLG,DIKDOUT) ;Recompile xrefs
+1 if '$GET(Y)
QUIT
+2 NEW DIERR,DIKZMSG,DMAX,DIRNM
+3 SET DIRNM=$GET(^DD(Y,0,"DIK"))
if DIRNM=""
QUIT
+4 SET DMAX=$$ROUSIZE^DILF
+5 DO EN2^DIKZ(Y,$EXTRACT("T",$GET(DIFLG)["W"),DIRNM,"","DIKZMSG")
+6 IF '$GET(DIERR)
IF $GET(DIKDOUT)]""
SET @DIKDOUT@("DIKZ")=DIRNM
+7 QUIT
+8 ;
AUDIT ;Audit DD change
+1 NEW %,%D,%T,A0,A1,A2,B0,B1,B2,B3,DA,DDA,DL,DQ,J,N
+2 SET DDA="D"
SET N=DIFINFO
SET J(0)=+DIFINFO(0)
SET J(N)=DIFIL
SET DL=DIFLD
SET DQ=DIXR
+3 DO XA^DICATTA
+4 if $GET(DIKDOUT)]""
SET @DIKDOUT@("DDAUD")=1
+5 QUIT
+6 ;
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 '$$VFNUM^DIKCU1(DIFIL,DIF)
DO QUIT
+4 IF '$GET(DIQUIT)
IF '$$VFLD^DIKCU1($GET(DIFIL),$GET(DIFLD),DIF)
DO QUIT
+5 ;
+6 IF $GET(DIXR)=""
Begin DoDot:1
+7 if DIF["D"
DO ERR^DIKCU2(202,"","","","CROSS-REFERENCE")
DO QUIT
End DoDot:1
+8 IF '$TEST
IF '$GET(DIQUIT)
Begin DoDot:1
+9 IF DIXR=+DIXR
Begin DoDot:2
+10 IF $DATA(^DD(DIFIL,DIFLD,1,DIXR,0))[0
if DIF["D"
DO ERR^DIKCU2(202,"","","","CROSS-REFERENCE")
DO QUIT
End DoDot:2
+11 IF '$TEST
Begin DoDot:2
+12 NEW I,XR
+13 SET I=0
FOR
SET I=$ORDER(^DD(DIFIL,DIFLD,1,I))
if 'I
QUIT
if $PIECE($GET(^(I,0)),U,2)=DIXR
SET XR=$GET(XR)+1
SET XR(XR)=I
+14 IF $GET(XR)=1
SET DIXR=XR(XR)
+15 IF '$TEST
if DIF["D"
DO ERR^DIKCU2(202,"","","","CROSS-REFERENCE")
DO QUIT
End DoDot:2
End DoDot:1
+16 ;
+17 if '$$VFLAG^DIKCU1(DIFLG,"KWcd",DIF)
DO QUIT
+18 QUIT
+19 ;
QUIT ;Set flag to quit
+1 SET DIQUIT=1
+2 QUIT
