| 1 | IBOMTE2 ;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 | ;
|
|---|
| 34 | WRITE ; 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 | ;
|
|---|
| 42 | COHDR ; 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
|
|---|
