source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBS8.m@ 1800

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

initial load of FOIAVistA 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,382**;21-MAR-94;Build 2
3 ;;Per VHA Directive 2004-038, 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)
52 I $P(ITLINE,U,2)'="SNF" G ISNFQ
53 I $P(ITLINE,U,1)'="999",$P(ITLINE,U,1)'="000" G ISNFQ
54 ;
55 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISNFQ
56 ;
57 S IBCHG=$P(ITLINE,U,5)*$P(IBAA,U,6) S IBCHG=$J(IBCHG,0,2)
58 ;
59ISNFQ Q IBCHG
60 ;
61 ;
62FAC(SITE,ITLINE) ; Return Facility Charge (Table B) for All Charge and Unit Types
63 ; each line record contains 1 charge that may be calculated in multiple ways
64 N IBCHG,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE)
65 ;
66 S IBUT=$P(ITLINE,U,10)
67 ;
68 I IBUT=1 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ
69 I IBUT=4 S IBCHG=$$FSTD(SITE,ITLINE) G FACQ
70 I IBUT=2 S IBCHG=$$FHRS(SITE,ITLINE) G FACQ
71 ;
72FACQ Q IBCHG
73 ;
74FSTD(SITE,ITLINE) ; Return Facility Charge of Unit Type = 1 or 4 (Standard and Miles)
75 N IBCHG,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
76 S IBUT=$P(ITLINE,U,10) I IBUT'=1,IBUT'=4 G FSTDQ
77 ;
78 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FSTDQ
79 S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FSTDQ
80 ;
81 S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
82 ;
83FSTDQ Q IBCHG
84 ;
85FHRS(SITE,ITLINE) ; Return Facility Charge of Unit Type = 2 (Hours)
86 N IBCHG,IBCHGB,IBZIP,IBUT,IBAA,IBSCC,IBSCCAAP S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
87 S IBUT=$P(ITLINE,U,10) I IBUT'=2 G FHRSQ
88 ;
89 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G FHRSQ
90 S IBSCC=$$GETSCC($P(ITLINE,U,5)),IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G FHRSQ
91 ;
92 S IBCHG=$P(ITLINE,U,8)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
93 S IBCHGB=$P(ITLINE,U,9)*$P(IBAA,U,IBSCCAAP) S IBCHGB=$J(IBCHGB,0,2)
94 ;
95FHRSQ Q IBCHG_U_IBCHGB
96 ;
97 ;
98PROF(SITE,ITLINE) ; Return Professional Charge (Table C) for All Charge and Unit Types
99 ; each line record contains 1 charge that may be calculated in multiple ways
100 N IBCHG,IBCT,IBUT S IBCHG=0,SITE=$G(SITE),ITLINE=$G(ITLINE)
101 ;
102 S IBCT=$P(ITLINE,U,8)
103 S IBUT=$P(ITLINE,U,16)
104 ;
105 I IBUT=1,IBCT="RBRVS" S IBCHG=$$PRBRVS(SITE,ITLINE) G PROFQ
106 I IBUT=1,IBCT="TotalUnits" S IBCHG=$$PTRVU(SITE,ITLINE) G PROFQ
107 I IBUT=1,IBCT="NW" S IBCHG=$$PNW(SITE,ITLINE) G PROFQ
108 I IBUT=3,IBCT="Anesth" S IBCHG=$$PANES(SITE,ITLINE) G PROFQ
109 ;
110PROFQ Q IBCHG
111 ;
112PRBRVS(SITE,ITLINE) ; Return Professional RBRVS Based Charge
113 N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBPEP,IBWE,IBPE,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
114 S IBCTI=$P(ITLINE,U,8) I IBCTI'="RBRVS" G PRBRVSQ
115 S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PRBRVSQ
116 ;
117 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PRBRVSQ
118 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PRBRVSQ
119 ;
120 S IBPEP=$S($P(SITE,U,5)=3:11,1:10) ; provider/non-provider site
121 ;
122 S IBWE=$P(ITLINE,U,9)*$P(IBAA,U,7)
123 S IBPE=$P(ITLINE,U,IBPEP)*$P(IBAA,U,8)
124 S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
125 ;
126 S IBCHG=(IBWE+IBPE)*IBCF S IBCHG=$J(IBCHG,0,2)
127 ;
128PRBRVSQ Q IBCHG
129 ;
130 ;
131PTRVU(SITE,ITLINE) ; Return Professional Total RVU Charge
132 N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBUN,IBCF S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
133 S IBCTI=$P(ITLINE,U,8) I IBCTI'="TotalUnits" G PTRVUQ
134 S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PTRVUQ
135 ;
136 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PTRVUQ
137 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PTRVUQ
138 ;
139 S IBUN=$P(ITLINE,U,12)*$P(IBAA,U,9)
140 S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
141 ;
142 S IBCHG=IBUN*IBCF S IBCHG=$J(IBCHG,0,2)
143 ;
144PTRVUQ Q IBCHG
145 ;
146PNW(SITE,ITLINE) ; Return Professional Nationwide Charge
147 N IBCHG,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
148 S IBCTI=$P(ITLINE,U,8) I IBCTI'="NW" G PNWQ
149 S IBUT=$P(ITLINE,U,16) I IBUT'=1 G PNWQ
150 ;
151 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PNWQ
152 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PNWQ
153 ;
154 S IBCHG=$P(ITLINE,U,14)*$P(IBAA,U,IBSCCAAP) S IBCHG=$J(IBCHG,0,2)
155 ;
156PNWQ Q IBCHG
157 ;
158PANES(SITE,ITLINE) ; Return Professional Anesthesia Charge
159 N IBCHG,IBCHGB,IBZIP,IBCTI,IBUT,IBAA,IBSCC,IBSCCAAP,IBCF S (IBCHG,IBCHGB)=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
160 S IBCTI=$P(ITLINE,U,8) I IBCTI'="Anesth" G PANESQ
161 S IBUT=$P(ITLINE,U,16) I IBUT'=3 G PANESQ
162 ;
163 S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G PANESQ
164 S IBSCC=$$GETSCC($P(ITLINE,U,6)) S IBSCCAAP=$P(IBSCC,U,4) I 'IBSCCAAP G PANESQ
165 ;
166 S IBCF=$P(IBSCC,U,3)*$P(IBAA,U,IBSCCAAP)
167 ;
168 S IBCHG=$P(ITLINE,U,14)*IBCF S IBCHG=$J(IBCHG,0,2)
169 S IBCHGB=$P(ITLINE,U,13)*IBCF S IBCHGB=$J(IBCHGB,0,2)
170 ;
171PANESQ Q IBCHG_U_IBCHGB
172 ;
173 ;
174 ;
175 ;
176GETAA(ZIP) ; return Area Factor entry for Zip from Table E
177 N IBTMPAA,IBAALN,IBDIV,IBDIVLN S IBAALN="",IBTMPAA="IBCR RC E",IBDIV=""
178 ;
179 I $G(ZIP)?3N S IBDIV=$O(^XTMP(IBTMPAA,"A",ZIP,0))
180 I +IBDIV S IBDIVLN=$G(^XTMP(IBTMPAA,IBDIV)) I $P(IBDIVLN,U,1)=ZIP S IBAALN=IBDIVLN
181 ;
182 Q IBAALN
183 ;
184GETSCC(SCC) ; return Service Category Code entry from Table D
185 N IBTMPSCC,IBSCC,IBSCCLN,IBLN S IBSCCLN="",IBTMPSCC="IBCR RC D",IBSCC=""
186 ;
187 I +$G(SCC) S IBSCC=$O(^XTMP(IBTMPSCC,"A",SCC,0))
188 I +IBSCC S IBLN=$G(^XTMP(IBTMPSCC,IBSCC)) I $P(IBLN,U,1)=SCC S IBSCCLN=IBLN
189 ;
190 Q IBSCCLN
Note: See TracBrowser for help on using the repository browser.