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

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1IBCRHBR3 ;ALB/ARH - RATES: UPLOAD HOST FILES (RC) PARSE ; 10-OCT-1998
2 ;;2.0;INTEGRATED BILLING;**106,138,148,169**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; IBFLINE required and VERS expected on entry
6 ;
7A ; Inpatient Facility DRG Charges: process a single line, parse out into individual fields and store in XTMP
8 N IBDRG,IBSNS,IBDESC,IBRB,IBANC,IBBEG,IBEND,LINE,IBXIFN,IBXTMP S IBXTMP="IBCR RC A"
9 ;
10 S IBDRG=$$P(IBFLINE,1),IBDRG=$$STRIP(IBDRG) Q:IBDRG'?3N ; DRG
11 S IBDESC=$$P(IBFLINE,2) ; description
12 S IBSNS=$$P(IBFLINE,3),IBSNS=$$STRIP(IBSNS) ; surgery/non-surgery
13 S IBRB=$$P(IBFLINE,4),IBRB=$$STRIP(IBRB) ; room & board
14 S IBANC=$$P(IBFLINE,5),IBANC=$$STRIP(IBANC) ; ancillary
15 S IBBEG=$$P(IBFLINE,6),IBBEG=$$STRIP(IBBEG) ; start date
16 S IBEND=$$P(IBFLINE,7),IBEND=$$STRIP(IBEND) ; end date
17 ;
18 S LINE=IBDRG_U_IBSNS_U_IBRB_U_IBANC_U_IBBEG_U_IBEND S IBXIFN=$$SET(IBFILE,IBXTMP,LINE)
19 ;
20 Q
21 ;
22B ; Inpatient Facility Area Factors: process a single line, parse out into individual fields and store in XTMP
23 N IBSITE,IBNAME,IBSRB,IBSAN,IBNRB,IBNAN,IBSNF,IBBEG,IBEND,LINE,IBXIFN,IBXTMP S IBXTMP="IBCR RC B"
24 ;
25 S IBSITE=$$P(IBFLINE,1),IBSITE=$$STRIP(IBSITE) Q:IBSITE'?3N.UN ; site
26 S IBNAME=$$P(IBFLINE,2) ; facility name
27 S IBSRB=$$P(IBFLINE,3),IBSRB=$$STRIP(IBSRB) ; surgical room&board
28 S IBSAN=$$P(IBFLINE,4),IBSAN=$$STRIP(IBSAN) ; surgical ancillary
29 S IBNRB=$$P(IBFLINE,5),IBNRB=$$STRIP(IBNRB) ; non-surgical room&board
30 S IBNAN=$$P(IBFLINE,6),IBNAN=$$STRIP(IBNAN) ; non-surgical ancillary
31 S IBSNF=$$P(IBFLINE,7),IBSNF=$$STRIP(IBSNF) ; skilled nursing
32 S IBBEG=$$P(IBFLINE,8),IBBEG=$$STRIP(IBBEG) ; start date
33 S IBEND=$$P(IBFLINE,9),IBEND=$$STRIP(IBEND) ; end date
34 ;
35 S LINE=IBSITE_U_IBSRB_U_IBSAN_U_IBNRB_U_IBNAN_U_IBSNF_U_IBBEG_U_IBEND
36 S IBXIFN=$$SET(IBFILE,IBXTMP,LINE) D SETSITE(IBXTMP,IBXIFN,IBSITE,IBNAME)
37 ;
38 Q
39 ;
40C ; Outpatient Facility CPT Charges: process a single line, parse out into individual fields and store in XTMP
41 N IBCPT,IBCHG,IBBEG,IBEND,IBLMT,LINE,IBXIFN,IBXTMP S IBXTMP="IBCR RC C"
42 ;
43 S IBCPT=$$P(IBFLINE,1),IBCPT=$$STRIP(IBCPT) I IBCPT'?5NU Q ; CPT
44 S IBCHG=$$P(IBFLINE,2),IBCHG=$$STRIP(IBCHG) ; charge
45 S IBBEG=$$P(IBFLINE,3),IBBEG=$$STRIP(IBBEG) ; start date
46 S IBEND=$$P(IBFLINE,4),IBEND=$$STRIP(IBEND) ; end date
47 S IBLMT=$$P(IBFLINE,5),IBLMT=$$STRIP(IBLMT) ; site limited flag
48 ;
49 S LINE=IBCPT_U_IBCHG_U_IBBEG_U_IBEND_U_IBLMT S IBXIFN=$$SET(IBFILE,IBXTMP,LINE)
50 ;
51 Q
52 ;
53D ; Outpatient Facility Area Factors: process a single line, parse out into individual fields and store in XTMP
54 N IBSITE,IBNAME,IBAF,IBBEG,IBEND,IBZIP,IBLMT,LINE,IBXIFN,IBXTMP S IBXTMP="IBCR RC D"
55 ;
56 S IBSITE=$$P(IBFLINE,1),IBSITE=$$STRIP(IBSITE) Q:IBSITE'?3N.UN ; site
57 S IBNAME=$$P(IBFLINE,2) ; facility name
58 S IBAF=$$P(IBFLINE,3),IBAF=$$STRIP(IBAF) ; area factor
59 S IBBEG=$$P(IBFLINE,4),IBBEG=$$STRIP(IBBEG) ; start date
60 S IBEND=$$P(IBFLINE,5),IBEND=$$STRIP(IBEND) ; end date
61 S IBZIP=$$P(IBFLINE,6),IBZIP=$$STRIP(IBZIP) ; 3-digit zip
62 S IBLMT=$$P(IBFLINE,7),IBLMT=$$STRIP(IBLMT) ; site limited flag
63 ;
64 S LINE=IBSITE_U_IBAF_U_IBBEG_U_IBEND_U_IBLMT
65 S IBXIFN=$$SET(IBFILE,IBXTMP,LINE) D SETSITE(IBXTMP,IBXIFN,IBSITE,IBNAME,IBZIP)
66 ;
67 Q
68 ;
69E ; Physician CPT Charges: process a single line, parse out into individual fields and store in XTMP
70 N IBCPT,IBMOD,IBDESC,IBCG,IBWE,IBPE,IBCV,IBBEG,IBEND,LINE,IBXIFN,IBXTMP S IBXTMP="IBCR RC E"
71 ;
72 S IBCPT=$$P(IBFLINE,1),IBCPT=$$STRIP(IBCPT) I IBCPT'?5NU Q ; CPT
73 S IBMOD="" ;IBMOD=$$P(IBFLINE,2),IBMOD=$$STRIP(IBMOD),IBMOD=$S('IBMOD:"",1:IBMOD) ; modifier
74 S IBDESC=$$P(IBFLINE,3) ; description
75 S IBCG=$$P(IBFLINE,4) ; code group
76 S IBWE=$$P(IBFLINE,5),IBWE=$$STRIP(IBWE) ; work expense
77 S IBPE=$$P(IBFLINE,6),IBPE=$$STRIP(IBPE) ; practice expense
78 S IBCV=$$P(IBFLINE,7),IBCV=$$STRIP(IBCV) ; conversion factor
79 S IBBEG=$$P(IBFLINE,8),IBBEG=$$STRIP(IBBEG) ; start date
80 S IBEND=$$P(IBFLINE,9),IBEND=$$STRIP(IBEND) ; end date
81 ;
82 S LINE=IBCPT_U_IBMOD_U_IBWE_U_IBPE_U_IBCG_U_IBCV_U_IBBEG_U_IBEND S IBXIFN=$$SET(IBFILE,IBXTMP,LINE)
83 ;
84 Q
85 ;
86F ; Physician CPT Charges (A&P): process a single line, parse out into individual fields and store in XTMP
87 N IBCPT,IBMOD,IBDESC,IBCG,IBCHG,IBBEG,IBEND,LINE,IBXIFN,IBXTMP S IBXTMP="IBCR RC F"
88 ;
89 S IBCPT=$$P(IBFLINE,1),IBCPT=$$STRIP(IBCPT) I IBCPT'?5NU Q ; CPT
90 S IBMOD="" ;IBMOD=$$P(IBFLINE,2),IBMOD=$$STRIP(IBMOD),IBMOD=$S('IBMOD:"",1:IBMOD) ; modifier
91 S IBDESC=$$P(IBFLINE,3) ; description
92 S IBCG=$$P(IBFLINE,4) ; code group
93 S IBCHG=$$P(IBFLINE,5),IBCHG=$$STRIP(IBCHG) ; average charge
94 S IBBEG=$$P(IBFLINE,6),IBBEG=$$STRIP(IBBEG) ; start date
95 S IBEND=$$P(IBFLINE,7),IBEND=$$STRIP(IBEND) ; end date
96 ;
97 S LINE=IBCPT_U_IBMOD_U_IBCHG_U_IBCG_U_IBBEG_U_IBEND S IBXIFN=$$SET(IBFILE,IBXTMP,LINE)
98 ;
99 Q
100 ;
101G ; Physician CPT Charges (ET): process a single line, parse out into individual fields and store in XTMP
102 N IBCPT,IBMOD,IBDESC,IBCG,IBTRVU,IBCV,IBBEG,IBEND,LINE,IBXIFN,IBXTMP S IBXTMP="IBCR RC G"
103 ;
104 S IBCPT=$$P(IBFLINE,1),IBCPT=$$STRIP(IBCPT) I IBCPT'?5NU Q ; CPT
105 S IBMOD="" ;IBMOD=$$P(IBFLINE,2),IBMOD=$$STRIP(IBMOD),IBMOD=$S('IBMOD:"",1:IBMOD) ; modifier
106 S IBDESC=$$P(IBFLINE,3) ; description
107 S IBCG=$$P(IBFLINE,4) ; code group
108 S IBTRVU=$$P(IBFLINE,5),IBTRVU=$$STRIP(IBTRVU) ; total rvu
109 S IBCV=$$P(IBFLINE,6),IBCV=$$STRIP(IBCV) ; conversion factor
110 S IBBEG=$$P(IBFLINE,7),IBBEG=$$STRIP(IBBEG) ; start date
111 S IBEND=$$P(IBFLINE,8),IBEND=$$STRIP(IBEND) ; end date
112 ;
113 S LINE=IBCPT_U_IBMOD_U_IBTRVU_U_IBCG_U_IBCV_U_IBBEG_U_IBEND S IBXIFN=$$SET(IBFILE,IBXTMP,LINE)
114 ;
115 Q
116 ;
117H ; Physician Area Factors: process a single line, parse out into individual fields and store in XTMP
118 N IBSITE,IBNAME,IBWA,IBWE,IBPE,IBBEG,IBEND,IBZIP,IBX,IBK,LINE,LINE2,IBXIFN,IBXTMP S IBXTMP="IBCR RC H"
119 ;
120 S IBSITE=$$P(IBFLINE,1),IBSITE=$$STRIP(IBSITE) Q:IBSITE'?3N.UN ; site
121 S IBNAME=$$P(IBFLINE,2) ; facility name
122 S IBWA=$$P(IBFLINE,3),IBWA=$$STRIP(IBWA) ; work adjuster
123 S IBWE=$$P(IBFLINE,4),IBWE=$$STRIP(IBWE) ; work expense
124 S IBPE=$$P(IBFLINE,5),IBPE=$$STRIP(IBPE) ; practice expense
125 S IBBEG=$$P(IBFLINE,30),IBBEG=$$STRIP(IBBEG) ; start date
126 S IBEND=$$P(IBFLINE,31),IBEND=$$STRIP(IBEND) ; end date
127 S IBZIP=$$P(IBFLINE,32),IBZIP=$$STRIP(IBZIP) ; 3-digit zip
128 ;
129 S LINE2="" F IBK=6:1:29 S IBX=$$P(IBFLINE,IBK),IBX=$$STRIP(IBX),LINE2=LINE2_IBX_U
130 ;
131 S LINE=IBSITE_U_IBWA_U_IBWE_U_IBPE_U_IBBEG_U_IBEND
132 S IBXIFN=$$SET(IBFILE,IBXTMP,LINE) D SET1(IBXTMP,IBXIFN,"BC",LINE2),SETSITE(IBXTMP,IBXIFN,IBSITE,IBNAME,IBZIP)
133 ;
134 Q
135 ;
136I ; Physician Unit Area Factors: process a single line, parse out into individual fields and store in XTMP
137 N IBSITE,IBNAME,IBAF,IBBEG,IBEND,IBZIP,LINE,IBXIFN,IBXTMP S IBXTMP="IBCR RC I"
138 ;
139 S IBSITE=$$P(IBFLINE,1),IBSITE=$$STRIP(IBSITE) Q:IBSITE'?3N.UN ; site
140 S IBNAME=$$P(IBFLINE,2) ; facility name
141 S IBAF=$$P(IBFLINE,3),IBAF=$$STRIP(IBAF) ; area factor
142 S IBBEG=$$P(IBFLINE,4),IBBEG=$$STRIP(IBBEG) ; start date
143 S IBEND=$$P(IBFLINE,5),IBEND=$$STRIP(IBEND) ; end date
144 S IBZIP=$$P(IBFLINE,6),IBZIP=$$STRIP(IBZIP) ; 3-digit zip
145 ;
146 S LINE=IBSITE_U_IBAF_U_IBBEG_U_IBEND
147 S IBXIFN=$$SET(IBFILE,IBXTMP,LINE) D SETSITE(IBXTMP,IBXIFN,IBSITE,IBNAME,IBZIP)
148 ;
149 Q
150 ;
151SETHDR(IBFILE,IBXRF1) ; set up header for XTMP file
152 ;
153 N IBX S IBX=IBFILE_" RC v"_$G(VERS)_" Host File Upload, "_$P($$HTE^XLFDT($H,2),":",1,2)_" by "_$P($G(^VA(200,+$G(DUZ),0)),U,1)
154 S ^XTMP(IBXRF1,0)=$$FMADD^XLFDT(DT,2)_U_DT_U_IBX_U_0_U_0
155 I IBXRF1="IBCR RC SITE" S ^XTMP(IBXRF1,"VERSION")=$G(VERS),^XTMP(IBXRF1,"VERSION INACTIVE")=$$VERSEDT^IBCRHBRV($G(VERS))
156 Q
157 ;
158SET(IBFILE,IBXRF1,LINE) ; set data parsed from host file to XTMP
159 N IBX,IBK
160 S IBX=$G(^XTMP(IBXRF1,0)) I IBX="" D SETHDR(IBFILE,IBXRF1)
161 S IBK=+$P(IBX,U,5)+1,$P(^XTMP(IBXRF1,0),U,5)=IBK
162 S ^XTMP(IBXRF1,IBK)=LINE
163 Q IBK
164 ;
165SET1(IBXRF1,IBXIFN,IBXRF3,LINE) ; set data parsed from host file to XTMP, second line
166 ;
167 S ^XTMP(IBXRF1,IBXIFN,IBXRF3)=LINE
168 Q
169 ;
170SETSITE(IBXTMP,IBXIFN,SITE,NAME,ZIP) ; set up site file and xref
171 ;
172 N IBX,IBK,IBI,IBXRF1,IBJ I SITE=""!(NAME="") Q
173 S IBXRF1="IBCR RC SITE" S ZIP=$G(ZIP) I ZIP'?3N S ZIP=""
174 S IBX=$G(^XTMP(IBXRF1,0)) I IBX="" D SETHDR("RC SITE LIST",IBXRF1)
175 ;
176 S IBK=0 F S IBK=$O(^XTMP(IBXRF1,"B",NAME,IBK)) Q:'IBK S IBX=$G(^XTMP(IBXRF1,IBK)) I $P(IBX,U,1)=SITE Q
177 ;
178 I +IBK,ZIP'="" S IBX=$G(^XTMP(IBXRF1,IBK)) D
179 . I $P(IBX,U,3)'="",$P(IBX,U,3)'=ZIP W !,?10,"SITE ERROR: ",IBX,"--",ZIP S IBK=0 Q
180 . S $P(^XTMP(IBXRF1,IBK),U,3)=ZIP
181 . S IBI="ZC "_ZIP S ^XTMP(IBXRF1,"B",IBI,IBK)=""
182 ;
183 I 'IBK D
184 . S IBK=$P(^XTMP(IBXRF1,0),U,5)+1,$P(^XTMP(IBXRF1,0),U,5)=IBK
185 . S ^XTMP(IBXRF1,IBK)=SITE_U_NAME_U_ZIP
186 . ;
187 . I NAME'="" S IBI=NAME S ^XTMP(IBXRF1,"B",IBI,IBK)=""
188 . I ZIP'="" S IBI="ZC "_ZIP S ^XTMP(IBXRF1,"B",IBI,IBK)=""
189 . I SITE'="" S IBI=SITE_" " S ^XTMP(IBXRF1,"B",IBI,IBK)="",^XTMP(IBXRF1,"C",IBI,IBK)=""
190 ;
191 S ^XTMP(IBXRF1,IBK,IBXTMP)=IBXIFN
192 Q
193 ;
194 ;
195STRIP(IBVAL) ; strip blanks, $, and commas
196 N IBI,IBY,IBX S IBY=""
197 F IBI=1:1:200 S IBX=$E(IBVAL,IBI) Q:IBX="" I IBX'=" ",IBX'=",",IBX'="$" S IBY=IBY_IBX
198 Q IBY
199 ;
200 ;
201P(LINE,P) ; parse the line and return the piece requested (replaces $P since may be two dilimiters)
202 ; the pieces are delimited by a comma, any piece that includes a comma within the text is surrounded by quotes
203 N I,U1,U2,PC S U1=",",U2="""",PC=""
204 ;
205 F I=1:1:P D
206 . I $E(LINE)=U2 S LINE=$E(LINE,2,9999),PC=$P(LINE,U2,1),LINE=$P(LINE,U2_U1,2,9999) Q
207 . ;
208 . S PC=$P(LINE,U1,1),LINE=$P(LINE,U1,2,9999)
209 ;
210 Q PC
Note: See TracBrowser for help on using the repository browser.