- 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 Feb 18, 2025@23:27:15 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