source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC3.m@ 846

Last change on this file since 846 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.4 KB
Line 
1IBCRBC3 ;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 ;
5SORTCI ; 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 ;
32ADDBCHGS(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 ;
57CLEANRX(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 ;
63DSPDL ;
64 I $D(ZTQUEUED)!(+$G(IBAUTO)) Q
65 W !,"Removing old Revenue Codes and Rate Schedules..."
66 Q
67DSPHDR ;
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
72DSPLN(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
Note: See TracBrowser for help on using the repository browser.