DICATT4 ;SFISC/XAK - DELETE A FIELD ;12NOV2015
;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
;;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.
;
DIEZ S DI=A,DA=D0 D DIPZ^DIU0
K ^DD(A,0,"ID",D0),^DD(A,0,"SP",D0)
EN I $O(@(I(0)_"0)"))>0 D
.N X,T,Y,Z,MUL
.S MUL=+$P(O,U,2)
.S %=1,Y=$P(O,U,4),X=$P(Y,";"),Y=$P(Y,";",2),Z=$S(+X=X:X,1:""""_X_"""")_")",E="^("_Z
.I $O(^DD(A,"GL",X,""))="" S T="K ^(M,"_Z G F
.I Y S T="U_$P("_E_",U,"_(Y+1)_",999) K:"_E_"?.""^"" "_E S:Y>1 T="$P("_E_",U,1,"_(Y-1)_")_U_"_T
.E S X=+$E(Y,2,4),Y=+$P(Y,",",2) Q:'X!'Y S T="$E("_E_",1,"_(X-1)_")_$J("""","_(Y-X+1)_")_$E("_E_","_(Y+1)_",999)"
.S T="I $D(^(M,"_Z_")#2 S "_E_"="_T
F .I '$D(DIU(0)) W $C(7),!,"OK TO DELETE '",$P(M,U),"' FIELDS IN THE EXISTING ENTRIES" D YN^DICN I %-1 D:'$D(DIU) DELXRF(A,D0) Q
KILLIX .I $D(DICATT4M) D S M="" F S M=$O(^DD(J(0),0,"IX",M)) Q:M="" I $O(^(M,MUL,0)) K @(I(0)_""""_M_""")")
..D INDEX^DIKC(J(0),"","","","KiRW"_MUL)
.E D:'$D(DIU) DELXRF(A,D0,1,J(0))
.S M="",X=DICL,Y=I(0) I $D(DQI) K @(I(0)_""""_DQI_""")")
L .S O="M" S:X O=O_"("_X_")" S Y=Y_O,M=M_"F "_O_"=0:0 S "_O_"=$O("_Y_")) Q:"_O_"'>0 "
.S X=X-1 I X+1 S Y=Y_","_I(DICL-X)_"," G L
.S M=M_"X T"_$P(" W "".""",U,$S('$D(DIU(0)):1,DIU(0)["E":1,1:0))
.X M ;HERE'S THE LOOP WHERE WE KILL THE VALUES!
N Q:$D(DIU)!$D(DICATT4M) G N^DICATT
;
NEW ;Delete the data in the multiple
S DICATT4M=$NA(^DD(A,D0))
S DICATT4M("SB")=$NA(^DD(A,"SB",+$P(O,U,2),D0))
S ^DD(A,D0,0)=O,^DD(A,"SB",+$P(O,U,2),D0)=""
D DICATT4
K @DICATT4M,@DICATT4M("SB"),DICATT4M
;
;Kill the DD globals and go back to N^DICATT
D KDD G N^DICATT
;
VP ; VARIABLE POINTER
S DA(2)=DA(1),DA(1)=DA,DICATT=DA I $D(DICS) S DICSS=DICS K DICS
V S DA(2)=A,DA(1)=DICATT,DIC="^DD("_A_","_DICATT_",""V"",",DIC("P")=".12P",DIC(0)="QEAMLI",DIC("W")="W:$S($D(^DIC(+^(0),0)):$P(^(0),U)'=$P(^DD(DA(2),DA(1),""V"",+Y,0),U,2),1:0) ?30,$P(^(0),U,2)" D ^DIC S DIE=DIC K DIC
I Y>0 S DA=+Y,Z="P",DR=".01:.04;"_$S($P($G(^DD(+$P(Y,U,2),0,"DI")),U,2)["Y":".06///n",1:".06T")_";S:DUZ(0)'=""@"" Y=0;.05;I ""n""[X K ^DD(DA(2),DA(1),""V"",DA,1),^(2) S Y=0;S DIE(""NO^"")=""BACK"";1;2;" S:$P(Y,U,3) DIE("NO^")=""
I Y>0 D ^DIE K DIE W ! S:$D(DTOUT) DA=DICATT G CHECK^DICATT:$D(DTOUT),V
S Z="V^",DIZ=Z,C="Q",L=18,DA=DICATT,DA(1)=A S:$D(DICSS) DICS=DICSS K DICSS,DR,DIE,DA(2),DICATT G CHECK^DICATT:$D(DTOUT)!(X=U),^DICATT1
Q
HELP ;
W !?5,"Enter a MUMPS statement that sets DIC(""S"") to code that sets $T."
W !?5,"Those entries for which $T=1 will be selectable."
I Z?1"P".E D Q
. W !?5,"The naked reference will be at the zeroeth node of the pointed to"
. W !?5,"file, e.g., ^DIZ(9999,Entry Number,0). The internal entry number"
. W !?5,"of the entry that is being processed in the pointed to file will be"
. W !?5,"in the variable Y."
W !?5,"The variable Y will be equal to the internally-stored code of the item"
W !?5,"in the set which is being processed."
Q
KDD ;
I '$D(DIANC) S X=A F S DIANC(X)="" Q:$D(^DD(X,0,"UP"))[0 S X=^("UP")
S DQ=$O(DQ(0)),X=0 I DQ="" S DQ=-1 K DIANC Q
D KIX(.DIANC,DQ)
F S X=$O(^DD(DQ,"SB",X)) Q:'X S DQ(X)=0
N DIFLD S DIFLD=0 F S DIFLD=$O(^DD(DQ,DIFLD)) Q:'DIFLD D
. I $D(^DD(DQ,DIFLD,9.01)) S X=^(9.01),Y=DIFLD D KACOMP
. D KTRB(.DIANC,DQ,DIFLD)
. S X=$P($G(^DD(DQ,DIFLD,0)),U,2) I X["t" D AFDEFDEL^DIETLIB(DQ,DIFLD) Q ;DELETE EXTENDED DATA TYPE CROSS-REFERENCE
. I X["P" S X=+$P(X,"P",2) K:X ^DD(X,0,"PT",DQ,DIFLD) Q
. F %=0:0 S %=$O(^DD(DQ,DIFLD,"V",%)) Q:'% S X=+$G(^(%,0)) K:X ^DD(X,0,"PT",DQ,DIFLD)
. Q
K DQ(DQ),^DD(DQ),^DD("ACOMP",DQ),^DDA(DQ)
S Y=0 F S Y=$O(DIANC(Y)) Q:'Y K ^DD(Y,"TRB",DQ)
D DELXR(DQ)
S Y=0 F S Y=$O(^DIE("AF",DQ,Y)) Q:Y="" S %=0 F S %=$O(^DIE("AF",DQ,Y,0)) Q:%="" K ^(%),^DIE(%,"ROU")
S Y=0 F S Y=$O(^DIPT("AF",DQ,Y)) G KDD:Y="" S %=0 F S %=$O(^DIPT("AF",DQ,Y,0)) Q:%="" K ^(%),^DIPT(%,"ROU")
;
KIX(DIANC,DIFIL) ;
N F,NM
S F=0 F S F=$O(DIANC(F)) Q:'F D
. S NM="" F S NM=$O(^DD(F,0,"IX",NM)) Q:NM="" K:$D(^(NM,DIFIL)) ^(DIFIL)
Q
KACOMP N DA,I,% S DA(1)=DQ,DA=Y X ^DD(0,9.01,1,1,2) Q
;
KTRB(DIANC,DIFIL,DIFLD) ;Kill 5 node of triggered field
;Also kill "TRB" nodes here if triggered field is in another file
N %,F,DITFLD,DITFIL,DIXR,DIXR0
S DIXR=0
F S DIXR=$O(^DD(DIFIL,DIFLD,1,DIXR)) Q:'DIXR S DIXR0=$G(^(DIXR,0)) D:$P(DIXR0,U,3)="TRIGGER"
. S DITFIL=$P(DIXR0,U,4),DITFLD=$P(DIXR0,U,5) Q:'DITFIL!'DITFLD
. S %=0
. F S %=$O(^DD(DITFIL,DITFLD,5,%)) Q:'% I $P($G(^(%,0)),U,1,3)=(DIFIL_U_DIFLD_U_DIXR) D Q
.. K ^DD(DITFIL,DITFLD,5,%) Q:DITFIL=DIFIL!$D(DIANC(DITFIL))
.. S F=DITFIL
.. F K ^DD(F,"TRB",DIFIL) S F=$G(^DD(F,0,"UP")) Q:'F!$D(DIANC(+F))
Q
DELXR(DIFIL) ;Delete the Key and Index file entries for file DIFIL
Q:'$G(DIFIL)
N DA,DIK
;
;Kill keys on file DIFIL
S DIK="^DD(""KEY"","
S DA=0 F S DA=$O(^DD("KEY","B",DIFIL,DA)) Q:'DA D ^DIK
;
;Kill indexes on file DIFIL
S DIK="^DD(""IX"","
S DA=0 F S DA=$O(^DD("IX","AC",DIFIL,DA)) Q:'DA D ^DIK
Q
;
DELXRF(DIFIL,DIFLD,DIFLG,DITOPFIL) ;Delete Keys and Indexes on field
;If DIFLG=1, also delete the Indexes from the data global.
Q:'$G(DIFIL)!'$G(DIFLD)
N DA,DIK
;
;Execute the kill logic for all indexes defined on the field
;for all entries in the file.
I $G(DIFLG) D
. S:$G(DITOPFIL)="" DITOPFIL=$$FNO^DILIBF(DIFIL)
. D:DITOPFIL INDEX^DIKC(DITOPFIL,"",DIFLD,"","RKW"_DIFIL)
;
;Kill keys on file/field
S DIK="^DD(""KEY"","
S DA=0 F S DA=$O(^DD("KEY","F",DIFIL,DIFLD,DA)) Q:'DA D ^DIK
;
;Kill indexes on file/field
S DIK="^DD(""IX"","
S DA=0 F S DA=$O(^DD("IX","F",DIFIL,DIFLD,DA)) Q:'DA D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATT4 5867 printed Sep 23, 2025@20:21:39 Page 2
DICATT4 ;SFISC/XAK - DELETE A FIELD ;12NOV2015
+1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
+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 ;
DIEZ SET DI=A
SET DA=D0
DO DIPZ^DIU0
+1 KILL ^DD(A,0,"ID",D0),^DD(A,0,"SP",D0)
EN IF $ORDER(@(I(0)_"0)"))>0
Begin DoDot:1
+1 NEW X,T,Y,Z,MUL
+2 SET MUL=+$PIECE(O,U,2)
+3 SET %=1
SET Y=$PIECE(O,U,4)
SET X=$PIECE(Y,";")
SET Y=$PIECE(Y,";",2)
SET Z=$SELECT(+X=X:X,1:""""_X_"""")_")"
SET E="^("_Z
+4 IF $ORDER(^DD(A,"GL",X,""))=""
SET T="K ^(M,"_Z
GOTO F
+5 IF Y
SET T="U_$P("_E_",U,"_(Y+1)_",999) K:"_E_"?.""^"" "_E
if Y>1
SET T="$P("_E_",U,1,"_(Y-1)_")_U_"_T
+6 IF '$TEST
SET X=+$EXTRACT(Y,2,4)
SET Y=+$PIECE(Y,",",2)
if 'X!'Y
QUIT
SET T="$E("_E_",1,"_(X-1)_")_$J("""","_(Y-X+1)_")_$E("_E_","_(Y+1)_",999)"
+7 SET T="I $D(^(M,"_Z_")#2 S "_E_"="_T
F IF '$DATA(DIU(0))
WRITE $CHAR(7),!,"OK TO DELETE '",$PIECE(M,U),"' FIELDS IN THE EXISTING ENTRIES"
DO YN^DICN
IF %-1
if '$DATA(DIU)
DO DELXRF(A,D0)
QUIT
KILLIX IF $DATA(DICATT4M)
Begin DoDot:2
+1 DO INDEX^DIKC(J(0),"","","","KiRW"_MUL)
End DoDot:2
SET M=""
FOR
SET M=$ORDER(^DD(J(0),0,"IX",M))
if M=""
QUIT
IF $ORDER(^(M,MUL,0))
KILL @(I(0)_""""_M_""")")
+2 IF '$TEST
if '$DATA(DIU)
DO DELXRF(A,D0,1,J(0))
+3 SET M=""
SET X=DICL
SET Y=I(0)
IF $DATA(DQI)
KILL @(I(0)_""""_DQI_""")")
L SET O="M"
if X
SET O=O_"("_X_")"
SET Y=Y_O
SET M=M_"F "_O_"=0:0 S "_O_"=$O("_Y_")) Q:"_O_"'>0 "
+1 SET X=X-1
IF X+1
SET Y=Y_","_I(DICL-X)_","
GOTO L
+2 SET M=M_"X T"_$PIECE(" W "".""",U,$SELECT('$DATA(DIU(0)):1,DIU(0)["E":1,1:0))
+3 ;HERE'S THE LOOP WHERE WE KILL THE VALUES!
XECUTE M
End DoDot:1
N if $DATA(DIU)!$DATA(DICATT4M)
QUIT
GOTO N^DICATT
+1 ;
NEW ;Delete the data in the multiple
+1 SET DICATT4M=$NAME(^DD(A,D0))
+2 SET DICATT4M("SB")=$NAME(^DD(A,"SB",+$PIECE(O,U,2),D0))
+3 SET ^DD(A,D0,0)=O
SET ^DD(A,"SB",+$PIECE(O,U,2),D0)=""
+4 DO DICATT4
+5 KILL @DICATT4M,@DICATT4M("SB"),DICATT4M
+6 ;
+7 ;Kill the DD globals and go back to N^DICATT
+8 DO KDD
GOTO N^DICATT
+9 ;
VP ; VARIABLE POINTER
+1 SET DA(2)=DA(1)
SET DA(1)=DA
SET DICATT=DA
IF $DATA(DICS)
SET DICSS=DICS
KILL DICS
V SET DA(2)=A
SET DA(1)=DICATT
SET DIC="^DD("_A_","_DICATT_",""V"","
SET DIC("P")=".12P"
SET DIC(0)="QEAMLI"
SET DIC("W")="W:$S($D(^DIC(+^(0),0)):$P(^(0),U)'=$P(^DD(DA(2),DA(1),""V"",+Y,0),U,2),1:0) ?30,$P(^(0),U,2)"
DO ^DIC
SET DIE=DIC
KILL DIC
+1 IF Y>0
SET DA=+Y
SET Z="P"
SET DR=".01:.04;"_$SELECT($PIECE($GET(^DD(+$PIECE(Y,U,2),0,"DI")),U,2)["Y":".06///n",1:".06T")_";S:DUZ(0)'=""@"" Y=0;.05;I ""n""[X K ^DD(DA(2),DA(1),""V"",DA,1),^(2) S Y=0;S DIE(""NO^"")=""BACK"";1;2;"
if $PIECE(Y,U,3)
SET DIE("NO^")=""
+2 IF Y>0
DO ^DIE
KILL DIE
WRITE !
if $DATA(DTOUT)
SET DA=DICATT
if $DATA(DTOUT)
GOTO CHECK^DICATT
GOTO V
+3 SET Z="V^"
SET DIZ=Z
SET C="Q"
SET L=18
SET DA=DICATT
SET DA(1)=A
if $DATA(DICSS)
SET DICS=DICSS
KILL DICSS,DR,DIE,DA(2),DICATT
if $DATA(DTOUT)!(X=U)
GOTO CHECK^DICATT
GOTO ^DICATT1
+4 QUIT
HELP ;
+1 WRITE !?5,"Enter a MUMPS statement that sets DIC(""S"") to code that sets $T."
+2 WRITE !?5,"Those entries for which $T=1 will be selectable."
+3 IF Z?1"P".E
Begin DoDot:1
+4 WRITE !?5,"The naked reference will be at the zeroeth node of the pointed to"
+5 WRITE !?5,"file, e.g., ^DIZ(9999,Entry Number,0). The internal entry number"
+6 WRITE !?5,"of the entry that is being processed in the pointed to file will be"
+7 WRITE !?5,"in the variable Y."
End DoDot:1
QUIT
+8 WRITE !?5,"The variable Y will be equal to the internally-stored code of the item"
+9 WRITE !?5,"in the set which is being processed."
+10 QUIT
KDD ;
+1 IF '$DATA(DIANC)
SET X=A
FOR
SET DIANC(X)=""
if $DATA(^DD(X,0,"UP"))[0
QUIT
SET X=^("UP")
+2 SET DQ=$ORDER(DQ(0))
SET X=0
IF DQ=""
SET DQ=-1
KILL DIANC
QUIT
+3 DO KIX(.DIANC,DQ)
+4 FOR
SET X=$ORDER(^DD(DQ,"SB",X))
if 'X
QUIT
SET DQ(X)=0
+5 NEW DIFLD
SET DIFLD=0
FOR
SET DIFLD=$ORDER(^DD(DQ,DIFLD))
if 'DIFLD
QUIT
Begin DoDot:1
+6 IF $DATA(^DD(DQ,DIFLD,9.01))
SET X=^(9.01)
SET Y=DIFLD
DO KACOMP
+7 DO KTRB(.DIANC,DQ,DIFLD)
+8 ;DELETE EXTENDED DATA TYPE CROSS-REFERENCE
SET X=$PIECE($GET(^DD(DQ,DIFLD,0)),U,2)
IF X["t"
DO AFDEFDEL^DIETLIB(DQ,DIFLD)
QUIT
+9 IF X["P"
SET X=+$PIECE(X,"P",2)
if X
KILL ^DD(X,0,"PT",DQ,DIFLD)
QUIT
+10 FOR %=0:0
SET %=$ORDER(^DD(DQ,DIFLD,"V",%))
if '%
QUIT
SET X=+$GET(^(%,0))
if X
KILL ^DD(X,0,"PT",DQ,DIFLD)
+11 QUIT
End DoDot:1
+12 KILL DQ(DQ),^DD(DQ),^DD("ACOMP",DQ),^DDA(DQ)
+13 SET Y=0
FOR
SET Y=$ORDER(DIANC(Y))
if 'Y
QUIT
KILL ^DD(Y,"TRB",DQ)
+14 DO DELXR(DQ)
+15 SET Y=0
FOR
SET Y=$ORDER(^DIE("AF",DQ,Y))
if Y=""
QUIT
SET %=0
FOR
SET %=$ORDER(^DIE("AF",DQ,Y,0))
if %=""
QUIT
KILL ^(%),^DIE(%,"ROU")
+16 SET Y=0
FOR
SET Y=$ORDER(^DIPT("AF",DQ,Y))
if Y=""
GOTO KDD
SET %=0
FOR
SET %=$ORDER(^DIPT("AF",DQ,Y,0))
if %=""
QUIT
KILL ^(%),^DIPT(%,"ROU")
+17 ;
KIX(DIANC,DIFIL) ;
+1 NEW F,NM
+2 SET F=0
FOR
SET F=$ORDER(DIANC(F))
if 'F
QUIT
Begin DoDot:1
+3 SET NM=""
FOR
SET NM=$ORDER(^DD(F,0,"IX",NM))
if NM=""
QUIT
if $DATA(^(NM,DIFIL))
KILL ^(DIFIL)
End DoDot:1
+4 QUIT
KACOMP NEW DA,I,%
SET DA(1)=DQ
SET DA=Y
XECUTE ^DD(0,9.01,1,1,2)
QUIT
+1 ;
KTRB(DIANC,DIFIL,DIFLD) ;Kill 5 node of triggered field
+1 ;Also kill "TRB" nodes here if triggered field is in another file
+2 NEW %,F,DITFLD,DITFIL,DIXR,DIXR0
+3 SET DIXR=0
+4 FOR
SET DIXR=$ORDER(^DD(DIFIL,DIFLD,1,DIXR))
if 'DIXR
QUIT
SET DIXR0=$GET(^(DIXR,0))
if $PIECE(DIXR0,U,3)="TRIGGER"
Begin DoDot:1
+5 SET DITFIL=$PIECE(DIXR0,U,4)
SET DITFLD=$PIECE(DIXR0,U,5)
if 'DITFIL!'DITFLD
QUIT
+6 SET %=0
+7 FOR
SET %=$ORDER(^DD(DITFIL,DITFLD,5,%))
if '%
QUIT
IF $PIECE($GET(^(%,0)),U,1,3)=(DIFIL_U_DIFLD_U_DIXR)
Begin DoDot:2
+8 KILL ^DD(DITFIL,DITFLD,5,%)
if DITFIL=DIFIL!$DATA(DIANC(DITFIL))
QUIT
+9 SET F=DITFIL
+10 FOR
KILL ^DD(F,"TRB",DIFIL)
SET F=$GET(^DD(F,0,"UP"))
if 'F!$DATA(DIANC(+F))
QUIT
End DoDot:2
QUIT
End DoDot:1
+11 QUIT
DELXR(DIFIL) ;Delete the Key and Index file entries for file DIFIL
+1 if '$GET(DIFIL)
QUIT
+2 NEW DA,DIK
+3 ;
+4 ;Kill keys on file DIFIL
+5 SET DIK="^DD(""KEY"","
+6 SET DA=0
FOR
SET DA=$ORDER(^DD("KEY","B",DIFIL,DA))
if 'DA
QUIT
DO ^DIK
+7 ;
+8 ;Kill indexes on file DIFIL
+9 SET DIK="^DD(""IX"","
+10 SET DA=0
FOR
SET DA=$ORDER(^DD("IX","AC",DIFIL,DA))
if 'DA
QUIT
DO ^DIK
+11 QUIT
+12 ;
DELXRF(DIFIL,DIFLD,DIFLG,DITOPFIL) ;Delete Keys and Indexes on field
+1 ;If DIFLG=1, also delete the Indexes from the data global.
+2 if '$GET(DIFIL)!'$GET(DIFLD)
QUIT
+3 NEW DA,DIK
+4 ;
+5 ;Execute the kill logic for all indexes defined on the field
+6 ;for all entries in the file.
+7 IF $GET(DIFLG)
Begin DoDot:1
+8 if $GET(DITOPFIL)=""
SET DITOPFIL=$$FNO^DILIBF(DIFIL)
+9 if DITOPFIL
DO INDEX^DIKC(DITOPFIL,"",DIFLD,"","RKW"_DIFIL)
End DoDot:1
+10 ;
+11 ;Kill keys on file/field
+12 SET DIK="^DD(""KEY"","
+13 SET DA=0
FOR
SET DA=$ORDER(^DD("KEY","F",DIFIL,DIFLD,DA))
if 'DA
QUIT
DO ^DIK
+14 ;
+15 ;Kill indexes on file/field
+16 SET DIK="^DD(""IX"","
+17 SET DA=0
FOR
SET DA=$ORDER(^DD("IX","F",DIFIL,DIFLD,DA))
if 'DA
QUIT
DO ^DIK
+18 QUIT
