FBAACO3 ;AISC/GRR - ENTER PAYMENT CONTINUED ;12/4/14 14:11
;;3.5;FEE BASIS;**4,38,55,61,116,122,133,108,124,143,139,157,154,158**;JAN 30, 1995;Build 94
;;Per VA Directive 6402, this routine should not be modified.
;
;FB*3.5*157 Modify file 162, Diagnosis (field 28) stuff from '///' to '////'
; since needed file 80 dx IEN is already passed back from DX
; lookup.
;
DOEDIT ;
N FB1725,FBFPPSC
W ! S FBAACP(0)=FBAACP
S DIC="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,"
S DIC(0)="EQMZ",DA(3)=DFN,DA(2)=FBV,DA(1)=FBSDI
S X=$$CPT^FBAAUTL4(FBAACP)
D ^DIC I Y<0 S FBAAOUT=1 Q
S (DA,FBAACPI)=+Y,K=$P(Y(0),U,3),FBZBN=$P(Y(0),U,8),FBZBS=$S(FBZBN]"":$P($G(^FBAA(161.7,FBZBN,"ST")),U),1:""),FBAAPTC=$P(Y(0),U,20),J(0)=$P(Y(0),U,2)
; set FB1725 true (1) if payment is for a Mill Bill claim
S FB1725=$S($P(Y(0),U,13)["FB583":+$P($G(^FB583(+$P(Y(0),U,13),0)),U,28),1:0)
S FBAAMM1=$P($G(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,2)),U,2)
S FBCNTRP=$P($G(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,3)),U,8)
S FBFSAMT(0)=$P($G(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,2)),U,12)
; determine lesser of original fee schedule amount and amount claimed
S FBAMTPD(0)=$S(FBFSAMT(0)="":J(0),FBFSAMT(0)>J(0):J(0),1:FBFSAMT(0))
S FBMODL=$$MODL^FBAAUTL4("^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,"_FBAACPI_",""M"")")
; load current adjustment data
D LOADADJ^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBADJ)
; save adjustment data prior to edit session in sorted list
S FBADJL(0)=$$ADJL^FBUTL2(.FBADJ) ; sorted list of original adjustments
; load current remittance remark data
D LOADRR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBRRMK)
; save remittance remarks prior to edit session in sorted list
S FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK)
; load FPPS data
S FBFPPSC=$P($G(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,3)),U)
S FBFPPSL=$P($G(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,3)),U,2)
I FBZBS=""!(FBZBS="V") D NOGO S FBAAOUT=1 Q
; first edit CPT code and modifiers
D CPTM^FBAALU(FBAADT,DFN,FBAACP(0),FBMODL) I '$G(FBGOT) S FBAAOUT=1 Q
; if CPT was changed then update file
I FBAACP'=FBAACP(0) D I FBAACP="@" S FBAAOUT=1 Q
. N FBIENS,FBFDA
. S FBIENS=FBAACPI_","_FBSDI_","_FBV_","_DFN_","
. S FBFDA(162.03,FBIENS,.01)=FBAACP
. D FILE^DIE("","FBFDA") D MSG^DIALOG()
; if modifiers changed then update file
I FBMODL'=$$MODL^FBAAUTL4("FBMODA") D REPMOD^FBAAUTL4(DFN,FBV,FBSDI,FBAACPI)
; now edit remaining fields
D SETO K DR
;JAS - 09/13/13 - PATCH 139 - Added FBDXCHK1 and FBDXCHK2
N FBDXCHK1 S FBDXCHK1=";S:FBAADT<$$IMPDATE^FBCSV1(""10D"") Y=""@20"";@15;S XX1=-1 S XX1=$$ASKICD10^FBAACO2(FBAADT) S:XX1<0 Y=""@15"";28////^S X=XX1;S Y=""@21"";" ;;FB*3.5*157
S FBDXCHK1=FBDXCHK1_"@20;S XX1=$$ASKICD9^FBAACO2(FBAADT) S:+XX1<0 Y=""@20"";28////^S X=+XX1;@21;31;32R;S Y=""@7"";"
N FBDXCHK2 S FBDXCHK2=";S:FBAADT<$$IMPDATE^FBCSV1(""10D"") Y=""@26"";@25;S XX1=-1 S XX1=$$ASKICD10^FBAACO2(FBAADT) S:XX1<0 Y=""@25"";28////^S X=XX1;S Y=""@30"";@26;" ;;FB*3.5*157
S DR="48;47;S FBUNITS=X;42R;S FBZIP=X;S:$$ANES^FBAAFS($$CPT^FBAAUTL4(FBAACP)) Y=""@2"";43///@;S FBTIME=X;S Y=""@3"";@2;43R;S FBTIME=X;@3"
; fb*3.5*116 remove edit of interest indicator (162.03,34) to prevent different interest indicator values at line item level; interest indicator set at invoice level only
S DR(1,162.03,1)="S FBAAMM=$S(FBAAPTC=""R"":"""",1:1);D PPT^FBAACO1(FBAAMM1,FBCNTRP,1);34///@;34////^S X=FBAAMM1;54///@;54////^S X=FBCNTRP;30R;S FBHCFA(30)=X;1;S J=X;Q"
S DR(1,162.03,2)="D FEEDT^FBAACO3;44///@;44///^S X=FBFSAMT;45///@;45///^S X=FBFSUSD;S:FBAMTPD'>0!(FBAMTPD=FBAMTPD(0)) Y=""@4"";2///^S X=FBAMTPD;@4;2//^S X=FBAMTPD;S K=X"
S DR(1,162.03,3)="K FBADJD;M FBADJD=FBADJ;S FBX=$$ADJ^FBUTL2(J-K,.FBADJ,5,,.FBADJD,1,.FBRRMK,1)"
S DR(1,162.03,4)="S:FBFPPSC="""" Y=13;W !,""FPPS CLAIM ID: ""_FBFPPSC;S FBX=$$FPPSL^FBUTL5(FBFPPSL,,1);51///^S X=FBX;S FBFPPSL=X;@13;13;I $$BADDATE^FBAACO3(FBAADT,X) S Y=""@13"";33"
;JAS - 09/13/13 - PATCH 139 - Updated line below for ICD-10
S DR(1,162.03,5)="S:$$EXTPV^FBAAUTL5(FBPOV)=""01"" Y=""@1"";S Y=$S('$D(FB7078):""@5"",FB7078]"""":""@21"",1:""@5"");@5"_FBDXCHK1_"@1"_FBDXCHK2_"S XX1=$$ASKICD9^FBAACO2(FBAADT) S:+XX1<0 Y=""@26"";28////^S X=+XX1;@30;31"
S DR(1,162.03,6)="73;74;75;58;59;60;61;62;63;64;65;66;67;76;77;78;79;68;69"
S DR(1,162.03,7)="82///^S X=$$PYMTH^FBAAUTL(FBFSUSD)" ;FB*3.5*158
S DIE="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,",DIE("NO^")="",FBOT=1
D LOCK^FBUCUTL("^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,",FBAACPI) I 'FBLOCK S FBAAOUT=1 Q
D ^DIE
; if adjustment data changed then file
I $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0) D FILEADJ^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBADJ)
; if remit remark data changed then file
I $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0) D FILERR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBRRMK)
L -^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI) K FBOT,DIE,DR,DA
Q:$D(FBDL)
I $G(FBAAIN) S FBINTOT=0 D CALC
Q
;
BADDATE(FBDOS,INVRCVDT) ;Reject entry if InvRcvDt is Prior to the Date of Service on the Invoice
I INVRCVDT<FBDOS D Q 1 ;Reject entry
.N SHOWDOS S SHOWDOS=$E(FBDOS,4,5)_"/"_$E(FBDOS,6,7)_"/"_$E(FBDOS,2,3) ;Convert FBDOS into display format for error message
.W *7,!!?5,"*** Invoice Received Date cannot be prior to the",!?8," Date of Service ("_SHOWDOS_") !!!"
Q 0 ;Accept entry
;
SETO S FY=$E(FBAADT,1,3)+1700+$S($E(FBAADT,4,5)>9:1,1:0)
Q
OUT ;
; FB*3.5*116 count line items that have 0.00 amount paid
;I K>0 S Z1=$P(^FBAA(161.7,FBAABE,0),"^",11)+1,$P(^(0),"^",11)=Z1,FBINTOT=FBINTOT+K
S Z1=$P(^FBAA(161.7,FBAABE,0),"^",11)+1,$P(^(0),"^",11)=Z1,FBINTOT=FBINTOT+K
Q
CKMAX S (FBAOT,A)=0,O="" F Z=S-.1:0 S Z=$O(^FBAAC(DFN,"AB",Z)) Q:Z'>0!(Z>R) F Q=0:0 S Q=$O(^FBAAC(DFN,"AB",Z,Q)) Q:Q'>0 S W=$O(^FBAAC(DFN,"AB",Z,Q,0)) I $D(^FBAAC(DFN,1,Q,1,W,0)) D SMORE
I A>$P(FBSITE(1),"^",9) G NO
Q
SMORE N FBA,FBB S FBB=$P($G(^FBAAC(+DFN,1,+Q,1,+W,0)),U,4),E=0
F S E=$O(^FBAAC(DFN,1,Q,1,W,1,E)) Q:'E S FBA=$G(^(E,0)) I $P(FBA,"^",9)=2,$P(FBA,"^",18)'=1 D
.I $$IDCHK^FBAAUTL3(DFN,FBB) S A=A+$P(FBA,"^",3) Q
.S FBAOT=FBAOT+$P(FBA,U,3)
Q
NO W !!,*7,"Warning Patient already at maximum allowed for month of service",! Q
WARN W !!,*7,"You have reached the maximum number of payments for a Batch!",!,"You must select another Batch for entering Payments!"
CALC ;Calculate Current Invoice Total
F J=0:0 S J=$O(^FBAAC("C",FBAAIN,J)) Q:J'>0 F K=0:0 S K=$O(^FBAAC("C",FBAAIN,J,K)) Q:K'>0 F L=0:0 S L=$O(^FBAAC("C",FBAAIN,J,K,L)) Q:L'>0 F M=0:0 S M=$O(^FBAAC("C",FBAAIN,J,K,L,M)) Q:M'>0 D CALC1
K J,K,L,M,FZNODE Q
CALC1 S FZNODE=^FBAAC(J,1,K,1,L,1,M,0),A2=$P(FZNODE,"^",3),FBINTOT=FBINTOT+A2,FBAAID=$P(FZNODE,"^",15),FBAAVID=$P($G(^FBAAC(J,1,K,1,L,1,M,2)),"^")
Q
FEEDT ;
;FB*3.5*143 Adding FB1725 as a parameter to prevent incorrect
; reductions in local fee schedule pricing.
; input FB1725 - true (=1) when edited payment is for a Mill BilL claim.
N FBX
D SETO:'$G(FY) S FBFY=FY-1
S (FBFSAMT,FBFSUSD)="",FBAMTPD=$G(FBAMTPD)
S FBX=$$GET^FBAAFS($$CPT^FBAAUTL4(FBAACP),$$MODL^FBAAUTL4("FBMODA","E"),FBAADT,$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."
;
I FB1725 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"&(FBAADT>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 FBAMTPD=$S(FBFSAMT'>0:J,FBFSAMT>J:J,1:FBFSAMT)
W !
Q
NOGO W !!,*7,"This payment CANNOT be edited. The batch the payment is in",!,"has been Vouchered. You may void the payment with the Void Payment option.",!
Q
;
SC W *7,!?4,"Suspense code is required!",! S Y="@4" Q
;
DEL ;delete date of service if no service provided entered
I '$O(^FBAAC(DFN,1,FBV,1,FBSDI,1,0)) D
.S DIK="^FBAAC(DFN,1,FBV,1,",DA(2)=DFN,DA(1)=FBV,DA=FBSDI D ^DIK W !!?5,*7,"Incomplete payment entry deleted.",!
K DIK,DA Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAACO3 8893 printed Apr 09, 2024@21:02:31 Page 2
FBAACO3 ;AISC/GRR - ENTER PAYMENT CONTINUED ;12/4/14 14:11
+1 ;;3.5;FEE BASIS;**4,38,55,61,116,122,133,108,124,143,139,157,154,158**;JAN 30, 1995;Build 94
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;FB*3.5*157 Modify file 162, Diagnosis (field 28) stuff from '///' to '////'
+5 ; since needed file 80 dx IEN is already passed back from DX
+6 ; lookup.
+7 ;
DOEDIT ;
+1 NEW FB1725,FBFPPSC
+2 WRITE !
SET FBAACP(0)=FBAACP
+3 SET DIC="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,"
+4 SET DIC(0)="EQMZ"
SET DA(3)=DFN
SET DA(2)=FBV
SET DA(1)=FBSDI
+5 SET X=$$CPT^FBAAUTL4(FBAACP)
+6 DO ^DIC
IF Y<0
SET FBAAOUT=1
QUIT
+7 SET (DA,FBAACPI)=+Y
SET K=$PIECE(Y(0),U,3)
SET FBZBN=$PIECE(Y(0),U,8)
SET FBZBS=$SELECT(FBZBN]"":$PIECE($GET(^FBAA(161.7,FBZBN,"ST")),U),1:"")
SET FBAAPTC=$PIECE(Y(0),U,20)
SET J(0)=$PIECE(Y(0),U,2)
+8 ; set FB1725 true (1) if payment is for a Mill Bill claim
+9 SET FB1725=$SELECT($PIECE(Y(0),U,13)["FB583":+$PIECE($GET(^FB583(+$PIECE(Y(0),U,13),0)),U,28),1:0)
+10 SET FBAAMM1=$PIECE($GET(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,2)),U,2)
+11 SET FBCNTRP=$PIECE($GET(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,3)),U,8)
+12 SET FBFSAMT(0)=$PIECE($GET(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,2)),U,12)
+13 ; determine lesser of original fee schedule amount and amount claimed
+14 SET FBAMTPD(0)=$SELECT(FBFSAMT(0)="":J(0),FBFSAMT(0)>J(0):J(0),1:FBFSAMT(0))
+15 SET FBMODL=$$MODL^FBAAUTL4("^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,"_FBAACPI_",""M"")")
+16 ; load current adjustment data
+17 DO LOADADJ^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBADJ)
+18 ; save adjustment data prior to edit session in sorted list
+19 ; sorted list of original adjustments
SET FBADJL(0)=$$ADJL^FBUTL2(.FBADJ)
+20 ; load current remittance remark data
+21 DO LOADRR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBRRMK)
+22 ; save remittance remarks prior to edit session in sorted list
+23 SET FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK)
+24 ; load FPPS data
+25 SET FBFPPSC=$PIECE($GET(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,3)),U)
+26 SET FBFPPSL=$PIECE($GET(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,3)),U,2)
+27 IF FBZBS=""!(FBZBS="V")
DO NOGO
SET FBAAOUT=1
QUIT
+28 ; first edit CPT code and modifiers
+29 DO CPTM^FBAALU(FBAADT,DFN,FBAACP(0),FBMODL)
IF '$GET(FBGOT)
SET FBAAOUT=1
QUIT
+30 ; if CPT was changed then update file
+31 IF FBAACP'=FBAACP(0)
Begin DoDot:1
+32 NEW FBIENS,FBFDA
+33 SET FBIENS=FBAACPI_","_FBSDI_","_FBV_","_DFN_","
+34 SET FBFDA(162.03,FBIENS,.01)=FBAACP
+35 DO FILE^DIE("","FBFDA")
DO MSG^DIALOG()
End DoDot:1
IF FBAACP="@"
SET FBAAOUT=1
QUIT
+36 ; if modifiers changed then update file
+37 IF FBMODL'=$$MODL^FBAAUTL4("FBMODA")
DO REPMOD^FBAAUTL4(DFN,FBV,FBSDI,FBAACPI)
+38 ; now edit remaining fields
+39 DO SETO
KILL DR
+40 ;JAS - 09/13/13 - PATCH 139 - Added FBDXCHK1 and FBDXCHK2
+41 ;;FB*3.5*157
NEW FBDXCHK1
SET FBDXCHK1=";S:FBAADT<$$IMPDATE^FBCSV1(""10D"") Y=""@20"";@15;S XX1=-1 S XX1=$$ASKICD10^FBAACO2(FBAADT) S:XX1<0 Y=""@15"";28////^S X=XX1;S Y=""@21"";"
+42 SET FBDXCHK1=FBDXCHK1_"@20;S XX1=$$ASKICD9^FBAACO2(FBAADT) S:+XX1<0 Y=""@20"";28////^S X=+XX1;@21;31;32R;S Y=""@7"";"
+43 ;;FB*3.5*157
NEW FBDXCHK2
SET FBDXCHK2=";S:FBAADT<$$IMPDATE^FBCSV1(""10D"") Y=""@26"";@25;S XX1=-1 S XX1=$$ASKICD10^FBAACO2(FBAADT) S:XX1<0 Y=""@25"";28////^S X=XX1;S Y=""@30"";@26;"
+44 SET DR="48;47;S FBUNITS=X;42R;S FBZIP=X;S:$$ANES^FBAAFS($$CPT^FBAAUTL4(FBAACP)) Y=""@2"";43///@;S FBTIME=X;S Y=""@3"";@2;43R;S FBTIME=X;@3"
+45 ; fb*3.5*116 remove edit of interest indicator (162.03,34) to prevent different interest indicator values at line item level; interest indicator set at invoice level only
+46 SET DR(1,162.03,1)="S FBAAMM=$S(FBAAPTC=""R"":"""",1:1);D PPT^FBAACO1(FBAAMM1,FBCNTRP,1);34///@;34////^S X=FBAAMM1;54///@;54////^S X=FBCNTRP;30R;S FBHCFA(30)=X;1;S J=X;Q"
+47 SET DR(1,162.03,2)="D FEEDT^FBAACO3;44///@;44///^S X=FBFSAMT;45///@;45///^S X=FBFSUSD;S:FBAMTPD'>0!(FBAMTPD=FBAMTPD(0)) Y=""@4"";2///^S X=FBAMTPD;@4;2//^S X=FBAMTPD;S K=X"
+48 SET DR(1,162.03,3)="K FBADJD;M FBADJD=FBADJ;S FBX=$$ADJ^FBUTL2(J-K,.FBADJ,5,,.FBADJD,1,.FBRRMK,1)"
+49 SET DR(1,162.03,4)="S:FBFPPSC="""" Y=13;W !,""FPPS CLAIM ID: ""_FBFPPSC;S FBX=$$FPPSL^FBUTL5(FBFPPSL,,1);51///^S X=FBX;S FBFPPSL=X;@13;13;I $$BADDATE^FBAACO3(FBAADT,X) S Y=""@13"";33"
+50 ;JAS - 09/13/13 - PATCH 139 - Updated line below for ICD-10
+51 SET DR(1,162.03,5)="S:$$EXTPV^FBAAUTL5(FBPOV)=""01"" Y=""@1"";S Y=$S('$D(FB7078):""@5"",FB7078]"""":""@21"",1:""@5"");@5"_FBDXCHK1_"@1"_FBDXCHK2_"S XX1=$$ASKICD9^FBAACO2(FBAADT) S:+XX1<0 Y=""@26"";28////^S X=+XX1;@30;31"
+52 SET DR(1,162.03,6)="73;74;75;58;59;60;61;62;63;64;65;66;67;76;77;78;79;68;69"
+53 ;FB*3.5*158
SET DR(1,162.03,7)="82///^S X=$$PYMTH^FBAAUTL(FBFSUSD)"
+54 SET DIE="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,"
SET DIE("NO^")=""
SET FBOT=1
+55 DO LOCK^FBUCUTL("^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,",FBAACPI)
IF 'FBLOCK
SET FBAAOUT=1
QUIT
+56 DO ^DIE
+57 ; if adjustment data changed then file
+58 IF $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0)
DO FILEADJ^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBADJ)
+59 ; if remit remark data changed then file
+60 IF $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0)
DO FILERR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBRRMK)
+61 LOCK -^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI)
KILL FBOT,DIE,DR,DA
+62 if $DATA(FBDL)
QUIT
+63 IF $GET(FBAAIN)
SET FBINTOT=0
DO CALC
+64 QUIT
+65 ;
BADDATE(FBDOS,INVRCVDT) ;Reject entry if InvRcvDt is Prior to the Date of Service on the Invoice
+1 ;Reject entry
IF INVRCVDT<FBDOS
Begin DoDot:1
+2 ;Convert FBDOS into display format for error message
NEW SHOWDOS
SET SHOWDOS=$EXTRACT(FBDOS,4,5)_"/"_$EXTRACT(FBDOS,6,7)_"/"_$EXTRACT(FBDOS,2,3)
+3 WRITE *7,!!?5,"*** Invoice Received Date cannot be prior to the",!?8," Date of Service ("_SHOWDOS_") !!!"
End DoDot:1
QUIT 1
+4 ;Accept entry
QUIT 0
+5 ;
SETO SET FY=$EXTRACT(FBAADT,1,3)+1700+$SELECT($EXTRACT(FBAADT,4,5)>9:1,1:0)
+1 QUIT
OUT ;
+1 ; FB*3.5*116 count line items that have 0.00 amount paid
+2 ;I K>0 S Z1=$P(^FBAA(161.7,FBAABE,0),"^",11)+1,$P(^(0),"^",11)=Z1,FBINTOT=FBINTOT+K
+3 SET Z1=$PIECE(^FBAA(161.7,FBAABE,0),"^",11)+1
SET $PIECE(^(0),"^",11)=Z1
SET FBINTOT=FBINTOT+K
+4 QUIT
CKMAX SET (FBAOT,A)=0
SET O=""
FOR Z=S-.1:0
SET Z=$ORDER(^FBAAC(DFN,"AB",Z))
if Z'>0!(Z>R)
QUIT
FOR Q=0:0
SET Q=$ORDER(^FBAAC(DFN,"AB",Z,Q))
if Q'>0
QUIT
SET W=$ORDER(^FBAAC(DFN,"AB",Z,Q,0))
IF $DATA(^FBAAC(DFN,1,Q,1,W,0))
DO SMORE
+1 IF A>$PIECE(FBSITE(1),"^",9)
GOTO NO
+2 QUIT
SMORE NEW FBA,FBB
SET FBB=$PIECE($GET(^FBAAC(+DFN,1,+Q,1,+W,0)),U,4)
SET E=0
+1 FOR
SET E=$ORDER(^FBAAC(DFN,1,Q,1,W,1,E))
if 'E
QUIT
SET FBA=$GET(^(E,0))
IF $PIECE(FBA,"^",9)=2
IF $PIECE(FBA,"^",18)'=1
Begin DoDot:1
+2 IF $$IDCHK^FBAAUTL3(DFN,FBB)
SET A=A+$PIECE(FBA,"^",3)
QUIT
+3 SET FBAOT=FBAOT+$PIECE(FBA,U,3)
End DoDot:1
+4 QUIT
NO WRITE !!,*7,"Warning Patient already at maximum allowed for month of service",!
QUIT
WARN WRITE !!,*7,"You have reached the maximum number of payments for a Batch!",!,"You must select another Batch for entering Payments!"
CALC ;Calculate Current Invoice Total
+1 FOR J=0:0
SET J=$ORDER(^FBAAC("C",FBAAIN,J))
if J'>0
QUIT
FOR K=0:0
SET K=$ORDER(^FBAAC("C",FBAAIN,J,K))
if K'>0
QUIT
FOR L=0:0
SET L=$ORDER(^FBAAC("C",FBAAIN,J,K,L))
if L'>0
QUIT
FOR M=0:0
SET M=$ORDER(^FBAAC("C",FBAAIN,J,K,L,M))
if M'>0
QUIT
DO CALC1
+2 KILL J,K,L,M,FZNODE
QUIT
CALC1 SET FZNODE=^FBAAC(J,1,K,1,L,1,M,0)
SET A2=$PIECE(FZNODE,"^",3)
SET FBINTOT=FBINTOT+A2
SET FBAAID=$PIECE(FZNODE,"^",15)
SET FBAAVID=$PIECE($GET(^FBAAC(J,1,K,1,L,1,M,2)),"^")
+1 QUIT
FEEDT ;
+1 ;FB*3.5*143 Adding FB1725 as a parameter to prevent incorrect
+2 ; reductions in local fee schedule pricing.
+3 ; input FB1725 - true (=1) when edited payment is for a Mill BilL claim.
+4 NEW FBX
+5 if '$GET(FY)
DO SETO
SET FBFY=FY-1
+6 SET (FBFSAMT,FBFSUSD)=""
SET FBAMTPD=$GET(FBAMTPD)
+7 SET FBX=$$GET^FBAAFS($$CPT^FBAAUTL4(FBAACP),$$MODL^FBAAUTL4("FBMODA","E"),FBAADT,$GET(FBZIP),$$FAC^FBAAFS($GET(FBHCFA(30))),$GET(FBTIME),$GET(FB1725))
+8 IF '$GET(FBAAMM1)
Begin DoDot:1
+9 SET FBFSAMT=$PIECE(FBX,U)
SET FBFSUSD=$PIECE(FBX,U,2)
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 WRITE !,?2,"Payment is for a contracted service so fee schedule does not apply."
End DoDot:1
+12 IF $PIECE($GET(FBX),U)]""
Begin DoDot:1
+13 WRITE !?2,$SELECT($GET(FBAAMM1):"However, f",1:"F")
+14 WRITE "ee schedule amount is $",$PIECE(FBX,U)," from the "
+15 ; year if returned
if $PIECE(FBX,U,3)]""
WRITE $PIECE(FBX,U,3)," "
+16 if $PIECE(FBX,U,2)]""
WRITE $$EXTERNAL^DILFD(162.03,45,"",$PIECE(FBX,U,2))
End DoDot:1
+17 IF '$TEST
WRITE !?2,"Unable to determine a FEE schedule amount."
+18 ;
+19 IF FB1725
Begin DoDot:1
+20 WRITE !!?2,"**Payment is for emergency treatment under 38 U.S.C. 1725."
+21 IF FBFSAMT
Begin DoDot:2
+22 SET FBFSAMT=$JUSTIFY(FBFSAMT*.7,0,2)
+23 WRITE !?2," Therefore, fee schedule amount reduced to $",FBFSAMT," (70%)."
End DoDot:2
End DoDot:1
+24 ;
+25 IF $GET(FBUNITS)>1
Begin DoDot:1
+26 WRITE !!?2,"Units Paid = ",FBUNITS
+27 if FBFSAMT'>0
QUIT
+28 NEW FBFSUNIT
+29 ; determine if fee schedule can be multiplied by units
+30 SET FBFSUNIT=$SELECT(FBFSUSD="R":1,FBFSUSD="F"&(FBAADT>3040930):1,1:0)
+31 IF FBFSUNIT
Begin DoDot:2
+32 SET FBFSAMT=$JUSTIFY(FBFSAMT*FBUNITS,0,2)
+33 WRITE !?2," Therefore, fee schedule amount increased to $",FBFSAMT
End DoDot:2
+34 IF '$TEST
Begin DoDot:2
+35 WRITE !?2," Fee schedule not complied on per unit basis so amount not adjusted by units."
End DoDot:2
End DoDot:1
+36 ;
+37 IF '$GET(FBAAMM1)
Begin DoDot:1
+38 ; set default amount paid to lesser of amt claimed (J) or fee sched.
+39 SET FBAMTPD=$SELECT(FBFSAMT'>0:J,FBFSAMT>J:J,1:FBFSAMT)
End DoDot:1
+40 WRITE !
+41 QUIT
NOGO WRITE !!,*7,"This payment CANNOT be edited. The batch the payment is in",!,"has been Vouchered. You may void the payment with the Void Payment option.",!
+1 QUIT
+2 ;
SC WRITE *7,!?4,"Suspense code is required!",!
SET Y="@4"
QUIT
+1 ;
DEL ;delete date of service if no service provided entered
+1 IF '$ORDER(^FBAAC(DFN,1,FBV,1,FBSDI,1,0))
Begin DoDot:1
+2 SET DIK="^FBAAC(DFN,1,FBV,1,"
SET DA(2)=DFN
SET DA(1)=FBV
SET DA=FBSDI
DO ^DIK
WRITE !!?5,*7,"Incomplete payment entry deleted.",!
End DoDot:1
+3 KILL DIK,DA
QUIT
