DIE2 ;SFISC/GFT,XAK-DELETE AND ENTRY ;12:45 PM 17 Sep 2002 [ 12/09/2003 4:45 PM ]
;;22.0;VA FileMan;**4,11,95,1002**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
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 W !,"'DELETE ACCESS' REQUIRED!!"
X I $D(DB(DQ)) D N G A
W:'$D(DIER) $C(7),"??" W:DV["R"&'$D(DIER) " Required" W:$D(^DD("KEY","F",DP,D))&'$D(DIER) $S(DV'["R":" Required",1:"")_" Key field" G R
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
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
DIE2 ;SFISC/GFT,XAK-DELETE AND ENTRY ;12:45 PM 17 Sep 2002 [ 12/09/2003 4:45 PM ]
+1 ;;22.0;VA FileMan;**4,11,95,1002**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 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
+4 ;
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 WRITE !,"'DELETE ACCESS' REQUIRED!!"
X IF $DATA(DB(DQ))
DO N
GOTO A
+1 IF '$DATA(DIER)
WRITE $CHAR(7),"??"
IF DV["R"&'$DATA(DIER)
WRITE " Required"
IF $DATA(^DD("KEY","F",DP,D))&'$DATA(DIER)
WRITE $SELECT(DV'["R":" Required",1:"")_" Key field"
GOTO R
DD 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
+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
