source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICD1831J.m@ 1446

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

initial load of FOIAVistA 6/30/08 version

File size: 7.5 KB
Line 
1ICD1831J ; ALB/ECF - FY 2008 UPDATE; 8/27/07 14:50
2 ;;18.0;DRG Grouper;**31**;Oct 13,2000 2:30 pm;Build 7
3 Q
4 ;
5DRG(ICDTMP) ;post-install driver for file ICD Diagnosis file(#80) DRG updates
6 ;This procedure creates and files the MSv25DRG updates
7 ;
8 ; Input:
9 ; ICDTMP - Temp file of error msg's
10 ; ICDTOT - Total MS-DRG codes filed
11 ; Output:
12 ; ICDTMP - Temp file of error msg's
13 ; ICDTOT - Total MS-DRG codes filed
14 ; ICDERTOT - Total error records of type "cannot file"
15 ;
16 N ICDI,ICDCRCD,ICDNWCD,ICDTOT,ICDETOT,ICDVAL,ICDXX,ICX1,ICDZZ ; This is a rough but growing list of variables
17 S U="^"
18 S (ICDI,ICDTOT,ICDETOT)=0
19 S ICDXX=""
20 S (ICDINAC,ICDAD)=0
21 ;
22 ;ANNOUNCE PROJECT
23 ;
24 D BMES^XPDUTL(">>> Adding FY 2008 DRG Grouper updates to ICD Diagnosis file (#80)...")
25 ;
26 ;Set up reference to error log
27 ;
28 S ICDTMP=$G(ICDTMP)
29 I ICDTMP']"" S ICDTMP=$NA(^TMP("ICDDGFY2008D",$J)) D
30 . K @ICDTMP
31 . S @ICDTMP@(0)="PATCH FY 2008 ICD DIAGNOSIS DRG UPDATE^"_$$NOW^XLFDT
32 ;
33 ;LOOP THROUGH FILE 80 - PROCESS EACH ENTRY
34 ;All except inactive entries may have new DRGs
35 ;
36 F S ICDI=$O(^ICD9(ICDI)) Q:ICDI=""!(ICDI'?.N) D
37 .;quit if no zero node
38 .Q:$G(^ICD9(ICDI,0))=""
39 .;quit if zero node corrupt
40 .Q:$P($G(^ICD9(ICDI,0)),U,1)']""
41 .;quit if code is inactive
42 .;
43 .S ICDVAL=$P($G(^ICD9(ICDI,0)),U)
44 .Q:ICDVAL=""
45 .;quit if code is inactive
46 .S ICDZZ=$$ICDDX^ICDCODE(ICDVAL,3071001)
47 .Q:$P($G(ICDZZ),U,10)=0
48 .;
49 .;check if already created in case patch being re-installed
50 .S:$D(^ICD9(ICDI,3,"B",3071001)) ICDAD=ICDAD+1
51 .Q:$D(^ICD9(ICDI,3,"B",3071001))
52 .;
53 .;Capture latest set of DRG codes (80.07) and latest MDC Effective Date's MDC (80.072)
54 .;
55 .S ICDCRCD=$$GETCRCD(ICDI)
56 .Q:ICDCRCD']""
57 .;
58 .;Codes are passed to converter in string ICDCRCD <.01 field>^<MDC ien>^<DRG ien)^<DRG ien>...
59 .;Function returns one set of codes, format is <.01 field>^<MDC ien>^<DRG ien)^<DRG ien>...
60 .;If no converion values, then return format is <.01_field>_^_<mdc_ien>
61 .;
62 .S ICDNWCD=$$CONV80^ICD1831L(ICDCRCD)
63 .Q:$P($G(ICDNWCD),U,1)']""
64 .Q:$P($G(ICDNWCD),U,2)']""
65 .Q:$P($G(ICDNWCD),U,3)']""
66 .;pass new codes to update procedure
67 .;
68 .D UPDDIAG(ICDI,ICDNWCD,ICDTMP,.ICDTOT)
69 ;
70 ;
71 ;HANDLE ERRORS
72 ;No errors present
73 ;
74 I '$D(@ICDTMP@("ERROR")) D
75 . D MES^XPDUTL(">>> ICD PROCEDURE File DRG Updates Completed...")
76 . D MES^XPDUTL(" ...Total Codes Edited: "_ICDTOT)
77 . D MES^XPDUTL("")
78 ;Q
79 ;Errors present
80 ;
81 I $D(@ICDTMP@("ERROR")) D
82 . F S ICDXX=$O(^TMP("ICDDGFY2008D",$J,ICDXX)) Q:ICDXX="" D
83 ..S ICDETOT=ICDETOT+1
84 . D MES^XPDUTL(">>> ...Total Errors "_ICDETOT_" ERRORS")
85 . D MES^XPDUTL("")
86 . D MES^XPDUTL("Error are in ^TMP(""ICDDGFY2008D"",$J)")
87 ;
88 K ICDCRCD,ICDVAL,ICDZZ
89 Q
90 ;
91 ;END OF DRIVER
92 ;
93 ;Start of helper functions and procedures
94 ;
95GETCRCD(ICDI) ;
96 ;INPUT ICDI = ien in file 80.1 ICD Diagnosis Codes
97 ;OUTPUT ICCRCDS = string of current DRG Codes for latest DRG Grouper Effective Date
98 ; and the latest MDC (80.072, #1)
99 ;
100 N ICDLDGED,ICDLMDED,ICDDGD2,ICDDGD3,ICDMDD1,ICDX,ICDCRCDS,ICDMDC
101 ;LAST DRG EFFECTIVE DATE, LAST MDC EFFECTIVE DATE, IEN IN DRG EF DT, IEN IN DRG
102 ;IEN IN MDC EFF DATE, STRING OF RETURN CODES, SCRATCH VARIABLE
103 ;
104 ;RETURN IEN^MDC^DRG^DRG^DRG..... (values are pointers)
105 ;
106 S (ICDMDC,ICDCRCDS)=""
107 ;
108 ;START STRING WITH THE .01 FIELD OF THE ENTRY (ICDI)
109 ;
110 S ICDCRCDS=$P(^ICD9(ICDI,0),U,1)
111 ;
112 ;NEXT GET THE MDC ATTACHED TO THE LATEST MDC EFFECTIVE DATE
113 ;
114 S ICDLMDED=$O(^ICD9(ICDI,4,"B",9999999),-1)
115 I ICDLMDED]"" D
116 .S ICDMDD1=$O(^ICD9(ICDI,4,"B",ICDLMDED,0))
117 .S ICDMDC=$P($G(^ICD9(ICDI,4,ICDMDD1,0)),U,2)
118 S ICDCRCDS=ICDCRCDS_"^"_$S((ICDMDC)]"":ICDMDC,1:"")
119 ;
120 ;THEN GET THE DRG MULTIPLE CODES
121 ;
122 S ICDLDGED=$O(^ICD9(ICDI,3,"B",9999999),-1)
123 Q:ICDLDGED="" ICDCRCDS ; new record - is active but has no DRG entries
124 S ICDDGD2=$O(^ICD9(ICDI,3,"B",ICDLDGED,0)) ;GET IEN IN DRG MULTIPLE
125 Q:$G(^ICD9(ICDI,3,ICDDGD2,1,0))']"" "" ;QUIT, SOMETHING IS WRONG
126 S ICDDGD3=0
127 F S ICDDGD3=$O(^ICD9(ICDI,3,ICDDGD2,1,ICDDGD3)) Q:ICDDGD3="" D
128 .S ICDCRCDS=ICDCRCDS_"^"_$G(^ICD9(ICDI,3,ICDDGD2,1,ICDDGD3,0))
129 Q ICDCRCDS
130 ;
131 ;
132UPDDIAG(ICDIP,ICDIAGP,ICDTMPP,ICDTOTP) ;
133 ;Add 80.071 and 80.711 records for DRG Effective Date 10/1/07
134 ;for both new and existing records
135 ;
136 ;Input ICDIP IEN in file 80
137 ; ICDIAGP DRG string from CONV80^ICD1831L function
138 ; format: <.01_field>^<mdc_ien>^<drg1_ien>^<drg2_ien>...
139 ; ICDTMPP Error tracker - ^TMP(""CDDGFY2008D",$J)
140 ; ICDTOT ICD Diagnosis Code File records sucessfully filed
141 ;
142 ;--------------------------------------------------------------------
143 ;
144 ; N ICDZ
145 ; F ICDZ=1:1:3 I $P(ICDIAGP,U,ICDZ)']"" D Q
146 ; .S @ICDTMP@("ERROR",ICDIP,68)="Missing field "_ICDZ_" filing "_ICDIAGP
147 ;
148 ;Add DRG FY08 Multiple
149 ;
150 K FDA(1831)
151 S FDA(1831,80,"?1,",.01)="`"_ICDIP
152 S FDA(1831,80.071,"+2,?1,",.01)=3071001
153 D UPDATE^DIE("","FDA(1831)")
154 K FDA(1831)
155 ;
156 I $P(ICDIAGP,U,3)]"" D
157 .S FDA(1831,80,"?1,",.01)="`"_ICDIP
158 .S FDA(1831,80.071,"?2,?1,",.01)=3071001
159 .S FDA(1831,80.711,"+3,?2,?1,",.01)=$P(ICDIAGP,U,3)
160 .D UPDATE^DIE("","FDA(1831)")
161 K FDA(1831)
162 ;
163 ;
164 I $P(ICDIAGP,U,4)]"" D
165 .S FDA(1831,80,"?1,",.01)="`"_ICDIP
166 .S FDA(1831,80.071,"?2,?1,",.01)=3071001
167 .S FDA(1831,80.711,"+4,?2,?1,",.01)=$P(ICDIAGP,U,4)
168 .D UPDATE^DIE("","FDA(1831)")
169 K FDA(1831)
170 ;
171 I $P(ICDIAGP,U,5)]"" D
172 .S FDA(1831,80,"?1,",.01)="`"_ICDIP
173 .S FDA(1831,80.071,"?2,?1,",.01)=3071001
174 .S FDA(1831,80.711,"+5,?2,?1,",.01)=$P(ICDIAGP,U,5)
175 .D UPDATE^DIE("","FDA(1831)")
176 K FDA(1831)
177 ;
178 I $P(ICDIAGP,U,6)]"" D
179 .S FDA(1831,80,"?1,",.01)="`"_ICDIP
180 .S FDA(1831,80.071,"?2,?1,",.01)=3071001
181 .S FDA(1831,80.711,"+6,?2,?1,",.01)=$P(ICDIAGP,U,6)
182 .D UPDATE^DIE("","FDA(1831)")
183 K FDA(1831)
184 ;
185 I $P(ICDIAGP,U,7)]"" D
186 .S FDA(1831,80,"?1,",.01)="`"_ICDIP
187 .S FDA(1831,80.071,"?2,?1,",.01)=3071001
188 .S FDA(1831,80.711,"+7,?2,?1,",.01)=$P(ICDIAGP,U,7)
189 .D UPDATE^DIE("","FDA(1831)")
190 K FDA(1831)
191 ;
192 ;
193 I $P(ICDIAGP,U,8)]"" D
194 .S FDA(1831,80,"?1,",.01)="`"_ICDIP
195 .S FDA(1831,80.071,"?2,?1,",.01)=3071001
196 .S FDA(1831,80.711,"+8,?2,?1,",.01)=$P(ICDIAGP,U,8)
197 .D UPDATE^DIE("","FDA(1831)")
198 K FDA(1831)
199 ;
200 I $P(ICDIAGP,U,9)]"" D
201 .S FDA(1831,80,"?1,",.01)="`"_ICDIP
202 .S FDA(1831,80.071,"?2,?1,",.01)=3071001
203 .S FDA(1831,80.711,"+9,?2,?1,",.01)=$P(ICDIAGP,U,9)
204 .D UPDATE^DIE("","FDA(1831)")
205 K FDA(1831)
206 ;
207 I $P(ICDIAGP,U,10)]"" D
208 .S FDA(1831,80,"?1,",.01)="`"_ICDIP
209 .S FDA(1831,80.071,"?2,?1,",.01)=3071001
210 .S FDA(1831,80.711,"+10,?2,?1,",.01)=$P(ICDIAGP,U,10)
211 .D UPDATE^DIE("","FDA(1831)")
212 K FDA(1831)
213 ;
214 I $P(ICDIAGP,U,11)]"" D
215 .S FDA(1831,80,"?1,",.01)="`"_ICDIP
216 .S FDA(1831,80.071,"?2,?1,",.01)=3071001
217 .S FDA(1831,80.711,"+11,?2,?1,",.01)=$P(ICDIAGP,U,11)
218 .D UPDATE^DIE("","FDA(1831)")
219 K FDA(1831)
220 ;
221 I $P(ICDIAGP,U,12)]"" D
222 .S FDA(1831,80,"?1,",.01)="`"_ICDIP
223 .S FDA(1831,80.071,"?2,?1,",.01)=3071001
224 .S FDA(1831,80.711,"+12,?2,?1,",.01)=$P(ICDIAGP,U,12)
225 .D UPDATE^DIE("","FDA(1831)")
226 K FDA(1831)
227 ;
228 I $O(^ICD9(ICDIP,4,0))="" D
229 .S FDA(1831,80,"?13,",.01)="`"_ICDIP
230 .S FDA(1831,80.072,"+14,?13,",.01)=3071001
231 .S FDA(1831,80.072,"+14,?13,",1)=$P(ICDIAGP,U,2)
232 .D UPDATE^DIE("","FDA(1831)")
233 .K FDA(1831)
234 K FDA(1831)
235 ;
236 ;for new Dx, place MDC in field #5
237 I $$GET1^DIQ(80,ICDIP_",",5,"I")="" D
238 .Q:($P(ICDIAGP,U,2)="")
239 .S FDA(1831,80,ICDIP_",",5)=$P(ICDIAGP,U,2)
240 .D FILE^DIE("","FDA(1831)")
241 .K FDA(1831)
242 ;
243 I '$D(^TMP("DIERR",$J)) S ICDTOTP=ICDTOTP+1
244 ;
245 I $D(^TMP("DIERR",$J)) D K ^TMP("DIERR",$J)
246 .S @ICDTMP@("ERROR",ICDIP,"80.1")="CANNOT FILE CODES FOR FY08 FOR IEN"_$P(ICDIAGP,U)_" CODES "_$P(ICDIAGP,3,99)
247 Q
Note: See TracBrowser for help on using the repository browser.