- 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 Feb 18, 2025@23:21:51 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