source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICD1831K.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 9.2 KB
Line 
1ICD1831K ; ALB/ECF - FY 2007 UPDATE; 10/23/07 2:50 pm;
2 ;;18.0;DRG Grouper;**31**;Oct 13,2000;Build 7
3 Q
4 ;
5DRG(ICDTMP) ;post-install driver for file ICD Operation/Procedure
6 ; file(#80.1) DRG updates
7 ;This procedure loops through the ICD OPERATION/PROCDURE file (80.1)
8 ;to create a DRG GROUPER EFFECTIVE DATE entry for FY08
9 ; Input:
10 ; ICDTMP - Temp file of error msg's
11 ; Output:
12 ; ICDTMP - Temp file of error msg's
13 ; ICDTOT - Total MS-DRG codes filed
14 ; ICDERTOT - Total error records - cannot file
15 ;
16 N ICDI,ICDCRCD,ICDFOK,ICDNWCD,ICDTOT,ICDX,ICDY,ICDVAL,ICDETOT,ICDYY,ICDZZ
17 S U="^"
18 ;
19 D BMES^XPDUTL(">>> Adding FY08 DRG Grouper updates to ICD OP/PR file (#80.1)...")
20 ;Error log
21 S ICDTMP=$G(ICDTMP)
22 I ICDTMP']"" S ICDTMP=$NA(^TMP("ICDDGFY2008OP",$J)) D
23 . K @ICDTMP
24 . S @ICDTMP@(0)="PATCH #? FY08 ICD DIAG DRG UPDATE^"_$$NOW^XLFDT
25 ;
26 ;Skip inactive
27 S (ICDETOT,ICDI,ICDTOT,ICDYY)=0
28 ;
29 F S ICDI=$O(^ICD0(ICDI)) Q:ICDI=""!(ICDI'?.N) D
30 .;quit if no zero node
31 .Q:$G(^ICD0(ICDI,0))=""
32 .;quit if zero node corrupt
33 .Q:$P($G(^ICD0(ICDI,0)),U)']""
34 .S ICDVAL=$P($G(^ICD0(ICDI,0)),U)
35 .Q:ICDVAL=""
36 .;quit if code is inactive
37 .S ICDZZ=$$ICDOP^ICDCODE(ICDVAL,3071001) Q:$P($G(ICDZZ),U,10)=0
38 .;check if already created in case patch being re-installed
39 .Q:$D(^ICD0(ICDI,2,"B",3071001))
40 .;
41 .;Get ien of latest Grouper Effective Date
42 .S ICDX=$O(^ICD0(ICDI,2,"B",9999999),-1)
43 .;No Grp Eff Dt means this is a new code
44 .I ICDX']"" D
45 ..;Call API
46 ..K ICDNCDAR
47 ..D NEW801^ICD1831L(ICDVAL,.ICDNCDAR)
48 ..Q:'$D(ICDNCDAR)
49 ..;Build code array for UPDDIAG()
50 ..K ICDCONAR
51 ..D GETNCRCD(ICDI,.ICDNCDAR,.ICDCONAR)
52 ..Q:'$D(ICDCONAR(0))
53 ..D UPDDIAG(ICDI,.ICDCONAR,.ICDTOT)
54 .;
55 .I ICDX]"" D
56 ..;Old codes to convert
57 ..;Call will be $$CONV801^ICD1831L(<ien of code>)for each MDC/DRG set
58 ..S ICDLEDI=$O(^ICD0(ICDI,2,"B",ICDX,0))
59 ..S (ICDFYMI,ICDY)=0
60 ..;Loop through MDCs for this ICD PROC - DRG EFF DATE
61 ..F S ICDFYMI=$O(^ICD0(ICDI,2,ICDLEDI,1,ICDFYMI)) Q:ICDFYMI=""!(ICDFYMI'?.N) D
62 ...K ICDNWCD,ICDNWCDA
63 ...S ICDDGCD=$$GETCRCD(ICDI,ICDLEDI,ICDFYMI) ;Build code string for conversion API
64 ...;If no code string for this MDC, nothing to convert
65 ...Q:ICDDGCD']""
66 ...;Code string is ok, pass to conversion function
67 ...S ICDNWCD=$$CONV801^ICD1831L(ICDDGCD)
68 ...;Return codes are in string ICDCRCD <.01>^<MDC ien>^<DRG ien)^<DRG ien>.........
69 ...;Filer requires an array - at least a zero node is needed
70 ...I ICDNWCD]"" K ICDNWCDA S ICDNWCDA(0)=ICDNWCD
71 ...;Now process the array of code strings for this ICD Proc IEN
72 ...Q:ICDNWCDA(0)']""
73 ...;pass new codes to update procedure
74 ...;D UPDDIAG(ICDI,"X",.ICDNWCDA,.ICDTOT)
75 ...D UPDDIAG(ICDI,.ICDNWCDA,.ICDTOT)
76 ...K ICDNWCDA
77 .
78 ;Back to top level - processing is over - do final tasks
79 K ICDCONAR,ICDDGCD,ICDETOT,ICDFYMI,ICDNCDAR,ICDNWCDA
80 ;HANDLE ERRORS
81 ;No errors present
82 ;
83 S (ICDTOT,ICDYY)=0
84 F S ICDYY=$O(^TMP("ICDFILEOK",$J,ICDYY)) Q:ICDYY="" I ^TMP("ICDFILEOK",$J,ICDYY)=1 S ICDTOT=ICDTOT+1
85 I '$D(@ICDTMP@("ERROR")) D
86 . D MES^XPDUTL(">>> ICD PROCEDURE File DRG Updates Completed...")
87 . D MES^XPDUTL(" ...Total Codes Edited: "_ICDTOT)
88 . D MES^XPDUTL("")
89 Q
90 ;Errors present
91 ;
92 I $D(@ICDTMP@("ERROR")) D
93 . F S ICDXX=$O(^TMP("ICDDGFY2008OP",$J,"ERROR",ICDXX)) Q:ICDXX="" D
94 ..S ICDETOT=ICDETOT+1
95 . D MES^XPDUTL(">>> ...Total Errors "_ICDETOT_" ERRORS")
96 . D MES^XPDUTL("")
97 . D MES^XPDUTL("Error are in ^TMP(""ICDDGFY2008OP"",$J)")
98 ;
99 K ICDCRCD,ICDVAL,ICDZZ
100 K ^TMP("ICDFILEOK")
101 Q
102 ;
103 ;END OF DRIVER
104 ;Start of helper functions and procedures
105 ;
106GETCRCD(ICDIEN,ICDDGIEN,ICDMDIEN) ;
107 ;Create input string for conversion API - only for non-New DRGs
108 ;
109 ;INPUT ICDIEN = ien in file 80.1 ICD OPERATION/PROCEDURE
110 ; ICDDGIEN = ien of last DRG GROUPER EFFECTIVE DATE
111 ; ICDMDIEN = ien of Major Diagnostic Category
112 ;OUTPUT ICDCRDCS = string of codes formatted for API
113 ;
114 N ICDCRCDS,ICDXS
115 ;
116 S (ICDCRCD)=""
117 S (ICDX)=0
118 ;
119 ;START STRING WITH THE .01 FIELD
120 S ICDCRCDS=$P(^ICD0(ICDI,0),U)
121 ;
122 ;Add MDC ien to string
123 S ICDCRCDS=ICDCRCDS_"^"_$P($G(^ICD0(ICDIEN,2,ICDDGIEN,1,ICDMDIEN,0)),U)
124 ;
125 ;Loop thru DRGs this ICD procedure, this eff date, this MDC
126 ;
127 F S ICDX=$O(^ICD0(ICDIEN,2,ICDDGIEN,1,ICDMDIEN,1,ICDX)) Q:ICDX=""!(ICDX'?.N) D
128 .Q:$G(^ICD0(ICDIEN,2,ICDDGIEN,1,ICDMDIEN,1,ICDX,0))=""
129 .S ICDCRCDS=ICDCRCDS_"^"_$P($G(^ICD0(ICDIEN,2,ICDDGIEN,1,ICDMDIEN,1,ICDX,0)),U)
130 Q ICDCRCDS
131 ;
132GETNCRCD(ICDIENP,ICDOAR,ICDCAR) ;
133 ;Quit if input not correct, passing back a null zero node
134 I '$D(ICDIENP) S ICDCAR(0)="" Q
135 ;
136 N ICDK,ICDJ,ICDL
137 S (ICDJ,ICDK,ICDL)=0
138 F S ICDJ=$O(ICDOAR(ICDJ)) Q:ICDJ="" D
139 .S ICDCAR(ICDL)=ICDIENP_"^"_ICDJ_"^"
140 .F S ICDK=$O(ICDOAR(ICDJ,ICDK)) Q:ICDK="" D
141 ..S ICDCAR(ICDL)=ICDCAR(ICDL)_ICDK_"^"
142 .S ICDL=ICDL+1
143 Q
144 ;
145 ;
146UPDDIAG(ICDIP,ICDNWCDA,ICDTOTP) ;
147 ;File 80.1 updater
148 ;
149 N ICDX1
150 ; F ICDZ=1:1:3 I $P(ICDIAGP,U,ICDZ)']"" D Q
151 ; .S @ICDTMP@("ERROR",ICDIP,"80.1")="Missing field "_ICDZ_" filing "_ICDIAGP
152 ;
153 ;Quit if complete data not passed
154 Q:'$D(ICDIP)
155 Q:'$D(ICDNWCDA(0))
156 Q:$P($G(ICDNWCDA(0)),U,1)']""
157 Q:$P($G(ICDNWCDA(0)),U,2)']""
158 Q:$P($G(ICDNWCDA(0)),U,3)']""
159 ;
160 S ^TMP("ICDFILEOK",$J,ICDIP)=1
161 ;
162 K FDA(1831)
163 ;
164 ;Passed in array will trigger DRG Effective Date Multiple ONLY IF NEEDED
165 ;
166 I '$D(^ICD0(ICDIP,2,"B",3071001)) D
167 .;DRG GROUPER EFFECTIVE DATE MULTIPLE
168 .S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
169 .S FDA(1831,80.171,"+2,?1,",.01)=3071001
170 .D UPDATE^DIE("","FDA(1831)")
171 .K FDA(1831)
172 ;
173 S ICDX1=""
174 ;
175 F S ICDX1=$O(ICDNWCDA(ICDX1)) Q:ICDX1="" D
176 .;ADD MDC MULTIPLE only if there are DRG codes for the MDC
177 .I $P(ICDNWCDA(ICDX1),U,2)]"" D K FDA
178 ..Q:$P(ICDNWCDA(ICDX1),U,3)']""
179 ..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
180 ..S FDA(1831,80.171,"?2,?1,",.01)=3071001
181 ..S FDA(1831,80.1711,"+3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
182 ..D UPDATE^DIE("","FDA(1831)")
183 .K FDA(1831)
184 .;
185 .;ADD DRG MULTIPLES - first code in Piece 3
186 .I $P(ICDNWCDA(ICDX1),U,3)]"" D
187 ..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
188 ..S FDA(1831,80.171,"?2,?1,",.01)=3071001
189 ..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
190 ..S FDA(1831,80.17111,"+4,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,3)
191 ..D UPDATE^DIE("","FDA(1831)")
192 .K FDA(1831)
193 .;
194 .;ADD DRG MULTIPLES - second code in piece 4
195 .I $P(ICDNWCDA(ICDX1),U,4)]"" D
196 ..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
197 ..S FDA(1831,80.171,"?2,?1,",.01)=3071001
198 ..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
199 ..S FDA(1831,80.17111,"+5,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,4)
200 ..D UPDATE^DIE("","FDA(1831)")
201 .K FDA(1831)
202 .;
203 .I $P(ICDNWCDA(ICDX1),U,5)]"" D
204 ..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
205 ..S FDA(1831,80.171,"?2,?1,",.01)=3071001
206 ..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
207 ..S FDA(1831,80.17111,"+6,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,5)
208 ..D UPDATE^DIE("","FDA(1831)")
209 .K FDA(1831)
210 .;
211 .I $P(ICDNWCDA(ICDX1),U,6)]"" D
212 ..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
213 ..S FDA(1831,80.171,"?2,?1,",.01)=3071001
214 ..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
215 ..S FDA(1831,80.17111,"+7,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,6)
216 ..D UPDATE^DIE("","FDA(1831)")
217 .K FDA(1831)
218 .;
219 .I $P(ICDNWCDA(ICDX1),U,7)]"" D
220 ..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
221 ..S FDA(1831,80.171,"?2,?1,",.01)=3071001
222 ..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
223 ..S FDA(1831,80.17111,"+8,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,7)
224 ..D UPDATE^DIE("","FDA(1831)")
225 .K FDA(1831)
226 .;
227 .I $P(ICDNWCDA(ICDX1),U,8)]"" D
228 ..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
229 ..S FDA(1831,80.171,"?2,?1,",.01)=3071001
230 ..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
231 ..S FDA(1831,80.17111,"+9,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,8)
232 ..D UPDATE^DIE("","FDA(1831)")
233 .K FDA(1831)
234 .;
235 .I $P(ICDNWCDA(ICDX1),U,9)]"" D
236 ..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
237 ..S FDA(1831,80.171,"?2,?1,",.01)=3071001
238 ..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
239 ..S FDA(1831,80.17111,"+10,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,9)
240 ..D UPDATE^DIE("","FDA(1831)")
241 .K FDA(1831)
242 .;
243 .I $P(ICDNWCDA(ICDX1),U,10)]"" D
244 ..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
245 ..S FDA(1831,80.171,"?2,?1,",.01)=3071001
246 ..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
247 ..S FDA(1831,80.17111,"+11,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,10)
248 ..D UPDATE^DIE("","FDA(1831)")
249 .K FDA(1831)
250 .;
251 .I $P(ICDNWCDA(ICDX1),U,11)]"" D
252 ..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
253 ..S FDA(1831,80.171,"?2,?1,",.01)=3071001
254 ..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
255 ..S FDA(1831,80.17111,"+12,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,11)
256 ..D UPDATE^DIE("","FDA(1831)")
257 .K FDA(1831)
258 .;
259 .I $P(ICDNWCDA(ICDX1),U,12)]"" D
260 ..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
261 ..S FDA(1831,80.171,"?2,?1,",.01)=3071001
262 ..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
263 ..S FDA(1831,80.17111,"+13,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,12)
264 ..D UPDATE^DIE("","FDA(1831)")
265 .K FDA(1831)
266 .;
267 .I $P(ICDNWCDA(ICDX1),U,13)]"" D
268 ..S FDA(1831,80.1,"?1,",.01)="`"_ICDIP
269 ..S FDA(1831,80.171,"?2,?1,",.01)=3071001
270 ..S FDA(1831,80.1711,"?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,2)
271 ..S FDA(1831,80.17111,"+14,?3,?2,?1,",.01)=$P(ICDNWCDA(ICDX1),U,13)
272 ..D UPDATE^DIE("","FDA(1831)")
273 .K FDA(1831)
274 .;
275 .I $D(^TMP("DIERR",$J)) S @ICDTMP@("ERROR",ICDIP,"80.1")="CAN'T FILE CODES FOR IEN"_$P(ICDNWCDA(ICDX1),U)_" CODES "_$P(ICDNWCDA(ICDX1),3,99)
276 .I $D(^TMP("DIERR",$J,ICDIP)) S ^TMP("ICDFILEOK",$J,ICDIP)=0
277 Q
Note: See TracBrowser for help on using the repository browser.