FBNHDLDI ;AISC/GRR - DELETE DISCHARGE FOR NURSING HOME ;1/22/15 13:39
;;3.5;FEE BASIS;**154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
RD1 D GETVET^FBAAUTL1 G:DFN']"" Q
I $D(^FBAACNH("AD",DFN)) W !!,*7,"Veteran presently has an active admission.",!,"You cannot delete a discharge when there is an active admission!",! G CKVEIW
RD2 S DIC("S")="I $P(^(0),U,3)=""D""&($P(^(0),U,2)=DFN)",DIC="^FBAACNH(",DIE=DIC,DIC(0)="AEQMZ",DLAYGO=162.3,DIC("A")="Select Discharge Date/Time: " D ^DIC K DIC,DLAYGO G RD1:X="^"!(X=""),RD2:Y<0 S DA=+Y
S FBCKDT=+Y(0) I $O(^FBAACNH("AF",DFN,0))<(9999999.9999-FBCKDT) W !!,*7,"There is activity following this discharge date.",!,"You must delete all subsequent activity before deleting this discharge." G RD1
S FBDA=$P(^FBAACNH(DA,0),"^",5)
S DIR("A")="Are you sure you want to delete this discharge",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G Q:$D(DTOUT),RD1:$D(DUOUT)!(Y=0)
S DIK="^FBAACNH(" D ^DIK S DIE="^FBAACNH(",DR="3////^S X=""Y""",DA=FBDA D ^DIE W !?5,"... deleted" D ALERT
I DFN D
. N FB,FBX
. S FB(161)=$S(FBDA:$P($G(^FBAACNH(FBDA,0)),"^",10),1:"")
. Q:'FB(161)
. I $D(^FBAAA(DFN,1,FB(161),0)) S FB(78)=+$P(^(0),"^",9)
. Q:'$G(FB(78))
. S FBX=$$ADDUA^FBUTL9(162.4,FB(78)_",","Delete CNH discharge.")
. I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
G RD1
Q K DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG,FBDA,FBCKDT
Q
CKVEIW S DIR("A")="Want data related to active admission displayed",DIR("B")="No",DIR(0)="Y" D ^DIR K DIR G RD1:$D(DTOUT)!$D(DUOUT)!(Y=0) S IFN=$O(^FBAACNH("AD",DFN,0)) D ^FBNHDEC
G RD1
ALERT W !!,*7,"It will be necessary to adjust the 'TO DATE' of this patient's authorization",!,"using the 'EDIT CNH AUTHORIZATION' option."
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHDLDI 1781 printed Nov 22, 2024@17:08:59 Page 2
FBNHDLDI ;AISC/GRR - DELETE DISCHARGE FOR NURSING HOME ;1/22/15 13:39
+1 ;;3.5;FEE BASIS;**154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
RD1 DO GETVET^FBAAUTL1
if DFN']""
GOTO Q
+1 IF $DATA(^FBAACNH("AD",DFN))
WRITE !!,*7,"Veteran presently has an active admission.",!,"You cannot delete a discharge when there is an active admission!",!
GOTO CKVEIW
RD2 SET DIC("S")="I $P(^(0),U,3)=""D""&($P(^(0),U,2)=DFN)"
SET DIC="^FBAACNH("
SET DIE=DIC
SET DIC(0)="AEQMZ"
SET DLAYGO=162.3
SET DIC("A")="Select Discharge Date/Time: "
DO ^DIC
KILL DIC,DLAYGO
if X="^"!(X="")
GOTO RD1
if Y<0
GOTO RD2
SET DA=+Y
+1 SET FBCKDT=+Y(0)
IF $ORDER(^FBAACNH("AF",DFN,0))<(9999999.9999-FBCKDT)
WRITE !!,*7,"There is activity following this discharge date.",!,"You must delete all subsequent activity before deleting this discharge."
GOTO RD1
+2 SET FBDA=$PIECE(^FBAACNH(DA,0),"^",5)
+3 SET DIR("A")="Are you sure you want to delete this discharge"
SET DIR(0)="Y"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if $DATA(DTOUT)
GOTO Q
if $DATA(DUOUT)!(Y=0)
GOTO RD1
+4 SET DIK="^FBAACNH("
DO ^DIK
SET DIE="^FBAACNH("
SET DR="3////^S X=""Y"""
SET DA=FBDA
DO ^DIE
WRITE !?5,"... deleted"
DO ALERT
+5 IF DFN
Begin DoDot:1
+6 NEW FB,FBX
+7 SET FB(161)=$SELECT(FBDA:$PIECE($GET(^FBAACNH(FBDA,0)),"^",10),1:"")
+8 if 'FB(161)
QUIT
+9 IF $DATA(^FBAAA(DFN,1,FB(161),0))
SET FB(78)=+$PIECE(^(0),"^",9)
+10 if '$GET(FB(78))
QUIT
+11 SET FBX=$$ADDUA^FBUTL9(162.4,FB(78)_",","Delete CNH discharge.")
+12 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
+13 GOTO RD1
Q KILL DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG,FBDA,FBCKDT
+1 QUIT
CKVEIW SET DIR("A")="Want data related to active admission displayed"
SET DIR("B")="No"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
if $DATA(DTOUT)!$DATA(DUOUT)!(Y=0)
GOTO RD1
SET IFN=$ORDER(^FBAACNH("AD",DFN,0))
DO ^FBNHDEC
+1 GOTO RD1
ALERT WRITE !!,*7,"It will be necessary to adjust the 'TO DATE' of this patient's authorization",!,"using the 'EDIT CNH AUTHORIZATION' option."
