source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBAUTL4.m@ 979

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

initial load of FOIAVistA 6/30/08 version
File size: 4.8 KB
Line 
1IBAUTL4 ;ALB/CPM-MEANS TEST BILLING UTILITIES (CON'T.) ;10-OCT-91
2 ;;2.0;INTEGRATED BILLING;**45,153,171,176,179,183,202**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN ; Calculate inpatient co-pay, per diem charges for a date range
6 ; Input: DFN, IBBDT, IBEDT, IBCLDA, IBEVDA, IBY, IBAFY
7 ; IBCLCT/IBCLDAY/IBCLDOL (if IBCLDA'=0)
8 F IBDATE=IBBDT:1:IBEDT S %H=IBDATE D YMD^%DTC S IBDT=X D CALC Q:IBY<1
9 Q
10 ;
11CALC ; Find charges for one day
12 N IBGMT,IBGMTR,IBGMTEFD ;GMT Status,GMT Related flag,GMT Effective Date
13 S (IBEVNEW,IBEVOLD,IBGMT,IBGMTR)=0
14 ; - is LTC?
15 I IBDT'<$$STDATE^IBAECU1() S VAIP("D")=IBDT_.2359 D IN5^VADPT I $P($$TREATSP^IBAECU2($P($G(^DIC(45.7,+VAIP(8),0)),U,2)),"^",1)="L"!($$ASIHORG^IBAECN1(DFN,+$G(IBEVDA),IBDT)=1) D G CALCQ
16 . I '$D(IBSITE) N IBSITE,IBFAC D SITE^IBAUTL
17 . D CANCVIS^IBAECU5(DFN,IBDT) ;cancel OPT charges for this date
18 . Q:$$CLOCK^IBAECU(DFN,IBDT) ; - increment clock
19 I IBCLDA S IBCLCT=IBCLCT+1 I IBCLCT>365 S IBWHER=2 D PASS^IBAUTL5:IBEVDA,CLOCKCL^IBAUTL3:IBY>0 G:IBY<1 CALCQ
20 ; - Means Test billable?
21 I '$$BIL^DGMTUB(DFN,IBDT+.2359) G:'IBCLDA CALCQ S IBWHER=3 D PASS^IBAUTL5:IBEVDA,CLOCKCL^IBAUTL3:IBY>0 G CALCQ
22 ; - GMT Status?
23 S IBGMT=$$ISGMTPT^IBAGMT(DFN,IBDT+.2359)
24 S IBGMTEFD=$$GMTEFD^IBAGMT() ; GMT Effective Date
25 ; - on leave?
26 S VAIP("D")=IBDT_.2359 D IN5^VADPT S IBBS=$$SECT^IBAUTL5(+VAIP(8)),IBSL="405:"_VAIP(1)
27 I 'VAIP(10) D G CALCQ
28 . I IBBS,'IBCLDA S IBCLDT=IBDT,IBWHER=7 D CLADD^IBAUTL3 S (IBCLDAY,IBCLDOL)=0,IBCLCT=1
29 . Q:'IBCLDA S IBWHER=4 D PASS^IBAUTL5:IBEVDA,CLOCKCL^IBAUTL3:IBCLCT'<365&(IBY>0)
30 ; - check billing status
31 I 'IBBS S IBWHER=5 D:IBEVDA PASS^IBAUTL5,EVCLOS1^IBAUTL3:IBY>0 D G CALCQ
32 . S IBEVDA=0 Q:'IBCLDA!(IBY<1) D:IBCLCT'<365 CLOCKCL^IBAUTL3
33 S IBNH=$P($G(^DGCR(399.1,IBBS,0)),"^")["NURSING"
34 I 'IBEVDA S IBEVDT=+VAIP(3)\1,IBWHER=6 D EVADD^IBAUTL3 G:IBY<1 CALCQ
35 ; - will bill today--got a clock?
36 I 'IBCLDA S IBCLDT=IBDT,IBWHER=7 D CLADD^IBAUTL3 G:IBY<1 CALCQ S (IBCLDAY,IBCLDOL)=0,IBCLCT=1
37 ; - cancel any OPT charges
38 D OPT^IBAMTD1(DFN,IBDT)
39 ; - update clock, $$ if starting another 90-day period of care
40 I IBCLDAY,'(IBCLDAY#90) D CLUPD^IBAUTL3 S:IBCLDAY'=360 IBCLDOL=0
41 S IBCLDAY=IBCLDAY+1
42 ; - process per diem
43 G:IBDT<$$DIEM^IBAUTL5 COPAY ; date is prior to per diem billing date
44 S IBX="P",IBWHER=8 D TYPE^IBAUTL2 G:IBY<1 CALCQ
45 S IBGMTR=0 I IBGMT>0,IBDT'<IBGMTEFD,$$ISGMTTYP^IBAGMT(IBATYP) S IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG) ;GMT Charge Adjustment
46 D CHFIND^IBAUTL2 S IBNOS=IBCHPDA,IBCHPDE=$P($G(^IB(+IBCHPDA,0)),"^",8),IBWHER=9
47 ; - update or pass to A/R an incomplete per diem charge
48 I IBCHPDA D G:IBY<1 CALCQ
49 . I (IBCHPDE["INPT"&(IBNH))!(IBCHPDE["NHC"&('IBNH)) D Q
50 .. D FILER^IBAUTL5,EVCLOS1^IBAUTL3:IBY>0 Q:IBY<1
51 .. S IBEVDT=+VAIP(3)\1,IBEVOLD=IBEVDA,IBWHER=10
52 .. D EVADD^IBAUTL3 Q:IBY<1 S IBCHPDA=0,IBEVNEW=IBEVDA
53 . S X1=IBDT,X2=IBCHTO D ^%DTC I X'=1 S IBWHER=11 D FILER^IBAUTL5 S IBCHPDA=0 Q
54 . ; Split pre- and post- GMT Eff.Date charges, for GMT patients only
55 . I IBGMT'=0,IBDT'<IBGMTEFD,$$ISGMTTYP^IBAGMT(IBATYP),IBCHTO<IBGMTEFD S IBWHER=11 D FILER^IBAUTL5 S IBCHPDA=0 Q
56 . ; Split charges, if the patient just received or lost GMT Status
57 . I (+$P($G(^IB(+IBCHPDA,0)),"^",21))'=IBGMTR S IBWHER=11 D FILER^IBAUTL5 S IBCHPDA=0 Q
58 . S IBN=IBCHPDA D CHUPD^IBAUTL2
59 I 'IBCHPDA S IBWHER=13 D CHADD^IBAUTL2 G:IBY<0 CALCQ S IBCHPDA=IBN
60COPAY ; - process co-payment
61 G:IBCLDAY>360!($$CONT^IBAUTL5(DFN)>IBDT) LAST ; last 5 days are grace days, or pt is continuous
62 S IBMAX=IBMED
63 I IBGMT>0,IBDT'<IBGMTEFD S IBMAX=$$REDUCE^IBAGMT(IBMAX) ;Adjust deductible for GMT patients
64 I IBCLDAY>90,'IBNH S IBMAX=IBMAX/2
65 G:IBCLDOL'<IBMAX LAST
66 S IBWHER=14 D COPAY^IBAUTL2 G:IBY<1 CALCQ
67 S IBGMTR=0 I IBGMT>0,IBDT'<IBGMTEFD S IBGMTR=1,IBCHG=$$REDUCE^IBAGMT(IBCHG) ;GMT Charge Adjustment
68 S IBCHARG=IBMAX-IBCLDOL I IBCHG<IBCHARG S IBCHARG=IBCHG
69 S IBCHG=IBCHARG S:IBCHG<0 IBCHG=0
70 S IBCLDOL=IBCLDOL+IBCHG
71 S:IBEVOLD IBEVDA=IBEVOLD S IBX="C" D CHFIND^IBAUTL2
72 S IBNOS=IBCHCDA,IBCHCTY=$P($G(^IB(+IBCHCDA,0)),"^",3) S:IBEVNEW IBEVDA=IBEVNEW
73 ; - update or pass to A/R an incomplete copay charge
74 I IBCHCDA D G:IBY<1 CALCQ
75 . I IBCHCTY'=IBATYP S IBWHER=15 D FILER^IBAUTL5 S IBCHCDA=0 Q
76 . S X1=IBDT,X2=IBCHTO D ^%DTC I X'=1 S IBWHER=16 D FILER^IBAUTL5 S IBCHCDA=0 Q
77 . ; Split pre- and post- GMT Eff.Date charges
78 . I IBGMT'=0,IBDT'<IBGMTEFD,IBCHTO<IBGMTEFD S IBWHER=16 D FILER^IBAUTL5 S IBCHPDA=0 Q
79 . S IBN=IBCHCDA D CHUPD^IBAUTL2
80 I 'IBCHCDA S IBWHER=18 D CHADD^IBAUTL2 G:IBY<1 CALCQ S IBCHCDA=IBN
81 I IBCHCDA,IBCLDOL'<IBMAX S IBEVOLD=0,IBNOS=IBCHCDA,IBWHER=19 D FILER^IBAUTL5 G:IBY<1 CALCQ S IBCHCDA=0
82LAST ; - handle last day of billing clock
83 G:IBCLCT<365 CALCQ
84 I $G(IBCHPDA) S IBNOS=IBCHPDA,IBWHER=20 D FILER^IBAUTL5 G:IBY<1 CALCQ S IBCHPDA=0
85 I $G(IBCHCDA) S IBNOS=IBCHCDA,IBWHER=21 D FILER^IBAUTL5 G:IBY<1 CALCQ S IBCHCDA=0
86 D CLOCKCL^IBAUTL3
87CALCQ I $G(IBJOB)=2,'$G(DGQUIET) W "."
88 Q
Note: See TracBrowser for help on using the repository browser.