FBNHEA ;AISC/GRR - ENTER ADMISSION TO NURSING HOME ;1/22/15 14:23
;;3.5;FEE BASIS;**82,108,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)) G CKVEIW
RD0 S FBPROG="I $P(^(0),U,3)=7" D GETAUTH^FBAAUTL1 G RD1:FTP']"",RD1:$D(DUOUT),Q:$D(DTOUT) I FBTYPE'=7 D WRONGT^FBAAUTL1 G RD0
RD2 I $D(^FBAACNH("AD",DFN)) G CKVEIW
S FBLTD=$O(^FBAACNH("AF",DFN,0)) K:FBLTD<1 FBLTD S FBTRT="A",DIR(0)="DA^"_FBAABDT_".000001:"_FBAABDT_".999999:EXR",DIR("A")="Enter Admission Date/Time: ",DIR("?")="Enter date pt. admitted to CNH facility (time is required)"
D ^DIR K DIR G:$D(DIRUT)!'Y Q S FBY=+Y D DATCK2^FBAAUTL1 G:'$D(X) RD2
S DIR(0)="S^1:AFTER RE-HOSPITALIZATION >15 DAYS;2:TRANSFER FROM OTHER CNH;3:FROM ASIH <15 DAYS;4:ALL OTHER",DIR("A")="Enter Admission Type" D ^DIR K DIR G:$D(DIRUT) Q S FBZ=+Y
K DD,DO S X=FBY,DIC="^FBAACNH(",DIE=DIC,DIC(0)="LM",DLAYGO=162.3 D FILE^DICN G RD1:$D(DUOUT)!($D(DTOUT)),RD2:Y<0 S DA=+Y K DIC,DLAYGO
D
. N FBX,DIE,DA
. S FBX=$$ADDUA^FBUTL9(162.4,FB7078_",","Enter CNH admission.")
. I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
S DR="8////^S X=FBVEN;Q;9////^S X=FTP;1////^S X=DFN;2////^S X=""A"";3////^S X=""Y"";4////^S X=DA;5////^S X=FBZ" D ^DIE I '$D(DTOUT) D PTFC^FBUTL6(DFN,FBY) I '$G(FBRCHK) G RD1
Q K DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG,FBVEN,CNT,DAT,F,FB7078,FBAABDT,FBAAEDT,FBAAOUT,FBASSOC,FBAUT,FBDX,FBI,FBLOC,FBPOV,FBPSA,FBPT,I,FBRR,FBTT,PI,PTYPE,T,TA,Z,ZZ,CNT,FBAUT,TA,DIRUT,DUOUT,DTOUT,FBY,FBLTD,FBTRT
K FBZ,FBRCHK
D GETAUTHK^FBAAUTL1
Q
CKVEIW W !!,*7,"Veteran already has an active admission, you may use the edit option to edit it.",!
S DIR(0)="Y",DIR("A")="Want data related to active admission displayed",DIR("B")="NO" D ^DIR K DIR I Y S IFN=$O(^FBAACNH("AD",DFN,0)) D ^FBNHDEC
I '$G(FBRCHK) G RD1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHEA 1905 printed Nov 22, 2024@17:09:01 Page 2
FBNHEA ;AISC/GRR - ENTER ADMISSION TO NURSING HOME ;1/22/15 14:23
+1 ;;3.5;FEE BASIS;**82,108,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))
GOTO CKVEIW
RD0 SET FBPROG="I $P(^(0),U,3)=7"
DO GETAUTH^FBAAUTL1
if FTP']""
GOTO RD1
if $DATA(DUOUT)
GOTO RD1
if $DATA(DTOUT)
GOTO Q
IF FBTYPE'=7
DO WRONGT^FBAAUTL1
GOTO RD0
RD2 IF $DATA(^FBAACNH("AD",DFN))
GOTO CKVEIW
+1 SET FBLTD=$ORDER(^FBAACNH("AF",DFN,0))
if FBLTD<1
KILL FBLTD
SET FBTRT="A"
SET DIR(0)="DA^"_FBAABDT_".000001:"_FBAABDT_".999999:EXR"
SET DIR("A")="Enter Admission Date/Time: "
SET DIR("?")="Enter date pt. admitted to CNH facility (time is required)"
+2 DO ^DIR
KILL DIR
if $DATA(DIRUT)!'Y
GOTO Q
SET FBY=+Y
DO DATCK2^FBAAUTL1
if '$DATA(X)
GOTO RD2
+3 SET DIR(0)="S^1:AFTER RE-HOSPITALIZATION >15 DAYS;2:TRANSFER FROM OTHER CNH;3:FROM ASIH <15 DAYS;4:ALL OTHER"
SET DIR("A")="Enter Admission Type"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO Q
SET FBZ=+Y
+4 KILL DD,DO
SET X=FBY
SET DIC="^FBAACNH("
SET DIE=DIC
SET DIC(0)="LM"
SET DLAYGO=162.3
DO FILE^DICN
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO RD1
if Y<0
GOTO RD2
SET DA=+Y
KILL DIC,DLAYGO
+5 Begin DoDot:1
+6 NEW FBX,DIE,DA
+7 SET FBX=$$ADDUA^FBUTL9(162.4,FB7078_",","Enter CNH admission.")
+8 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
+9 SET DR="8////^S X=FBVEN;Q;9////^S X=FTP;1////^S X=DFN;2////^S X=""A"";3////^S X=""Y"";4////^S X=DA;5////^S X=FBZ"
DO ^DIE
IF '$DATA(DTOUT)
DO PTFC^FBUTL6(DFN,FBY)
IF '$GET(FBRCHK)
GOTO RD1
Q KILL DIC,DIE,DR,DA,DFN,FBTYPE,FTP,Y,X,FBPROG,FBVEN,CNT,DAT,F,FB7078,FBAABDT,FBAAEDT,FBAAOUT,FBASSOC,FBAUT,FBDX,FBI,FBLOC,FBPOV,FBPSA,FBPT,I,FBRR,FBTT,PI,PTYPE,T,TA,Z,ZZ,CNT,FBAUT,TA,DIRUT,DUOUT,DTOUT,FBY,FBLTD,FBTRT
+1 KILL FBZ,FBRCHK
+2 DO GETAUTHK^FBAAUTL1
+3 QUIT
CKVEIW WRITE !!,*7,"Veteran already has an active admission, you may use the edit option to edit it.",!
+1 SET DIR(0)="Y"
SET DIR("A")="Want data related to active admission displayed"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF Y
SET IFN=$ORDER(^FBAACNH("AD",DFN,0))
DO ^FBNHDEC
+2 IF '$GET(FBRCHK)
GOTO RD1
+3 QUIT
