FBNHDLTR ;AISC/GRR - DELETE TRANSFER FOR NURSING HOME ;1/22/15 14:13
;;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
RD2 S DIC("S")="I $P(^(0),U,3)=""T""&($P(^(0),U,2)=DFN)",DIC="^FBAACNH(",DIE=DIC,DIC(0)="AEQMZ",DLAYGO=162.3,DIC("A")="Select Transfer Date/Time: " D ^DIC K DIC,DLAYGO G RD1:X="^"!(X=""),RD2:Y<0 S DA=+Y
S FBDA(0)=Y(0),FBDA=$P(FBDA(0),U,5) D G Q:$D(FBERR)
.I $O(^FBAACNH("AC",FBDA,DA)) W !,*7,"There are movements following this transfer that must be deleted first.",!! S FBERR=1
S DIR("A")="Are you sure you want to delete this transfer",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G Q:$D(DTOUT),RD1:$D(DUOUT)!(Y=0)
S DIK="^FBAACNH(" D ^DIK
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 transfer.")
. I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
K FBDA G RD1
Q K DIC,DIE,DR,DA,DFN,DIR,FBTYPE,FTP,Y,X,FBPROG,FBDA,FBERR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHDLTR 1155 printed Dec 13, 2024@01:58:49 Page 2
FBNHDLTR ;AISC/GRR - DELETE TRANSFER FOR NURSING HOME ;1/22/15 14:13
+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
RD2 SET DIC("S")="I $P(^(0),U,3)=""T""&($P(^(0),U,2)=DFN)"
SET DIC="^FBAACNH("
SET DIE=DIC
SET DIC(0)="AEQMZ"
SET DLAYGO=162.3
SET DIC("A")="Select Transfer Date/Time: "
DO ^DIC
KILL DIC,DLAYGO
if X="^"!(X="")
GOTO RD1
if Y<0
GOTO RD2
SET DA=+Y
+1 SET FBDA(0)=Y(0)
SET FBDA=$PIECE(FBDA(0),U,5)
Begin DoDot:1
+2 IF $ORDER(^FBAACNH("AC",FBDA,DA))
WRITE !,*7,"There are movements following this transfer that must be deleted first.",!!
SET FBERR=1
End DoDot:1
if $DATA(FBERR)
GOTO Q
+3 SET DIR("A")="Are you sure you want to delete this transfer"
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
+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 transfer.")
+12 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
+13 KILL FBDA
GOTO RD1
Q KILL DIC,DIE,DR,DA,DFN,DIR,FBTYPE,FTP,Y,X,FBPROG,FBDA,FBERR
+1 QUIT
