- 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 Feb 18, 2025@23:25:20 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