FBAAUTL1 ;AISC/GRR - Fee Basis Utility Routine ;9/12/2012
;;3.5;FEE BASIS;**3,12,13,108,132**;JAN 30, 1995;Build 17
;;Per VHA Directive 2004-038, this routine should not be modified.
PLUSOB ;ENTRY POINT TO INCREASE OBLIGATION ADJUSTMENT
S FBAAMT="-"_FBAARA
D ADD Q
;D NOW^%DTC S X=FBAAOB_"^"_%_"^^"_FBAAMT_"^"_FBAAB_"^"_FBCOMM,PRCS("TYPE")="FB" D EN2^PRCS58 I +Y=0 W !!,*7,Y,! S FBERR=1 Q
Q
VALCK ;DETERMINE VALIDITY OF RESPONSE
S VAL=0 I $E(X)="?"!("YyNn"'[$E(X,1)) D HELPYN Q
S VAL=1
Q
HELPYN ;DISPLAY HELP TEXT FOR YES OR NO
W !!,"Please enter 'Yes' or 'No'."
Q
GETVET D DT^DICRW S DFN="",U="^" W !! S DIC="^FBAAA(",DIC(0)="AEMQZ",DIC("A")="Select Patient: " D ^DIC K DIC("A"),DIC("S") Q:Y<0 S (D0,DFN)=+Y
Q
GETAUTH S CNT=0,FTP="" N FB,FBFDT
I '$D(^FBAAA(DFN,1)) W !!,"PATIENT HAS NO AUTHORIZATIONS " Q
S FBPROG=$S($D(FBPROG):FBPROG,1:"I 1")
S FBFDT=9999999 F S FBFDT=$O(^FBAAA(DFN,1,"B",FBFDT),-1) Q:'FBFDT D
. S I=0 F S I=$O(^FBAAA(DFN,1,"B",FBFDT,I)) Q:'I I $D(^FBAAA(DFN,1,I,0)) X FBPROG I S CNT=CNT+1,CNT(CNT)=I
S PI="" D HOME^%ZIS D ^FBAADEM
I CNT<1 W !!,"Veteran does NOT have an Authorization for the Fee Program being used !!" G Q
RD I CNT=1 S DIR(0)="Y",DIR("A")="Is this the correct Authorization period (Y/N)",DIR("B")="Yes" D ^DIR K DIR G:Y=0!($D(DIRUT)) NOAUTH S X=1 G 2
CHOOS W !! S DIR(0)="N^1:"_CNT D ^DIR K DIR S X=+Y Q:$D(DUOUT) G H^XUS:$D(DTOUT)
2 S (FTP,X)=CNT(X),FB=$G(^FBAAA(DFN,1,X,0)),FBAABDT=$P(FB,"^"),FBAAEDT=$P(FB,"^",2),FBTYPE=$P(FB,"^",3),TA=$P(FB,"^",11),FBTT=$P(FB,"^",13),FBPOV=$P(FB,"^",7),FBPT=$P(FB,"^",18),FBPSA=$P(FB,"^",5),FBVEN=$P(FB,"^",4),FB7078=""
I $P(FB,"^",9)[";FB7078(" S FB7078=+$P(FB,"^",9)
I $P(FB,"^",9)[";FB583(" S FB583=+$P(FB,"^",9)
S FBDMRA=$G(^FBAAA(DFN,1,X,"ADEL")) I FBDMRA']"" K FBDMRA
S FBASSOC=X
I FB7078]"" S FBVEN=+$P($G(^FB7078(+FB7078,0)),U,2)
S FBCNTRA=$P(FB,"^",22)
Q Q
GETAUTHK ; kill new authorization variables output from GETAUTH
K FBCNTRA
Q
DAYS ;CALCULATES THE NUMBER OF DAYS IN MONTH
S X1=X,X=+$E(X,4,5),X=$S("^1^3^5^7^8^10^12^"[("^"_X_"^"):31,X=2:28,1:30)
I X=28 D
. N YEAR
. S YEAR=$E(X1,1,3)+1700
. I $S(YEAR#400=0:1,YEAR#4=0&'(YEAR#100=0):1,1:0) S X=29
Q
DATCK2 I $D(FBAABDT),$D(FBAAEDT),Y<FBAABDT!(Y\1>FBAAEDT) W !!,*7,"Date ",$S(Y<FBAABDT:"prior to ",1:"later than "),"Authorization period",! K X Q
I $D(FBTRT),$D(FBLTD),(9999999.999999-Y)'<FBLTD W !,*7,"There is already an existing admission for this authorization!",! K X
Q
DATCK3 I $D(FBLTTYP),FBLTTYP]"",FBLTTYP<4,(X-3)'=FBLTTYP W !!,*7,"That transfer type NOT consistent with last transfer type!",! K X
I $D(FBLTT),FBLTT="A",X>3 W !!,*7,"A 'Transfer From' type transaction can only follow a 'Transfer To' type!",! K X
Q
WRONGT ;WRONG TYPE OF AUTHORIZATION SELECTED
W !!,"Authorization type selected inconsistent with option being used" Q
GETVEN ;LOOKUP VENDOR
W ! S DIC=161.2,DIC(0)="AEQM",IFN="" D ^DIC Q:Y<0 S IFN=+Y Q
HANG ;IF $E(IOST,1,2)["C-" ASK TO CONTINUE
S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 Q
CKOB D STATION^FBAAUTL I $D(FB("ERROR")) K FB("ERROR"),X Q
S PRC("SITE")=$S($D(PRC("SITE")):PRC("SITE"),1:FBSN) K FBSN,FBAASN
I '$D(^PRC(442,"B",PRC("SITE")_"-"_X)) W !,"This Obligation number does not exist in the IFCAP file!",! K PRC,X
Q
CK1358 ;CHECK TO SEE IF 1358 AVAILABLE
;FBAAOB=FULL OBLIGATION NUMBER (STA-CXXXXX)
;RETURNS Y=1 IF OK
S PRCS("X")=FBAAOB,PRCS("TYPE")="FB" D EN3^PRCS58 I Y=-1 W !!,*7,"1358 not available for posting!",! S FBERR=1 Q
Q
NOAUTH S (FTP,X)="" Q
LOCK W !!,*7,"Queueing has been initiated by another user and is now in progress!",!! Q
;
XSET ;SET X-REF IN FILE 161.27 FOR LOOK-UP BY SHORT DESCRIPTION
S ZZ=^FBAA(161.27,DA,2) D TRANS S ^FBAA(161.27,"C",$E(ZZ,1,30),DA)=""
K ZZ Q
XKILL ;
S ZZ=^FBAA(161.27,DA,2) D TRANS K ^FBAA(161.27,"C",$E(ZZ,1,30),DA)
K ZZ Q
;
TRANS ;
S ZZ=$TR(ZZ,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q
;
VER() ;no parameters passed
;returns 1 if site is running version 4 of IFCAP
;S X=$G(^DIC(9.4,+$O(^DIC(9.4,"C","PRC",0)),"VERSION"))
N X
S X=$$VERSION^XPDUTL("PRC")
Q $S(+X=4:1,1:0)
;
ADD ;call to add money back into 1358 when version of IFCAP>3.6
;uses interface ID look-up to get internal entry number
;interface ID = IEN of batch from 161.7
;find ien to 424 by $O(^PRC(424,"E",FBN,0))
;call NOT used for civil hospital/cnh
S PRCS("X")=FBAAOB,PRCS("TYPE")="FB" D EN3^PRCS58 I Y=-1 W !!,*7,"1358 not available for posting!",! S FBERR=1 Q
N FBADDX S FBADDX=$O(^PRC(424,"E",+$G(FBN),0)) I 'FBADDX S FBERR=1 Q
D NOW^%DTC
S PRCSX=FBADDX_"^"_%_"^"_FBAAMT_"^"_FBCOMM_"^"_1
D ^PRCS58CC I Y'=1 W !!,*7,$P(Y,U,2),! S FBERR=1
Q
;
ASKVET(FBSCR) ; Prompt for patient
; input FBSCR - (optional) screen logic for DIC lookup
; e.g. I $D(^FBAAC("AH",12,+Y))
; returns IEN of patient in file 161 or 0 if none selected
N DIC,FBRET,Y
S FBRET=0
W !!
S DIC="^FBAAA("
S DIC(0)="AQEM"
S:$G(FBSCR)'="" DIC("S")=FBSCR
D ^DIC
I Y'<0 S FBRET=+Y
Q FBRET
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAUTL1 5069 printed Sep 23, 2025@19:32:51 Page 2
FBAAUTL1 ;AISC/GRR - Fee Basis Utility Routine ;9/12/2012
+1 ;;3.5;FEE BASIS;**3,12,13,108,132**;JAN 30, 1995;Build 17
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
PLUSOB ;ENTRY POINT TO INCREASE OBLIGATION ADJUSTMENT
+1 SET FBAAMT="-"_FBAARA
+2 DO ADD
QUIT
+3 ;D NOW^%DTC S X=FBAAOB_"^"_%_"^^"_FBAAMT_"^"_FBAAB_"^"_FBCOMM,PRCS("TYPE")="FB" D EN2^PRCS58 I +Y=0 W !!,*7,Y,! S FBERR=1 Q
+4 QUIT
VALCK ;DETERMINE VALIDITY OF RESPONSE
+1 SET VAL=0
IF $EXTRACT(X)="?"!("YyNn"'[$EXTRACT(X,1))
DO HELPYN
QUIT
+2 SET VAL=1
+3 QUIT
HELPYN ;DISPLAY HELP TEXT FOR YES OR NO
+1 WRITE !!,"Please enter 'Yes' or 'No'."
+2 QUIT
GETVET DO DT^DICRW
SET DFN=""
SET U="^"
WRITE !!
SET DIC="^FBAAA("
SET DIC(0)="AEMQZ"
SET DIC("A")="Select Patient: "
DO ^DIC
KILL DIC("A"),DIC("S")
if Y<0
QUIT
SET (D0,DFN)=+Y
+1 QUIT
GETAUTH SET CNT=0
SET FTP=""
NEW FB,FBFDT
+1 IF '$DATA(^FBAAA(DFN,1))
WRITE !!,"PATIENT HAS NO AUTHORIZATIONS "
QUIT
+2 SET FBPROG=$SELECT($DATA(FBPROG):FBPROG,1:"I 1")
+3 SET FBFDT=9999999
FOR
SET FBFDT=$ORDER(^FBAAA(DFN,1,"B",FBFDT),-1)
if 'FBFDT
QUIT
Begin DoDot:1
+4 SET I=0
FOR
SET I=$ORDER(^FBAAA(DFN,1,"B",FBFDT,I))
if 'I
QUIT
IF $DATA(^FBAAA(DFN,1,I,0))
XECUTE FBPROG
IF $TEST
SET CNT=CNT+1
SET CNT(CNT)=I
End DoDot:1
+5 SET PI=""
DO HOME^%ZIS
DO ^FBAADEM
+6 IF CNT<1
WRITE !!,"Veteran does NOT have an Authorization for the Fee Program being used !!"
GOTO Q
RD IF CNT=1
SET DIR(0)="Y"
SET DIR("A")="Is this the correct Authorization period (Y/N)"
SET DIR("B")="Yes"
DO ^DIR
KILL DIR
if Y=0!($DATA(DIRUT))
GOTO NOAUTH
SET X=1
GOTO 2
CHOOS WRITE !!
SET DIR(0)="N^1:"_CNT
DO ^DIR
KILL DIR
SET X=+Y
if $DATA(DUOUT)
QUIT
if $DATA(DTOUT)
GOTO H^XUS
2 SET (FTP,X)=CNT(X)
SET FB=$GET(^FBAAA(DFN,1,X,0))
SET FBAABDT=$PIECE(FB,"^")
SET FBAAEDT=$PIECE(FB,"^",2)
SET FBTYPE=$PIECE(FB,"^",3)
SET TA=$PIECE(FB,"^",11)
SET FBTT=$PIECE(FB,"^",13)
SET FBPOV=$PIECE(FB,"^",7)
SET FBPT=$PIECE(FB,"^",18)
SET FBPSA=$PIECE(FB,"^",5)
SET FBVEN=$PIECE(FB,"^",4)
SET FB7078=""
+1 IF $PIECE(FB,"^",9)[";FB7078("
SET FB7078=+$PIECE(FB,"^",9)
+2 IF $PIECE(FB,"^",9)[";FB583("
SET FB583=+$PIECE(FB,"^",9)
+3 SET FBDMRA=$GET(^FBAAA(DFN,1,X,"ADEL"))
IF FBDMRA']""
KILL FBDMRA
+4 SET FBASSOC=X
+5 IF FB7078]""
SET FBVEN=+$PIECE($GET(^FB7078(+FB7078,0)),U,2)
+6 SET FBCNTRA=$PIECE(FB,"^",22)
Q QUIT
GETAUTHK ; kill new authorization variables output from GETAUTH
+1 KILL FBCNTRA
+2 QUIT
DAYS ;CALCULATES THE NUMBER OF DAYS IN MONTH
+1 SET X1=X
SET X=+$EXTRACT(X,4,5)
SET X=$SELECT("^1^3^5^7^8^10^12^"[("^"_X_"^"):31,X=2:28,1:30)
+2 IF X=28
Begin DoDot:1
+3 NEW YEAR
+4 SET YEAR=$EXTRACT(X1,1,3)+1700
+5 IF $SELECT(YEAR#400=0:1,YEAR#4=0&'(YEAR#100=0):1,1:0)
SET X=29
End DoDot:1
+6 QUIT
DATCK2 IF $DATA(FBAABDT)
IF $DATA(FBAAEDT)
IF Y<FBAABDT!(Y\1>FBAAEDT)
WRITE !!,*7,"Date ",$SELECT(Y<FBAABDT:"prior to ",1:"later than "),"Authorization period",!
KILL X
QUIT
+1 IF $DATA(FBTRT)
IF $DATA(FBLTD)
IF (9999999.999999-Y)'<FBLTD
WRITE !,*7,"There is already an existing admission for this authorization!",!
KILL X
+2 QUIT
DATCK3 IF $DATA(FBLTTYP)
IF FBLTTYP]""
IF FBLTTYP<4
IF (X-3)'=FBLTTYP
WRITE !!,*7,"That transfer type NOT consistent with last transfer type!",!
KILL X
+1 IF $DATA(FBLTT)
IF FBLTT="A"
IF X>3
WRITE !!,*7,"A 'Transfer From' type transaction can only follow a 'Transfer To' type!",!
KILL X
+2 QUIT
WRONGT ;WRONG TYPE OF AUTHORIZATION SELECTED
+1 WRITE !!,"Authorization type selected inconsistent with option being used"
QUIT
GETVEN ;LOOKUP VENDOR
+1 WRITE !
SET DIC=161.2
SET DIC(0)="AEQM"
SET IFN=""
DO ^DIC
if Y<0
QUIT
SET IFN=+Y
QUIT
HANG ;IF $E(IOST,1,2)["C-" ASK TO CONTINUE
+1 SET DIR(0)="E"
DO ^DIR
KILL DIR
if 'Y
SET FBAAOUT=1
QUIT
CKOB DO STATION^FBAAUTL
IF $DATA(FB("ERROR"))
KILL FB("ERROR"),X
QUIT
+1 SET PRC("SITE")=$SELECT($DATA(PRC("SITE")):PRC("SITE"),1:FBSN)
KILL FBSN,FBAASN
+2 IF '$DATA(^PRC(442,"B",PRC("SITE")_"-"_X))
WRITE !,"This Obligation number does not exist in the IFCAP file!",!
KILL PRC,X
+3 QUIT
CK1358 ;CHECK TO SEE IF 1358 AVAILABLE
+1 ;FBAAOB=FULL OBLIGATION NUMBER (STA-CXXXXX)
+2 ;RETURNS Y=1 IF OK
+3 SET PRCS("X")=FBAAOB
SET PRCS("TYPE")="FB"
DO EN3^PRCS58
IF Y=-1
WRITE !!,*7,"1358 not available for posting!",!
SET FBERR=1
QUIT
+4 QUIT
NOAUTH SET (FTP,X)=""
QUIT
LOCK WRITE !!,*7,"Queueing has been initiated by another user and is now in progress!",!!
QUIT
+1 ;
XSET ;SET X-REF IN FILE 161.27 FOR LOOK-UP BY SHORT DESCRIPTION
+1 SET ZZ=^FBAA(161.27,DA,2)
DO TRANS
SET ^FBAA(161.27,"C",$EXTRACT(ZZ,1,30),DA)=""
+2 KILL ZZ
QUIT
XKILL ;
+1 SET ZZ=^FBAA(161.27,DA,2)
DO TRANS
KILL ^FBAA(161.27,"C",$EXTRACT(ZZ,1,30),DA)
+2 KILL ZZ
QUIT
+3 ;
TRANS ;
+1 SET ZZ=$TRANSLATE(ZZ,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 QUIT
+3 ;
VER() ;no parameters passed
+1 ;returns 1 if site is running version 4 of IFCAP
+2 ;S X=$G(^DIC(9.4,+$O(^DIC(9.4,"C","PRC",0)),"VERSION"))
+3 NEW X
+4 SET X=$$VERSION^XPDUTL("PRC")
+5 QUIT $SELECT(+X=4:1,1:0)
+6 ;
ADD ;call to add money back into 1358 when version of IFCAP>3.6
+1 ;uses interface ID look-up to get internal entry number
+2 ;interface ID = IEN of batch from 161.7
+3 ;find ien to 424 by $O(^PRC(424,"E",FBN,0))
+4 ;call NOT used for civil hospital/cnh
+5 SET PRCS("X")=FBAAOB
SET PRCS("TYPE")="FB"
DO EN3^PRCS58
IF Y=-1
WRITE !!,*7,"1358 not available for posting!",!
SET FBERR=1
QUIT
+6 NEW FBADDX
SET FBADDX=$ORDER(^PRC(424,"E",+$GET(FBN),0))
IF 'FBADDX
SET FBERR=1
QUIT
+7 DO NOW^%DTC
+8 SET PRCSX=FBADDX_"^"_%_"^"_FBAAMT_"^"_FBCOMM_"^"_1
+9 DO ^PRCS58CC
IF Y'=1
WRITE !!,*7,$PIECE(Y,U,2),!
SET FBERR=1
+10 QUIT
+11 ;
ASKVET(FBSCR) ; Prompt for patient
+1 ; input FBSCR - (optional) screen logic for DIC lookup
+2 ; e.g. I $D(^FBAAC("AH",12,+Y))
+3 ; returns IEN of patient in file 161 or 0 if none selected
+4 NEW DIC,FBRET,Y
+5 SET FBRET=0
+6 WRITE !!
+7 SET DIC="^FBAAA("
+8 SET DIC(0)="AQEM"
+9 if $GET(FBSCR)'=""
SET DIC("S")=FBSCR
+10 DO ^DIC
+11 IF Y'<0
SET FBRET=+Y
+12 QUIT FBRET
