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

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

initial load of FOIAVistA 6/30/08 version
File size: 9.6 KB
Line 
1IBCRHBR6 ;ALB/ARH - RATES: UPLOAD (RC) SITE CALCULATIONS ; 10-OCT-1998
2 ;;2.0;INTEGRATED BILLING;**106,138,148,169,245**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5INPT(SITE) ; use Inpatient Facility National Rates to calculate Site Specific Rates
6 N IBXTMPC,IBXTMPA,IBSITE,IBXRF1,IBXRF2,IBAA,IBI,IBDRG,IBEFF,IBINA,IBCHRG,IBSNS,IBDRMB,IBSRMB,IBDANC,IBSANC,IBRG,IBRATE,IBEVNT,IBBS,IBCSRB,IBCSAN
7 ;
8 S IBXTMPC="IBCR RC A",IBXTMPA="IBCR RC B",IBSITE=$$SITE(SITE,IBXTMPA,"Inpatient Facility") Q:'IBSITE
9 S IBXRF1="IBCR UPLOAD RC "_$P(IBSITE,U,2)_" "_$P(IBSITE,U,3),IBXRF2="Inpt Fac"
10 W !,$P(IBSITE,U,2)," ",$P(IBSITE,U,3)," - Inpatient Facility Charges"
11 ;
12 S IBAA=$G(^XTMP(IBXTMPA,+IBSITE)) Q:IBAA=""
13 ;
14 S IBRG=$$RG^IBCRHU2("RC "_$P(IBSITE,U,2)_" - "_$P(IBSITE,U,3),$P(IBSITE,U,2),$P(IBSITE,U,4)),IBRG=$P(IBRG,U,2)
15 S IBRATE="RC INPATIENT FACILITY"
16 S IBEVNT="INPATIENT DRG"
17 S IBBS="GENERAL MEDICAL CARE"
18 S IBCSRB=$$CS^IBCRHU2("RC-INPT R&B "_$P(IBSITE,U,2),IBRATE,IBEVNT,IBRG,"INST",101,IBBS)
19 S IBCSAN=$$CS^IBCRHU2("RC-INPT ANC "_$P(IBSITE,U,2),IBRATE,IBEVNT,IBRG,"INST",240,IBBS)
20 ;
21 S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D I '(IBI#100) W "."
22 . S IBDRG=$G(^XTMP(IBXTMPC,IBI)) Q:IBDRG=""
23 . ;
24 . S IBEFF=$P(IBDRG,U,5) I $P(IBAA,U,7)>IBEFF S IBEFF=$P(IBAA,U,7)
25 . S IBINA=$P(IBDRG,U,6) I $P(IBAA,U,8)>IBINA S IBINA=$P(IBAA,U,8)
26 . ;
27 . S IBSNS=$P(IBDRG,U,2)
28 . S IBDRMB=$P(IBDRG,U,3),IBSRMB=$S(IBSNS="S":$P(IBAA,U,2),IBSNS="N":$P(IBAA,U,4),1:0)
29 . S IBCHRG=IBDRMB*IBSRMB,IBCHRG=$J(IBCHRG,0,$$RND)
30 . D SET(IBXRF1,IBXRF2_" R&B","DRG"_+$P(IBDRG,U,1),IBEFF,IBINA,+IBCHRG,"",IBCSRB,4)
31 . ;
32 . S IBDANC=$P(IBDRG,U,4),IBSANC=$S(IBSNS="S":$P(IBAA,U,3),IBSNS="N":$P(IBAA,U,5),1:0)
33 . S IBCHRG=IBDANC*IBSANC,IBCHRG=$J(IBCHRG,0,$$RND)
34 . D SET(IBXRF1,IBXRF2_" Anc","DRG"_+$P(IBDRG,U,1),IBEFF,IBINA,+IBCHRG,"",IBCSAN,4)
35 Q
36 ;
37SNF(SITE) ; Skilled Nursing
38 N IBXTMPC,IBXTMPA,IBSITE,IBXRF1,IBXRF2,IBAA,IBI,IBDRG,IBEFF,IBINA,IBCHRG,IBRG,IBRATE,IBEVNT,IBBS,IBCS
39 ;
40 ;
41 S IBXTMPC="IBCR RC A",IBXTMPA="IBCR RC B",IBSITE=$$SITE(SITE,IBXTMPA,"Skilled Nursing") Q:'IBSITE
42 S IBXRF1="IBCR UPLOAD RC "_$P(IBSITE,U,2)_" "_$P(IBSITE,U,3),IBXRF2="Inpt SNF"
43 W !,$P(IBSITE,U,2)," ",$P(IBSITE,U,3)," - Inpatient Skilled Nursing Charges"
44 ;
45 S IBRG=$$RG^IBCRHU2("RC "_$P(IBSITE,U,2)_" - "_$P(IBSITE,U,3),$P(IBSITE,U,2),$P(IBSITE,U,4)),IBRG=$P(IBRG,U,2)
46 S IBRATE="RC SKILLED NURSING/SUB-ACUTE"
47 S IBEVNT="UNASSOCIATED"
48 S IBBS="SKILLED NURSING/SUB-ACUTE CARE"
49 S IBCS=$$CS^IBCRHU2("RC-SNF "_$P(IBSITE,U,2),IBRATE,IBEVNT,IBRG,"INST","100",IBBS)
50 ;
51 S IBAA=$G(^XTMP(IBXTMPA,+IBSITE)) Q:IBAA=""
52 ;
53 S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D
54 . S IBDRG=$G(^XTMP(IBXTMPC,IBI)) I $P(IBDRG,U,1)'=999 Q
55 . ;
56 . S IBEFF=$P(IBDRG,U,5) I $P(IBAA,U,7)>IBEFF S IBEFF=$P(IBAA,U,7)
57 . S IBINA=$P(IBDRG,U,6) I $P(IBAA,U,8)>IBINA S IBINA=$P(IBAA,U,8)
58 . ;
59 . S IBCHRG=$P(IBAA,U,6)*$P(IBDRG,U,3),IBCHRG=$J(IBCHRG,0,$$RND)
60 . D SET(IBXRF1,IBXRF2,"SKILLED NURSING CARE",IBEFF,IBINA,+IBCHRG,"",IBCS,9)
61 . S IBCHRG=$P(IBAA,U,6)*$P(IBDRG,U,3),IBCHRG=$J(IBCHRG,0,$$RND)
62 . D SET(IBXRF1,IBXRF2,"SUB-ACUTE CARE",IBEFF,IBINA,+IBCHRG,"",IBCS,9)
63 Q
64 ;
65OPT(SITE) ; use Outpatient Facility National Rates to calculate Site Specific Rates
66 N IBXTMPC,IBXTMPA,IBSITE,IBXRF1,IBXRF2,IBAA,IBI,IBCPT,IBEFF,IBINA,IBCHRG,IBRG,IBRATE,IBEVNT,IBBS,IBCS
67 ;
68 S IBXTMPC="IBCR RC C",IBXTMPA="IBCR RC D",IBSITE=$$SITE(SITE,IBXTMPA,"Outpatient Facility") Q:'IBSITE
69 S IBXRF1="IBCR UPLOAD RC "_$P(IBSITE,U,2)_" "_$P(IBSITE,U,3),IBXRF2="Opt Fac"
70 W !,$P(IBSITE,U,2)," ",$P(IBSITE,U,3)," - Outpatient Facility Charges"
71 ;
72 S IBRG=$$RG^IBCRHU2("RC "_$P(IBSITE,U,2)_" - "_$P(IBSITE,U,3),$P(IBSITE,U,2),$P(IBSITE,U,4)),IBRG=$P(IBRG,U,2)
73 S IBRATE="RC FACILITY PR"
74 S IBEVNT="PROCEDURE"
75 S IBBS="OUTPATIENT VISIT"
76 S IBCS=$$CS^IBCRHU2("RC-OPT FAC "_$P(IBSITE,U,2),IBRATE,IBEVNT,IBRG,"INST",510,IBBS)
77 ;
78 S IBAA=$G(^XTMP(IBXTMPA,+IBSITE)) Q:IBAA=""
79 ;
80 S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D I '(IBI#100) W "."
81 . S IBCPT=$G(^XTMP(IBXTMPC,IBI)) Q:IBCPT=""
82 . ;
83 . I +$P(IBCPT,U,5),$P(IBCPT,U,5)'=$P(IBAA,U,5) Q ; site limited charge
84 . ;
85 . S IBEFF=$P(IBCPT,U,3) I $P(IBAA,U,3)>IBEFF S IBEFF=$P(IBAA,U,3)
86 . S IBINA=$P(IBCPT,U,4) I $P(IBAA,U,4)>IBINA S IBINA=$P(IBAA,U,4)
87 . ;
88 . S IBCHRG=+$P(IBAA,U,2)*$P(IBCPT,U,2),IBCHRG=$J(IBCHRG,0,2)
89 . D SET(IBXRF1,IBXRF2,$P(IBCPT,U,1),IBEFF,IBINA,+IBCHRG,"",IBCS,2)
90 Q
91 ;
92PCE(SITE) ; use Physician (General) National Rates to calculate Site Specific Rates
93 N IBXTMPC,IBXTMPA,IBSITE,IBXRF1,IBXRF2,IBAA,IBI,IBCPT,IBEFF,IBINA,IBCHRG,IBAAM,IBCGP,IBC1,IBC2,IBC3,IBOK,IBRG,IBRATE,IBEVNT,IBBS,IBCS S IBOK=1
94 ;
95 S IBXTMPC="IBCR RC E",IBXTMPA="IBCR RC H",IBSITE=$$SITE(SITE,IBXTMPA,"Physician E") Q:'IBSITE
96 S IBXRF1="IBCR UPLOAD RC "_$P(IBSITE,U,2)_" "_$P(IBSITE,U,3),IBXRF2="Phys Fee E"
97 W !,$P(IBSITE,U,2)," ",$P(IBSITE,U,3)," - Physician Charges E"
98 ;
99 S IBRG=$$RG^IBCRHU2("RC "_$P(IBSITE,U,2)_" - "_$P(IBSITE,U,3),$P(IBSITE,U,2),$P(IBSITE,U,4)),IBRG=$P(IBRG,U,2)
100 S IBRATE="RC PHYSICIAN PR"
101 S IBEVNT="PROCEDURE"
102 S IBBS="OUTPATIENT VISIT"
103 S IBCS=$$CS^IBCRHU2("RC-PHYSICIAN "_$P(IBSITE,U,2),IBRATE,IBEVNT,IBRG,"PROF",510,IBBS)
104 ;
105 S IBAA=$G(^XTMP(IBXTMPA,+IBSITE)) Q:IBAA=""
106 S IBAAM=$G(^XTMP(IBXTMPA,+IBSITE,"BC")) Q:IBAAM=""
107 ;
108 S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D W:'(IBI#100) "." I 'IBOK Q
109 . S IBCPT=$G(^XTMP(IBXTMPC,IBI)) Q:IBCPT=""
110 . S IBCGP=$$CGP($P(IBCPT,U,5),IBXTMPC_"="_$P(IBCPT,U,1)) I 'IBCGP S IBOK=0 Q
111 . ;
112 . S IBEFF=$P(IBCPT,U,7) I $P(IBAA,U,5)>IBEFF S IBEFF=$P(IBAA,U,5)
113 . S IBINA=$P(IBCPT,U,8) I $P(IBAA,U,6)>IBINA S IBINA=$P(IBAA,U,6)
114 . ;
115 . S IBC1=$P(IBCPT,U,3)*$P(IBAA,U,3)*$P(IBAA,U,2)
116 . S IBC2=$P(IBCPT,U,4)*$P(IBAA,U,4)
117 . S IBC3=$P(IBCPT,U,6)*$P(IBAAM,U,IBCGP)
118 . S IBCHRG=(IBC1+IBC2)*IBC3,IBCHRG=$J(IBCHRG,0,2)
119 . D SET(IBXRF1,IBXRF2,$P(IBCPT,U,1),IBEFF,IBINA,+IBCHRG,$P(IBCPT,U,2),IBCS,2)
120 Q
121 ;
122PCF(SITE) ; use Physician (Path & Anesthesia) National Rates to calculate Site Specific Rates
123 N IBXTMPC,IBXTMPA,IBSITE,IBXRF1,IBXRF2,IBAA,IBI,IBCPT,IBEFF,IBINA,IBCHRG,IBAAM,IBCGP,IBOK,IBCS S IBOK=1
124 ;
125 S IBXTMPC="IBCR RC F",IBXTMPA="IBCR RC H",IBSITE=$$SITE(SITE,IBXTMPA,"Physician F") Q:'IBSITE
126 S IBXRF1="IBCR UPLOAD RC "_$P(IBSITE,U,2)_" "_$P(IBSITE,U,3),IBXRF2="Phys Fee F"
127 W !,$P(IBSITE,U,2)," ",$P(IBSITE,U,3)," - Physician Charges F"
128 ;
129 S IBCS=$$USECS^IBCRHU2("RC-PHYSICIAN "_$P(IBSITE,U,2))
130 ;
131 S IBAA=$G(^XTMP(IBXTMPA,+IBSITE)) Q:IBAA=""
132 S IBAAM=$G(^XTMP(IBXTMPA,+IBSITE,"BC")) Q:IBAAM=""
133 ;
134 S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D W:'(IBI#100) "." I 'IBOK Q
135 . S IBCPT=$G(^XTMP(IBXTMPC,IBI)) Q:IBCPT=""
136 . S IBCGP=$$CGP($P(IBCPT,U,4),IBXTMPC_"="_$P(IBCPT,U,1)) I 'IBCGP S IBOK=0 Q
137 . ;
138 . S IBEFF=$P(IBCPT,U,5) I $P(IBAA,U,5)>IBEFF S IBEFF=$P(IBAA,U,5)
139 . S IBINA=$P(IBCPT,U,6) I $P(IBAA,U,6)>IBINA S IBINA=$P(IBAA,U,6)
140 . ;
141 . S IBCHRG=+$P(IBAAM,U,IBCGP)*$P(IBCPT,U,3),IBCHRG=$J(IBCHRG,0,2)
142 . D SET(IBXRF1,IBXRF2,$P(IBCPT,U,1),IBEFF,IBINA,+IBCHRG,$P(IBCPT,U,2),IBCS,2)
143 Q
144 ;
145PCG(SITE) ; use Physician (Total RVU) National Rates to calculate Site Specific Rates
146 N IBXTMPC,IBXTMPA,IBXRF1,IBXRF2,IBSITE,IBAA,IBAAM,IBI,IBCPT,IBCGP,IBEFF,IBINA,IBCHRG,IBCS
147 ;
148 S IBXTMPC="IBCR RC G",IBXTMPA="IBCR RC I",IBSITE=$$SITE(SITE,IBXTMPA,"Physician G") Q:'IBSITE
149 S IBXRF1="IBCR UPLOAD RC "_$P(IBSITE,U,2)_" "_$P(IBSITE,U,3),IBXRF2="Phys Fee G"
150 W !,$P(IBSITE,U,2)," ",$P(IBSITE,U,3)," - Physician Charges G"
151 ;
152 S IBCS=$$USECS^IBCRHU2("RC-PHYSICIAN "_$P(IBSITE,U,2))
153 ;
154 S IBAA=$G(^XTMP(IBXTMPA,+IBSITE)) Q:IBAA=""
155 S IBAAM=$G(^XTMP("IBCR RC H",+IBSITE,"BC")) Q:IBAAM=""
156 ;
157 S IBI=0 F S IBI=$O(^XTMP(IBXTMPC,IBI)) Q:'IBI D I '(IBI#100) W "."
158 . S IBCPT=$G(^XTMP(IBXTMPC,IBI)) Q:IBCPT=""
159 . S IBCGP=$$CGP($P(IBCPT,U,4),IBXTMPC_"="_$P(IBCPT,U,1)) I 'IBCGP S IBOK=0 Q
160 . ;
161 . S IBEFF=$P(IBCPT,U,6) I $P(IBAA,U,3)>IBEFF S IBEFF=$P(IBAA,U,3)
162 . S IBINA=$P(IBCPT,U,7) I $P(IBAA,U,4)>IBINA S IBINA=$P(IBAA,U,4)
163 . ;
164 . S IBCHRG=+$P(IBAAM,U,IBCGP)*$P(IBAA,U,2)*$P(IBCPT,U,3)*$P(IBCPT,U,5),IBCHRG=$J(IBCHRG,0,2)
165 . D SET(IBXRF1,IBXRF2,$P(IBCPT,U,1),IBEFF,IBINA,+IBCHRG,$P(IBCPT,U,2),IBCS,2)
166 Q
167 ;
168SITE(IBSXIFN,IBXTMP,IBCHGTYP) ; return site data: XTMP file IFN ^ div num ^ name ^ 3-digit zip
169 N IBSITE,IBSXTMP,IBSITEN S IBSITE="",IBSXTMP="IBCR RC SITE"
170 S IBSITE=$G(^XTMP(IBSXTMP,IBSXIFN,IBXTMP)),IBSITEN=$G(^XTMP(IBSXTMP,IBSXIFN))
171 I +IBSITE S IBSITE=IBSITE_U_$P(IBSITEN,U,1,3)
172 I 'IBSITE W !,"There are no ",$G(IBCHGTYP)," charges for ",$P(IBSITEN,U,1)," ",$P(IBSITEN,U,2),"!",!
173 Q IBSITE
174 ;
175SETHDR(IBXRF1) ; set up header for XTMP file
176 N IBX K ^XTMP(IBXRF1)
177 S IBX="IB Upload RC v"_$$VERSION^IBCRHBRV_" "_$P(IBXRF1,"UPLOAD RC ",2)_", "_$P($$HTE^XLFDT($H,2),":",1,2)_" by "_$P($G(^VA(200,+$G(DUZ),0)),U,1)
178 S ^XTMP(IBXRF1,0)=$$FMADD^XLFDT(DT,2)_U_DT_U_IBX
179 Q
180 ;
181SET(IBXRF1,IBXRF2,ITEM,EFFDT,INACTDT,CHRG,MOD,CS,ITYPE) ; set calculated charges into XTMP
182 ;
183 N IBX,IBK,IBINACT S IBX=$G(^XTMP(IBXRF1,0)) I IBX="" D SETHDR(IBXRF1)
184 S IBK=+$P(IBX,U,4)+1,$P(^XTMP(IBXRF1,0),U,4)=IBK
185 S ^XTMP(IBXRF1,IBXRF2)=(+$G(^XTMP(IBXRF1,IBXRF2))+1)_U_$G(ITYPE)_U_$G(CS)
186 ;
187 S ^XTMP(IBXRF1,IBXRF2,IBK)=ITEM_U_$$DATE(EFFDT)_U_$$ENDDT(INACTDT)_U_+CHRG_U_$G(MOD)
188 Q
189 ;
190CGP(CG,TXT) ; if Code Group is defined return benefit category number in list
191 N IBCGP I '$D(^TMP($J,"IBCR RC CGROUP")) D CGROUP^IBCRHBR
192 S IBCGP=0 I $G(CG)'="" S IBCGP=+$G(^TMP($J,"IBCR RC CGROUP",CG))
193 I '$G(IBCGP) W !," *** Fatal Error: ",$G(TXT),!,?21,"could not find Code Group: ",CG
194 Q IBCGP
195 ;
196DATE(X) ; return yyyymmdd in FM format
197 N Y S Y="" I $G(X)?8N S Y=$S($E(X,1,4)>1999:3,1:2)_$E(X,3,4)_$E(X,5,8)
198 Q Y
199 ;
200ENDDT(X) ; return yyyymmdd date in FM format, check version inactive date
201 N Y,V S Y=$$DATE($G(X)) I 'Y S V=$G(^XTMP("IBCR RC SITE","VERSION INACTIVE")) I +V S Y=V
202 Q Y
203 ;
204RND() ;
205 N Y S Y=$$VERSION^IBCRHBRV S Y=$S(Y=1:0,1:2)
206 Q Y
Note: See TracBrowser for help on using the repository browser.