FBUTL7 ;WIOFO/SAB - FEE BASIS UTILITY FOR CONTRACT ;9/24/2009
;;3.5;FEE BASIS;**108**;JAN 30, 1995;Build 115
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
EDCNTRA(FBDFN,FBAUTH) ; determine if CONTRACT can be edited
; Input
; FBDFN = IEN of patient in file 161 (and file 2)
; FBAUTH = IEN of authorization in sub-file 161.01
; Returns a string value flag^message where
; flag = 1 if contract field in sub-file 161.01 can be edited
; = 0 if it cannot be edited
; message = optional text that if present should be displayed
;
N FBPAY,FBRET,FBY
S FBRET=0
;
; check inputs
I '$G(FBDFN) G EDCNTRAX ; missing patient IEN
I '$G(FBAUTH) G EDCNTRAX ; missing authorization IEN
S FBY=$G(^FBAAA(FBDFN,1,FBAUTH,0))
I FBY']"" G EDCNTRAX ; no authorization data
;
; check if contract is applicable to the authorization type
; must be outpatient or civil hospital fee program
I "^2^6^"'[("^"_$P(FBY,"^",3)_"^") G EDCNTRAX
; must not be an unauthorized claim
I $P(FBY,"^",9)["FB583" G EDCNTRAX
;
; check if any existing payments on file
S FBPAY=0
I $P(FBY,"^",3)=2 S FBPAY=$$OUTPA(FBDFN,FBAUTH) ; check outpatient
I $P(FBY,"^",9)["FB7078" S FBPAY=$$PAY^FBUCUTL(+$P(FBY,"^",9),$P($P(FBY,"^",9),";",2)) ; check using the associated 7078
I FBPAY=1 D G EDCNTRAX
. N FBX
. S FBX="Can't change contract ("
. S FBX=FBX_$S($P(FBY,"^",22):$$GET1^DIQ(161.43,$P(FBY,"^",22)_",",.01),1:"")
. S FBX=FBX_") because payments exist."
. S $P(FBRET,"^",2)=FBX
;
;passed all checks - OK to edit field
S FBRET=1
;
EDCNTRAX ; EDCNTRA exit
Q FBRET
;
OUTPA(FBDFN,FBAUTH) ; Outpatient Authorization Has Payments?
; input
; patient IEN
; authorization IEN
; output
; FBPAY = 1 or 0, =1 if any payments on file for the authorization
N FBPAY,FBVEN
S FBPAY=0
;
S FBVEN=+$P($G(^FBAAA(FBDFN,1,FBAUTH,0)),"^",4) ; vendor on auth
I FBVEN D OUTPAV
E F S FBVEN=$O(^FBAAC(FBDFN,1,FBVEN)) Q:'FBVEN D OUTPAV Q:FBPAY
Q FBPAY
;
OUTPAV ;
N FBDTI
S FBDTI=0
F S FBDTI=$O(^FBAAC(FBDFN,1,FBVEN,1,FBDTI)) Q:'FBDTI D Q:FBPAY
. Q:$P($G(^FBAAC(FBDFN,1,FBVEN,1,FBDTI,0)),"^",4)'=FBAUTH
. Q:'$O(^FBAAC(FBDFN,1,FBVEN,1,FBDTI,1,0))
. S FBPAY=1
Q
CNTRPTR(FBDA) ; Contract pointed-to
; input FBDA = ien of contract in file 161.43
; result 0 or 1, =1 if contract is pointed-to
N FBRET
S FBRET=0
; check fee basis patient (authorizations)
I $D(^FBAAA("ACN",FBDA)) S FBRET=1
; check fee basis payment
I 'FBRET,$D(^FBAAC("ACN",FBDA)) S FBRET=1
; check fee basis invoice
I 'FBRET,$D(^FBAAI("ACN",FBDA)) S FBRET=1
Q FBRET
;
;
UCFA(FBVENI,FBVENA,FBCNTRA) ; Use Contract From Authorization
; input
; FBVENI = vendor IEN for invoice/payment
; FBVENA = vendor IEN for associated authorization
; FBCNTRA = contract IEN for associated authorization
; returns 0 or 1
; = 1 if invoice must have same contract as associated authorization
N FBAR,FBI,FBRET
S FBRET=0
; if authorization has a contract
I FBCNTRA D
. ; does the vendor being paid match the vendor on the authorizaton
. I FBVENI=FBVENA S FBRET=1
. Q:FBRET=1
. ; build a list of linked vendors for the vendor being paid
. I FBVENI D ; build list of linked vendors in FBAR(
. . N DA,FBA,FBDA,FBJ
. . S DA=FBVENI
. . S FBAR(DA)=""
. . D ^FBAACO4
. ; loop thru linked vendors to see if any match
. S FBI=0 F S FBI=$O(FBAR(FBI)) Q:'FBI D Q:FBRET
. . I FBI=FBVENA S FBRET=1
Q FBRET
;
CNTRSCR(FBDFN,FBAUT,FBCNTRA) ; contract screen
; called by 161.01 CONTRACT field screen
; input
; FEE BASIS PATIENT ien
; AUTHORIZATION ien
; CONTRACT ien
; return 0 or 1, =1 if contract passes screen
N FBRET,FBVEN
S FBRET=1
; check status of contract
I $G(DIUTIL)'="VERIFY FIELDS",$P($G(^FBAA(161.43,FBCNTRA,0)),"^",2)'="A" S FBRET=0
; if authorization iens provided, then screen on vendor
I FBRET,$G(FBDFN),$G(FBAUT) D
. S FBVEN=$P($G(^FBAAA(FBDFN,1,FBAUT,0)),"^",4)
. I FBVEN'>0 S FBRET=0 Q
. S FBRET=$$VCNTR(FBVEN,FBCNTRA)
Q FBRET
;
VCNTR(FBV,FBC) ; vendor applicable for the contract
; input
; FBV = IEN of vendor (FEE BASIS VENDOR file)
; FBC = IEN on contract (FEE BASIS CONTRACT file)
; returns 0 or 1
; =1 if vendor is applicable for the contract
N FBAR,FBI,FBRET
S FBRET=0
I $G(FBV),$G(FBC) D
. ; is vendor applicable?
. I $D(^FBAA(161.43,"AV",FBV,FBC)) S FBRET=1
. Q:FBRET=1
. ; try linked vendors (if any)
. D ; build list of linked vendors in FBAR(
. . N DA,FBA,FBDA,FBJ
. . S DA=FBV
. . S FBAR(DA)=""
. . D ^FBAACO4
. ; loop thru linked vendors to see if any are applicable
. S FBI=0 F S FBI=$O(FBAR(FBI)) Q:'FBI D Q:FBRET
. . I $D(^FBAA(161.43,"AV",FBI,FBC)) S FBRET=1
Q FBRET
;
;FBUTL7
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUTL7 4847 printed Sep 23, 2025@19:36:54 Page 2
FBUTL7 ;WIOFO/SAB - FEE BASIS UTILITY FOR CONTRACT ;9/24/2009
+1 ;;3.5;FEE BASIS;**108**;JAN 30, 1995;Build 115
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
EDCNTRA(FBDFN,FBAUTH) ; determine if CONTRACT can be edited
+1 ; Input
+2 ; FBDFN = IEN of patient in file 161 (and file 2)
+3 ; FBAUTH = IEN of authorization in sub-file 161.01
+4 ; Returns a string value flag^message where
+5 ; flag = 1 if contract field in sub-file 161.01 can be edited
+6 ; = 0 if it cannot be edited
+7 ; message = optional text that if present should be displayed
+8 ;
+9 NEW FBPAY,FBRET,FBY
+10 SET FBRET=0
+11 ;
+12 ; check inputs
+13 ; missing patient IEN
IF '$GET(FBDFN)
GOTO EDCNTRAX
+14 ; missing authorization IEN
IF '$GET(FBAUTH)
GOTO EDCNTRAX
+15 SET FBY=$GET(^FBAAA(FBDFN,1,FBAUTH,0))
+16 ; no authorization data
IF FBY']""
GOTO EDCNTRAX
+17 ;
+18 ; check if contract is applicable to the authorization type
+19 ; must be outpatient or civil hospital fee program
+20 IF "^2^6^"'[("^"_$PIECE(FBY,"^",3)_"^")
GOTO EDCNTRAX
+21 ; must not be an unauthorized claim
+22 IF $PIECE(FBY,"^",9)["FB583"
GOTO EDCNTRAX
+23 ;
+24 ; check if any existing payments on file
+25 SET FBPAY=0
+26 ; check outpatient
IF $PIECE(FBY,"^",3)=2
SET FBPAY=$$OUTPA(FBDFN,FBAUTH)
+27 ; check using the associated 7078
IF $PIECE(FBY,"^",9)["FB7078"
SET FBPAY=$$PAY^FBUCUTL(+$PIECE(FBY,"^",9),$PIECE($PIECE(FBY,"^",9),";",2))
+28 IF FBPAY=1
Begin DoDot:1
+29 NEW FBX
+30 SET FBX="Can't change contract ("
+31 SET FBX=FBX_$SELECT($PIECE(FBY,"^",22):$$GET1^DIQ(161.43,$PIECE(FBY,"^",22)_",",.01),1:"")
+32 SET FBX=FBX_") because payments exist."
+33 SET $PIECE(FBRET,"^",2)=FBX
End DoDot:1
GOTO EDCNTRAX
+34 ;
+35 ;passed all checks - OK to edit field
+36 SET FBRET=1
+37 ;
EDCNTRAX ; EDCNTRA exit
+1 QUIT FBRET
+2 ;
OUTPA(FBDFN,FBAUTH) ; Outpatient Authorization Has Payments?
+1 ; input
+2 ; patient IEN
+3 ; authorization IEN
+4 ; output
+5 ; FBPAY = 1 or 0, =1 if any payments on file for the authorization
+6 NEW FBPAY,FBVEN
+7 SET FBPAY=0
+8 ;
+9 ; vendor on auth
SET FBVEN=+$PIECE($GET(^FBAAA(FBDFN,1,FBAUTH,0)),"^",4)
+10 IF FBVEN
DO OUTPAV
+11 IF '$TEST
FOR
SET FBVEN=$ORDER(^FBAAC(FBDFN,1,FBVEN))
if 'FBVEN
QUIT
DO OUTPAV
if FBPAY
QUIT
+12 QUIT FBPAY
+13 ;
OUTPAV ;
+1 NEW FBDTI
+2 SET FBDTI=0
+3 FOR
SET FBDTI=$ORDER(^FBAAC(FBDFN,1,FBVEN,1,FBDTI))
if 'FBDTI
QUIT
Begin DoDot:1
+4 if $PIECE($GET(^FBAAC(FBDFN,1,FBVEN,1,FBDTI,0)),"^",4)'=FBAUTH
QUIT
+5 if '$ORDER(^FBAAC(FBDFN,1,FBVEN,1,FBDTI,1,0))
QUIT
+6 SET FBPAY=1
End DoDot:1
if FBPAY
QUIT
+7 QUIT
CNTRPTR(FBDA) ; Contract pointed-to
+1 ; input FBDA = ien of contract in file 161.43
+2 ; result 0 or 1, =1 if contract is pointed-to
+3 NEW FBRET
+4 SET FBRET=0
+5 ; check fee basis patient (authorizations)
+6 IF $DATA(^FBAAA("ACN",FBDA))
SET FBRET=1
+7 ; check fee basis payment
+8 IF 'FBRET
IF $DATA(^FBAAC("ACN",FBDA))
SET FBRET=1
+9 ; check fee basis invoice
+10 IF 'FBRET
IF $DATA(^FBAAI("ACN",FBDA))
SET FBRET=1
+11 QUIT FBRET
+12 ;
+13 ;
UCFA(FBVENI,FBVENA,FBCNTRA) ; Use Contract From Authorization
+1 ; input
+2 ; FBVENI = vendor IEN for invoice/payment
+3 ; FBVENA = vendor IEN for associated authorization
+4 ; FBCNTRA = contract IEN for associated authorization
+5 ; returns 0 or 1
+6 ; = 1 if invoice must have same contract as associated authorization
+7 NEW FBAR,FBI,FBRET
+8 SET FBRET=0
+9 ; if authorization has a contract
+10 IF FBCNTRA
Begin DoDot:1
+11 ; does the vendor being paid match the vendor on the authorizaton
+12 IF FBVENI=FBVENA
SET FBRET=1
+13 if FBRET=1
QUIT
+14 ; build a list of linked vendors for the vendor being paid
+15 ; build list of linked vendors in FBAR(
IF FBVENI
Begin DoDot:2
+16 NEW DA,FBA,FBDA,FBJ
+17 SET DA=FBVENI
+18 SET FBAR(DA)=""
+19 DO ^FBAACO4
End DoDot:2
+20 ; loop thru linked vendors to see if any match
+21 SET FBI=0
FOR
SET FBI=$ORDER(FBAR(FBI))
if 'FBI
QUIT
Begin DoDot:2
+22 IF FBI=FBVENA
SET FBRET=1
End DoDot:2
if FBRET
QUIT
End DoDot:1
+23 QUIT FBRET
+24 ;
CNTRSCR(FBDFN,FBAUT,FBCNTRA) ; contract screen
+1 ; called by 161.01 CONTRACT field screen
+2 ; input
+3 ; FEE BASIS PATIENT ien
+4 ; AUTHORIZATION ien
+5 ; CONTRACT ien
+6 ; return 0 or 1, =1 if contract passes screen
+7 NEW FBRET,FBVEN
+8 SET FBRET=1
+9 ; check status of contract
+10 IF $GET(DIUTIL)'="VERIFY FIELDS"
IF $PIECE($GET(^FBAA(161.43,FBCNTRA,0)),"^",2)'="A"
SET FBRET=0
+11 ; if authorization iens provided, then screen on vendor
+12 IF FBRET
IF $GET(FBDFN)
IF $GET(FBAUT)
Begin DoDot:1
+13 SET FBVEN=$PIECE($GET(^FBAAA(FBDFN,1,FBAUT,0)),"^",4)
+14 IF FBVEN'>0
SET FBRET=0
QUIT
+15 SET FBRET=$$VCNTR(FBVEN,FBCNTRA)
End DoDot:1
+16 QUIT FBRET
+17 ;
VCNTR(FBV,FBC) ; vendor applicable for the contract
+1 ; input
+2 ; FBV = IEN of vendor (FEE BASIS VENDOR file)
+3 ; FBC = IEN on contract (FEE BASIS CONTRACT file)
+4 ; returns 0 or 1
+5 ; =1 if vendor is applicable for the contract
+6 NEW FBAR,FBI,FBRET
+7 SET FBRET=0
+8 IF $GET(FBV)
IF $GET(FBC)
Begin DoDot:1
+9 ; is vendor applicable?
+10 IF $DATA(^FBAA(161.43,"AV",FBV,FBC))
SET FBRET=1
+11 if FBRET=1
QUIT
+12 ; try linked vendors (if any)
+13 ; build list of linked vendors in FBAR(
Begin DoDot:2
+14 NEW DA,FBA,FBDA,FBJ
+15 SET DA=FBV
+16 SET FBAR(DA)=""
+17 DO ^FBAACO4
End DoDot:2
+18 ; loop thru linked vendors to see if any are applicable
+19 SET FBI=0
FOR
SET FBI=$ORDER(FBAR(FBI))
if 'FBI
QUIT
Begin DoDot:2
+20 IF $DATA(^FBAA(161.43,"AV",FBI,FBC))
SET FBRET=1
End DoDot:2
if FBRET
QUIT
End DoDot:1
+21 QUIT FBRET
+22 ;
+23 ;FBUTL7
