IBOMTE2 ;ALB/CPM - ESTIMATE CATEGORY C CHARGES (COPAY) ; 17-DEC-91
;;Version 2.0 ; INTEGRATED BILLING ;; 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
. 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
. 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,"----------" 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
IBOMTE2 ;ALB/CPM - ESTIMATE CATEGORY C CHARGES (COPAY) ; 17-DEC-91
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 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
End DoDot:2
+9 IF IBCLDAY>360
QUIT
+10 SET IBMAX=IBMED
IF IBCLDAY>90
IF 'IBNH
SET IBMAX=IBMED/2
+11 IF IBCLDOL'<IBMAX
Begin DoDot:2
+12 SET IBCLDOL=0
SET X=90-(IBCLDAY#90)
+13 SET IBI=IBI+X
SET IBCLCT=IBCLCT+X
SET IBCLDAY=IBCLDAY+X
+14 IF IBCLCT>365
SET IBI=IBI-(IBCLCT-365)
SET IBCLDAY=0
SET IBCLCT=365
+15 IF $DATA(IBA)
DO WRITE
End DoDot:2
QUIT
+16 SET %H=IBI+IBFCTR
DO YMD^%DTC
SET IBDT=X
DO COPAY^IBAUTL2
+17 SET IBCHARG=IBMAX-IBCLDOL
IF IBCHG<IBCHARG
SET IBCHARG=IBCHG
+18 SET IBCHG=IBCHARG
IF IBCHG<0
SET IBCHG=0
SET IBCLDOL=IBCLDOL+IBCHG
+19 IF '$DATA(IBA)
SET IBA=IBDT_"^"_IBDT_"^"_IBCLDAY_"^"_IBCLDAY_"^"_IBCLCT_"^"_IBCLCT_"^"_IBCHG
QUIT
+20 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
+21 IF $DATA(IBA)
DO WRITE
+22 ;
+23 ; Print copayment totals.
+24 IF 'IBCHGT
DO NOCOP^IBOMTE1
QUIT
+25 WRITE !?62,"----------"
SET X=IBCHGT
SET X2="2$"
SET X3=12
DO COMMA^%DTC
WRITE !?61,X
+26 QUIT
+27 ;
+28 ;
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
