ICD1824N ; ALB/JAT - FY 2007 UPDATE; 7/27/05 14:50;
;;18.0;DRG Grouper;**24**;Oct 13,2000;Build 5
Q
;
DIAG ;
D BMES^XPDUTL(">>>DRG Reclassification changes")
D MES^XPDUTL(">>>Modifying diagnosis codes - file 80")
D MES^XPDUTL(">>>for new DRGs")
N LINE,X,ICDDIAG,ENTRY,FDA
F LINE=1:1 S X=$T(REVD+LINE) S ICDDIAG=$P(X,";;",2) Q:ICDDIAG="EXIT" D
.S ENTRY=+$O(^ICD9("BA",$P(ICDDIAG,U)_" ",0))
.I ENTRY D
..;check for possible inactive dupe
..I $P($G(^ICD9(ENTRY,0)),U,9)=1 S ENTRY=+$O(^ICD9("BA",$P(ICDDIAG,U)_" ",ENTRY)) I 'ENTRY Q
..;check if already created in case patch being re-installed
..Q:$D(^ICD9(ENTRY,3,"B",3061001))
..; add 80.071 and 80.711 records
..S FDA(1820,80,"?1,",.01)="`"_ENTRY
..S FDA(1820,80.071,"+2,?1,",.01)=3061001
..D UPDATE^DIE("","FDA(1820)") K FDA(1820)
..S FDA(1820,80,"?1,",.01)="`"_ENTRY
..S FDA(1820,80.071,"?2,?1,",.01)=3061001
..S FDA(1820,80.711,"+3,?2,?1,",.01)=$P(ICDDIAG,U,2)
..I $P(ICDDIAG,U,3) S FDA(1820,80.711,"+4,?2,?1,",.01)=$P(ICDDIAG,U,3)
..I $P(ICDDIAG,U,4) S FDA(1820,80.711,"+5,?2,?1,",.01)=$P(ICDDIAG,U,4)
..D UPDATE^DIE("","FDA(1820)") K FDA(1820)
Q
REVD ;
;;100.81^561^
;;100.89^561^
;;112.83^561^489
;;114.2^561^489
;;115.01^561^489
;;115.11^561^489
;;115.91^561^489
;;320.0^560^
;;320.1^560^
;;320.2^560^
;;320.3^560^
;;320.7^560^
;;320.9^560^
;;321.1^561^
;;321.2^561^
;;321.3^561^
;;321.4^561^
;;321.8^561^
;;322.1^561^
;;322.2^561^
;;322.9^561^
;;323.1^561^
;;323.2^561^
;;323.9^561^489
;;324.1^560^
;;324.9^560^
;;003.21^560^489
;;006.5^561^
;;013.00^560^489
;;013.01^560^489
;;013.02^560^489
;;013.03^560^489
;;013.04^560^489
;;013.05^560^489
;;013.06^560^489
;;013.10^560^489
;;013.11^560^489
;;013.12^560^489
;;013.13^560^489
;;013.14^560^489
;;013.15^560^489
;;013.16^560^489
;;013.20^560^489
;;013.21^560^489
;;013.22^560^489
;;013.23^560^489
;;013.24^560^489
;;013.25^560^489
;;013.26^560^489
;;013.30^560^489
;;013.31^560^489
;;013.32^560^489
;;013.33^560^489
;;013.34^560^489
;;013.35^560^489
;;013.36^560^489
;;013.40^560^489
;;013.41^560^489
;;013.42^560^489
;;013.43^560^489
;;013.44^560^489
;;013.45^560^489
;;013.46^560^489
;;013.50^560^489
;;013.51^560^489
;;013.52^560^489
;;013.53^560^489
;;013.54^560^489
;;013.55^560^489
;;013.56^560^489
;;013.60^560^489
;;013.61^560^489
;;013.62^560^489
;;013.63^560^489
;;013.64^560^489
;;013.65^560^489
;;013.66^560^489
;;013.80^560^489
;;013.81^560^489
;;013.82^560^489
;;013.83^560^489
;;013.84^560^489
;;013.85^560^489
;;013.86^560^489
;;013.90^560^489
;;013.91^560^489
;;013.92^560^489
;;013.93^560^489
;;013.94^560^
;;013.95^560^
;;013.96^560^
;;036.0^560^
;;036.1^560^
;;045.00^561^
;;045.01^561^
;;045.02^561^
;;045.03^561^
;;045.10^561^
;;045.11^561^
;;045.12^561^
;;045.13^561^
;;045.90^561^
;;045.91^561^
;;045.92^561^
;;045.93^561^
;;049.8^561^489
;;049.9^561^489
;;052.0^561^
;;054.3^561^489
;;055.0^561^
;;056.01^561^
;;056.09^561^
;;062.0^561^
;;062.1^561^
;;062.2^561^
;;062.3^561^
;;062.4^561^
;;062.5^561^
;;062.8^561^
;;062.9^561^
;;063.0^561^
;;063.1^561^
;;063.2^561^
;;063.8^561^
;;063.9^561^
;;064.^561^
;;066.2^561^
;;071.^561^
;;072.2^561^
;;090.40^561^
;;090.41^561^
;;090.42^561^
;;090.49^561^
;;091.81^561^
;;094.2^561^
;;094.3^561^
;;094.81^561^
;;098.82^560^
;;130.0^561^489
;;321.0^561^
;;322.0^561^
;;324.0^560^
;;357.0^560^
;;320.82^560^
;;320.81^560^
;;320.89^560^
;;307.81^26^564
;;310.2^26^564
;;345.2^26^562^563
;;345.3^26^562^563
;;348.2^26^564
;;437.4^26^564
;;349.0^26^564
;;784.0^26^564
;;345.00^26^562^563
;;345.01^26^562^563
;;345.10^26^562^563
;;345.11^26^562^563
;;345.40^26^562^563
;;345.41^26^562^563
;;345.50^26^562^563
;;345.51^26^562^563
;;345.60^26^562^563
;;345.61^26^562^563
;;345.70^26^562^563
;;345.71^26^562^563
;;345.80^26^562^563
;;345.81^26^562^563
;;345.90^26^562^563
;;345.91^26^562^563
;;346.01^26^564
;;346.11^26^564
;;346.21^26^564
;;346.81^26^564
;;346.91^26^564
;;346.00^26^564
;;346.10^26^564
;;346.20^26^564
;;346.80^26^564
;;346.90^26^564
;;780.31^26^562^563
;;780.39^26^562^563
;;017.80^571^489
;;017.81^571^489
;;017.82^571^489
;;017.83^571^489
;;017.84^571^489
;;017.85^571^489
;;017.86^571^489
;;112.84^571^489
;;456.0^571
;;456.1^571
;;456.20^571
;;530.4^571
;;530.7^571
;;530.82^571
;;530.84^571
;;750.3^571
;;750.4^571
;;862.22^571
;;947.2^571
;;001.0^572
;;001.1^572
;;001.9^572
;;003.0^572
;;004.0^572
;;004.1^572
;;004.2^572
;;004.3^572
;;004.8^572
;;004.9^572
;;005.0^572
;;005.2^572
;;005.3^572
;;005.4^572
;;005.81^572
;;005.89^572
;;006.0^572
;;006.1^572
;;006.2^572
;;007.0^572
;;007.1^572
;;007.2^572^489
;;007.3^572
;;007.4^572
;;007.5^572
;;007.8^572
;;007.9^572
;;008.00^572
;;008.01^572
;;008.02^572
;;008.03^572
;;008.04^572
;;008.09^572
;;008.1^572
;;008.2^572
;;008.3^572
;;008.41^572
;;008.42^572
;;008.43^572
;;008.44^572
;;008.45^572
;;008.46^572
;;008.47^572
;;008.49^572
;;008.5^572
;;4.00^572
;;014.01^572
;;014.02^572
;;014.03^572
;;014.04^572
;;014.05^572
;;014.06^572
;;014.80^572
;;014.81^572
;;014.82^572
;;014.83^572
;;014.84^572
;;014.85^572
;;014.86^572
;;021.1^572
;;022.2^572
;;032.83^572
;;039.2^572^489
;;095.2^572
;;098.86^572
;;123.1^572
;;123.5^572
;;123.6^572
;;123.8^572
;;123.9^572
;;126.0^572
;;126.1^572
;;126.2^572
;;126.3^572
;;126.8^572
;;126.9^572
;;540.0^572
;;540.1^572
;;567.0^572
;;567.1^572
;;567.21^572
;;567.22^572
;;567.23^572
;;567.29^572
;;567.31^572
;;567.38^572
;;7.39^572
;;567.89^572
;;567.9^572
;;569.5^572
;;279.11^574
;;279.12^574
;;279.13^574
;;279.19^574
;;279.2^574
;;283.0^574
;;283.10^574
;;283.19^574
;;283.2^574
;;283.9^574
;;284.8^574
;;284.9^574
;;288.1^574
;;288.2^574
;;996.85^574
;;EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1824N 6438 printed Dec 13, 2024@01:48:11 Page 2
ICD1824N ; ALB/JAT - FY 2007 UPDATE; 7/27/05 14:50;
+1 ;;18.0;DRG Grouper;**24**;Oct 13,2000;Build 5
+2 QUIT
+3 ;
DIAG ;
+1 DO BMES^XPDUTL(">>>DRG Reclassification changes")
+2 DO MES^XPDUTL(">>>Modifying diagnosis codes - file 80")
+3 DO MES^XPDUTL(">>>for new DRGs")
+4 NEW LINE,X,ICDDIAG,ENTRY,FDA
+5 FOR LINE=1:1
SET X=$TEXT(REVD+LINE)
SET ICDDIAG=$PIECE(X,";;",2)
if ICDDIAG="EXIT"
QUIT
Begin DoDot:1
+6 SET ENTRY=+$ORDER(^ICD9("BA",$PIECE(ICDDIAG,U)_" ",0))
+7 IF ENTRY
Begin DoDot:2
+8 ;check for possible inactive dupe
+9 IF $PIECE($GET(^ICD9(ENTRY,0)),U,9)=1
SET ENTRY=+$ORDER(^ICD9("BA",$PIECE(ICDDIAG,U)_" ",ENTRY))
IF 'ENTRY
QUIT
+10 ;check if already created in case patch being re-installed
+11 if $DATA(^ICD9(ENTRY,3,"B",3061001))
QUIT
+12 ; add 80.071 and 80.711 records
+13 SET FDA(1820,80,"?1,",.01)="`"_ENTRY
+14 SET FDA(1820,80.071,"+2,?1,",.01)=3061001
+15 DO UPDATE^DIE("","FDA(1820)")
KILL FDA(1820)
+16 SET FDA(1820,80,"?1,",.01)="`"_ENTRY
+17 SET FDA(1820,80.071,"?2,?1,",.01)=3061001
+18 SET FDA(1820,80.711,"+3,?2,?1,",.01)=$PIECE(ICDDIAG,U,2)
+19 IF $PIECE(ICDDIAG,U,3)
SET FDA(1820,80.711,"+4,?2,?1,",.01)=$PIECE(ICDDIAG,U,3)
+20 IF $PIECE(ICDDIAG,U,4)
SET FDA(1820,80.711,"+5,?2,?1,",.01)=$PIECE(ICDDIAG,U,4)
+21 DO UPDATE^DIE("","FDA(1820)")
KILL FDA(1820)
End DoDot:2
End DoDot:1
+22 QUIT
REVD ;
+1 ;;100.81^561^
+2 ;;100.89^561^
+3 ;;112.83^561^489
+4 ;;114.2^561^489
+5 ;;115.01^561^489
+6 ;;115.11^561^489
+7 ;;115.91^561^489
+8 ;;320.0^560^
+9 ;;320.1^560^
+10 ;;320.2^560^
+11 ;;320.3^560^
+12 ;;320.7^560^
+13 ;;320.9^560^
+14 ;;321.1^561^
+15 ;;321.2^561^
+16 ;;321.3^561^
+17 ;;321.4^561^
+18 ;;321.8^561^
+19 ;;322.1^561^
+20 ;;322.2^561^
+21 ;;322.9^561^
+22 ;;323.1^561^
+23 ;;323.2^561^
+24 ;;323.9^561^489
+25 ;;324.1^560^
+26 ;;324.9^560^
+27 ;;003.21^560^489
+28 ;;006.5^561^
+29 ;;013.00^560^489
+30 ;;013.01^560^489
+31 ;;013.02^560^489
+32 ;;013.03^560^489
+33 ;;013.04^560^489
+34 ;;013.05^560^489
+35 ;;013.06^560^489
+36 ;;013.10^560^489
+37 ;;013.11^560^489
+38 ;;013.12^560^489
+39 ;;013.13^560^489
+40 ;;013.14^560^489
+41 ;;013.15^560^489
+42 ;;013.16^560^489
+43 ;;013.20^560^489
+44 ;;013.21^560^489
+45 ;;013.22^560^489
+46 ;;013.23^560^489
+47 ;;013.24^560^489
+48 ;;013.25^560^489
+49 ;;013.26^560^489
+50 ;;013.30^560^489
+51 ;;013.31^560^489
+52 ;;013.32^560^489
+53 ;;013.33^560^489
+54 ;;013.34^560^489
+55 ;;013.35^560^489
+56 ;;013.36^560^489
+57 ;;013.40^560^489
+58 ;;013.41^560^489
+59 ;;013.42^560^489
+60 ;;013.43^560^489
+61 ;;013.44^560^489
+62 ;;013.45^560^489
+63 ;;013.46^560^489
+64 ;;013.50^560^489
+65 ;;013.51^560^489
+66 ;;013.52^560^489
+67 ;;013.53^560^489
+68 ;;013.54^560^489
+69 ;;013.55^560^489
+70 ;;013.56^560^489
+71 ;;013.60^560^489
+72 ;;013.61^560^489
+73 ;;013.62^560^489
+74 ;;013.63^560^489
+75 ;;013.64^560^489
+76 ;;013.65^560^489
+77 ;;013.66^560^489
+78 ;;013.80^560^489
+79 ;;013.81^560^489
+80 ;;013.82^560^489
+81 ;;013.83^560^489
+82 ;;013.84^560^489
+83 ;;013.85^560^489
+84 ;;013.86^560^489
+85 ;;013.90^560^489
+86 ;;013.91^560^489
+87 ;;013.92^560^489
+88 ;;013.93^560^489
+89 ;;013.94^560^
+90 ;;013.95^560^
+91 ;;013.96^560^
+92 ;;036.0^560^
+93 ;;036.1^560^
+94 ;;045.00^561^
+95 ;;045.01^561^
+96 ;;045.02^561^
+97 ;;045.03^561^
+98 ;;045.10^561^
+99 ;;045.11^561^
+100 ;;045.12^561^
+101 ;;045.13^561^
+102 ;;045.90^561^
+103 ;;045.91^561^
+104 ;;045.92^561^
+105 ;;045.93^561^
+106 ;;049.8^561^489
+107 ;;049.9^561^489
+108 ;;052.0^561^
+109 ;;054.3^561^489
+110 ;;055.0^561^
+111 ;;056.01^561^
+112 ;;056.09^561^
+113 ;;062.0^561^
+114 ;;062.1^561^
+115 ;;062.2^561^
+116 ;;062.3^561^
+117 ;;062.4^561^
+118 ;;062.5^561^
+119 ;;062.8^561^
+120 ;;062.9^561^
+121 ;;063.0^561^
+122 ;;063.1^561^
+123 ;;063.2^561^
+124 ;;063.8^561^
+125 ;;063.9^561^
+126 ;;064.^561^
+127 ;;066.2^561^
+128 ;;071.^561^
+129 ;;072.2^561^
+130 ;;090.40^561^
+131 ;;090.41^561^
+132 ;;090.42^561^
+133 ;;090.49^561^
+134 ;;091.81^561^
+135 ;;094.2^561^
+136 ;;094.3^561^
+137 ;;094.81^561^
+138 ;;098.82^560^
+139 ;;130.0^561^489
+140 ;;321.0^561^
+141 ;;322.0^561^
+142 ;;324.0^560^
+143 ;;357.0^560^
+144 ;;320.82^560^
+145 ;;320.81^560^
+146 ;;320.89^560^
+147 ;;307.81^26^564
+148 ;;310.2^26^564
+149 ;;345.2^26^562^563
+150 ;;345.3^26^562^563
+151 ;;348.2^26^564
+152 ;;437.4^26^564
+153 ;;349.0^26^564
+154 ;;784.0^26^564
+155 ;;345.00^26^562^563
+156 ;;345.01^26^562^563
+157 ;;345.10^26^562^563
+158 ;;345.11^26^562^563
+159 ;;345.40^26^562^563
+160 ;;345.41^26^562^563
+161 ;;345.50^26^562^563
+162 ;;345.51^26^562^563
+163 ;;345.60^26^562^563
+164 ;;345.61^26^562^563
+165 ;;345.70^26^562^563
+166 ;;345.71^26^562^563
+167 ;;345.80^26^562^563
+168 ;;345.81^26^562^563
+169 ;;345.90^26^562^563
+170 ;;345.91^26^562^563
+171 ;;346.01^26^564
+172 ;;346.11^26^564
+173 ;;346.21^26^564
+174 ;;346.81^26^564
+175 ;;346.91^26^564
+176 ;;346.00^26^564
+177 ;;346.10^26^564
+178 ;;346.20^26^564
+179 ;;346.80^26^564
+180 ;;346.90^26^564
+181 ;;780.31^26^562^563
+182 ;;780.39^26^562^563
+183 ;;017.80^571^489
+184 ;;017.81^571^489
+185 ;;017.82^571^489
+186 ;;017.83^571^489
+187 ;;017.84^571^489
+188 ;;017.85^571^489
+189 ;;017.86^571^489
+190 ;;112.84^571^489
+191 ;;456.0^571
+192 ;;456.1^571
+193 ;;456.20^571
+194 ;;530.4^571
+195 ;;530.7^571
+196 ;;530.82^571
+197 ;;530.84^571
+198 ;;750.3^571
+199 ;;750.4^571
+200 ;;862.22^571
+201 ;;947.2^571
+202 ;;001.0^572
+203 ;;001.1^572
+204 ;;001.9^572
+205 ;;003.0^572
+206 ;;004.0^572
+207 ;;004.1^572
+208 ;;004.2^572
+209 ;;004.3^572
+210 ;;004.8^572
+211 ;;004.9^572
+212 ;;005.0^572
+213 ;;005.2^572
+214 ;;005.3^572
+215 ;;005.4^572
+216 ;;005.81^572
+217 ;;005.89^572
+218 ;;006.0^572
+219 ;;006.1^572
+220 ;;006.2^572
+221 ;;007.0^572
+222 ;;007.1^572
+223 ;;007.2^572^489
+224 ;;007.3^572
+225 ;;007.4^572
+226 ;;007.5^572
+227 ;;007.8^572
+228 ;;007.9^572
+229 ;;008.00^572
+230 ;;008.01^572
+231 ;;008.02^572
+232 ;;008.03^572
+233 ;;008.04^572
+234 ;;008.09^572
+235 ;;008.1^572
+236 ;;008.2^572
+237 ;;008.3^572
+238 ;;008.41^572
+239 ;;008.42^572
+240 ;;008.43^572
+241 ;;008.44^572
+242 ;;008.45^572
+243 ;;008.46^572
+244 ;;008.47^572
+245 ;;008.49^572
+246 ;;008.5^572
+247 ;;4.00^572
+248 ;;014.01^572
+249 ;;014.02^572
+250 ;;014.03^572
+251 ;;014.04^572
+252 ;;014.05^572
+253 ;;014.06^572
+254 ;;014.80^572
+255 ;;014.81^572
+256 ;;014.82^572
+257 ;;014.83^572
+258 ;;014.84^572
+259 ;;014.85^572
+260 ;;014.86^572
+261 ;;021.1^572
+262 ;;022.2^572
+263 ;;032.83^572
+264 ;;039.2^572^489
+265 ;;095.2^572
+266 ;;098.86^572
+267 ;;123.1^572
+268 ;;123.5^572
+269 ;;123.6^572
+270 ;;123.8^572
+271 ;;123.9^572
+272 ;;126.0^572
+273 ;;126.1^572
+274 ;;126.2^572
+275 ;;126.3^572
+276 ;;126.8^572
+277 ;;126.9^572
+278 ;;540.0^572
+279 ;;540.1^572
+280 ;;567.0^572
+281 ;;567.1^572
+282 ;;567.21^572
+283 ;;567.22^572
+284 ;;567.23^572
+285 ;;567.29^572
+286 ;;567.31^572
+287 ;;567.38^572
+288 ;;7.39^572
+289 ;;567.89^572
+290 ;;567.9^572
+291 ;;569.5^572
+292 ;;279.11^574
+293 ;;279.12^574
+294 ;;279.13^574
+295 ;;279.19^574
+296 ;;279.2^574
+297 ;;283.0^574
+298 ;;283.10^574
+299 ;;283.19^574
+300 ;;283.2^574
+301 ;;283.9^574
+302 ;;284.8^574
+303 ;;284.9^574
+304 ;;288.1^574
+305 ;;288.2^574
+306 ;;996.85^574
+307 ;;EXIT
