FBAAETA ;AISC/GRR,DMK/CMR - ENTER TRAVEL PAYMENT ONLY ;9/25/2014
;;3.5;FEE BASIS;**154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
RD ;set site parameters
S:$G(FBAAPTC)']"" FBAAPTC="R"
D SITE^FBAACO G END:$G(FBPOP)
;get veteran
D GETVET^FBAAUTL1 I '$G(DFN) D END Q
;get authorization
D GETAUTH^FBAAUTL1 G RD:'$G(FTP)
;
I '$$UOKPAY^FBUTL9(DFN,FTP) D G RD
. W !!,"You cannot process a payment associated with authorization ",DFN,"-",FTP
. W !,"due to separation of duties."
;
;call to verify veteran address data
D ^FBAACO0
;check for travel multiple dd reference
S DA(1)=+$G(DFN)
I '$D(^FBAAC(DA(1),3,0)) S ^(0)="^162.04DA^^"
RD1 W !! S DIC="^FBAAC(DA(1),3,",DIC(0)="AEQLM",DLAYGO=162 D ^DIC K DLAYGO
G END:X="^"!(X=""),RD1:Y<0 S DA=+Y,FBNEW=$P(Y,"^",3)
S FBTRVDT=$P(Y,U,2)
;check if travel date within selected authorization if 'kill and reask
I $G(FBAABDT),$G(FBAAEDT),(FBTRVDT<FBAABDT!(FBTRVDT>FBAAEDT)) D D KILL G RD1
. W !!,*7,"Date of Travel is ",$S(FBTRVDT<FBAABDT:"prior to",1:"after")," authorization date.",!
;set travel payment
S DIE=DIC,DR=".01;1;2;3.5///^S X=FBAAPTC;15///^S X=FTP" D ^DIE I $G(FBNEW)&($D(Y)'=0) D KILL,END
G RD
;
END K DIC,DIE,DR,X,Y,DA,C,D0,D1,DI,DIYS,Z,FBNEW,DLAYGO,FB1,FB2,FBTRVDT
D Q^FBAACO
Q
KILL ;KILLS ENTRY IF USER UP-ARROWED DURING ENTRY
W !!,*7,"Travel Payment entry not complete. Deleting entry..."
S DIK="^FBAAC("_DA(1)_",3," D ^DIK Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAETA 1489 printed Dec 13, 2024@01:55:25 Page 2
FBAAETA ;AISC/GRR,DMK/CMR - ENTER TRAVEL PAYMENT ONLY ;9/25/2014
+1 ;;3.5;FEE BASIS;**154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
RD ;set site parameters
+1 if $GET(FBAAPTC)']""
SET FBAAPTC="R"
+2 DO SITE^FBAACO
if $GET(FBPOP)
GOTO END
+3 ;get veteran
+4 DO GETVET^FBAAUTL1
IF '$GET(DFN)
DO END
QUIT
+5 ;get authorization
+6 DO GETAUTH^FBAAUTL1
if '$GET(FTP)
GOTO RD
+7 ;
+8 IF '$$UOKPAY^FBUTL9(DFN,FTP)
Begin DoDot:1
+9 WRITE !!,"You cannot process a payment associated with authorization ",DFN,"-",FTP
+10 WRITE !,"due to separation of duties."
End DoDot:1
GOTO RD
+11 ;
+12 ;call to verify veteran address data
+13 DO ^FBAACO0
+14 ;check for travel multiple dd reference
+15 SET DA(1)=+$GET(DFN)
+16 IF '$DATA(^FBAAC(DA(1),3,0))
SET ^(0)="^162.04DA^^"
RD1 WRITE !!
SET DIC="^FBAAC(DA(1),3,"
SET DIC(0)="AEQLM"
SET DLAYGO=162
DO ^DIC
KILL DLAYGO
+1 if X="^"!(X="")
GOTO END
if Y<0
GOTO RD1
SET DA=+Y
SET FBNEW=$PIECE(Y,"^",3)
+2 SET FBTRVDT=$PIECE(Y,U,2)
+3 ;check if travel date within selected authorization if 'kill and reask
+4 IF $GET(FBAABDT)
IF $GET(FBAAEDT)
IF (FBTRVDT<FBAABDT!(FBTRVDT>FBAAEDT))
Begin DoDot:1
+5 WRITE !!,*7,"Date of Travel is ",$SELECT(FBTRVDT<FBAABDT:"prior to",1:"after")," authorization date.",!
End DoDot:1
DO KILL
GOTO RD1
+6 ;set travel payment
+7 SET DIE=DIC
SET DR=".01;1;2;3.5///^S X=FBAAPTC;15///^S X=FTP"
DO ^DIE
IF $GET(FBNEW)&($DATA(Y)'=0)
DO KILL
DO END
+8 GOTO RD
+9 ;
END KILL DIC,DIE,DR,X,Y,DA,C,D0,D1,DI,DIYS,Z,FBNEW,DLAYGO,FB1,FB2,FBTRVDT
+1 DO Q^FBAACO
+2 QUIT
KILL ;KILLS ENTRY IF USER UP-ARROWED DURING ENTRY
+1 WRITE !!,*7,"Travel Payment entry not complete. Deleting entry..."
+2 SET DIK="^FBAAC("_DA(1)_",3,"
DO ^DIK
QUIT
