FBNHED ;AISC/GRR - ENTER DISCHARGE FROM NURSING HOME ;1/22/15 14:38
;;3.5;FEE BASIS;**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)) W !!,*7,"Veteran does NOT have an active admission!" G RD1
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
S IFN=+$O(^FBAACNH("AD",DFN,0)),FBTRT="D",FB(0)=$G(^FBAACNH(IFN,0)),FBLAD=$P(FB(0),"^",1),FBLTD=$O(^FBAACNH("AF",DFN,0)) D ^FBNHDEC
RD2 S DIR(0)="DA^::EXR",DIR("A")="Enter Discharge Date/Time: ",DIR("?")="Enter date of discharge (time is required)" D ^DIR K DIR G:$D(DIRUT)!'Y Q S FBY=+Y D DATCK2^FBAAUTL1 G:'$D(X) RD2
;check to see if enough rate info to date of discharge
D DRIV^FBNHRAT(DFN,IFN,.FB,$P(FBY,".")) I $D(FBUNR) D D Q G RD1
.W !!,*7,"Unable to establish rates for the following timeframes:"
.S J=0 F S J=$O(FBUNR(J)) Q:'J W !?5,$$DATX^FBAAUTL(J)," through ",$$DATX^FBAAUTL($O(FBUNR(J,0)))
.W !!,*7,"You can not discharge this patient without sufficient rate information.",!,"Check your contract!"
S FBJ=0 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)=IFN 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")="Enter Discharge 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
S DR="8////^S X=FBVEN;1////^S X=DFN;2////^S X=""D"";4////^S X=IFN;7////^S X=FBZ" D ^DIE K DIE
D
. N FBX
. S FBX=$$ADDUA^FBUTL9(162.4,FB7078_",","Enter CNH discharge.")
. I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
S DIE="^FBAACNH(",DA=IFN,DR="3///@" D ^DIE
D UPDT
G RD1
Q K FBTRT,FBTYPE,FBLAD,FTP,FBPROG,CNT,DAT,DIC,FBAUT,F,FBAAOUT,FBDX,FBI,FBRR,FBXX,I,PI,PTYPE,T,X,Y,Z,ZZ,FBY,FB7078,FBAAAD,FBAABDT,FBAAEDT,FBASSOC,FBAT,FBLOC,FBLTD,FBPDT,FBPOV,FBY1,FBNHED,FBUNR,DFN,IFN,FBASIH,FBJ,FBK
K FBPSA,FBPT,FBTT,FBVEN D Q^FBNHRAT D GETAUTHK^FBAAUTL1 Q
UPDT S DA(1)=DFN,FBY1=$P(FBY,".")
S DIE="^FBAAA("_DA(1)_",1,",DR=".02////^S X=FBY1",DA=FTP D ^DIE K DIE,DR
K DA S DIE="^FB7078(",DR="4////^S X=FBY1",DA=FB7078 D ^DIE K DIE,DR
;update rate sensitive file since To Date of authorization is changed
Q:FBY1>FBAAEDT
S (FBO,FBAA(1))=FBAABDT,FB1=FBAAEDT,FBAA(2)=FBY1
D UPDATE^FBNHEDA1
K FBO,FBAA,FB1,FBZ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHED 2624 printed Dec 13, 2024@01:58:54 Page 2
FBNHED ;AISC/GRR - ENTER DISCHARGE FROM NURSING HOME ;1/22/15 14:38
+1 ;;3.5;FEE BASIS;**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))
WRITE !!,*7,"Veteran does NOT have an active admission!"
GOTO RD1
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
+1 SET IFN=+$ORDER(^FBAACNH("AD",DFN,0))
SET FBTRT="D"
SET FB(0)=$GET(^FBAACNH(IFN,0))
SET FBLAD=$PIECE(FB(0),"^",1)
SET FBLTD=$ORDER(^FBAACNH("AF",DFN,0))
DO ^FBNHDEC
RD2 SET DIR(0)="DA^::EXR"
SET DIR("A")="Enter Discharge Date/Time: "
SET DIR("?")="Enter date of discharge (time is required)"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!'Y
GOTO Q
SET FBY=+Y
DO DATCK2^FBAAUTL1
if '$DATA(X)
GOTO RD2
+1 ;check to see if enough rate info to date of discharge
+2 DO DRIV^FBNHRAT(DFN,IFN,.FB,$PIECE(FBY,"."))
IF $DATA(FBUNR)
Begin DoDot:1
+3 WRITE !!,*7,"Unable to establish rates for the following timeframes:"
+4 SET J=0
FOR
SET J=$ORDER(FBUNR(J))
if 'J
QUIT
WRITE !?5,$$DATX^FBAAUTL(J)," through ",$$DATX^FBAAUTL($ORDER(FBUNR(J,0)))
+5 WRITE !!,*7,"You can not discharge this patient without sufficient rate information.",!,"Check your contract!"
End DoDot:1
DO Q
GOTO RD1
+6 SET FBJ=0
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)=IFN
Begin DoDot:1
+7 IF $PIECE(^FBAACNH(FBK,0),"^",7)=3
SET FBASIH=1
End DoDot:1
QUIT
+8 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")="Enter Discharge Type: "
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO Q
SET FBZ=+Y
+9 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
+10 SET DR="8////^S X=FBVEN;1////^S X=DFN;2////^S X=""D"";4////^S X=IFN;7////^S X=FBZ"
DO ^DIE
KILL DIE
+11 Begin DoDot:1
+12 NEW FBX
+13 SET FBX=$$ADDUA^FBUTL9(162.4,FB7078_",","Enter CNH discharge.")
+14 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
+15 SET DIE="^FBAACNH("
SET DA=IFN
SET DR="3///@"
DO ^DIE
+16 DO UPDT
+17 GOTO RD1
Q KILL FBTRT,FBTYPE,FBLAD,FTP,FBPROG,CNT,DAT,DIC,FBAUT,F,FBAAOUT,FBDX,FBI,FBRR,FBXX,I,PI,PTYPE,T,X,Y,Z,ZZ,FBY,FB7078,FBAAAD,FBAABDT,FBAAEDT,FBASSOC,FBAT,FBLOC,FBLTD,FBPDT,FBPOV,FBY1,FBNHED,FBUNR,DFN,IFN,FBASIH,FBJ,FBK
+1 KILL FBPSA,FBPT,FBTT,FBVEN
DO Q^FBNHRAT
DO GETAUTHK^FBAAUTL1
QUIT
UPDT SET DA(1)=DFN
SET FBY1=$PIECE(FBY,".")
+1 SET DIE="^FBAAA("_DA(1)_",1,"
SET DR=".02////^S X=FBY1"
SET DA=FTP
DO ^DIE
KILL DIE,DR
+2 KILL DA
SET DIE="^FB7078("
SET DR="4////^S X=FBY1"
SET DA=FB7078
DO ^DIE
KILL DIE,DR
+3 ;update rate sensitive file since To Date of authorization is changed
+4 if FBY1>FBAAEDT
QUIT
+5 SET (FBO,FBAA(1))=FBAABDT
SET FB1=FBAAEDT
SET FBAA(2)=FBY1
+6 DO UPDATE^FBNHEDA1
+7 KILL FBO,FBAA,FB1,FBZ
+8 QUIT
