FBAAMP ;AISC/CMR - MULTIPLE PAYMENT ENTRY ;10/23/14 12:47
;;3.5;FEE BASIS;**4,21,38,55,61,67,116,108,143,123,154,158**;JAN 30, 1995;Build 94
;;Per VA Directive 6402, this routine should not be modified.
S FBMP=1 ;multiple payment flag
G ^FBAACO
1 ;return from FBAACO
D MMPPT^FBAACO G:$G(FBAAOUT) Q1
D MPDT I 'FBMPDT G Q1
K FBAAOUT W ! D CPTM^FBAALU(FBMPDT,DFN) I 'FBGOT G Q1
; prompt revenue code
S FBAARC=$$ASKREVC^FBUTL5() I FBAARC="^" S FBAAOUT=1 G Q1
; prompt units paid
S FBUNITS=$$ASKUNITS^FBUTL5() I FBUNITS="^" S FBAAOUT=1 G Q1
S FY=$E(DT,1,3)+1700+$S($E(DT,4,5)>9:1,1:0)
D ASKZIP^FBAAFS($G(FBV)) I $G(FBAAOUT)!($G(FBZIP)']"") G Q1
I $$ANES^FBAAFS($$CPT^FBAAUTL4(FBAACP)) D ASKTIME^FBAAFS I $G(FBAAOUT)!('$G(FBTIME)) G Q1
D HCFA^FBAAMP1 G Q1:$G(FBAAOUT)
AMTCL S DIR(0)="162.03,1",DIR("A")="AMOUNT CLAIMED",DIR("?")="Enter the amount being claimed by the vendor" D ^DIR K DIR G Q:$D(DIRUT) S FBJ=+Y
W ! S DIR("A")="Is $"_FBJ_" correct for Amount Claimed",DIR("B")="Yes",DIR(0)="Y" D ^DIR K DIR G Q:$D(DIRUT),AMTCL:'Y
RDAP D FEE G Q:$G(FBAAOUT) S FBK=FBAMTPD W ! S DIR("A")="Is $"_FBK_" correct for Amount Paid",DIR("B")="Yes",DIR(0)="Y" D ^DIR K DIR G Q:$D(DIRUT),RDAP:'Y
S FBAAAS=0 K FBADJ I FBJ-FBK D SUSP^FBAAMP1 I $G(FBAAOUT) G Q:$D(DUOUT),Q1
S FBJ=+FBJ,FBK=+FBK,FBAAAS=+FBAAAS
MULT W:FBINTOT>0 !,"Invoice: "_FBAAIN_" Totals: $ "_FBINTOT
W !! S %DT("A")="Date of Service: ",%DT="AEPX" D ^%DT G Q1:X=""!(X="^")
D DATCK^FBAAUTL G MULT:'$D(X)!(Y<0)
S FBDT=Y
I '$$CHKCPT() W !,$C(7),"Invalid Date of Service." G MULT
I $$CHKICD9^FBCSV1(+$G(FBHCFA(28)),$G(FBDT))="" G MULT
I '$G(FBAAMM1),'$$CHKFS() W !,$C(7),"Invalid Date of Service." G MULT
S DIR(0)="Y",DIR("A")="Is "_($$DATX^FBAAUTL(FBDT))_" correct",DIR("B")="Yes" D ^DIR K DIR G MULT:$D(DIRUT)!('Y)
S FBAADT=FBDT
S FBMODL=$$MODL^FBAAUTL4("FBMODA","I")
I $D(^FBAAC("AE",DFN,FBV,FBAADT,FBAACP_$S($G(FBMODL)]"":"-"_FBMODL,1:""))) S DIR(0)="Y",DIR("A")="Code already exists for that date! Want to add another service for the SAME DATE",DIR("B")="No" D ^DIR K DIR G MULT:$D(DIRUT)!('Y)
I FBFPPSC]"" S FBFPPSL=$$FPPSL^FBUTL5() I FBFPPSL=-1 G Q1
W !! D GETSVDT^FBAACO5(DFN,FBV,FBASSOC,0,FBAADT) G Q:$G(FBAAOUT)
D SETO^FBAACO3,SVCPR^FBAACO1 G Q:$G(FBAAOUT)
FILE S TP="",DR="1///^S X=FBJ;Q;2///^S X=FBK;47///^S X=FBUNITS"
I FBCSID]"" S DR=DR_";49///^S X=FBCSID"
I FBFPPSC]"" S DR=DR_";50///^S X=FBFPPSC;51///^S X=FBFPPSL"
I FBAARC]"" S DR=DR_";48////^S X=FBAARC"
S DR(1,162.03,1)="6////^S X=DUZ;7////^S X=FBAABE;8////^S X=BO;13///^S X=FBAAID;14///^S X=FBAAIN;15///^S X=FBPT;16////^S X=FBPOV;17///^S X=FBTT;18///^S X=FBAAPTC;23////^S X=FBTYPE;26////^S X=FBPSA"
S DR(1,162.03,2)="34///^S X=$G(FBAAMM1);54////^S X=$G(FBCNTRP);28////^S X=FBHCFA(28);30////^S X=FBHCFA(30);31////^S X=FBHCFA(31);32////^S X=FBHCFA(32);33///^S X=FBAAVID;44///^S X=FBFSAMT;45////^S X=FBFSUSD"
S DR(1,162.03,3)=".05////^S X=$G(FBIA);.055///^S X=$G(FBDODINV)" ; FB*3.5*123
S DR(1,162.03,4)="82///^S X=$$PYMTH^FBAAUTL(FBFSUSD)" ;FB*3.5*158
S DIE="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,"
S DA=FBAACPI,DA(1)=FBSDI,DA(2)=FBV,DA(3)=DFN
D LOCK^FBUCUTL(DIE,FBAACPI,1)
D ^DIE
D FILEADJ^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBADJ)
D FILERR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBRRMK)
L -^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI)
S FBINTOT=FBINTOT+FBK
W " ....OK, DONE...."
; HIPAA 5010 - count line items that have 0.00 amount paid
S Z1=$P(^FBAA(161.7,FBAABE,0),"^",11)+1,$P(^(0),"^",11)=Z1
W:Z1>(FBAAMPI-20) !,*7,"Warning, you can only enter ",(FBAAMPI-Z1)," more line items!" I Z1>(FBAAMPI-1) D S FBMAX=1 G Q1
.W !!,*7,"You have reached the maximum number of payments for a Batch!",!,"You must select another Batch for entering Payments!"
G MULT
Q1 K FBADJ,FBAADT,FBX,FBAACP,DIC,DIE,X,Y,DIRUT,DUOUT,DTOUT,FBOUT,FBSI,FBMPDT,FBIA,FBDODINV G ^FBAACO:$D(FBMAX),1^FBAACO
;
Q ;kill variables and exit
D Q^FBAACO
Q
;
MPDT ;
S FBMPDT=""
S DIR(0)="D^::EX"
S DIR("A")="Enter date to use for CPT/ICD checks and fee schedule calc"
S DIR("B")="TODAY"
S DIR("?",1)="Enter a date. This date will be used when checking for"
S DIR("?",2)="an active CPT/Modifier/ICD code. Also, the fee schedule"
S DIR("?",3)="amount will be computed based on this date."
S DIR("?")="Enter '^' to exit."
W !
D ^DIR K DIR S:'$D(DIRUT) FBMPDT=Y
Q
;
FEE N FBX,FB1725
; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
S FB1725=$S($G(FB583):+$P($G(^FB583(+FB583,0)),U,28),1:0)
S FBFY=FY-1
S (FBFSAMT,FBFSUSD,FBAMFS)=""
; FB*3.5*143 Adding FB1725 as a parameter to prevent reduction
; of local fee schedule payments
S FBX=$$GET^FBAAFS($$CPT^FBAAUTL4(FBAACP),$$MODL^FBAAUTL4("FBMODA","E"),FBMPDT,$G(FBZIP),$$FAC^FBAAFS($G(FBHCFA(30))),$G(FBTIME),$G(FB1725))
;
I '$G(FBAAMM1) D
. S FBFSAMT=$P(FBX,U),FBFSUSD=$P(FBX,U,2)
E D
. W !,?2,"Payment is for a contracted service so fee schedule does not apply."
;
I $P($G(FBX),U)]"" D
. W !?2,$S($G(FBAAMM1):"However, f",1:"F")
. W "ee schedule amount is $",$P(FBX,U)," from the "
. W:$P(FBX,U,3)]"" $P(FBX,U,3)," " ; year if returned
. W:$P(FBX,U,2)]"" $$EXTERNAL^DILFD(162.03,45,"",$P(FBX,U,2))
E W !?2,"Unable to determine a FEE schedule amount."
;
; FB*3.5*143 - Preventing 70% reduction of 75th percentile rates
I FB1725,FBFSUSD'="F" D
. W !!?2,"**Payment is for emergency treatment under 38 U.S.C. 1725."
. I FBFSAMT D
. . S FBFSAMT=$J(FBFSAMT*.7,0,2)
. . W !?2," Therefore, fee schedule amount reduced to $",FBFSAMT," (70%)."
;
I $G(FBUNITS)>1 D
. W !!?2,"Units Paid = ",FBUNITS
. Q:FBFSAMT'>0
. N FBFSUNIT
. ; determine if fee schedule can be multiplied by units
. S FBFSUNIT=$S(FBFSUSD="R":1,FBFSUSD="F"&(FBMPDT>3040930):1,1:0)
. I FBFSUNIT D
. . S FBFSAMT=$J(FBFSAMT*FBUNITS,0,2)
. . W !?2," Therefore, fee schedule amount increased to $",FBFSAMT
. E D
. . W !?2," Fee schedule not complied on per unit basis so amount not adjusted by units."
;
I '$G(FBAAMM1) D
. ; set default amount paid to lesser of amt claimed (J) or fee sched.
. S FBAMFS=$S(FBFSAMT>$G(FBJ):$G(FBJ),1:FBFSAMT)
;
W !
;
AMTPD K DIR S DIR(0)="162.03,2",DIR("A")="AMOUNT PAID" S:$G(FBAMFS)'="" DIR("B")=FBAMFS D ^DIR K DIR I $D(DIRUT) S FBAAOUT=1 Q
S FBAMTPD=+Y K FBAMFS Q
;
CHKCPT() ; check if CPT/Modifier active on date of service
N FBCPTX,FBI,FBMOD,FBMODX,FBRET
S FBRET=1
S FBCPTX=$$CPT^ICPTCOD(FBAACP,FBDT,1)
I '$P(FBCPTX,U,7) S FBRET=0 W !," CPT Code ",$P(FBCPTX,U,2)," inactive on date of service."
I $O(FBMODA(0)) D
. S FBI=0 F S FBI=$O(FBMODA(FBI)) Q:'FBI D
. . S FBMODX=$$MOD^ICPTMOD(FBMODA(FBI),"I",FBDT,1)
. . I '$P(FBMODX,U,7) S FBRET=0 W !," CPT Modifier ",$P(FBMODX,U,2)," inactive on date of service."
Q FBRET
;
CHKFS() ; check if fee schedule amount is different on date of service
N FBX,FBRET,FB1725
S FBRET=1 ; return value - true if date of service allowed
; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
S FB1725=$S($G(FB583):+$P($G(^FB583(+FB583,0)),U,28),1:0)
S FBX=$$GET^FBAAFS($$CPT^FBAAUTL4(FBAACP),$$MODL^FBAAUTL4("FBMODA","E"),FBDT,$G(FBZIP),$$FAC^FBAAFS($G(FBHCFA(30))),$G(FBTIME),$G(FB1725))
; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
S FB1725=$S($G(FB583):+$P($G(^FB583(+FB583,0)),U,28),1:0)
; adjust amount if mill bill
I FB1725 S $P(FBX,U)=$J($P(FBX,U)*.7,0,2)
; adjust amount if units > 1
I $G(FBUNITS) D
. N FBFSUNIT
. ; determine if fee schedule can be multiplied by units
. S FBFSUNIT=$S($P(FBX,U,2)="R":1,$P(FBX,U,2)="F"&(FBDT>3040930):1,1:0)
. I FBFSUNIT S $P(FBX,U)=$J($P(FBX,U)*FBUNITS,0,2)
; issue warning if lesser of claim and fee schedule amount different
I +$S($P(FBX,U)>$G(FBJ):$G(FBJ),1:$P(FBX,U))'=+$S(FBFSAMT>$G(FBJ):$G(FBJ),1:FBFSAMT) D
. W !," Warning: The fee schedule amount (",$P(FBX,U),") for this date of service "
. W !," differs from the initial fee schedule amount (",FBFSAMT,")."
. I $P(FBX,U)>0,FBK>$P(FBX,U) D
. . W !," Amount paid (",FBK,") exceeds the fee schedule amount."
. W:FBRET !," You may want to separately process this date of service."
Q FBRET
;
IPACID(FBVEN,FBIPIEN) ; function to return IPAC agreement ID# if exactly 1 active IPAC on file for vendor (FB*3.5*123)
; No user interface allowed with this function. Called by background, Austin transmission process.
;
; Input:
; FBVEN - Vendor ien (ptr to file 161.2)
;
; Output:
; Function value = if exactly 1 active IPAC agreement is on file, then this returns the external agreement ID#
; otherwise, this returns ""
; FBIPIEN (pass by reference) - internal entry ien of the active IPAC agreement on file
;
N X1,X2,RET
S RET="" ; default value
S FBIPIEN="" ; initialize
S FBVEN=+$G(FBVEN)
I '$$IPACREQD(FBVEN) G IPACIDX ; IPAC not required
S X1=+$O(^FBAA(161.95,"AVA",FBVEN,"A","")) ; first active IPAC entry
I 'X1 G IPACIDX ; no IPAC data found for vendor so get out
S X2=+$O(^FBAA(161.95,"AVA",FBVEN,"A",""),-1) ; last active IPAC entry
;
; only 1 IPAC on file - retrieve the ID# in this case only
I X1=X2 S RET=$P($G(^FBAA(161.95,X1,0)),U,1),FBIPIEN=X1 ; IPAC external agreement ID#
;
IPACIDX ;
Q RET
;
IPAC(FBVEN) ; Determine if active IPAC agreement data exists for vendor (FB*3.5*123)
; Input:
; FBVEN - Vendor ien (ptr to file 161.2)
;
; Output:
; Function value = -1 if active IPAC records exist, but none were selected (this is an error condition)
; = ien of IPAC entry in file 161.95 (if only 1 exists, or user selected it)
; = "" if no IPAC data found or if IPAC not required
;
N FBIA,X1,X2,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S FBIA=""
S FBVEN=+$G(FBVEN)
I '$$IPACREQD(FBVEN) G IPACX ; IPAC not required
S X1=+$O(^FBAA(161.95,"AVA",FBVEN,"A","")) ; first active IPAC entry
I 'X1 G IPACX ; no IPAC data found for vendor, get out with FBIA=""
W !!,"This is a Federal Vendor. IPAC payment information is required."
S X2=+$O(^FBAA(161.95,"AVA",FBVEN,"A",""),-1) ; last active IPAC entry
;
; only 1 IPAC on file - select it automatically
I X1=X2 S FBIA=X1 D
. W !," - Required IPAC agreement information has been found."
. Q
;
I X1'=X2 S FBIA=$$MULTIPAC(FBVEN) ; multiple IPAC selection for vendor
I FBIA'>0 G IPACX ; get out if user failed to select one
;
S DIR(0)="Y",DIR("A")="Would you like to display the detailed IPAC agreement information"
S DIR("B")="No"
W ! D ^DIR K DIR
I $D(DIRUT) W " Not displaying detail ... "
I 'Y G IPACX ; exit without displaying the data by user choice
;
; Display the IPAC data
W !
D VADISP^FBAAIAU(FBIA,1)
S DIR(0)="E" D ^DIR K DIR ; press return to continue
IPACX ;
Q FBIA
;
MULTIPAC(FBVEN) ; multiple IPAC agreement display, lister, selection
; same input and output parameters as IPAC above
;
N FBIA,Z,CNT,FBLN,FBG,ID,FY,DESC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,LN,T,W
S FBVEN=+$G(FBVEN)
S FBIA=""
S Z=0,CNT=0 K FBLN
F S Z=$O(^FBAA(161.95,"AVA",FBVEN,"A",Z)) Q:'Z D
. S FBG=$G(^FBAA(161.95,Z,0)) I FBG="" Q
. S ID=$P(FBG,U,1)
. S FY=$P(FBG,U,3)
. S DESC=$P(FBG,U,5)
. S CNT=CNT+1,FBLN(CNT)=Z_U_ID_U_FY_U_DESC
. Q
;
I 'CNT G MULIPACX ; get out if nothing found (should not happen)
I CNT=1 S FBIA=$P(FBLN(1),U,1) G MULIPACX ; only 1 found (also should not happen)
;
; Multiple found. Build list.
S DIR(0)="N"_U_"1:"_CNT,LN=0
S LN=LN+1,DIR("A",LN)=$$GET1^DIQ(161.2,FBVEN_",",.01)_" is a Federal Vendor with"
S LN=LN+1,DIR("A",LN)=CNT_" active IPAC agreements on file:"
S LN=LN+1,DIR("A",LN)=" "
S LN=LN+1,DIR("A",LN)="# ID FY Description"
S LN=LN+1,DIR("A",LN)="-- ---------- ---- -----------"
S T=0 F S T=$O(FBLN(T)) Q:'T S W=FBLN(T) D
. S LN=LN+1,DIR("A",LN)=$$LJ^XLFSTR(T,3)_$$LJ^XLFSTR($P(W,U,2),12)_$$LJ^XLFSTR($P(W,U,3),6)_$E($P(W,U,4),1,58)
. Q
S LN=LN+1,DIR("A",LN)=" "
S LN=LN+1,DIR("A",LN)="Please select the IPAC agreement to be used with this invoice."
S LN=LN+1,DIR("A",LN)="This information is required."
S DIR("A")="Selection#"
W ! D ^DIR K DIR
I Y>0 S FBIA=$P($G(FBLN(Y)),U,1) G MULIPACX ; user selection is good so set FBIA and get out
;
; in all other cases, user failed to make a selection so set FBIA=-1
S FBIA=-1
W !!,$C(7),"IPAC Agreement Selection is required for this vendor."
;
MULIPACX ;
Q FBIA
;
IPACINV(FBDODINV,FBDEF) ; function to get the DoD invoice number for IPAC (FB*3.5*123)
; Function value is 1 if the DoD invoice number was obtained.
; Function value is 0 if not.
; FBDODINV - pass by reference. This is set to the DoD invoice number.
; FBDEF is an optional default value
;
N RET,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
S FBDODINV="",RET=0 ; initialize
S DIR(0)="Fr^3:22",DIR("A")="Enter the DoD Invoice Number"
I $G(FBDEF)'="" S DIR("B")=FBDEF
S DIR("?",1)="If invoice is a UB-04 look in block 3a."
S DIR("?",2)="If invoice is a CMS-1500 look in block 26."
S DIR("?")="You must enter between 3-22 characters."
W ! D ^DIR K DIR
I $D(DIRUT),$G(FBDEF)'="" S Y=FBDEF K DIRUT
I '$D(DIRUT),Y'="" S FBDODINV=Y,RET=1 G IPINVX
W !!,$C(7),"The DoD Invoice Number is required for IPAC processing."
IPINVX ;
W !
Q RET
;
IPACREQD(FBVEN) ; Is IPAC data required for vendor? (FB*3.5*123)
I $G(FBAAPTC)="R" Q 0 ; IPAC is not applicable for Patient/Veteran reimbursements
I +$O(^FBAA(161.95,"AVA",+$G(FBVEN),"A","")) Q 1
Q 0
;
IPACDISP(FBIA,FBDODINV) ; Quick display of IPAC data currently on file for this invoice (FB*3.5*123)
N G
S FBIA=+$G(FBIA)
S G=$G(^FBAA(161.95,FBIA,0))
I G="",$G(FBDODINV)="" G IDISPX
W !!,"IPAC Agreement Information on file for this Invoice/Payment"
W !,"-----------------------------------------------------------"
W !,"IPAC Agreement ID: ",$P(G,U,1)," (",$$GET1^DIQ(161.95,FBIA,3),")"
W !?11,"Vendor: ",$$GET1^DIQ(161.95,FBIA,1)
W !?6,"Fiscal Year: ",$P(G,U,3)
W !,"Short Description: ",$P(G,U,5)
W !?5,"DoD Invoice#: ",$G(FBDODINV)
IDISPX ;
Q
;
ANCIL ;ENTRY POINT FOR multiple ancillary payment option
S FBCHCO=1 D ^FBAAMP
K FBCHCO Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAMP 14484 printed Sep 23, 2025@19:31:51 Page 2
FBAAMP ;AISC/CMR - MULTIPLE PAYMENT ENTRY ;10/23/14 12:47
+1 ;;3.5;FEE BASIS;**4,21,38,55,61,67,116,108,143,123,154,158**;JAN 30, 1995;Build 94
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;multiple payment flag
SET FBMP=1
+4 GOTO ^FBAACO
1 ;return from FBAACO
+1 DO MMPPT^FBAACO
if $GET(FBAAOUT)
GOTO Q1
+2 DO MPDT
IF 'FBMPDT
GOTO Q1
+3 KILL FBAAOUT
WRITE !
DO CPTM^FBAALU(FBMPDT,DFN)
IF 'FBGOT
GOTO Q1
+4 ; prompt revenue code
+5 SET FBAARC=$$ASKREVC^FBUTL5()
IF FBAARC="^"
SET FBAAOUT=1
GOTO Q1
+6 ; prompt units paid
+7 SET FBUNITS=$$ASKUNITS^FBUTL5()
IF FBUNITS="^"
SET FBAAOUT=1
GOTO Q1
+8 SET FY=$EXTRACT(DT,1,3)+1700+$SELECT($EXTRACT(DT,4,5)>9:1,1:0)
+9 DO ASKZIP^FBAAFS($GET(FBV))
IF $GET(FBAAOUT)!($GET(FBZIP)']"")
GOTO Q1
+10 IF $$ANES^FBAAFS($$CPT^FBAAUTL4(FBAACP))
DO ASKTIME^FBAAFS
IF $GET(FBAAOUT)!('$GET(FBTIME))
GOTO Q1
+11 DO HCFA^FBAAMP1
if $GET(FBAAOUT)
GOTO Q1
AMTCL SET DIR(0)="162.03,1"
SET DIR("A")="AMOUNT CLAIMED"
SET DIR("?")="Enter the amount being claimed by the vendor"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO Q
SET FBJ=+Y
+1 WRITE !
SET DIR("A")="Is $"_FBJ_" correct for Amount Claimed"
SET DIR("B")="Yes"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO Q
if 'Y
GOTO AMTCL
RDAP DO FEE
if $GET(FBAAOUT)
GOTO Q
SET FBK=FBAMTPD
WRITE !
SET DIR("A")="Is $"_FBK_" correct for Amount Paid"
SET DIR("B")="Yes"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO Q
if 'Y
GOTO RDAP
+1 SET FBAAAS=0
KILL FBADJ
IF FBJ-FBK
DO SUSP^FBAAMP1
IF $GET(FBAAOUT)
if $DATA(DUOUT)
GOTO Q
GOTO Q1
+2 SET FBJ=+FBJ
SET FBK=+FBK
SET FBAAAS=+FBAAAS
MULT if FBINTOT>0
WRITE !,"Invoice: "_FBAAIN_" Totals: $ "_FBINTOT
+1 WRITE !!
SET %DT("A")="Date of Service: "
SET %DT="AEPX"
DO ^%DT
if X=""!(X="^")
GOTO Q1
+2 DO DATCK^FBAAUTL
if '$DATA(X)!(Y<0)
GOTO MULT
+3 SET FBDT=Y
+4 IF '$$CHKCPT()
WRITE !,$CHAR(7),"Invalid Date of Service."
GOTO MULT
+5 IF $$CHKICD9^FBCSV1(+$GET(FBHCFA(28)),$GET(FBDT))=""
GOTO MULT
+6 IF '$GET(FBAAMM1)
IF '$$CHKFS()
WRITE !,$CHAR(7),"Invalid Date of Service."
GOTO MULT
+7 SET DIR(0)="Y"
SET DIR("A")="Is "_($$DATX^FBAAUTL(FBDT))_" correct"
SET DIR("B")="Yes"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!('Y)
GOTO MULT
+8 SET FBAADT=FBDT
+9 SET FBMODL=$$MODL^FBAAUTL4("FBMODA","I")
+10 IF $DATA(^FBAAC("AE",DFN,FBV,FBAADT,FBAACP_$SELECT($GET(FBMODL)]"":"-"_FBMODL,1:"")))
SET DIR(0)="Y"
SET DIR("A")="Code already exists for that date! Want to add another service for the SAME DATE"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!('Y)
GOTO MULT
+11 IF FBFPPSC]""
SET FBFPPSL=$$FPPSL^FBUTL5()
IF FBFPPSL=-1
GOTO Q1
+12 WRITE !!
DO GETSVDT^FBAACO5(DFN,FBV,FBASSOC,0,FBAADT)
if $GET(FBAAOUT)
GOTO Q
+13 DO SETO^FBAACO3
DO SVCPR^FBAACO1
if $GET(FBAAOUT)
GOTO Q
FILE SET TP=""
SET DR="1///^S X=FBJ;Q;2///^S X=FBK;47///^S X=FBUNITS"
+1 IF FBCSID]""
SET DR=DR_";49///^S X=FBCSID"
+2 IF FBFPPSC]""
SET DR=DR_";50///^S X=FBFPPSC;51///^S X=FBFPPSL"
+3 IF FBAARC]""
SET DR=DR_";48////^S X=FBAARC"
+4 SET DR(1,162.03,1)="6////^S X=DUZ;7////^S X=FBAABE;8////^S X=BO;13///^S X=FBAAID;14///^S X=FBAAIN;15///^S X=FBPT;16////^S X=FBPOV;17///^S X=FBTT;18///^S X=FBAAPTC;23////^S X=FBTYPE;26////^S X=FBPSA"
+5 SET DR(1,162.03,2)="34///^S X=$G(FBAAMM1);54////^S X=$G(FBCNTRP);28////^S X=FBHCFA(28);30////^S X=FBHCFA(30);31////^S X=FBHCFA(31);32////^S X=FBHCFA(32);33///^S X=FBAAVID;44///^S X=FBFSAMT;45////^S X=FBFSUSD"
+6 ; FB*3.5*123
SET DR(1,162.03,3)=".05////^S X=$G(FBIA);.055///^S X=$G(FBDODINV)"
+7 ;FB*3.5*158
SET DR(1,162.03,4)="82///^S X=$$PYMTH^FBAAUTL(FBFSUSD)"
+8 SET DIE="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,"
+9 SET DA=FBAACPI
SET DA(1)=FBSDI
SET DA(2)=FBV
SET DA(3)=DFN
+10 DO LOCK^FBUCUTL(DIE,FBAACPI,1)
+11 DO ^DIE
+12 DO FILEADJ^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBADJ)
+13 DO FILERR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBRRMK)
+14 LOCK -^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI)
+15 SET FBINTOT=FBINTOT+FBK
+16 WRITE " ....OK, DONE...."
+17 ; HIPAA 5010 - count line items that have 0.00 amount paid
+18 SET Z1=$PIECE(^FBAA(161.7,FBAABE,0),"^",11)+1
SET $PIECE(^(0),"^",11)=Z1
+19 if Z1>(FBAAMPI-20)
WRITE !,*7,"Warning, you can only enter ",(FBAAMPI-Z1)," more line items!"
IF Z1>(FBAAMPI-1)
Begin DoDot:1
+20 WRITE !!,*7,"You have reached the maximum number of payments for a Batch!",!,"You must select another Batch for entering Payments!"
End DoDot:1
SET FBMAX=1
GOTO Q1
+21 GOTO MULT
Q1 KILL FBADJ,FBAADT,FBX,FBAACP,DIC,DIE,X,Y,DIRUT,DUOUT,DTOUT,FBOUT,FBSI,FBMPDT,FBIA,FBDODINV
if $DATA(FBMAX)
GOTO ^FBAACO
GOTO 1^FBAACO
+1 ;
Q ;kill variables and exit
+1 DO Q^FBAACO
+2 QUIT
+3 ;
MPDT ;
+1 SET FBMPDT=""
+2 SET DIR(0)="D^::EX"
+3 SET DIR("A")="Enter date to use for CPT/ICD checks and fee schedule calc"
+4 SET DIR("B")="TODAY"
+5 SET DIR("?",1)="Enter a date. This date will be used when checking for"
+6 SET DIR("?",2)="an active CPT/Modifier/ICD code. Also, the fee schedule"
+7 SET DIR("?",3)="amount will be computed based on this date."
+8 SET DIR("?")="Enter '^' to exit."
+9 WRITE !
+10 DO ^DIR
KILL DIR
if '$DATA(DIRUT)
SET FBMPDT=Y
+11 QUIT
+12 ;
FEE NEW FBX,FB1725
+1 ; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
+2 SET FB1725=$SELECT($GET(FB583):+$PIECE($GET(^FB583(+FB583,0)),U,28),1:0)
+3 SET FBFY=FY-1
+4 SET (FBFSAMT,FBFSUSD,FBAMFS)=""
+5 ; FB*3.5*143 Adding FB1725 as a parameter to prevent reduction
+6 ; of local fee schedule payments
+7 SET FBX=$$GET^FBAAFS($$CPT^FBAAUTL4(FBAACP),$$MODL^FBAAUTL4("FBMODA","E"),FBMPDT,$GET(FBZIP),$$FAC^FBAAFS($GET(FBHCFA(30))),$GET(FBTIME),$GET(FB1725))
+8 ;
+9 IF '$GET(FBAAMM1)
Begin DoDot:1
+10 SET FBFSAMT=$PIECE(FBX,U)
SET FBFSUSD=$PIECE(FBX,U,2)
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 WRITE !,?2,"Payment is for a contracted service so fee schedule does not apply."
End DoDot:1
+13 ;
+14 IF $PIECE($GET(FBX),U)]""
Begin DoDot:1
+15 WRITE !?2,$SELECT($GET(FBAAMM1):"However, f",1:"F")
+16 WRITE "ee schedule amount is $",$PIECE(FBX,U)," from the "
+17 ; year if returned
if $PIECE(FBX,U,3)]""
WRITE $PIECE(FBX,U,3)," "
+18 if $PIECE(FBX,U,2)]""
WRITE $$EXTERNAL^DILFD(162.03,45,"",$PIECE(FBX,U,2))
End DoDot:1
+19 IF '$TEST
WRITE !?2,"Unable to determine a FEE schedule amount."
+20 ;
+21 ; FB*3.5*143 - Preventing 70% reduction of 75th percentile rates
+22 IF FB1725
IF FBFSUSD'="F"
Begin DoDot:1
+23 WRITE !!?2,"**Payment is for emergency treatment under 38 U.S.C. 1725."
+24 IF FBFSAMT
Begin DoDot:2
+25 SET FBFSAMT=$JUSTIFY(FBFSAMT*.7,0,2)
+26 WRITE !?2," Therefore, fee schedule amount reduced to $",FBFSAMT," (70%)."
End DoDot:2
End DoDot:1
+27 ;
+28 IF $GET(FBUNITS)>1
Begin DoDot:1
+29 WRITE !!?2,"Units Paid = ",FBUNITS
+30 if FBFSAMT'>0
QUIT
+31 NEW FBFSUNIT
+32 ; determine if fee schedule can be multiplied by units
+33 SET FBFSUNIT=$SELECT(FBFSUSD="R":1,FBFSUSD="F"&(FBMPDT>3040930):1,1:0)
+34 IF FBFSUNIT
Begin DoDot:2
+35 SET FBFSAMT=$JUSTIFY(FBFSAMT*FBUNITS,0,2)
+36 WRITE !?2," Therefore, fee schedule amount increased to $",FBFSAMT
End DoDot:2
+37 IF '$TEST
Begin DoDot:2
+38 WRITE !?2," Fee schedule not complied on per unit basis so amount not adjusted by units."
End DoDot:2
End DoDot:1
+39 ;
+40 IF '$GET(FBAAMM1)
Begin DoDot:1
+41 ; set default amount paid to lesser of amt claimed (J) or fee sched.
+42 SET FBAMFS=$SELECT(FBFSAMT>$GET(FBJ):$GET(FBJ),1:FBFSAMT)
End DoDot:1
+43 ;
+44 WRITE !
+45 ;
AMTPD KILL DIR
SET DIR(0)="162.03,2"
SET DIR("A")="AMOUNT PAID"
if $GET(FBAMFS)'=""
SET DIR("B")=FBAMFS
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET FBAAOUT=1
QUIT
+1 SET FBAMTPD=+Y
KILL FBAMFS
QUIT
+2 ;
CHKCPT() ; check if CPT/Modifier active on date of service
+1 NEW FBCPTX,FBI,FBMOD,FBMODX,FBRET
+2 SET FBRET=1
+3 SET FBCPTX=$$CPT^ICPTCOD(FBAACP,FBDT,1)
+4 IF '$PIECE(FBCPTX,U,7)
SET FBRET=0
WRITE !," CPT Code ",$PIECE(FBCPTX,U,2)," inactive on date of service."
+5 IF $ORDER(FBMODA(0))
Begin DoDot:1
+6 SET FBI=0
FOR
SET FBI=$ORDER(FBMODA(FBI))
if 'FBI
QUIT
Begin DoDot:2
+7 SET FBMODX=$$MOD^ICPTMOD(FBMODA(FBI),"I",FBDT,1)
+8 IF '$PIECE(FBMODX,U,7)
SET FBRET=0
WRITE !," CPT Modifier ",$PIECE(FBMODX,U,2)," inactive on date of service."
End DoDot:2
End DoDot:1
+9 QUIT FBRET
+10 ;
CHKFS() ; check if fee schedule amount is different on date of service
+1 NEW FBX,FBRET,FB1725
+2 ; return value - true if date of service allowed
SET FBRET=1
+3 ; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
+4 SET FB1725=$SELECT($GET(FB583):+$PIECE($GET(^FB583(+FB583,0)),U,28),1:0)
+5 SET FBX=$$GET^FBAAFS($$CPT^FBAAUTL4(FBAACP),$$MODL^FBAAUTL4("FBMODA","E"),FBDT,$GET(FBZIP),$$FAC^FBAAFS($GET(FBHCFA(30))),$GET(FBTIME),$GET(FB1725))
+6 ; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
+7 SET FB1725=$SELECT($GET(FB583):+$PIECE($GET(^FB583(+FB583,0)),U,28),1:0)
+8 ; adjust amount if mill bill
+9 IF FB1725
SET $PIECE(FBX,U)=$JUSTIFY($PIECE(FBX,U)*.7,0,2)
+10 ; adjust amount if units > 1
+11 IF $GET(FBUNITS)
Begin DoDot:1
+12 NEW FBFSUNIT
+13 ; determine if fee schedule can be multiplied by units
+14 SET FBFSUNIT=$SELECT($PIECE(FBX,U,2)="R":1,$PIECE(FBX,U,2)="F"&(FBDT>3040930):1,1:0)
+15 IF FBFSUNIT
SET $PIECE(FBX,U)=$JUSTIFY($PIECE(FBX,U)*FBUNITS,0,2)
End DoDot:1
+16 ; issue warning if lesser of claim and fee schedule amount different
+17 IF +$SELECT($PIECE(FBX,U)>$GET(FBJ):$GET(FBJ),1:$PIECE(FBX,U))'=+$SELECT(FBFSAMT>$GET(FBJ):$GET(FBJ),1:FBFSAMT)
Begin DoDot:1
+18 WRITE !," Warning: The fee schedule amount (",$PIECE(FBX,U),") for this date of service "
+19 WRITE !," differs from the initial fee schedule amount (",FBFSAMT,")."
+20 IF $PIECE(FBX,U)>0
IF FBK>$PIECE(FBX,U)
Begin DoDot:2
+21 WRITE !," Amount paid (",FBK,") exceeds the fee schedule amount."
End DoDot:2
+22 if FBRET
WRITE !," You may want to separately process this date of service."
End DoDot:1
+23 QUIT FBRET
+24 ;
IPACID(FBVEN,FBIPIEN) ; function to return IPAC agreement ID# if exactly 1 active IPAC on file for vendor (FB*3.5*123)
+1 ; No user interface allowed with this function. Called by background, Austin transmission process.
+2 ;
+3 ; Input:
+4 ; FBVEN - Vendor ien (ptr to file 161.2)
+5 ;
+6 ; Output:
+7 ; Function value = if exactly 1 active IPAC agreement is on file, then this returns the external agreement ID#
+8 ; otherwise, this returns ""
+9 ; FBIPIEN (pass by reference) - internal entry ien of the active IPAC agreement on file
+10 ;
+11 NEW X1,X2,RET
+12 ; default value
SET RET=""
+13 ; initialize
SET FBIPIEN=""
+14 SET FBVEN=+$GET(FBVEN)
+15 ; IPAC not required
IF '$$IPACREQD(FBVEN)
GOTO IPACIDX
+16 ; first active IPAC entry
SET X1=+$ORDER(^FBAA(161.95,"AVA",FBVEN,"A",""))
+17 ; no IPAC data found for vendor so get out
IF 'X1
GOTO IPACIDX
+18 ; last active IPAC entry
SET X2=+$ORDER(^FBAA(161.95,"AVA",FBVEN,"A",""),-1)
+19 ;
+20 ; only 1 IPAC on file - retrieve the ID# in this case only
+21 ; IPAC external agreement ID#
IF X1=X2
SET RET=$PIECE($GET(^FBAA(161.95,X1,0)),U,1)
SET FBIPIEN=X1
+22 ;
IPACIDX ;
+1 QUIT RET
+2 ;
IPAC(FBVEN) ; Determine if active IPAC agreement data exists for vendor (FB*3.5*123)
+1 ; Input:
+2 ; FBVEN - Vendor ien (ptr to file 161.2)
+3 ;
+4 ; Output:
+5 ; Function value = -1 if active IPAC records exist, but none were selected (this is an error condition)
+6 ; = ien of IPAC entry in file 161.95 (if only 1 exists, or user selected it)
+7 ; = "" if no IPAC data found or if IPAC not required
+8 ;
+9 NEW FBIA,X1,X2,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+10 SET FBIA=""
+11 SET FBVEN=+$GET(FBVEN)
+12 ; IPAC not required
IF '$$IPACREQD(FBVEN)
GOTO IPACX
+13 ; first active IPAC entry
SET X1=+$ORDER(^FBAA(161.95,"AVA",FBVEN,"A",""))
+14 ; no IPAC data found for vendor, get out with FBIA=""
IF 'X1
GOTO IPACX
+15 WRITE !!,"This is a Federal Vendor. IPAC payment information is required."
+16 ; last active IPAC entry
SET X2=+$ORDER(^FBAA(161.95,"AVA",FBVEN,"A",""),-1)
+17 ;
+18 ; only 1 IPAC on file - select it automatically
+19 IF X1=X2
SET FBIA=X1
Begin DoDot:1
+20 WRITE !," - Required IPAC agreement information has been found."
+21 QUIT
End DoDot:1
+22 ;
+23 ; multiple IPAC selection for vendor
IF X1'=X2
SET FBIA=$$MULTIPAC(FBVEN)
+24 ; get out if user failed to select one
IF FBIA'>0
GOTO IPACX
+25 ;
+26 SET DIR(0)="Y"
SET DIR("A")="Would you like to display the detailed IPAC agreement information"
+27 SET DIR("B")="No"
+28 WRITE !
DO ^DIR
KILL DIR
+29 IF $DATA(DIRUT)
WRITE " Not displaying detail ... "
+30 ; exit without displaying the data by user choice
IF 'Y
GOTO IPACX
+31 ;
+32 ; Display the IPAC data
+33 WRITE !
+34 DO VADISP^FBAAIAU(FBIA,1)
+35 ; press return to continue
SET DIR(0)="E"
DO ^DIR
KILL DIR
IPACX ;
+1 QUIT FBIA
+2 ;
MULTIPAC(FBVEN) ; multiple IPAC agreement display, lister, selection
+1 ; same input and output parameters as IPAC above
+2 ;
+3 NEW FBIA,Z,CNT,FBLN,FBG,ID,FY,DESC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y,LN,T,W
+4 SET FBVEN=+$GET(FBVEN)
+5 SET FBIA=""
+6 SET Z=0
SET CNT=0
KILL FBLN
+7 FOR
SET Z=$ORDER(^FBAA(161.95,"AVA",FBVEN,"A",Z))
if 'Z
QUIT
Begin DoDot:1
+8 SET FBG=$GET(^FBAA(161.95,Z,0))
IF FBG=""
QUIT
+9 SET ID=$PIECE(FBG,U,1)
+10 SET FY=$PIECE(FBG,U,3)
+11 SET DESC=$PIECE(FBG,U,5)
+12 SET CNT=CNT+1
SET FBLN(CNT)=Z_U_ID_U_FY_U_DESC
+13 QUIT
End DoDot:1
+14 ;
+15 ; get out if nothing found (should not happen)
IF 'CNT
GOTO MULIPACX
+16 ; only 1 found (also should not happen)
IF CNT=1
SET FBIA=$PIECE(FBLN(1),U,1)
GOTO MULIPACX
+17 ;
+18 ; Multiple found. Build list.
+19 SET DIR(0)="N"_U_"1:"_CNT
SET LN=0
+20 SET LN=LN+1
SET DIR("A",LN)=$$GET1^DIQ(161.2,FBVEN_",",.01)_" is a Federal Vendor with"
+21 SET LN=LN+1
SET DIR("A",LN)=CNT_" active IPAC agreements on file:"
+22 SET LN=LN+1
SET DIR("A",LN)=" "
+23 SET LN=LN+1
SET DIR("A",LN)="# ID FY Description"
+24 SET LN=LN+1
SET DIR("A",LN)="-- ---------- ---- -----------"
+25 SET T=0
FOR
SET T=$ORDER(FBLN(T))
if 'T
QUIT
SET W=FBLN(T)
Begin DoDot:1
+26 SET LN=LN+1
SET DIR("A",LN)=$$LJ^XLFSTR(T,3)_$$LJ^XLFSTR($PIECE(W,U,2),12)_$$LJ^XLFSTR($PIECE(W,U,3),6)_$EXTRACT($PIECE(W,U,4),1,58)
+27 QUIT
End DoDot:1
+28 SET LN=LN+1
SET DIR("A",LN)=" "
+29 SET LN=LN+1
SET DIR("A",LN)="Please select the IPAC agreement to be used with this invoice."
+30 SET LN=LN+1
SET DIR("A",LN)="This information is required."
+31 SET DIR("A")="Selection#"
+32 WRITE !
DO ^DIR
KILL DIR
+33 ; user selection is good so set FBIA and get out
IF Y>0
SET FBIA=$PIECE($GET(FBLN(Y)),U,1)
GOTO MULIPACX
+34 ;
+35 ; in all other cases, user failed to make a selection so set FBIA=-1
+36 SET FBIA=-1
+37 WRITE !!,$CHAR(7),"IPAC Agreement Selection is required for this vendor."
+38 ;
MULIPACX ;
+1 QUIT FBIA
+2 ;
IPACINV(FBDODINV,FBDEF) ; function to get the DoD invoice number for IPAC (FB*3.5*123)
+1 ; Function value is 1 if the DoD invoice number was obtained.
+2 ; Function value is 0 if not.
+3 ; FBDODINV - pass by reference. This is set to the DoD invoice number.
+4 ; FBDEF is an optional default value
+5 ;
+6 NEW RET,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+7 ; initialize
SET FBDODINV=""
SET RET=0
+8 SET DIR(0)="Fr^3:22"
SET DIR("A")="Enter the DoD Invoice Number"
+9 IF $GET(FBDEF)'=""
SET DIR("B")=FBDEF
+10 SET DIR("?",1)="If invoice is a UB-04 look in block 3a."
+11 SET DIR("?",2)="If invoice is a CMS-1500 look in block 26."
+12 SET DIR("?")="You must enter between 3-22 characters."
+13 WRITE !
DO ^DIR
KILL DIR
+14 IF $DATA(DIRUT)
IF $GET(FBDEF)'=""
SET Y=FBDEF
KILL DIRUT
+15 IF '$DATA(DIRUT)
IF Y'=""
SET FBDODINV=Y
SET RET=1
GOTO IPINVX
+16 WRITE !!,$CHAR(7),"The DoD Invoice Number is required for IPAC processing."
IPINVX ;
+1 WRITE !
+2 QUIT RET
+3 ;
IPACREQD(FBVEN) ; Is IPAC data required for vendor? (FB*3.5*123)
+1 ; IPAC is not applicable for Patient/Veteran reimbursements
IF $GET(FBAAPTC)="R"
QUIT 0
+2 IF +$ORDER(^FBAA(161.95,"AVA",+$GET(FBVEN),"A",""))
QUIT 1
+3 QUIT 0
+4 ;
IPACDISP(FBIA,FBDODINV) ; Quick display of IPAC data currently on file for this invoice (FB*3.5*123)
+1 NEW G
+2 SET FBIA=+$GET(FBIA)
+3 SET G=$GET(^FBAA(161.95,FBIA,0))
+4 IF G=""
IF $GET(FBDODINV)=""
GOTO IDISPX
+5 WRITE !!,"IPAC Agreement Information on file for this Invoice/Payment"
+6 WRITE !,"-----------------------------------------------------------"
+7 WRITE !,"IPAC Agreement ID: ",$PIECE(G,U,1)," (",$$GET1^DIQ(161.95,FBIA,3),")"
+8 WRITE !?11,"Vendor: ",$$GET1^DIQ(161.95,FBIA,1)
+9 WRITE !?6,"Fiscal Year: ",$PIECE(G,U,3)
+10 WRITE !,"Short Description: ",$PIECE(G,U,5)
+11 WRITE !?5,"DoD Invoice#: ",$GET(FBDODINV)
IDISPX ;
+1 QUIT
+2 ;
ANCIL ;ENTRY POINT FOR multiple ancillary payment option
+1 SET FBCHCO=1
DO ^FBAAMP
+2 KILL FBCHCO
QUIT
