source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBS8.m

Last change on this file was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version
File size: 6.8 KB
Line 
1IBCRHBS8 ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS CHARGE ; 10-OCT-03
2 ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6ISA(SITE,ITLINE) ; Return Inpatient DRG Standard Ancillary Charge
7 N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
8 I $P(ITLINE,U,2)'="DRG" G ISAQ
9 ;
10 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISAQ
11 S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G ISAQ
12 ;
13 S IBCHG=$P(ITLINE,U,6)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
14 ;
15ISAQ Q IBCHG
16 ;
17ISR(SITE,ITLINE) ; Return Inpatient DRG Standard Room & Board Charge
18 N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
19 I $P(ITLINE,U,2)'="DRG" G ISRQ
20 ;
21 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISRQ
22 S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G ISRQ
23 ;
24 S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
25 ;
26ISRQ Q IBCHG
27 ;
28IIA(SITE,ITLINE) ; Return Inpatient DRG ICU Ancillary Charge
29 N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
30 I $P(ITLINE,U,2)'="DRG" G IIAQ
31 ;
32 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIAQ
33 S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":3,IBCTI="N":5,1:0) I 'IBCTIAAP G IIAQ
34 ;
35 S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
36 ;
37IIAQ Q IBCHG
38 ;
39IIR(SITE,ITLINE) ; Return Inpatient DRG ICU Room & Board Charge
40 N IBCHG,IBZIP,IBAA,IBCTI,IBCTIAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
41 I $P(ITLINE,U,2)'="DRG" G IIRQ
42 ;
43 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G IIRQ
44 S IBCTI=$P($G(ITLINE),U,4),IBCTIAAP=$S(IBCTI="S":2,IBCTI="N":4,1:0) I 'IBCTIAAP G IIRQ
45 ;
46 S IBCHG=$P(ITLINE,U,7)*$P(IBAA,U,IBCTIAAP) S IBCHG=$J(IBCHG,0,2)
47 ;
48IIRQ Q IBCHG
49 ;
50ISNF(SITE,ITLINE) ; Return Inpatient Skilled Nursing Facility Per Diem
51 N IBCHG,IBZIP,IBAA S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) I $P(ITLINE,U,2)'="SNF" G ISNFQ
52 I $P(ITLINE,U,1)'="999" G ISNFQ
53 ;
54 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISNFQ
55 ;
56 S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,6) S IBCHG=$J(IBCHG,0,2)
57 ;
58ISNFQ Q IBCHG
59 ;
60 ;
61FAC(SITE,ITLINE) ; Return Facility Charge (Table B) for All Charge and Unit Types
62 ; each line record contains 1 charge that may be calculated in multiple ways
63 N IBCHG,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE)
64 ;
65 S IBUT=$P(ITLINE,U,10)
66 ;
67 I IBUT=1 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ
68 I IBUT=4 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ
69 I IBUT=2 S IBCHG=$$FHRS(SITE,ITLINE) G FACQ
70 ;
71FACQ Q IBCHG
72 ;
73FSTD(SITE,ITLINE) ; Return Facility Charge of Unit Type = 1 or 4 (Standard and Miles)
74 N IBCHG,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
75 S IBUT=$P(ITLINE,U,10) I IBUT'=1,IBUT'=4 G FSTDQ
76 ;
77 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FSTDQ
78 S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FSTDQ
79 ;
80 S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
81 ;
82FSTDQ Q IBCHG
83 ;
84FHRS(SITE,ITLINE) ; Return Facility Charge of Unit Type = 2 (Hours)
85 N IBCHG,IBCHGB,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
86 S IBUT=$P(ITLINE,U,10) I IBUT'=2 G FHRSQ
87 ;
88 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FHRSQ
89 S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FHRSQ
90 ;
91 S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
92 S IBCHGB=$P(ITLINE,U,9)*$P(IBAA,U,IBSCCAAP) S IBCHGB=$J(IBCHGB,0,2)
93 ;
94FHRSQ Q IBCHG_U_IBCHGB
95 ;
96 ;
97PROF(SITE,ITLINE) ; Return Professional Charge (Table C) for All Charge and Unit Types
98 ; each line record contains 1 charge that may be calculated in multiple ways
99 N IBCHG,IBCT,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE)
100 ;
101 S IBCT=$P(ITLINE,U,8)
102 S IBUT=$P(ITLINE,U,16)
103 ;
104 I IBUT=1,IBCT="RBRVS" S IBCHG=$$PRBRVS(SITE,ITLINE) G PROFQ
105 I IBUT=1,IBCT="TotalUnits" S IBCHG=$$PTRVU(SITE,ITLINE) G PROFQ
106 I IBUT=1,IBCT="NW" S IBCHG=$$PNW(SITE,ITLINE) G PROFQ
107 I IBUT=3,IBCT="Anesth" S IBCHG=$$PANES(SITE,ITLINE) G PROFQ
108 ;
109PROFQ Q IBCHG
110 ;
111PRBRVS(SITE,ITLINE) ; Return Professional RBRVS Based Charge
112 N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBPEP,IBWE,IBPE,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
113 S IBCTI=$P(ITLINE,U,8) I IBCTI'="RBRVS" G PRBRVSQ
114 S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PRBRVSQ
115 ;
116 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PRBRVSQ
117 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PRBRVSQ
118 ;
119 S IBPEP=$S($P(SITE,U,5)=3:11,1:10) ; provider/non-provider site
120 ;
121 S IBWE=$P(ITLINE,U,9)*$P(IBAA,U,7)
122 S IBPE=$P(ITLINE,U,IBPEP)*$P(IBAA,U,8)
123 S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
124 ;
125 S IBCHG=(IBWE+IBPE)*IBCF S IBCHG=$J(IBCHG,0,2)
126 ;
127PRBRVSQ Q IBCHG
128 ;
129 ;
130PTRVU(SITE,ITLINE) ; Return Professional Total RVU Charge
131 N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBUN,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
132 S IBCTI=$P(ITLINE,U,8) I IBCTI'="TotalUnits" G PTRVUQ
133 S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PTRVUQ
134 ;
135 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PTRVUQ
136 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PTRVUQ
137 ;
138 S IBUN=$P(ITLINE,U,12)*$P(IBAA,U,9)
139 S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
140 ;
141 S IBCHG=IBUN*IBCF S IBCHG=$J(IBCHG,0,2)
142 ;
143PTRVUQ Q IBCHG
144 ;
145PNW(SITE,ITLINE) ; Return Professional Nationwide Charge
146 N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
147 S IBCTI=$P(ITLINE,U,8) I IBCTI'="NW" G PNWQ
148 S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PNWQ
149 ;
150 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PNWQ
151 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PNWQ
152 ;
153 S IBCHG=$P(ITLINE,U,14)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
154 ;
155PNWQ Q IBCHG
156 ;
157PANES(SITE,ITLINE) ; Return Professional Anesthesia Charge
158 N IBCHG,IBCHGB,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBCF S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
159 S IBCTI=$P(ITLINE,U,8) I IBCTI'="Anesth" G PANESQ
160 S IBUT=$P(ITLINE,U,16) I IBUT'=3 G PANESQ
161 ;
162 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PANESQ
163 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PANESQ
164 ;
165 S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
166 ;
167 S IBCHG=$P(ITLINE,U,14)*IBCF S IBCHG=$J(IBCHG,0,2)
168 S IBCHGB=$P(ITLINE,U,13)*IBCF S IBCHGB=$J(IBCHGB,0,2)
169 ;
170PANESQ Q IBCHG_U_IBCHGB
171 ;
172 ;
173 ;
174 ;
175GETAA(ZIP) ; return Area Factor entry for Zip from Table E
176 N IBTMPAA,IBAALN,IBDIV,IBDIVLN S IBAALN="",IBTMPAA="IBCR RC E",IBDIV=""
177 ;
178 I $G(ZIP)?3N S IBDIV=$O(^XTMP(IBTMPAA,"A",ZIP,0))
179 I +IBDIV S IBDIVLN=$G(^XTMP(IBTMPAA,IBDIV)) I $P(IBDIVLN,U,1)=ZIP S IBAALN=IBDIVLN
180 ;
181 Q IBAALN
182 ;
183GETSCC(SCC) ; return Service Category Code entry from Table D
184 N IBTMPSCC,IBSCC,IBSCCLN,IBLN S IBSCCLN="",IBTMPSCC="IBCR RC D",IBSCC=""
185 ;
186 I +$G(SCC) S IBSCC=$O(^XTMP(IBTMPSCC,"A",SCC,0))
187 I +IBSCC S IBLN=$G(^XTMP(IBTMPSCC,IBSCC)) I $P(IBLN,U,1)=SCC S IBSCCLN=IBLN
188 ;
189 Q IBSCCLN
Note: See TracBrowser for help on using the repository browser.