- 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 Jan 18, 2025@03:46:31 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