- 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 Mar 13, 2025@21:30:55 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
