- 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
