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