source: FOIAVistA/tag/r/FEE_BASIS-FB/FBAACO3.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1FBAACO3 ;AISC/GRR-ENTER PAYMENT CONTINUED ;7/7/2003
2 ;;3.5;FEE BASIS;**4,38,55,61**;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4DOEDIT ;
5 N FB1725,FBFPPSC
6 W ! S FBAACP(0)=FBAACP
7 S DIC="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,"
8 S DIC(0)="EQMZ",DA(3)=DFN,DA(2)=FBV,DA(1)=FBSDI
9 S X=$$CPT^FBAAUTL4(FBAACP)
10 D ^DIC I Y<0 S FBAAOUT=1 Q
11 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)
12 ; set FB1725 true (1) if payment is for a Mill Bill claim
13 S FB1725=$S($P(Y(0),U,13)["FB583":+$P($G(^FB583(+$P(Y(0),U,13),0)),U,28),1:0)
14 S FBAAMM1=$P($G(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,2)),U,2)
15 S FBFSAMT(0)=$P($G(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,2)),U,12)
16 ; determine lesser of original fee schedule amount and amount claimed
17 S FBAMTPD(0)=$S(FBFSAMT(0)="":J(0),FBFSAMT(0)>J(0):J(0),1:FBFSAMT(0))
18 S FBMODL=$$MODL^FBAAUTL4("^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,"_FBAACPI_",""M"")")
19 ; load current adjustment data
20 D LOADADJ^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBADJ)
21 ; save adjustment data prior to edit session in sorted list
22 S FBADJL(0)=$$ADJL^FBUTL2(.FBADJ) ; sorted list of original adjustments
23 ; load current remittance remark data
24 D LOADRR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBRRMK)
25 ; save remittance remarks prior to edit session in sorted list
26 S FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK)
27 ; load FPPS data
28 S FBFPPSC=$P($G(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,3)),U)
29 S FBFPPSL=$P($G(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,3)),U,2)
30 I FBZBS=""!(FBZBS="V") D NOGO S FBAAOUT=1 Q
31 ; first edit CPT code and modifiers
32 D CPTM^FBAALU(FBAADT,DFN,FBAACP(0),FBMODL) I '$G(FBGOT) S FBAAOUT=1 Q
33 ; if CPT was changed then update file
34 I FBAACP'=FBAACP(0) D I FBAACP="@" S FBAAOUT=1 Q
35 . N FBIENS,FBFDA
36 . S FBIENS=FBAACPI_","_FBSDI_","_FBV_","_DFN_","
37 . S FBFDA(162.03,FBIENS,.01)=FBAACP
38 . D FILE^DIE("","FBFDA") D MSG^DIALOG()
39 ; if modifiers changed then update file
40 I FBMODL'=$$MODL^FBAAUTL4("FBMODA") D REPMOD^FBAAUTL4(DFN,FBV,FBSDI,FBAACPI)
41 ; now edit remaining fields
42 D SETO K DR
43 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"
44 S DR(1,162.03,1)="S FBAAMM=$S(FBAAPTC=""R"":"""",1:1);D PPT^FBAACO1(FBAAMM1);34///@;34////^S X=FBAAMM1;30R;S FBHCFA(30)=X;1;S J=X;Q"
45 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;D CHKIT^FBAACO3;S K=X"
46 ;S DR(1,162.03,3)="3//^S X=$S(J-K:J-K,1:"""");4;S:X'=4 Y=6;22;6////^S X=DUZ;13;33"
47 S DR(1,162.03,3)="K FBADJD;M FBADJD=FBADJ;S FBX=$$ADJ^FBUTL2(J-K,.FBADJ,2,,.FBADJD,1)"
48 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;33"
49 S DR(1,162.03,5)="S:$$EXTPV^FBAAUTL5(FBPOV)=""01"" Y=""@1"";S Y=$S('$D(FB7078):28,FB7078]"""":31,1:28);@5;28R;S:$$INPICD9^FBCSV1(X,"""",$G(FBAADT)) Y=""@5"";31;32R;S Y=""@7"";@1;28;I X]"""" S:$$INPICD9^FBCSV1(X,"""",$G(FBAADT)) Y=""@1"";31"
50 S DR(1,162.03,6)="@7;K FBRRMKD;M FBRRMKD=FBRRMK;S FBX=$$RR^FBUTL4(.FBRRMK,2,,.FBRRMKD)"
51 S DIE="^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,",DIE("NO^")="",FBOT=1
52 D LOCK^FBUCUTL("^FBAAC("_DFN_",1,"_FBV_",1,"_FBSDI_",1,",FBAACPI) I 'FBLOCK S FBAAOUT=1 Q
53 D ^DIE
54 ; if adjustment data changed then file
55 I $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0) D FILEADJ^FBAAFA(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBADJ)
56 ; if remit remark data changed then file
57 I $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0) D FILERR^FBAAFR(FBAACPI_","_FBSDI_","_FBV_","_DFN_",",.FBRRMK)
58 L -^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI) K FBOT,DIE,DR,DA
59 Q:$D(FBDL)
60 I $G(FBAAIN) S FBINTOT=0 D CALC
61 Q
62SETO S FY=$E(FBAADT,1,3)+1700+$S($E(FBAADT,4,5)>9:1,1:0)
63 Q
64OUT I K>0 S Z1=$P(^FBAA(161.7,FBAABE,0),"^",11)+1,$P(^(0),"^",11)=Z1,FBINTOT=FBINTOT+K
65 Q
66CKMAX 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
67 I A>$P(FBSITE(1),"^",9) G NO
68 Q
69SMORE N FBA,FBB S FBB=$P($G(^FBAAC(+DFN,1,+Q,1,+W,0)),U,4),E=0
70 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
71 .I $$IDCHK^FBAAUTL3(DFN,FBB) S A=A+$P(FBA,"^",3) Q
72 .S FBAOT=FBAOT+$P(FBA,U,3)
73 Q
74NO W !!,*7,"Warning Patient already at maximum allowed for month of service",! Q
75WARN W !!,*7,"You have reached the maximum number of payments for a Batch!",!,"You must select another Batch for entering Payments!"
76CALC ;Calculate Current Invoice Total
77 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
78 K J,K,L,M,FZNODE Q
79CALC1 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)),"^")
80 Q
81FEEDT ;
82 ; input FB1725 - true (=1) when edited payment is for a Mill Bill claim
83 N FBX
84 D SETO:'$G(FY) S FBFY=FY-1
85 S (FBFSAMT,FBFSUSD)="",FBAMTPD=$G(FBAMTPD)
86 S FBX=$$GET^FBAAFS($$CPT^FBAAUTL4(FBAACP),$$MODL^FBAAUTL4("FBMODA","E"),FBAADT,$G(FBZIP),$$FAC^FBAAFS($G(FBHCFA(30))),$G(FBTIME))
87 I '$G(FBAAMM1) D
88 . S FBFSAMT=$P(FBX,U),FBFSUSD=$P(FBX,U,2)
89 E D
90 . W !,?2,"Payment is for a contracted service so fee schedule does not apply."
91 I $P($G(FBX),U)]"" D
92 . W !?2,$S($G(FBAAMM1):"However, f",1:"F")
93 . W "ee schedule amount is $",$P(FBX,U)," from the "
94 . W:$P(FBX,U,3)]"" $P(FBX,U,3)," " ; year if returned
95 . W:$P(FBX,U,2)]"" $$EXTERNAL^DILFD(162.03,45,"",$P(FBX,U,2))
96 E W !?2,"Unable to determine a FEE schedule amount."
97 ;
98 I FB1725 D
99 . W !!?2,"**Payment is for emergency treatment under 38 U.S.C. 1725."
100 . I FBFSAMT D
101 . . S FBFSAMT=$J(FBFSAMT*.7,0,2)
102 . . W !?2," Therefore, fee schedule amount reduced to $",FBFSAMT," (70%)."
103 ;
104 I $G(FBUNITS)>1 D
105 . W !!?2,"Units Paid = ",FBUNITS
106 . Q:FBFSAMT'>0
107 . N FBFSUNIT
108 . ; determine if fee schedule can be multipled by units
109 . S FBFSUNIT=$S(FBFSUSD="R":1,FBFSUSD="F"&(FBAADT>3040930):1,1:0)
110 . I FBFSUNIT D
111 . . S FBFSAMT=$J(FBFSAMT*FBUNITS,0,2)
112 . . W !?2," Therefore, fee schedule amount increased to $",FBFSAMT
113 . E D
114 . . W !?2," Fee schedule not complied on per unit basis so amount not adjusted by units."
115 ;
116 I '$G(FBAAMM1) D
117 . ; set default amount paid to lesser of amt claimed (J) or fee sched.
118 . S FBAMTPD=$S(FBFSAMT'>0:J,FBFSAMT>J:J,1:FBFSAMT)
119 W !
120 Q
121CHKIT I X>FBAMTPD&('$D(^XUSEC("FBAASUPERVISOR",DUZ))) W !!,"You must be a holder of the 'FBAASUPERVISOR' security key in order to",!,"exceed the Fee Schedule.",! S $P(^FBAAC(DFN,1,FBV,1,FBSDI,1,FBAACPI,0),"^",3)=K,Y=2 Q
122 Q
123NOGO 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.",!
124 Q
125 ;
126SC W *7,!?4,"Suspense code is required!",! S Y="@4" Q
127 ;
128DEL ;delete date of service if no service provided entered
129 I '$O(^FBAAC(DFN,1,FBV,1,FBSDI,1,0)) D
130 .S DIK="^FBAAC(DFN,1,FBV,1,",DA(2)=DFN,DA(1)=FBV,DA=FBSDI D ^DIK W !!?5,*7,"Incomplete payment entry deleted.",!
131 K DIK,DA Q
Note: See TracBrowser for help on using the repository browser.