[613] | 1 | IBCRBC3 ;ALB/ARH - RATES: BILL CALCULATION SORT/STORE ;22-MAY-1996
|
---|
| 2 | ;;2.0;INTEGRATED BILLING;**52,106,138,51**;21-MAR-94
|
---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
---|
| 4 | ;
|
---|
| 5 | SORTCI ; process charge array - create new array sorted by bedsection and revenue code
|
---|
| 6 | ; if bs, rv cd, unit charge, cpt, div, item type, item ptr and component all match then charge is combined
|
---|
| 7 | ; Input: TMP($J,"IBCRCC",X) = ... (from IBCRBC2)
|
---|
| 8 | ; Output: TMP($J,"IBCRCS",BS,RV CD,Y) =
|
---|
| 9 | ; RV CD PTR ^ BS PTR ^ UNIT $ ^ UNITS ^ CPT ^ DIV ^ ITEM TYPE ^ ITEM PTR ^ CHARGE COMPONENT
|
---|
| 10 | ;
|
---|
| 11 | N IBI,IBLN,IBRVCD,IBBS,IBUNITS,IBCHG,IBCPT,IBDV,IBIT,IBIP,IBCMPT,IBTUNITS,IBK,IBJ,IBX K ^TMP($J,"IBCRCS")
|
---|
| 12 | ;
|
---|
| 13 | S IBI=0 F S IBI=$O(^TMP($J,"IBCRCC",IBI)) Q:'IBI D
|
---|
| 14 | . ;
|
---|
| 15 | . S IBLN=^TMP($J,"IBCRCC",IBI)
|
---|
| 16 | . S IBRVCD=$P(IBLN,U,6),IBBS=$P(IBLN,U,7),IBCHG=$P(IBLN,U,12),IBUNITS=$P(IBLN,U,13) Q:'IBCHG
|
---|
| 17 | . S IBCPT=$P(IBLN,U,14),IBDV=$P(IBLN,U,15),IBIT=$P(IBLN,U,16),IBIP=$P(IBLN,U,17),IBCMPT=$P(IBLN,U,18)
|
---|
| 18 | . ;
|
---|
| 19 | . S (IBTUNITS,IBK)=0 ; combine like charges
|
---|
| 20 | . S IBJ=0 F S IBJ=$O(^TMP($J,"IBCRCS",+IBBS,+IBRVCD,IBJ)) Q:'IBJ D Q:+IBTUNITS
|
---|
| 21 | .. S IBK=IBJ,IBX=$G(^TMP($J,"IBCRCS",+IBBS,+IBRVCD,IBJ))
|
---|
| 22 | .. I IBCHG=$P(IBX,U,3),IBCPT=$P(IBX,U,5),IBDV=$P(IBX,U,6),IBIT=$P(IBX,U,7),IBIP=$P(IBX,U,8),IBCMPT=$P(IBX,U,9) D
|
---|
| 23 | ... S IBTUNITS=$P(IBX,U,4)
|
---|
| 24 | . ;
|
---|
| 25 | . I 'IBTUNITS S IBK=IBK+1 ; no combination, new line item charge
|
---|
| 26 | . S IBTUNITS=IBTUNITS+IBUNITS
|
---|
| 27 | . ;
|
---|
| 28 | . S ^TMP($J,"IBCRCS",+IBBS,+IBRVCD,IBK)=IBRVCD_U_+IBBS_U_IBCHG_U_IBTUNITS_U_IBCPT_U_IBDV_U_IBIT_U_IBIP_U_IBCMPT
|
---|
| 29 | Q
|
---|
| 30 | ;
|
---|
| 31 | ;
|
---|
| 32 | ADDBCHGS(IBIFN) ; store all auto calculated charges: add charges to bill: sets RC multiple
|
---|
| 33 | ; Input: TMP($J,"IBCRCS",BS,RV CD,X) = ... (from SORTCI)
|
---|
| 34 | ;
|
---|
| 35 | N IBX,IBI,IBJ,IBK,IBLN,IBRVCD,IBBS,IBCHG,IBUNITS,IBAUTOAD,IBCPT,IBDIV,IBITYP,IBIPTR,IBCMPNT,IBRCFN,Z
|
---|
| 36 | ;
|
---|
| 37 | D DSPHDR
|
---|
| 38 | ;
|
---|
| 39 | S IBI=0 F S IBI=$O(^TMP($J,"IBCRCS",IBI)) Q:'IBI D
|
---|
| 40 | . S IBJ=0 F S IBJ=$O(^TMP($J,"IBCRCS",IBI,IBJ)) Q:'IBJ D
|
---|
| 41 | .. S IBK=0 F S IBK=$O(^TMP($J,"IBCRCS",IBI,IBJ,IBK)) Q:'IBK D
|
---|
| 42 | ... S IBLN=$G(^TMP($J,"IBCRCS",IBI,IBJ,IBK)) Q:IBLN=""
|
---|
| 43 | ... ;
|
---|
| 44 | ... ; add charges to RC multiple
|
---|
| 45 | ... S IBRVCD=$P(IBLN,U,1),IBBS=$P(IBLN,U,2),IBCHG=$P(IBLN,U,3),IBUNITS=$P(IBLN,U,4),IBAUTOAD=1
|
---|
| 46 | ... S IBCPT=$P(IBLN,U,5),IBDIV=$P(IBLN,U,6),IBITYP=$P(IBLN,U,7),IBIPTR=$P(IBLN,U,8),IBCMPNT=$P(IBLN,U,9)
|
---|
| 47 | ... ;
|
---|
| 48 | ... S IBRCFN=$$ADDRC^IBCRBF(IBIFN,IBRVCD,IBBS,IBCHG,IBUNITS,IBCPT,IBDIV,IBAUTOAD,IBITYP,IBIPTR,IBCMPNT)
|
---|
| 49 | ... ;
|
---|
| 50 | ... I +IBRCFN D
|
---|
| 51 | .... I IBITYP=3,IBIPTR'="" D DEFAULT^IBCSC5C(IBIFN,+IBRCFN)
|
---|
| 52 | .... S IBX=IBRVCD_U_IBCHG_U_IBUNITS_U_IBBS_U_IBITYP_U_IBIPTR_U_IBCPT D DSPLN(IBX)
|
---|
| 53 | ;
|
---|
| 54 | D CLEANRX(IBIFN)
|
---|
| 55 | Q
|
---|
| 56 | ;
|
---|
| 57 | CLEANRX(IBIFN) ; Clean up any procedures left over from deleted Rx entries
|
---|
| 58 | N Z,DA,DIK
|
---|
| 59 | S Z=0 F S Z=$O(^TMP("IBCRRX",$J,Z)) Q:'Z S DA=0 F S DA=$O(^TMP("IBCRRX",$J,Z,DA)) Q:'DA S DA(1)=IBIFN,DIK="^DGCR(399,"_DA(1)_",""CP""," D ^DIK
|
---|
| 60 | K ^TMP("IBCRRX",$J)
|
---|
| 61 | Q
|
---|
| 62 | ;
|
---|
| 63 | DSPDL ;
|
---|
| 64 | I $D(ZTQUEUED)!(+$G(IBAUTO)) Q
|
---|
| 65 | W !,"Removing old Revenue Codes and Rate Schedules..."
|
---|
| 66 | Q
|
---|
| 67 | DSPHDR ;
|
---|
| 68 | I $D(ZTQUEUED)!(+$G(IBAUTO)) Q
|
---|
| 69 | W !,"Updating Revenue Codes and Charges"
|
---|
| 70 | W !,?9,"Rev Code",?19,"Units",?31,"Charge",?41,"Bedsection"
|
---|
| 71 | Q
|
---|
| 72 | DSPLN(LN) ;
|
---|
| 73 | I $D(ZTQUEUED)!(+$G(IBAUTO)) Q
|
---|
| 74 | N RVCD,BS,ITM S LN=$G(LN)
|
---|
| 75 | S RVCD=$P($G(^DGCR(399.2,+LN,0)),U,1),BS=$$EMUTL^IBCRU1(+$P(LN,U,4)),ITM=$$NAME^IBCSC61($P(LN,U,5),$P(LN,U,6))
|
---|
| 76 | I ITM="",$P(LN,U,7) S ITM=$P($$CPT^ICPTCOD(+$P(LN,U,7),DT),U,2)
|
---|
| 77 | W !,"Adding",?11,RVCD,?19,$J($P(LN,U,3),3),?28,"$",$J($P(LN,U,2),8,2),?41,$E(BS,U,26),?69,$E(ITM,1,11)
|
---|
| 78 | Q
|
---|