FBNHEDDI ;AISC/GRR,JPN - EDIT DISCHARGE FOR NURSING HOME ;JUL 22,2019@08:43
;;3.5;FEE BASIS;**154,182**;JAN 30, 1995;Build 2
;;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)=""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,FBAADT=$P(Y,U,2)
S FBDIST=$P(^FBAACNH(DA,0),U,8)
S FBJ=9999999.999999-FBAADT F S FBJ=$O(^FBAACNH("AF",DFN,FBJ)) Q:'FBJ S FBK=$O(^FBAACNH("AF",DFN,FBJ,0)) I $P($G(^FBAACNH(FBK,0)),"^",5)=$P(^FBAACNH(DA,0),"^",5) D Q
.I $P(^FBAACNH(FBK,0),"^",7)=3 S FBASIH=1
S DIR(0)=$S($G(FBASIH):"S^4:ASIH;5:DEATH WHILE ASIH",1:"S^1:REGULAR;2:DEATH;3:TRANSFER TO OTHER CNH;6:REGULAR - PRIVATE PAY"),DIR("A")="Discharge Type: ",DIR("B")=FBDIST D ^DIR K DIR Q:$D(DIRUT) S FBZ=+Y
; S DR="7////^S X=FBZ" D ^DIE
;FB*3.5*182 changed from 4 slashes to 3
S DR="7///^S X=FBZ" D ^DIE
D
. N FB,FBDA,FBX
. S FBDA=$P($G(^FBAACNH(DA,0)),"^",5)
. Q:'FBDA
. 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)_",","Edit 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,FBASIH,FBK,FBJ,FBAADT,FBDIST,FBZ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHEDDI 1461 printed Dec 13, 2024@01:58:58 Page 2
FBNHEDDI ;AISC/GRR,JPN - EDIT DISCHARGE FOR NURSING HOME ;JUL 22,2019@08:43
+1 ;;3.5;FEE BASIS;**154,182**;JAN 30, 1995;Build 2
+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)=""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
SET FBAADT=$PIECE(Y,U,2)
+1 SET FBDIST=$PIECE(^FBAACNH(DA,0),U,8)
+2 SET FBJ=9999999.999999-FBAADT
FOR
SET FBJ=$ORDER(^FBAACNH("AF",DFN,FBJ))
if 'FBJ
QUIT
SET FBK=$ORDER(^FBAACNH("AF",DFN,FBJ,0))
IF $PIECE($GET(^FBAACNH(FBK,0)),"^",5)=$PIECE(^FBAACNH(DA,0),"^",5)
Begin DoDot:1
+3 IF $PIECE(^FBAACNH(FBK,0),"^",7)=3
SET FBASIH=1
End DoDot:1
QUIT
+4 SET DIR(0)=$SELECT($GET(FBASIH):"S^4:ASIH;5:DEATH WHILE ASIH",1:"S^1:REGULAR;2:DEATH;3:TRANSFER TO OTHER CNH;6:REGULAR - PRIVATE PAY")
SET DIR("A")="Discharge Type: "
SET DIR("B")=FBDIST
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET FBZ=+Y
+5 ; S DR="7////^S X=FBZ" D ^DIE
+6 ;FB*3.5*182 changed from 4 slashes to 3
+7 SET DR="7///^S X=FBZ"
DO ^DIE
+8 Begin DoDot:1
+9 NEW FB,FBDA,FBX
+10 SET FBDA=$PIECE($GET(^FBAACNH(DA,0)),"^",5)
+11 if 'FBDA
QUIT
+12 SET FB(161)=$SELECT(FBDA:$PIECE($GET(^FBAACNH(FBDA,0)),"^",10),1:"")
+13 if 'FB(161)
QUIT
+14 IF $DATA(^FBAAA(DFN,1,FB(161),0))
SET FB(78)=+$PIECE(^(0),"^",9)
+15 if '$GET(FB(78))
QUIT
+16 SET FBX=$$ADDUA^FBUTL9(162.4,FB(78)_",","Edit CNH discharge.")
+17 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
+18 GOTO RD1
Q KILL DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG,FBASIH,FBK,FBJ,FBAADT,FBDIST,FBZ
+1 QUIT
