- 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 Feb 18, 2025@23:21:37 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