FBNHEDAD ;AISC/GRR - EDIT ADMISSION TYPE FOR NURSING HOME ;1/22/15 14:49
;;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)=""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 DR="5;8" D ^DIE
D
. N FB,FBX,DTOUT
. S FB(161)=$S(DA:$P($G(^FBAACNH(DA,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 admission.")
. I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
G RD1:'$D(DTOUT)
Q K DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHEDAD 823 printed Nov 22, 2024@17:09:06 Page 2
FBNHEDAD ;AISC/GRR - EDIT ADMISSION TYPE FOR NURSING HOME ;1/22/15 14:49
+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)=""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 SET DR="5;8"
DO ^DIE
+2 Begin DoDot:1
+3 NEW FB,FBX,DTOUT
+4 SET FB(161)=$SELECT(DA:$PIECE($GET(^FBAACNH(DA,0)),"^",10),1:"")
+5 if 'FB(161)
QUIT
+6 IF $DATA(^FBAAA(DFN,1,FB(161),0))
SET FB(78)=+$PIECE(^(0),"^",9)
+7 if '$GET(FB(78))
QUIT
+8 SET FBX=$$ADDUA^FBUTL9(162.4,FB(78)_",","Edit CNH admission.")
+9 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
+10 if '$DATA(DTOUT)
GOTO RD1
Q KILL DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG
+1 QUIT
