DIE2 ;SFISC/GFT,XAK-DELETE AN ENTRY ;12:37 PM 20 Feb 2003
;;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.
;
D F,DL Q:$D(DTOUT) G B^DIED:Y=2,A^DIED:Y,UP^DIE1:DL>1,Q^DIE1
;
F S D=$P(DQ(DQ),U,4) S:DP+1 D=DIFLD Q
;
Z S DIEZFLAG=1 D DL K DIEZFLAG S DU="" I Y=2 G @(DQ_U_DNM)
I Y D:$G(DE(DW,"INDEX")) SAVEVALS^@DNM G @("A^"_DNM)
G R^DIE9:DL>1,E^DIE9
DL ;
S %=DP,X=D,Y=$P(DQ(DQ),U,4)="0;1"
G X:$D(DE(DQ))[0,X:DV["R"&'Y,X:$D(^DD("KEY","F",DP,D))&'Y,S:DP<0,DD:DUZ(0)="@" I DV S %=+$P(DC,U,2),X=.01
G DD:DP<2 I $D(DIDEL),DIDEL\1=(DP\1) G DD
I Y,$S($D(^VA(200,"AFOF")):1,1:$D(^DIC(3,"AFOF"))) G DD:$D(^DD(DP,0,"UP"))!DV,DAR:'$S($D(^VA(200,DUZ,"FOF",DP)):1,1:$D(^DIC(3,DUZ,"FOF",DP))),DAR:'$P(^(DP,0),U,3),DD
I Y,$D(^DIC(%,0,"DEL")) S X=^("DEL")
E G DD:'$D(^DD(%,X,8.5)) S X=^(8.5)
G DD:X="" F %=1:1:$L(X) G DD:DUZ(0)[$E(X,%)
DAR D ;**CCO/NI "DELETE ACCESS REQUIRED" thru next 5 lines
.N IN,OUT
.S IN(1)=$$LABEL^DIALOGZ(DP,DIFLD),IN(2)=$$FILENAME^DIALOGZ(DP)
.D BLD^DIALOG(712,.IN,,"OUT"),EN^DDIOL(.OUT)
X I $D(DB(DQ)) D N G A
W:$D(^DD("KEY","F",DP,D))!(DV["R")&'$D(DIER) " ",$$EZBLD^DIALOG(8041) G R ;This is a required response. Enter '^' to exit
;
;
DD G MD:DV S DH=0,DU=0 F S DH=$O(^DD(DP,D,"DEL",DH)) Q:DH="" I $D(^(DH,0)) X ^(0) Q:$D(DTOUT) G X:$T ;IF SWITCH ON MEANS NO DELETION ALLOWED
CC ;CONSISTENCY CHECK WOULD GO HERE
S DH=-1,X=DQ(DQ) I Y,$E(@(DIE_"0)"))'=U S X=^(0)
D D G R:X I Y D FIREREC(DP) S X=DE(DQ) D DEL:$D(DIU(0)) K DE,DG,DQ,DB S DIK=DIE D ^DIK S Y=0 K:DL<2 DA Q
S S X="",DG($P(DQ(DQ),U,4))="" D:'$G(DIEZFLAG) LOADXR^DIED
A S Y=1 Q
;
D I $D(DB(DQ)) S X=0 Q
W $C(7),!?3,"SURE YOU WANT TO DELETE"
I Y W " THE ENTIRE " W:DV'["D"&(DV'["P")&(DV'["V") "'"_DE(DQ)_"' " W $P(X,U,1)
S %=0,X=0 D YN^DICN Q:%=1 S X=1 W:$X>55 !?9
N I $D(DE(DQ))#2,'$D(DDS) W:'$D(ZTQUEUED) $C(7)," <NOTHING DELETED>"
Q
;
MD G X:DV["R"&($P(DC,U,5)=1) S DH=0,DU=0 F S DH=$O(^DD(+$P(DC,U,2),.01,"DEL",DH)) Q:DH="" I $D(^(DH,0)) D DDA X ^(0) D UDA G X:$T
S DH=-1,Y=DC>1,X=$E(DQ(DQ),8,99) D D
I 'X D DDA D FIREREC(+$P(DC,U,2)) S DIK=DIC D ^DIK,UDA K DE(DQ) S X=$P(@(DIK_"0)"),U,3,4),DC=$P(DC,U,1,3)_U_X,DIC=DIE S:$D(^(+X,0)) DE(DQ)=$P(^(0),U,1)
R S Y=2 Q
;
DDA N T,X
S T=$T
F X=+$O(DA(" "),-1):-1:1 K DA(X+1) S:$D(DA(X))#2 DA(X+1)=DA(X)
S:$D(DA)#2 DA(1)=DA
S DIC=DIE_DA_","""_$P(DC,U,3)_""",",DA=$P(DC,U,4)
S:$D(DIETMP)#2 DIIENS=DA_","_DIIENS
I T
Q
;
UDA N T,X
S T=$T
S DA=$G(DA(1)) ;K DA(1)
F X=2:1:+$O(DA(" "),-1) I $D(DA(X))#2 S DA(X-1)=DA(X) K DA(X)
S:$D(DIETMP)#2 DIIENS=$P(DIIENS,",",2,999)
I T
Q
QS ;
G ^DIEQ
QQ ;
G QQ^DIEQ
Q
DEL I '$S($D(^VA(200,"AFOF",DA)):1,1:$D(^DIC(3,"AFOF",DA))) Q
S DA(1)="",DIFOF=DA
F P=0:0 S DA(1)=$S($D(^VA(200,"AFOF")):$O(^VA(200,"AFOF",DA,DA(1))),1:$O(^DIC(3,"AFOF",DA,DA(1)))) Q:'DA(1) I $S($D(^VA(200,DA(1),"FOF",DA)):1,1:$D(^DIC(3,DA(1),"FOF",DA))) S DIK=$S($D(^VA(200)):"^VA(200,",1:"^DIC(3,")_DA(1)_",""FOF""," D ^DIK
K DA S DA=DIFOF K DIFOF
Q
V ;
G ^DIE3
;
FIREREC(DIFILE) ;Fire record-level xrefs accumulated in ^TMP for file
;or subfile DIFILE and all its subfiles
G:$G(DIEZFLAG) FIRERECZ
Q:$D(DIETMP)[0
Q:$D(@DIETMP@("R"))<2
;
;If we're at top level, fire all accumulated record-level xrefs
N X,Y
I '$G(^DD(DIFILE,0,"UP")) D FIREREC^DIE1 Q
;
;Save the DA array and DIIENS
N DASV,DIIENSSV
M DASV=DA S DIIENSSV=DIIENS
;
;Get list of subfiles under DIFILE
N DA,DIE,DIFLIST,DIIENS,DIPAT,DP
D SUBFILES^DIKCU(DIFILE,.DIFLIST)
S DIFLIST(DIFILE)=""
S DIPAT=".E1"""_DIIENSSV_""""
;
;Fire record-level cross references DIFILE and its subfiles
S DP=0 F S DP=$O(DIFLIST(DP)) Q:'DP D
. Q:'$D(@DIETMP@("R",DP))
. S DIIENS=" " F S DIIENS=$O(@DIETMP@("R",DP,DIIENS)) Q:DIIENS="" D
.. Q:DIIENS'?@DIPAT
.. S DIE=@DIETMP@("R",DP,DIIENS)
.. D DA^DILF(DIIENS,.DA)
.. D FIRE^DIKC(DP,.DA,"KS",$NA(@DIETMP@("R")),"F")
.. K @DIETMP@("R",DP,DIIENS),@DIETMP@("V",DP,DIIENS)
. K:'$D(@DIETMP@("V",DP)) @DIETMP@("R",DP)
Q
;
FIRERECZ ;Come here from FIREREC above, for compiled templates
Q:'$D(DIEZRXR)
;
;If we're at top level, fire all accumulated record-level xrefs
N X,Y
I '$G(^DD(DIFILE,0,"UP")) D FIREREC^DIE17 Q
;
;Save the DA array and DIIENS
N DASV,DIIENSSV
M DASV=DA S DIIENSSV=DIIENS
;
;Get list of subfiles under DIFILE
N DA,DIE,DIEZXR,DIFLIST,DIIENS,DIPAT,DP
D SUBFILES^DIKCU(DIFILE,.DIFLIST)
S DIFLIST(DIFILE)=""
S DIPAT=".E1"""_DIIENSSV_""""
;
;Fire record-level cross references DIFILE and its subfiles
S DP=0 F S DP=$O(DIFLIST(DP)) Q:'DP D
. Q:'$D(DIEZRXR(DP))
. S DIIENS=" " F S DIIENS=$O(DIEZRXR(DP,DIIENS)) Q:DIIENS="" D
.. Q:DIIENS'?@DIPAT
.. S DIE=DIEZRXR(DP,DIIENS)
.. D DA^DILF(DIIENS,.DA)
.. S DIEZXR=0 F S DIEZXR=$O(DIEZRXR(DP,DIEZXR)) Q:DIEZXR'=+DIEZXR D
... D:$D(DIEZAR(DP,DIEZXR))#2 @DIEZAR(DP,DIEZXR)
.. K DIEZRXR(DP,DIIENS),@DIETMP@("V",DP,DIIENS)
. K:'$D(@DIETMP@("V",DP)) DIEZRXR(DP)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIE2 5236 printed Oct 16, 2024@18:47:36 Page 2
DIE2 ;SFISC/GFT,XAK-DELETE AN ENTRY ;12:37 PM 20 Feb 2003
+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 DO F
DO DL
if $DATA(DTOUT)
QUIT
if Y=2
GOTO B^DIED
if Y
GOTO A^DIED
if DL>1
GOTO UP^DIE1
GOTO Q^DIE1
+8 ;
F SET D=$PIECE(DQ(DQ),U,4)
if DP+1
SET D=DIFLD
QUIT
+1 ;
Z SET DIEZFLAG=1
DO DL
KILL DIEZFLAG
SET DU=""
IF Y=2
GOTO @(DQ_U_DNM)
+1 IF Y
if $GET(DE(DW,"INDEX"))
DO SAVEVALS^@DNM
GOTO @("A^"_DNM)
+2 if DL>1
GOTO R^DIE9
GOTO E^DIE9
DL ;
+1 SET %=DP
SET X=D
SET Y=$PIECE(DQ(DQ),U,4)="0;1"
+2 if $DATA(DE(DQ))[0
GOTO X
if DV["R"&'Y
GOTO X
if $DATA(^DD("KEY","F",DP,D))&'Y
GOTO X
if DP<0
GOTO S
if DUZ(0)="@"
GOTO DD
IF DV
SET %=+$PIECE(DC,U,2)
SET X=.01
+3 if DP<2
GOTO DD
IF $DATA(DIDEL)
IF DIDEL\1=(DP\1)
GOTO DD
+4 IF Y
IF $SELECT($DATA(^VA(200,"AFOF")):1,1:$DATA(^DIC(3,"AFOF")))
if $DATA(^DD(DP,0,"UP"))!DV
GOTO DD
if '$SELECT($DATA(^VA(200,DUZ,"FOF",DP)):1,1:$DATA(^DIC(3,DUZ,"FOF",DP)))
GOTO DAR
if '$PIECE(^(DP,0),U,3)
GOTO DAR
GOTO DD
+5 IF Y
IF $DATA(^DIC(%,0,"DEL"))
SET X=^("DEL")
+6 IF '$TEST
if '$DATA(^DD(%,X,8.5))
GOTO DD
SET X=^(8.5)
+7 if X=""
GOTO DD
FOR %=1:1:$LENGTH(X)
if DUZ(0)[$EXTRACT(X,%)
GOTO DD
DAR ;**CCO/NI "DELETE ACCESS REQUIRED" thru next 5 lines
Begin DoDot:1
+1 NEW IN,OUT
+2 SET IN(1)=$$LABEL^DIALOGZ(DP,DIFLD)
SET IN(2)=$$FILENAME^DIALOGZ(DP)
+3 DO BLD^DIALOG(712,.IN,,"OUT")
DO EN^DDIOL(.OUT)
End DoDot:1
X IF $DATA(DB(DQ))
DO N
GOTO A
+1 ;This is a required response. Enter '^' to exit
if $DATA(^DD("KEY","F",DP,D))!(DV["R")&'$DATA(DIER)
WRITE " ",$$EZBLD^DIALOG(8041)
GOTO R
+2 ;
+3 ;
DD ;IF SWITCH ON MEANS NO DELETION ALLOWED
if DV
GOTO MD
SET DH=0
SET DU=0
FOR
SET DH=$ORDER(^DD(DP,D,"DEL",DH))
if DH=""
QUIT
IF $DATA(^(DH,0))
XECUTE ^(0)
if $DATA(DTOUT)
QUIT
if $TEST
GOTO X
CC ;CONSISTENCY CHECK WOULD GO HERE
+1 SET DH=-1
SET X=DQ(DQ)
IF Y
IF $EXTRACT(@(DIE_"0)"))'=U
SET X=^(0)
+2 DO D
if X
GOTO R
IF Y
DO FIREREC(DP)
SET X=DE(DQ)
if $DATA(DIU(0))
DO DEL
KILL DE,DG,DQ,DB
SET DIK=DIE
DO ^DIK
SET Y=0
if DL<2
KILL DA
QUIT
S SET X=""
SET DG($PIECE(DQ(DQ),U,4))=""
if '$GET(DIEZFLAG)
DO LOADXR^DIED
A SET Y=1
QUIT
+1 ;
D IF $DATA(DB(DQ))
SET X=0
QUIT
+1 WRITE $CHAR(7),!?3,"SURE YOU WANT TO DELETE"
+2 IF Y
WRITE " THE ENTIRE "
if DV'["D"&(DV'["P")&(DV'["V")
WRITE "'"_DE(DQ)_"' "
WRITE $PIECE(X,U,1)
+3 SET %=0
SET X=0
DO YN^DICN
if %=1
QUIT
SET X=1
if $X>55
WRITE !?9
N IF $DATA(DE(DQ))#2
IF '$DATA(DDS)
if '$DATA(ZTQUEUED)
WRITE $CHAR(7)," <NOTHING DELETED>"
+1 QUIT
+2 ;
MD if DV["R"&($PIECE(DC,U,5)=1)
GOTO X
SET DH=0
SET DU=0
FOR
SET DH=$ORDER(^DD(+$PIECE(DC,U,2),.01,"DEL",DH))
if DH=""
QUIT
IF $DATA(^(DH,0))
DO DDA
XECUTE ^(0)
DO UDA
if $TEST
GOTO X
+1 SET DH=-1
SET Y=DC>1
SET X=$EXTRACT(DQ(DQ),8,99)
DO D
+2 IF 'X
DO DDA
DO FIREREC(+$PIECE(DC,U,2))
SET DIK=DIC
DO ^DIK
DO UDA
KILL DE(DQ)
SET X=$PIECE(@(DIK_"0)"),U,3,4)
SET DC=$PIECE(DC,U,1,3)_U_X
SET DIC=DIE
if $DATA(^(+X,0))
SET DE(DQ)=$PIECE(^(0),U,1)
R SET Y=2
QUIT
+1 ;
DDA NEW T,X
+1 SET T=$TEST
+2 FOR X=+$ORDER(DA(" "),-1):-1:1
KILL DA(X+1)
if $DATA(DA(X))#2
SET DA(X+1)=DA(X)
+3 if $DATA(DA)#2
SET DA(1)=DA
+4 SET DIC=DIE_DA_","""_$PIECE(DC,U,3)_""","
SET DA=$PIECE(DC,U,4)
+5 if $DATA(DIETMP)#2
SET DIIENS=DA_","_DIIENS
+6 IF T
+7 QUIT
+8 ;
UDA NEW T,X
+1 SET T=$TEST
+2 ;K DA(1)
SET DA=$GET(DA(1))
+3 FOR X=2:1:+$ORDER(DA(" "),-1)
IF $DATA(DA(X))#2
SET DA(X-1)=DA(X)
KILL DA(X)
+4 if $DATA(DIETMP)#2
SET DIIENS=$PIECE(DIIENS,",",2,999)
+5 IF T
+6 QUIT
QS ;
+1 GOTO ^DIEQ
QQ ;
+1 GOTO QQ^DIEQ
+2 QUIT
DEL IF '$SELECT($DATA(^VA(200,"AFOF",DA)):1,1:$DATA(^DIC(3,"AFOF",DA)))
QUIT
+1 SET DA(1)=""
SET DIFOF=DA
+2 FOR P=0:0
SET DA(1)=$SELECT($DATA(^VA(200,"AFOF")):$ORDER(^VA(200,"AFOF",DA,DA(1))),1:$ORDER(^DIC(3,"AFOF",DA,DA(1))))
if 'DA(1)
QUIT
IF $SELECT($DATA(^VA(200,DA(1),"FOF",DA)):1,1:$DATA(^DIC(3,DA(1),"FOF",DA)))
SET DIK=$SELECT($DATA(^VA(200)):"^VA(200,",1:"^DIC(3,")_DA(1)_",""FOF"","
DO ^DIK
+3 KILL DA
SET DA=DIFOF
KILL DIFOF
+4 QUIT
V ;
+1 GOTO ^DIE3
+2 ;
FIREREC(DIFILE) ;Fire record-level xrefs accumulated in ^TMP for file
+1 ;or subfile DIFILE and all its subfiles
+2 if $GET(DIEZFLAG)
GOTO FIRERECZ
+3 if $DATA(DIETMP)[0
QUIT
+4 if $DATA(@DIETMP@("R"))<2
QUIT
+5 ;
+6 ;If we're at top level, fire all accumulated record-level xrefs
+7 NEW X,Y
+8 IF '$GET(^DD(DIFILE,0,"UP"))
DO FIREREC^DIE1
QUIT
+9 ;
+10 ;Save the DA array and DIIENS
+11 NEW DASV,DIIENSSV
+12 MERGE DASV=DA
SET DIIENSSV=DIIENS
+13 ;
+14 ;Get list of subfiles under DIFILE
+15 NEW DA,DIE,DIFLIST,DIIENS,DIPAT,DP
+16 DO SUBFILES^DIKCU(DIFILE,.DIFLIST)
+17 SET DIFLIST(DIFILE)=""
+18 SET DIPAT=".E1"""_DIIENSSV_""""
+19 ;
+20 ;Fire record-level cross references DIFILE and its subfiles
+21 SET DP=0
FOR
SET DP=$ORDER(DIFLIST(DP))
if 'DP
QUIT
Begin DoDot:1
+22 if '$DATA(@DIETMP@("R",DP))
QUIT
+23 SET DIIENS=" "
FOR
SET DIIENS=$ORDER(@DIETMP@("R",DP,DIIENS))
if DIIENS=""
QUIT
Begin DoDot:2
+24 if DIIENS'?@DIPAT
QUIT
+25 SET DIE=@DIETMP@("R",DP,DIIENS)
+26 DO DA^DILF(DIIENS,.DA)
+27 DO FIRE^DIKC(DP,.DA,"KS",$NAME(@DIETMP@("R")),"F")
+28 KILL @DIETMP@("R",DP,DIIENS),@DIETMP@("V",DP,DIIENS)
End DoDot:2
+29 if '$DATA(@DIETMP@("V",DP))
KILL @DIETMP@("R",DP)
End DoDot:1
+30 QUIT
+31 ;
FIRERECZ ;Come here from FIREREC above, for compiled templates
+1 if '$DATA(DIEZRXR)
QUIT
+2 ;
+3 ;If we're at top level, fire all accumulated record-level xrefs
+4 NEW X,Y
+5 IF '$GET(^DD(DIFILE,0,"UP"))
DO FIREREC^DIE17
QUIT
+6 ;
+7 ;Save the DA array and DIIENS
+8 NEW DASV,DIIENSSV
+9 MERGE DASV=DA
SET DIIENSSV=DIIENS
+10 ;
+11 ;Get list of subfiles under DIFILE
+12 NEW DA,DIE,DIEZXR,DIFLIST,DIIENS,DIPAT,DP
+13 DO SUBFILES^DIKCU(DIFILE,.DIFLIST)
+14 SET DIFLIST(DIFILE)=""
+15 SET DIPAT=".E1"""_DIIENSSV_""""
+16 ;
+17 ;Fire record-level cross references DIFILE and its subfiles
+18 SET DP=0
FOR
SET DP=$ORDER(DIFLIST(DP))
if 'DP
QUIT
Begin DoDot:1
+19 if '$DATA(DIEZRXR(DP))
QUIT
+20 SET DIIENS=" "
FOR
SET DIIENS=$ORDER(DIEZRXR(DP,DIIENS))
if DIIENS=""
QUIT
Begin DoDot:2
+21 if DIIENS'?@DIPAT
QUIT
+22 SET DIE=DIEZRXR(DP,DIIENS)
+23 DO DA^DILF(DIIENS,.DA)
+24 SET DIEZXR=0
FOR
SET DIEZXR=$ORDER(DIEZRXR(DP,DIEZXR))
if DIEZXR'=+DIEZXR
QUIT
Begin DoDot:3
+25 if $DATA(DIEZAR(DP,DIEZXR))#2
DO @DIEZAR(DP,DIEZXR)
End DoDot:3
+26 KILL DIEZRXR(DP,DIIENS),@DIETMP@("V",DP,DIIENS)
End DoDot:2
+27 if '$DATA(@DIETMP@("V",DP))
KILL DIEZRXR(DP)
End DoDot:1
+28 QUIT
