IBOMTE2 ;ALB/CPM-ESTIMATE MEANS TEST CHARGES (COPAY);17-DEC-91
;;2.0;INTEGRATED BILLING;**153,183**;21-MAR-94
;
; Process each day in the admission for co-payments.
D COHDR F IBI=1:1:IBLOS D Q:IBQUIT
. S IBCLCT=IBCLCT+1,IBCLDAY=IBCLDAY+1
. I IBCLCT>365 D
.. S %H=IBI+IBFCTR D YMD^%DTC W !," ** NEW BILLING CLOCK TO BEGIN ON ",$$DAT1^IBOUTL(X)," **"
.. S (IBCLCT,IBCLDAY)=1,IBCLDT=X D DED^IBAUTL3
.. I IBGMT>0 S IBMED=$$REDUCE^IBAGMT(IBMED) ;GMT Deductible
. Q:IBCLDAY>360
. S IBMAX=IBMED I IBCLDAY>90,'IBNH S IBMAX=IBMED/2
. I IBCLDOL'<IBMAX D Q
.. S IBCLDOL=0,X=90-(IBCLDAY#90)
.. S IBI=IBI+X,IBCLCT=IBCLCT+X,IBCLDAY=IBCLDAY+X
.. I IBCLCT>365 S IBI=IBI-(IBCLCT-365),IBCLDAY=0,IBCLCT=365
.. D:$D(IBA) WRITE
. S %H=IBI+IBFCTR D YMD^%DTC S IBDT=X D COPAY^IBAUTL2
. I IBGMT>0 S IBCHG=$$REDUCE^IBAGMT(IBCHG) ;GMT Copay Adjustment
. S IBCHARG=IBMAX-IBCLDOL S:IBCHG<IBCHARG IBCHARG=IBCHG
. S IBCHG=IBCHARG S:IBCHG<0 IBCHG=0 S IBCLDOL=IBCLDOL+IBCHG
. I '$D(IBA) S IBA=IBDT_"^"_IBDT_"^"_IBCLDAY_"^"_IBCLDAY_"^"_IBCLCT_"^"_IBCLCT_"^"_IBCHG Q
. S $P(IBA,"^",2)=IBDT,$P(IBA,"^",4)=IBCLDAY,$P(IBA,"^",6)=IBCLCT,$P(IBA,"^",7)=$P(IBA,"^",7)+IBCHG
D:$D(IBA) WRITE
;
; Print copayment totals.
I 'IBCHGT D NOCOP^IBOMTE1 Q
W !?62,"----------",!
I IBGMT>0 W ?3,"Copayment amount reduced due to Patient's GMT Status"
S X=IBCHGT,X2="2$",X3=12 D COMMA^%DTC W ?61,X
Q
;
;
WRITE ; Write out detail line for copayments.
I $Y>(IOSL-5) D PAUSE^IBOUTL Q:IBQUIT D HDR^IBOMTE1,COHDR
S IBTOT=IBTOT+$P(IBA,"^",7),IBCHGT=IBCHGT+$P(IBA,"^",7)
W !,$$DAT1^IBOUTL($P(IBA,"^")),?12,$$DAT1^IBOUTL($P(IBA,"^",2)),?26,$J($P(IBA,"^",3),3)
W ?35,$J($P(IBA,"^",4),3),?44,$J($P(IBA,"^",5),3),?53,$J($P(IBA,"^",6),3)
S X=$P(IBA,"^",7),X2="2$",X3=12 D COMMA^%DTC W ?61,X
K IBA Q
;
COHDR ; Print copayment subheader.
W !,"COPAYMENT CHARGES for ",$P($G(^DGCR(399.1,IBBS,0)),"^"),!,IBLINE
W !," Billing Dates",?27,"Inpt. Days",?45,"Clock Days"
W !," From To",?26,"1st Last",?44,"1st Last",?66,"Charge"
W !,IBLINE Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOMTE2 2083 printed Apr 09, 2024@21:33:43 Page 2
IBOMTE2 ;ALB/CPM-ESTIMATE MEANS TEST CHARGES (COPAY);17-DEC-91
+1 ;;2.0;INTEGRATED BILLING;**153,183**;21-MAR-94
+2 ;
+3 ; Process each day in the admission for co-payments.
+4 DO COHDR
FOR IBI=1:1:IBLOS
Begin DoDot:1
+5 SET IBCLCT=IBCLCT+1
SET IBCLDAY=IBCLDAY+1
+6 IF IBCLCT>365
Begin DoDot:2
+7 SET %H=IBI+IBFCTR
DO YMD^%DTC
WRITE !," ** NEW BILLING CLOCK TO BEGIN ON ",$$DAT1^IBOUTL(X)," **"
+8 SET (IBCLCT,IBCLDAY)=1
SET IBCLDT=X
DO DED^IBAUTL3
+9 ;GMT Deductible
IF IBGMT>0
SET IBMED=$$REDUCE^IBAGMT(IBMED)
End DoDot:2
+10 if IBCLDAY>360
QUIT
+11 SET IBMAX=IBMED
IF IBCLDAY>90
IF 'IBNH
SET IBMAX=IBMED/2
+12 IF IBCLDOL'<IBMAX
Begin DoDot:2
+13 SET IBCLDOL=0
SET X=90-(IBCLDAY#90)
+14 SET IBI=IBI+X
SET IBCLCT=IBCLCT+X
SET IBCLDAY=IBCLDAY+X
+15 IF IBCLCT>365
SET IBI=IBI-(IBCLCT-365)
SET IBCLDAY=0
SET IBCLCT=365
+16 if $DATA(IBA)
DO WRITE
End DoDot:2
QUIT
+17 SET %H=IBI+IBFCTR
DO YMD^%DTC
SET IBDT=X
DO COPAY^IBAUTL2
+18 ;GMT Copay Adjustment
IF IBGMT>0
SET IBCHG=$$REDUCE^IBAGMT(IBCHG)
+19 SET IBCHARG=IBMAX-IBCLDOL
if IBCHG<IBCHARG
SET IBCHARG=IBCHG
+20 SET IBCHG=IBCHARG
if IBCHG<0
SET IBCHG=0
SET IBCLDOL=IBCLDOL+IBCHG
+21 IF '$DATA(IBA)
SET IBA=IBDT_"^"_IBDT_"^"_IBCLDAY_"^"_IBCLDAY_"^"_IBCLCT_"^"_IBCLCT_"^"_IBCHG
QUIT
+22 SET $PIECE(IBA,"^",2)=IBDT
SET $PIECE(IBA,"^",4)=IBCLDAY
SET $PIECE(IBA,"^",6)=IBCLCT
SET $PIECE(IBA,"^",7)=$PIECE(IBA,"^",7)+IBCHG
End DoDot:1
if IBQUIT
QUIT
+23 if $DATA(IBA)
DO WRITE
+24 ;
+25 ; Print copayment totals.
+26 IF 'IBCHGT
DO NOCOP^IBOMTE1
QUIT
+27 WRITE !?62,"----------",!
+28 IF IBGMT>0
WRITE ?3,"Copayment amount reduced due to Patient's GMT Status"
+29 SET X=IBCHGT
SET X2="2$"
SET X3=12
DO COMMA^%DTC
WRITE ?61,X
+30 QUIT
+31 ;
+32 ;
WRITE ; Write out detail line for copayments.
+1 IF $Y>(IOSL-5)
DO PAUSE^IBOUTL
if IBQUIT
QUIT
DO HDR^IBOMTE1
DO COHDR
+2 SET IBTOT=IBTOT+$PIECE(IBA,"^",7)
SET IBCHGT=IBCHGT+$PIECE(IBA,"^",7)
+3 WRITE !,$$DAT1^IBOUTL($PIECE(IBA,"^")),?12,$$DAT1^IBOUTL($PIECE(IBA,"^",2)),?26,$JUSTIFY($PIECE(IBA,"^",3),3)
+4 WRITE ?35,$JUSTIFY($PIECE(IBA,"^",4),3),?44,$JUSTIFY($PIECE(IBA,"^",5),3),?53,$JUSTIFY($PIECE(IBA,"^",6),3)
+5 SET X=$PIECE(IBA,"^",7)
SET X2="2$"
SET X3=12
DO COMMA^%DTC
WRITE ?61,X
+6 KILL IBA
QUIT
+7 ;
COHDR ; Print copayment subheader.
+1 WRITE !,"COPAYMENT CHARGES for ",$PIECE($GET(^DGCR(399.1,IBBS,0)),"^"),!,IBLINE
+2 WRITE !," Billing Dates",?27,"Inpt. Days",?45,"Clock Days"
+3 WRITE !," From To",?26,"1st Last",?44,"1st Last",?66,"Charge"
+4 WRITE !,IBLINE
QUIT
