source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICD1831A.m@ 731

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

initial load of FOIAVistA 6/30/08 version
File size: 9.4 KB
Line 
1ICD1831A ;ALB/RBS - FY 2008 DRG UPDATE ; 11/13/07 3:37pm
2 ;;18.0;DRG Grouper;**31**;Oct 13, 2000;Build 7
3 ;
4 ;Update the (#80.2) DRG file with FY 2008 DRG Grouper MS-DRG codes.
5 ;The last DRG code filed for FY 2007 was DRG579.
6 ;
7 Q
8 ;
9 ;Routines ICD1831* contain each FY 2008 MS-DRG code update values
10 ;in a line of text delimited by up-arrow "^".
11 ; $TEXT line field names
12 ; MS-DRG^MDC^TYPE^MS-DRG TITLE^WEIGHTS^GEOMETRIC MEAN LOS^
13 ; routine MS-DRG codes
14 ; ICD1831B - 1 to 168
15 ; ICD1831C - 175 to 329
16 ; ICD1831D - 330 to 480
17 ; ICD1831E - 481 to 639
18 ; ICD1831F - 640 to 809
19 ; ICD1831G - 810 to 999
20 ;
21 ;The following nodes/fields will be updated or created:
22 ; .001 NUMBER (same as DRG Number)
23 ; 0 node - .01 NAME (composed of prefix "DRG"_Number... DRG579)
24 ; 5 MDC#
25 ; .06 SURGERY
26 ; 1 node - #1 DESCRIPTION *** don't update existing records ***
27 ; 80.21A, .01 DESCRIPTION Multiple
28 ; 2 node - #71 DRG GROUPER EFFECIVE DATE
29 ; 80.271D, .01 DRG GROUPER EFFECIVE DATE
30 ; 1 REFERENCE - MUMPS Routine name
31 ; 66 node - #66 EFFECTIVE DATE
32 ; 80.266D, .01 EFFECTIVE DATE
33 ; .03 STATUS
34 ; .05 MDC#
35 ; .06 SURGERY
36 ; 68 node - #68 DESCRIPTION (VERSIONED)
37 ; 80.268D, .01 EFFECTIVE DATE
38 ; 1 DESCRIPTION
39 ; 80.2681, .01 DESCRIPTION
40 ; "FY" node - #20 FISCAL YEAR WEIGHTS&TRIM
41 ; 80.22D, .01 FISCAL YEAR WEIGHTS&TRIMS
42 ; 2 WEIGHT
43 ; 3 LOW TRIM(days)
44 ; 4 HIGH TRIM(days)
45 ; 4.5 AVG LENGTH OF STAY(days)
46 ;
47DRG ;post-install driver (#80.2) DRG updates
48 ;This procedure calls a series of routines that contain the data
49 ;element values used to create the FY 2008 MS-DRG updates.
50 ; Input:
51 ; ICDTMP - Temp file of error msg's
52 ; ICDTOT - Total MS-DRG codes filed
53 ; Output:
54 ; ICDTMP - Temp file of error msg's
55 ; ICDTOT - Total MS-DRG codes filed
56 ;
57 D BMES^XPDUTL(">>> Adding FY 2008 DRG Grouper updates to (#80.2) DRG file...")
58 N ICDRTN,ICDI,ICDSUB,ICDEDIT,ICDADD
59 S (ICDEDIT,ICDADD)=0
60 S ICDTOT=$G(ICDTOT) I ICDTOT']"" S ICDTOT=0
61 S ICDTMP=$G(ICDTMP)
62 I ICDTMP']"" S ICDTMP=$NA(^TMP("DRGFY2008",$J)) D
63 . K @ICDTMP
64 . S @ICDTMP@(0)="PATCH FY 2008 DRG UPDATE^"_$$NOW^XLFDT
65 ;
66 ;loop each sub-routine
67 S ICDSUB="BCDEFG"
68 F ICDI=1:1:6 S ICDRTN="^ICD1831"_$E(ICDSUB,ICDI) D
69 . Q:($T(@ICDRTN)="")
70 . D GETDRG(ICDRTN,ICDTMP,.ICDTOT,.ICDEDIT,.ICDADD)
71 ;
72 I '$D(@ICDTMP@("ERROR")) D
73 . D MES^XPDUTL(">>> DRG Updates Completed...")
74 . D MES^XPDUTL(" ...Total Codes Edited: "_ICDEDIT)
75 . D MES^XPDUTL(" ...Total Codes Added: "_ICDADD)
76 . D MES^XPDUTL(" ................Total: "_ICDTOT)
77 . D MES^XPDUTL("")
78 Q
79 ;
80GETDRG(ICDRTN,ICDTMP,ICDTOT,ICDEDIT,ICDADD) ;get and file MS-DRG data
81 ; Input:
82 ; ICDRTN - Post Install routine to process MS-DRG codes
83 ; ICDTMP - Temp file of error msg's
84 ; ICDTOT - Total MS-DRG codes filed
85 ; Output:
86 ; ICDTMP - Temp file of error msg's
87 ; ICDTOT - Total MS-DRG codes filed
88 ;
89 N ICDLN,ICDLINE,ICDTAG,ICDDRG,ICDTEXT
90 ;
91 F ICDLN=1:1 S ICDTAG="MSDRG+"_ICDLN_ICDRTN,ICDTEXT=$T(@ICDTAG) S ICDLINE=$P(ICDTEXT,";;",2) Q:ICDLINE="EXIT" D
92 . ; check if DRG exists or is a new one
93 . I $D(^ICD(+$P(+ICDLINE,U),0)) D EDITDRG(ICDLINE,ICDTMP,.ICDTOT,.ICDEDIT)
94 . E D NEWDRG(ICDLINE,ICDTMP,.ICDTOT,.ICDADD)
95 Q
96 ;
97EDITDRG(ICDLINE,ICDTMP,ICDTOT,ICDEDIT) ; edit existing (#80.2) DRG record
98 ; Input:
99 ; ICDLINE - $TEXT line of MS-DRG code data
100 ; ICDTMP - Temp file of error msg's
101 ; ICDTOT - Total MS-DRG codes filed
102 ; Output:
103 ; ICDTMP - Temp file of error msg's
104 ; ICDTOT - Total MS-DRG codes filed
105 ;
106 N X,Y,DA,DIE,DR,ICDDRG,ICDDESC,ICDMDC,ICDSURG,ICDFDA,ICDFY,ICDERR,ICDREF
107 ;
108 S ICDFY=3071001
109 S ICDDRG=+$P(ICDLINE,U)
110 S ICDDESC=$P(ICDLINE,U,4)
111 I '$D(^ICD(ICDDRG,0)) D Q
112 . S @ICDTMP@("ERROR",ICDDRG,0)="MISSING (#80.2) DRG FILE RECORD"
113 ;
114 ; check if already done in case patch being re-installed
115 Q:$D(^ICD(ICDDRG,66,"B",ICDFY))
116 ;
117 ;-- 80.271D subfile - #71 DRG GROUPER EFFECIVE DATE
118 ;S ICDREF="ICDTLB6D" ;*** REFERENCE routine not defined yet ???
119 ;S ICDREF="" ;*** ECF commented out-see next line
120 S ICDREF="ICDTBL"_$S(ICDDRG<100:"0",1:$E(ICDDRG,1)) ;ECF new line
121 D DRGEFFDT(ICDDRG,ICDFY,ICDREF,ICDTMP)
122 ;
123 ;-- 80.266D subfile - #66 EFFECTIVE DATE
124 S ICDMDC=$P(ICDLINE,U,2) S:ICDMDC="PRE" ICDMDC=98
125 I ICDMDC]"" S ICDMDC=+ICDMDC
126 S ICDSURG=$P(ICDLINE,U,3) S ICDSURG=$S(ICDSURG="SURG":1,1:0)
127 D EFFDATE(ICDDRG,ICDFY,ICDMDC,ICDSURG,ICDTMP)
128 ;
129 ;-- 80.268D subfile - #68 DESCRIPTION
130 D DESCA(ICDDRG,ICDFY,ICDTMP)
131 ;
132 ;-- 80.2681 subfile - #68 DESCRIPTION
133 D DESCB(ICDDRG,ICDFY,ICDDESC,ICDTMP)
134 ;
135 ;--80.22D subfile - #20 FISCAL YEAR WEIGHTS&TRIM
136 D WEIGHTS(ICDLINE,ICDTMP)
137 ;
138 S ICDTOT=ICDTOT+1,ICDEDIT=ICDEDIT+1
139 Q
140 ;
141NEWDRG(ICDLINE,ICDTMP,ICDTOT,ICDADD) ; add new (#80.2) DRG record
142 ; Input:
143 ; ICDLINE - $TEXT line of MS-DRG code data
144 ; ICDTMP - Temp file of error msg's
145 ; ICDTOT - Total MS-DRG codes filed
146 ; Output:
147 ; ICDTMP - Temp file of error msg's
148 ; ICDTOT - Total MS-DRG codes filed
149 ;
150 N DA,DIC,DIE,DR,X,Y
151 N ICDDRG,ICDDESC,ICDMDC,ICDSURG,ICDFDA,ICDFY,ICDERR,ICDREF,ICDIEN
152 S ICDFY=3071001
153 S ICDDRG=+$P(ICDLINE,U)
154 ; check for duplicates in case install is being rerun
155 I $D(^ICD(ICDDRG,0)) Q
156 ;
157 S ICDMDC=$P(ICDLINE,U,2) I ICDMDC="PRE" S ICDMDC=98
158 I ICDMDC]"" S ICDMDC=+ICDMDC
159 S ICDSURG=$P(ICDLINE,U,3) S ICDSURG=$S(ICDSURG="SURG":1,1:"")
160 S ICDDESC=$P(ICDLINE,U,4)
161 ;
162 ;-- #.001 NUMBER and 0 node fields
163 K ICDFDA,ICDIEN,ICDERR
164 S ICDFDA(80.2,"+1,",.01)="DRG"_ICDDRG
165 S ICDFDA(80.2,"+1,",5)=ICDMDC
166 S ICDFDA(80.2,"+1,",.06)=ICDSURG
167 S ICDIEN(1)=ICDDRG
168 D UPDATE^DIE("","ICDFDA","ICDIEN","ICDERR") K ICDFDA,ICDIEN
169 I $D(ICDERR) D K ICDERR ;*** quit here if can't setup IEN ???
170 . S @ICDTMP@("ERROR",ICDDRG,.001)="FILING TO (#.001) NUMBER FIELD"
171 ;
172 ;-- 80.21A subfile - #1 DESCRIPTION
173 K DIC,DA
174 S DA(1)=ICDDRG
175 S DIC="^ICD("_DA(1)_",1,"
176 S DIC(0)="L"
177 S X=ICDDESC
178 K DO D FILE^DICN
179 K DIC,DA
180 I Y=-1 D
181 . S @ICDTMP@("ERROR",ICDDRG,1)="FILING TO (#1) DESCRIPTION FIELD"
182 ;
183 ;-- 80.271D subfile - #71 DRG GROUPER EFFECIVE DATE
184 ;S ICDREF="ICDTLB6D" ;*** REFERENCE routine not defined yet ???
185 ;S ICDREF="" ;ECF commented out - see next line
186 S ICDREF="ICDTBL"_$S(ICDDRG<100:"0",1:$E(ICDDRG,1)) ;ECF new line
187 D DRGEFFDT(ICDDRG,ICDFY,ICDREF,ICDTMP)
188 ;
189 ;-- 80.266D subfile - #66 EFFECTIVE DATE
190 I ICDSURG="" S ICDSURG=0
191 D EFFDATE(ICDDRG,ICDFY,ICDMDC,ICDSURG,ICDTMP)
192 ;
193 ;-- 80.268D subfile - #68 DESCRIPTION
194 D DESCA(ICDDRG,ICDFY,ICDTMP)
195 ;
196 ;-- 80.2681 subfile - #68 DESCRIPTION
197 D DESCB(ICDDRG,ICDFY,ICDDESC,ICDTMP)
198 ;
199 ;-- 80.22D subfile - update weights&trims/ALOS
200 D WEIGHTS(ICDLINE,ICDTMP)
201 ;
202 S ICDTOT=ICDTOT+1,ICDADD=ICDADD+1
203 Q
204 ;
205DRGEFFDT(ICDDRG,ICDFY,ICDREF,ICDTMP) ;-- 80.271D - #71 DRG GROUPER EFFECIVE DATE
206 I '$G(ICDDRG)!'$G(ICDFY)!($G(ICDTMP)']"") Q
207 K ICDFDA,ICDERR
208 S ICDFDA(80.2,"?1,",.01)=ICDDRG
209 S ICDFDA(80.271,"+2,?1,",.01)=ICDFY
210 S ICDFDA(80.271,"+2,?1,",1)=ICDREF
211 D UPDATE^DIE("","ICDFDA","","ICDERR") K ICDFDA
212 I $D(ICDERR) D K ICDERR
213 . S @ICDTMP@("ERROR",ICDDRG,71)="FILING TO (#71) DRG GROUPER EFFECIVE DATE FIELD"
214 Q
215 ;
216EFFDATE(ICDDRG,ICDFY,ICDMDC,ICDSURG,ICDTMP) ;-- 80.266D - #66 EFFECTIVE DATE
217 I '$G(ICDDRG)!'$G(ICDFY)!($G(ICDTMP)']"") Q
218 K ICDFDA,ICDERR
219 S ICDFDA(80.2,"?1,",.01)=ICDDRG
220 S ICDFDA(80.266,"+2,?1,",.01)=ICDFY
221 S ICDFDA(80.266,"+2,?1,",.03)=1
222 S ICDFDA(80.266,"+2,?1,",.05)=ICDMDC
223 S ICDFDA(80.266,"+2,?1,",.06)=ICDSURG
224 D UPDATE^DIE("","ICDFDA","","ICDERR") K ICDFDA
225 I $D(ICDERR) D K ICDERR
226 . S @ICDTMP@("ERROR",ICDDRG,66)="FILING TO (#66) EFFECTIVE DATE FIELD"
227 Q
228 ;
229DESCA(ICDDRG,ICDFY,ICDTMP) ;-- 80.268D - #68 DESCRIPTION
230 I '$G(ICDDRG)!'$G(ICDFY)!($G(ICDTMP)']"") Q
231 K ICDFDA,ICDERR
232 S ICDFDA(80.2,"?1,",.01)=ICDDRG
233 S ICDFDA(80.268,"+2,?1,",.01)=ICDFY
234 D UPDATE^DIE("","ICDFDA","","ICDERR") K ICDFDA
235 I $D(ICDERR) D K ICDERR
236 . S @ICDTMP@("ERROR",ICDDRG,68)="FILING TO (#68) DESCRIPTION FIELD"
237 Q
238 ;
239DESCB(ICDDRG,ICDFY,ICDDESC,ICDTMP) ;-- 80.2681 - #68 DESCRIPTION
240 I '$G(ICDDRG)!'$G(ICDFY)!($G(ICDDESC)']"")!($G(ICDTMP)']"") Q
241 K ICDFDA,ICDERR
242 S ICDFDA(80.2,"?1,",.01)=ICDDRG
243 S ICDFDA(80.268,"?2,?1,",.01)=ICDFY
244 S ICDFDA(80.2681,"+3,?2,?1,",.01)=ICDDESC
245 D UPDATE^DIE("","ICDFDA","","ICDERR") K ICDFDA
246 I $D(ICDERR) D K ICDERR
247 . S @ICDTMP@("ERROR",ICDDRG,68)="FILING TO (#68) DESCRIPTION SUB-FIELD"
248 Q
249 ;
250WEIGHTS(ICDLINE,ICDTMP) ;--80.22D subfile - #20 FISCAL YEAR WEIGHTS&TRIM
251 ; Input:
252 ; ICDLINE - $TEXT line of MS-DRG code data
253 ; ICDTMP - Temp file of error msg's
254 ; Output:
255 ; ICDTMP - Temp file of error msg's
256 ;
257 I $G(ICDLINE)'[""!($G(ICDTMP)'["") Q
258 N ICDDRG,ICDWT,ICDLOS,ICDSTR,ICDX,ICDJ,ICDFYR,ICDLOW,ICDHIGH
259 S ICDFYR=3080000,ICDLOW=1,ICDHIGH=99 ; *** default Low/High ???
260 S ICDDRG=+$P(ICDLINE,U)
261 I '$D(^ICD(ICDDRG,0)) D Q
262 . S @ICDTMP@("ERROR",ICDDRG,0)="MISSING (#80.2) DRG FILE RECORD"
263 ;
264 ; check if being re-installed
265 Q:$D(^ICD(ICDDRG,"FY",ICDFYR))
266 ;
267 I ICDDRG=998!(ICDDRG=999) S (ICDLOW,ICDHIGH)=0
268 S ICDWT=$P(ICDLINE,U,5),ICDLOS=$P(ICDLINE,U,6)
269 I ICDLOS["*" S ICDLOS=0
270 S $P(ICDSTR,U)=ICDFYR,$P(ICDSTR,U,2)=ICDWT,$P(ICDSTR,U,3)=ICDLOW,$P(ICDSTR,U,4)=ICDHIGH,$P(ICDSTR,U,9)=ICDLOS
271 ;
272 S ^ICD(ICDDRG,"FY",ICDFYR,0)=ICDSTR
273 ;
274 I '$D(^ICD(ICDDRG,"FY",0)) S ^ICD(ICDDRG,"FY",0)="^80.22D^"_ICDFYR_"^1" Q
275 E D
276 . S ICDX=0 F ICDJ=0:1 S ICDX=$O(^ICD(ICDDRG,"FY",ICDX)) Q:ICDX=""
277 . S $P(^ICD(ICDDRG,"FY",0),"^",3,4)=ICDFYR_"^"_ICDJ
278 Q
Note: See TracBrowser for help on using the repository browser.