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

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

initial load of WorldVistAEHR

File size: 2.0 KB
Line 
1IBOMTE2 ;ALB/CPM-ESTIMATE MEANS TEST CHARGES (COPAY);17-DEC-91
2 ;;2.0;INTEGRATED BILLING;**153,183**;21-MAR-94
3 ;
4 ; Process each day in the admission for co-payments.
5 D COHDR F IBI=1:1:IBLOS D Q:IBQUIT
6 . S IBCLCT=IBCLCT+1,IBCLDAY=IBCLDAY+1
7 . I IBCLCT>365 D
8 .. S %H=IBI+IBFCTR D YMD^%DTC W !," ** NEW BILLING CLOCK TO BEGIN ON ",$$DAT1^IBOUTL(X)," **"
9 .. S (IBCLCT,IBCLDAY)=1,IBCLDT=X D DED^IBAUTL3
10 .. I IBGMT>0 S IBMED=$$REDUCE^IBAGMT(IBMED) ;GMT Deductible
11 . Q:IBCLDAY>360
12 . S IBMAX=IBMED I IBCLDAY>90,'IBNH S IBMAX=IBMED/2
13 . I IBCLDOL'<IBMAX D Q
14 .. S IBCLDOL=0,X=90-(IBCLDAY#90)
15 .. S IBI=IBI+X,IBCLCT=IBCLCT+X,IBCLDAY=IBCLDAY+X
16 .. I IBCLCT>365 S IBI=IBI-(IBCLCT-365),IBCLDAY=0,IBCLCT=365
17 .. D:$D(IBA) WRITE
18 . S %H=IBI+IBFCTR D YMD^%DTC S IBDT=X D COPAY^IBAUTL2
19 . I IBGMT>0 S IBCHG=$$REDUCE^IBAGMT(IBCHG) ;GMT Copay Adjustment
20 . S IBCHARG=IBMAX-IBCLDOL S:IBCHG<IBCHARG IBCHARG=IBCHG
21 . S IBCHG=IBCHARG S:IBCHG<0 IBCHG=0 S IBCLDOL=IBCLDOL+IBCHG
22 . I '$D(IBA) S IBA=IBDT_"^"_IBDT_"^"_IBCLDAY_"^"_IBCLDAY_"^"_IBCLCT_"^"_IBCLCT_"^"_IBCHG Q
23 . S $P(IBA,"^",2)=IBDT,$P(IBA,"^",4)=IBCLDAY,$P(IBA,"^",6)=IBCLCT,$P(IBA,"^",7)=$P(IBA,"^",7)+IBCHG
24 D:$D(IBA) WRITE
25 ;
26 ; Print copayment totals.
27 I 'IBCHGT D NOCOP^IBOMTE1 Q
28 W !?62,"----------",!
29 I IBGMT>0 W ?3,"Copayment amount reduced due to Patient's GMT Status"
30 S X=IBCHGT,X2="2$",X3=12 D COMMA^%DTC W ?61,X
31 Q
32 ;
33 ;
34WRITE ; Write out detail line for copayments.
35 I $Y>(IOSL-5) D PAUSE^IBOUTL Q:IBQUIT D HDR^IBOMTE1,COHDR
36 S IBTOT=IBTOT+$P(IBA,"^",7),IBCHGT=IBCHGT+$P(IBA,"^",7)
37 W !,$$DAT1^IBOUTL($P(IBA,"^")),?12,$$DAT1^IBOUTL($P(IBA,"^",2)),?26,$J($P(IBA,"^",3),3)
38 W ?35,$J($P(IBA,"^",4),3),?44,$J($P(IBA,"^",5),3),?53,$J($P(IBA,"^",6),3)
39 S X=$P(IBA,"^",7),X2="2$",X3=12 D COMMA^%DTC W ?61,X
40 K IBA Q
41 ;
42COHDR ; Print copayment subheader.
43 W !,"COPAYMENT CHARGES for ",$P($G(^DGCR(399.1,IBBS,0)),"^"),!,IBLINE
44 W !," Billing Dates",?27,"Inpt. Days",?45,"Clock Days"
45 W !," From To",?26,"1st Last",?44,"1st Last",?66,"Charge"
46 W !,IBLINE Q
Note: See TracBrowser for help on using the repository browser.