FBNHET ;AISC/GRR - ENTER TRANSFER FOR NURSING HOME ;1/22/15 14:57
;;3.5;FEE BASIS;**108,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
RD1 D Q,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="T",FBLTD=$O(^FBAACNH("AF",DFN,0)),FBIFN=$O(^FBAACNH("AF",DFN,FBLTD,0)),FBLTT=$P(^FBAACNH(FBIFN,0),"^",3),FBLTTYP=$S(FBLTT'="T":"",1:$P(^(0),"^",7))
;
RD2 D ^FBNHDEC
W ! S DIR(0)="DA^::EXR",DIR("A")="Enter Transfer Date/Time: ",DIR("?")="Enter date of transfer (time is required)" D ^DIR K DIR G:$D(DIRUT)!('Y) RD1
I $D(FBTRT),$D(FBLTD),(9999999.999999-Y)'<FBLTD D G RD2:'$G(X)
. W !,*7,"The date/time must follow an existing movement.",! H 2
. K X
S FBY=+Y
S DIR(0)="S^1:TO AUTHORIZED ABSENCE;2:TO UN-AUTHORIZED ABSENCE;3:TO ASIH"
S DIR(0)=$S('$G(FBLTTYP):DIR(0),FBLTTYP<4:"S^"_$P($T(TRANS+(3+FBLTTYP)),";;",2),1:DIR(0))
S DIR("A")="Enter Transfer Type"
I $G(FBLTTYP),FBLTTYP<4 S DIR("B")=$P($P(DIR(0),"^",2),":",2)
D ^DIR K DIR
G RD1:$D(DIRUT) S FBZ=+Y
S (DIC,DIE)="^FBAACNH(",DIC(0)="L",DLAYGO=162.3,X=FBY
K DD,DO D FILE^DICN K DLAYGO,DIC G RD1:$D(DIRUT),RD2:Y<0
S DA=+Y
S DR="8////^S X=FBVEN;Q;1////^S X=DFN;2////^S X=""T"";4////^S X=IFN;6////^S X=FBZ" D ^DIE K DIE I $D(Y)'=0 G DEL
D
. N FBX
. S FBX=$$ADDUA^FBUTL9(162.4,FB7078_",","Enter CNH transfer.")
. I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
G RD1
DEL W !!,*7,"Deleting Transfer because of incomplete transaction!" S DIK="^FBAACNH(" D ^DIK K DIK G RD1
;
Q K FBLTT,FBLTTYP,FBINF,FBTRT,FBLTD,DFN,IFN,DIK,FBPROG,CNT,DAT,DIC,F,FBAUT,FBDX,FBEDT,FBI,FBMULT,FBRR,FBTDT,FBXX,FTP,I,PI,PTYPE,T,X,Z,ZZ,FBAAOUT,Y,FBAABDT,FB7078,FBAAEDT,FBAAOUT,FBASSOC,FBDX,FBI,FBPOV,FBY
K FBPSA,FBPT,I,PI,PTYPE,T,TA,VAL,FBTT,FBLOC,FBAAAD,FBAT,FBIFN,FBPDT,FBTYPE,FBVEN,DA,DR,FBASIH,FBJ,FBK,FBZ
D GETAUTHK^FBAAUTL1
Q
;
TRANS ;transfer types
;;1:TO AUTHORIZED ABSENCE
;;2:TO UNAUTHORIZED ABSENCE
;;3:TO ASIH
;;4:FROM AUTHORIZED ABSENCE
;;5:FROM UNAUTHORIZED ABSENCE
;;6:FROM ASIH < 15 DAYS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHET 2293 printed Oct 16, 2024@17:59:53 Page 2
FBNHET ;AISC/GRR - ENTER TRANSFER FOR NURSING HOME ;1/22/15 14:57
+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 Q
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="T"
SET FBLTD=$ORDER(^FBAACNH("AF",DFN,0))
SET FBIFN=$ORDER(^FBAACNH("AF",DFN,FBLTD,0))
SET FBLTT=$PIECE(^FBAACNH(FBIFN,0),"^",3)
SET FBLTTYP=$SELECT(FBLTT'="T":"",1:$PIECE(^(0),"^",7))
+2 ;
RD2 DO ^FBNHDEC
+1 WRITE !
SET DIR(0)="DA^::EXR"
SET DIR("A")="Enter Transfer Date/Time: "
SET DIR("?")="Enter date of transfer (time is required)"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!('Y)
GOTO RD1
+2 IF $DATA(FBTRT)
IF $DATA(FBLTD)
IF (9999999.999999-Y)'<FBLTD
Begin DoDot:1
+3 WRITE !,*7,"The date/time must follow an existing movement.",!
HANG 2
+4 KILL X
End DoDot:1
if '$GET(X)
GOTO RD2
+5 SET FBY=+Y
+6 SET DIR(0)="S^1:TO AUTHORIZED ABSENCE;2:TO UN-AUTHORIZED ABSENCE;3:TO ASIH"
+7 SET DIR(0)=$SELECT('$GET(FBLTTYP):DIR(0),FBLTTYP<4:"S^"_$PIECE($TEXT(TRANS+(3+FBLTTYP)),";;",2),1:DIR(0))
+8 SET DIR("A")="Enter Transfer Type"
+9 IF $GET(FBLTTYP)
IF FBLTTYP<4
SET DIR("B")=$PIECE($PIECE(DIR(0),"^",2),":",2)
+10 DO ^DIR
KILL DIR
+11 if $DATA(DIRUT)
GOTO RD1
SET FBZ=+Y
+12 SET (DIC,DIE)="^FBAACNH("
SET DIC(0)="L"
SET DLAYGO=162.3
SET X=FBY
+13 KILL DD,DO
DO FILE^DICN
KILL DLAYGO,DIC
if $DATA(DIRUT)
GOTO RD1
if Y<0
GOTO RD2
+14 SET DA=+Y
+15 SET DR="8////^S X=FBVEN;Q;1////^S X=DFN;2////^S X=""T"";4////^S X=IFN;6////^S X=FBZ"
DO ^DIE
KILL DIE
IF $DATA(Y)'=0
GOTO DEL
+16 Begin DoDot:1
+17 NEW FBX
+18 SET FBX=$$ADDUA^FBUTL9(162.4,FB7078_",","Enter CNH transfer.")
+19 IF 'FBX
WRITE !,"Error adding record in User Audit. Please contact IRM."
End DoDot:1
+20 GOTO RD1
DEL WRITE !!,*7,"Deleting Transfer because of incomplete transaction!"
SET DIK="^FBAACNH("
DO ^DIK
KILL DIK
GOTO RD1
+1 ;
Q KILL FBLTT,FBLTTYP,FBINF,FBTRT,FBLTD,DFN,IFN,DIK,FBPROG,CNT,DAT,DIC,F,FBAUT,FBDX,FBEDT,FBI,FBMULT,FBRR,FBTDT,FBXX,FTP,I,PI,PTYPE,T,X,Z,ZZ,FBAAOUT,Y,FBAABDT,FB7078,FBAAEDT,FBAAOUT,FBASSOC,FBDX,FBI,FBPOV,FBY
+1 KILL FBPSA,FBPT,I,PI,PTYPE,T,TA,VAL,FBTT,FBLOC,FBAAAD,FBAT,FBIFN,FBPDT,FBTYPE,FBVEN,DA,DR,FBASIH,FBJ,FBK,FBZ
+2 DO GETAUTHK^FBAAUTL1
+3 QUIT
+4 ;
TRANS ;transfer types
+1 ;;1:TO AUTHORIZED ABSENCE
+2 ;;2:TO UNAUTHORIZED ABSENCE
+3 ;;3:TO ASIH
+4 ;;4:FROM AUTHORIZED ABSENCE
+5 ;;5:FROM UNAUTHORIZED ABSENCE
+6 ;;6:FROM ASIH < 15 DAYS
