source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBECEA3.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 8.6 KB
Line 
1IBECEA3 ;ALB/CPM - Cancel/Edit/Add... Add a Charge ;30-MAR-93
2 ;;2.0;INTEGRATED BILLING;**7,57,52,132,150,153,166,156,167,176,198,188,183,202,240,312**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ADD ; Add a Charge protocol
6 N IBSWINFO S IBSWINFO=$$SWSTAT^IBBAPI() ;IB*2.0*312
7 N IBGMT,IBGMTR
8 S (IBGMT,IBGMTR)=0
9 S IBCOMMIT=0,IBEXSTAT=$$RXST^IBARXEU(DFN,DT),IBCATC=$$BILST^DGMTUB(DFN),IBCVAEL=$$CVA^IBAUTL5(DFN),IBLTCST=$$LTCST^IBAECU(DFN,DT,1)
10 ;I 'IBCVAEL,'IBCATC,'$G(IBRX),+IBEXSTAT<1 W !!,"This patient has never been Means Test billable." S VALMBCK="" D PAUSE^VALM1 G ADDQ1
11 ;
12 ; - clear screen and begin
13 D CLOCK^IBAUTL3 I 'IBCLDA S (IBMED,IBCLDAY,IBCLDOL,IBCLDT)=0
14 D HDR^IBECEAU("A D D")
15 I IBY<0 D NODED^IBECEAU3 G ADDQ
16 ;
17 ; - ask for the charge type
18 D CHTYP^IBECEA33 G:IBY<0 ADDQ
19 N IBAFEE S:$P($G(^IBE(350.1,+$G(IBATYP),0)),"^",8)="FEE SERVICE/OUTPATIENT" IBAFEE=IBATYP
20 ;
21 ; - process CHAMPVA charges
22 I IBXA=6 D CHMPVA^IBECEA32 G ADDQ
23 ;
24 ; - process TRICARE charges
25 I IBXA=7 D CUS^IBECEA35 G ADDQ
26 ;
27 ; - display MT billing clock data
28 I IBXA=2,$P($G(^IBE(350.1,+IBATYP,0)),"^",8)'["NHCU",IBCLDAY>90 S IBMED=IBMED/2
29 I IBXA=1,IBCLDAY>90 D MED^IBECEA34 G:IBY<0 ADDQ
30 I "^1^2^3^"[("^"_IBXA_"^"),IBCLDA W !!," ** Active Billing Clock ** # Inpt Days: ",IBCLDAY," ",$$INPT^IBECEAU(IBCLDAY)," 90 days: $",+IBCLDOL,!
31 ;
32 ; - display LTC billing clock data
33 I IBXA>7,IBXA<10 D G:IBCLDA<1 ADDQ
34 . N IBCLZ
35 . S IBCLDA=$O(^IBA(351.81,"AE",DFN,9999999),-1)
36 . S:IBCLDA IBCLDA=$O(^IBA(351.81,"AE",DFN,IBCLDA,0))
37 . I 'IBCLDA W !!," ** Patient has no LTC billing clock **" Q
38 . S IBCLZ=^IBA(351.81,IBCLDA,0)
39 . W !!," **Last LTC Billing Clock Start Date: ",$$FMTE^XLFDT($P(IBCLZ,"^",3))," Free Days Remaining: ",+$P(IBCLZ,"^",6)
40 . I $P(IBCLZ,"^",6) W !,"The patient must use his free days first." S IBCLDA=0
41 ;
42 ; - ask units for rx copay charge
43 I IBXA=5 D UNIT^IBECEAU2(0) G ADDQ:IBY<0 D G ADDQ:IBY<0 G PROC
44 . ;
45 . ; has patient been previously tracked for cap info
46 . D TRACK^IBARXMN(DFN)
47 . ;
48 . D CTBB^IBECEAU3
49 . ;
50 . ; check if above cap
51 . I IBY'<0 D
52 .. N IBB,IBN,DIR,DIRUT,DUOUT,DTOUT,X,Y
53 .. D NEW^IBARXMC(1,IBCHG,DT,.IBB,.IBN) Q:'IBN
54 .. ;
55 .. ; display message ask to proceed
56 .. W !!,"This charge will put the patient > $",$J(IBN,0,2)," above their cap amount."
57 .. S DIR(0)="Y",DIR("A")="Okay to proceed" D ^DIR S:'Y IBY=-1
58 .. ;
59 S IBLIM=$S(IBXA=4!(IBXA=3):DT,1:$$FMADD^XLFDT(DT,-1))
60 ;
61FR ; - ask 'bill from' date
62 D FR^IBECEAU2(0) G:IBY<0 ADDQ
63 ; Do NOT PROCESS on VistA if IBFR>=Switch Eff Date ;CCR-930
64 I +IBSWINFO,(IBFR+1)>$P(IBSWINFO,"^",2) D G FR ;IB*2.0*312
65 .W !!,"The 'Bill From' date cannot be on or AFTER the PFSS Effective Date"
66 .W ": ",$$FMTE^XLFDT($P(IBSWINFO,"^",2))
67 ;
68 S IBGMT=$$ISGMTPT^IBAGMT(DFN,IBFR),IBGMTR=0 ;GMT Copayment Status
69 I IBGMT>0,IBXA>0,IBXA<4 W !,"The patient has GMT Copayment Status."
70 ; - check the MT billing clock
71 I IBXA'=8,IBXA'=9 D CLMSG^IBECEA33 G:IBY<0 ADDQ
72 ;Adjust Deductible for GMT patient
73 I IBGMT>0,IBXA>0,IBXA<4,$G(IBMED) S IBMED=$$REDUCE^IBAGMT(IBMED) W !,"Medicare Deductible reduced due to GMT Copayment Status ($",$J(IBMED,"",2),")."
74 ;
75 ; - check the LTC billing clock
76 I IBXA>7,IBXA<10 D I IBY<0 W !!,"The patient has no LTC clock active for the date.",! G ADDQ
77 . N IBCLZ S IBCLZ=^IBA(351.81,IBCLDA,0)
78 . ;
79 . ; is this the clock and within the date range
80 . I IBFR'<$P(IBCLZ,"^",3),$$YR^IBAECU($P(IBCLZ,"^",3),IBFR) S IBY=-1 Q
81 . ;
82 . ; look for another clock that might fit the date
83 . I IBFR<$P(IBCLZ,"^",3) S IBCLDA=$O(^IBA(351.81,"AE",DFN,IBFR+1),-1) I 'IBCLDA!($$YR^IBAECU($P($G(^IBA(351.81,+IBCLDA,0)),"^",3),IBFR)) S IBY=-1
84 ;
85 ; - calculate the MT inpt copay charge
86 I IBXA=2 S IBDT=IBFR D COPAY^IBAUTL2 G ADDQ:IBY<0 S:IBGMT>0 IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG) I IBCHG+IBCLDOL<IBMED W *7," ($",IBCHG,"/day)" W:IBGMTR " GMT Rate"
87 ;
88 ; - find the correct clock from the 'bill from' date (ignore LTC)
89 I IBXA'=8,IBXA'=9,('IBCLDA!(IBCLDA&(IBFR<IBCLDT))) D NOCL^IBECEA33 G:IBY<0 ADDQ
90 ;
91 ; - perform outpatient edits
92 N IBSTOPDA
93 I IBXA=4 D G ADDQ:IBY<0,PROC
94 . ; for visits prior to 12/6/01 or FEE
95 . I IBFR<3011206!($G(IBAFEE)) D OPT^IBECEA33 Q
96 . ; for visits on or after 12/5/01
97 . D OPT^IBEMTSCU
98 ;
99 ; - if LTC outpatient calculate the charge
100 I IBXA=8 D G:IBY<0 ADDQ S (IBDT,IBTO,IBEVDT)=IBFR,IBDESC=$P(^IBE(350.1,IBATYP,0),"^",8),IBUNIT=1,IBEVDA="*" D COST^IBAUTL2,CALC^IBAECO,CTBB^IBECEAU3 G @$S(IBCHG:"PROC",1:"ADDQ")
101 . ;
102 . ; is this day already a free day
103 . I $D(^IBA(351.81,IBCLDA,1,"AC",IBFR)) W !!,"This day is already marked as a Free Day." S IBY=-1
104 . ;
105 . ; have we already billed for this day
106 . I $D(^IB("AFDT",DFN,-IBFR)) W !!,"This patient has already been billed for this date." S IBY=-1
107 ;
108 ; - find per diem charge and description
109 I IBXA=3 D I 'IBCHG W !!,"Unable to determine the per diem rate. Please check your rate table." G ADDQ
110 .N IBDT S IBDT=IBFR,IBGMTR=0 D COST^IBAUTL2
111 .I IBGMT>0 S IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG)
112 .S IBDESC="" X:$D(^IBE(350.1,IBATYP,20)) ^(20)
113 ;
114 ; - calculate charge for the inpatient copay
115 I IBXA=2,IBCHG+IBCLDOL'<IBMED S IBCHG=IBMED-IBCLDOL,IBUNIT=1,IBTO=IBFR D CTBB^IBECEAU3 G EV
116 ;
117TO ; - ask 'bill to' date
118 D TO^IBECEAU2(0) G:IBY<0 ADDQ
119 ; Do NOT PROCESS on VistA if IBTO>=Switch Eff Date ;CCR-930
120 I +IBSWINFO,(IBTO+1)>$P(IBSWINFO,"^",2) D G TO ;IB*2.0*312
121 .W !!,"The 'Bill To' date cannot be on or AFTER the PFSS Effective Date"
122 .W ": ",$$FMTE^XLFDT($P(IBSWINFO,"^",2))
123 ;
124 I IBXA>0,IBXA<4,IBGMT'=$$ISGMTPT^IBAGMT(DFN,IBTO) W !!,"The patient's GMT Copayment status changed within the specified period!",! G ADDQ
125 ;
126 ; - calculate unit charge for LTC inpatient in IBCHG
127 I IBXA=9 S IBDT=IBFR,IBEVDA=$$EVF^IBECEA31(DFN,IBFR,IBTO,IBNH),IBEVDT=$E(IBFR,1,5)_"01" D:IBEVDA<1 G ADDQ:IBY<0 D COST^IBAUTL2 I $E(IBFR,1,5)'=$E(IBTO,1,5) W !!," LTC Copayment charges cannot go from one month to another." G ADDQ
128 . D NOEV^IBECEA31 I '$G(IBDG)!(IBY<0) S IBY=-1 Q
129 . ; - build the event record
130 . N IBNHLTC S IBNHLTC=1 D ADEV^IBECEA31
131 ;
132 ;
133 ; - calculate units and total charge
134 S IBUNIT=$$FMDIFF^XLFDT(IBTO,IBFR) S:IBXA'=3!(IBFR=IBTO) IBUNIT=IBUNIT+1
135 I IBXA=1 D:IBGMT>0 D FEPR^IBECEA32 G ADDQ:IBY<0,EV
136 . S IBGMTR=1
137 . W !,"The patient has GMT Copayment Status! GMT rate must be applied.",!
138 S IBCHG=IBCHG*IBUNIT S:IBXA=2 IBCHG=$S(IBCLDOL+IBCHG>IBMED:IBMED-IBCLDOL,1:IBCHG)
139 ;
140 ; adjust the LTC charge based on the calculated copay cap
141 I IBXA=9 D CALC^IBAECI G:IBY<1!('IBCHG) ADDQ S IBDESC="LTC INPATIENT COPAY"
142 ;
143 D CTBB^IBECEAU3 W:IBXA=3!(IBXA=9) " (for ",IBUNIT," day",$E("s",IBUNIT>1),")" W:IBGMTR " GMT Rate"
144 ;
145EV ; - find event record, or select admission for linkage
146 I IBXA'=9 S IBEVDA=$$EVF^IBECEA31(DFN,IBFR,IBTO,IBNH)
147 I IBEVDA'>0 D NOEV^IBECEA31 G ADDQ:IBY<0,PROC
148 S IBSL=$P($G(^IB(+IBEVDA,0)),"^",4)
149 W !!,"Linked charge to ",$$TYP(),"admission on ",$$DAT1^IBOUTL($P(IBEVDA,"^",2))," ("
150 W $S($P(IBEVDA,"^",3)=9999999:"Still admitted)",1:"Discharged on "_$$DAT1^IBOUTL($P(IBEVDA,"^",3))_$S($P(IBEVDA,"^",3)>DT:" [pseudo])",1:")"))," ..."
151 S IBEVDA=+IBEVDA
152 I '$G(IBSIBC) D SPEC^IBECEA32(0,$O(^IBE(351.2,"AD",IBEVDA,0)))
153 ;
154 ;
155PROC ; - okay to proceed?
156 D PROC^IBECEAU4("add") G:IBY<0 ADDQ
157 ;
158 ; - build the event record first if necessary
159 I $G(IBDG),IBXA'=9 D @("ADEV^IBECEA3"_$S($G(IBFEEV):4,1:1)) G:IBY<0 ADDQ
160 ;
161 ; - disposition the special inpatient billing case, if necessary
162 I $G(IBSIBC) D CEA^IBAMTI1(IBSIBC,IBEVDA)
163 ;
164 ; - generate entry in file #354.71 and #350
165 I IBXA=5 W !!,"Building the new transaction... " S IBAM=$$ADD^IBARXMN(DFN,"^^"_DT_"^^P^^"_IBUNIT_"^"_IBCHG_"^"_IBDESC_"^^"_IBCHG_"^0^"_IBSITE) G:IBAM<0 ADDQ
166 D ADD^IBECEAU3 G:IBY<0 ADDQ W "done."
167 ;
168 ; - pass the charge off to AR on-line
169 W !,"Passing the charge directly to Accounts Receivable... "
170 D PASSCH^IBECEA22 W:IBY>0 "done." G:IBY<0 ADDQ
171 ;
172 ; - review the special inpatient billing case
173 I $G(IBSIBC1) D CHK^IBAMTI1(IBSIBC1,IBEVDA)
174 ;
175 ; - handle updating of clock
176 I IBXA'=8,IBXA'=9 D CLUPD^IBECEA32
177 ;
178ADDQ ; - display error, rebuild list, and quit
179 D ERR^IBECEAU4:IBY<0,PAUSE^IBECEAU S VALMBCK="R"
180 I IBCOMMIT S IBBG=VALMBG W !,"Rebuilding list of charges..." D ARRAY^IBECEA0 S VALMBG=IBBG
181 K IBMED,IBCLDA,IBCLDT,IBCLDOL,IBCLDAY,IBATYP,IBDG,IBSEQNO,IBXA,IBNH,IBBS,IBLIM,IBFR,IBTO,IBRTED,IBSIBC,IBSIBC1,IBBG,IBFEEV,IBAM
182 K IBX,IBCHG,IBUNIT,IBDESC,IBDT,IBEVDT,IBEVDA,IBSL,IBNOS,IBN,IBTOTL,IBARTYP,IBIL,IBTRAN,IBAFY,IBCVA,IBCLSF,IBDD,IBND,VADM,VA,VAERR,IBADJMED
183ADDQ1 K IBEXSTAT,IBCOMMIT,IBCATC,IBCVAEL,IBLTCST
184 Q
185 ;
186 ;
187TYP() ; Return descriptive admission type.
188 N X S X=""
189 I IBNH'=2 G TYPQ
190 I $G(IBADJMED) S X=$S(IBADJMED=1:"C",1:"H")
191 E S X=$S($P($G(^IBE(350.1,+IBATYP,0)),"^")["NHCU":"C",1:"H")
192 S X=$S(X="C":"CNH ",1:"Contract Hospital ")
193TYPQ Q X
Note: See TracBrowser for help on using the repository browser.