FBNHDLAD ;AISC/GRR - DELETE ADMISSION FOR NURSING HOME ;1/22/15 13:18
;;3.5;FEE BASIS;**82,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
RD1 D GETVET^FBAAUTL1 G:DFN']"" Q W !
RD2 S DIC("S")="I $P(^(0),U,3)=""A""&($P(^(0),U,2)=DFN)",DIC="^FBAACNH(",DIE=DIC,DIC(0)="AEQMZ",DLAYGO=162.3,DIC("A")="Select Admission Date/Time: " D ^DIC K DIC,DLAYGO G RD1:X="^"!(X=""),RD2:Y<0 S DA=+Y
S FB("ADDT")=$P(Y(0),"^") ; admission date/time
S FB(161)=$P(Y(0),"^",10)
I $O(^FBAACNH("AC",DA,DA))>0 W !!,*7,"Other movements associated with this admission are still on file.",!,"You cannot delete the admission when other movements exist!" G CKVEIW
S DIR("A")="Are you sure you want to delete this admission",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G Q:$D(DTOUT)!$D(DUOUT),RD1:Y=0
I FB(161),$D(^FBAAA(DFN,1,FB(161),0)) S FB(78)=$P($P(^(0),"^",9),";")
I $G(FB(78)) S FB(1625)=+$O(^FBAAI("E",FB(78)_";FB7078(",0))
I $G(FB(1625)),$D(^FBAAI(FB(1625),0)) W *7,!,"Unable to delete. Payments already made against this admission!",!! G RD1
S DIK=DIE D ^DIK K DIK W !?5,"...deleted",!
D PTFD^FBUTL6(DFN,FB("ADDT")) ; delete associated PTF record
D
. N FBX
. S FBX=$$ADDUA^FBUTL9(162.4,FB(78)_",","Delete CNH admission.")
. I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
K FB
G RD1
Q K DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG,FB,FBZZ,ZZZ
Q
CKVEIW S DIR("A")="Want data related to this admission displayed",DIR("B")="No",DIR(0)="Y" D ^DIR K DIR G RD1:$D(DTOUT)!$D(DUOUT)!(Y=0) S IFN=DA D ^FBNHDEC
G RD1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHDLAD 1581 printed Dec 13, 2024@01:58:47 Page 2
FBNHDLAD ;AISC/GRR - DELETE ADMISSION FOR NURSING HOME ;1/22/15 13:18
+1 ;;3.5;FEE BASIS;**82,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
WRITE !
RD2 SET DIC("S")="I $P(^(0),U,3)=""A""&($P(^(0),U,2)=DFN)"
SET DIC="^FBAACNH("
SET DIE=DIC
SET DIC(0)="AEQMZ"
SET DLAYGO=162.3
SET DIC("A")="Select Admission Date/Time: "
DO ^DIC
KILL DIC,DLAYGO
if X="^"!(X="")
GOTO RD1
if Y<0
GOTO RD2
SET DA=+Y
+1 ; admission date/time
SET FB("ADDT")=$PIECE(Y(0),"^")
+2 SET FB(161)=$PIECE(Y(0),"^",10)
+3 IF $ORDER(^FBAACNH("AC",DA,DA))>0
WRITE !!,*7,"Other movements associated with this admission are still on file.",!,"You cannot delete the admission when other movements exist!"
GOTO CKVEIW
+4 SET DIR("A")="Are you sure you want to delete this admission"
SET DIR(0)="Y"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO Q
if Y=0
GOTO RD1
+5 IF FB(161)
IF $DATA(^FBAAA(DFN,1,FB(161),0))
SET FB(78)=$PIECE($PIECE(^(0),"^",9),";")
+6 IF $GET(FB(78))
SET FB(1625)=+$ORDER(^FBAAI("E",FB(78)_";FB7078(",0))
+7 IF $GET(FB(1625))
IF $DATA(^FBAAI(FB(1625),0))
WRITE *7,!,"Unable to delete. Payments already made against this admission!",!!
GOTO RD1
+8 SET DIK=DIE
DO ^DIK
KILL DIK
WRITE !?5,"...deleted",!
+9 ; delete associated PTF record
DO PTFD^FBUTL6(DFN,FB("ADDT"))
+10 Begin DoDot:1
+11 NEW FBX
+12 SET FBX=$$ADDUA^FBUTL9(162.4,FB(78)_",","Delete CNH admission.")
+13 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
+14 KILL FB
+15 GOTO RD1
Q KILL DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG,FB,FBZZ,ZZZ
+1 QUIT
CKVEIW SET DIR("A")="Want data related to this 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=DA
DO ^FBNHDEC
+1 GOTO RD1
