ICD1831S ;;ALB/EG/JAT - FY 2008 UPDATE; 6/19/05 4:08pm ; 11/14/07 5:22pm
;;18.0;DRG Grouper;**31**;Oct 13,2000;Build 7
;
Q
;
PRO ;-update operation/procedure codes
; from Table 6B in Fed Reg - assumes new codes already added by Lexicon
D BMES^XPDUTL(">>>Modifying new op/pro codes - file 80.1")
N LINE,X,ICDPROC,ENTRY,DA,DIE,DR,IDENT,MDC24,SUBLINE,DATA,FDA
F LINE=1:1 S X=$T(REV+LINE) S ICDPROC=$P(X,";;",2) Q:ICDPROC="EXIT" D
.Q:ICDPROC["+"
.; check if already created in case patch being re-installed
.S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",0))
.I $D(^ICD0(ENTRY,2,"B",3071001)) D
..;kill existing entry for FY
.. S DA(1)=ENTRY,DA=$O(^ICD0(ENTRY,2,"B",3071001,0))
.. S DIK="^ICD0("_DA(1)_",2," D ^DIK K DIK,DA
.I ENTRY D
..;check for possible inactive dupe
..I $P($G(^ICD0(ENTRY,0)),U,9)=1 S ENTRY=+$O(^ICD0("BA",$P(ICDPROC,U)_" ",ENTRY)) I 'ENTRY Q
..S DA=ENTRY,DIE="^ICD0("
..S IDENT=$P(ICDPROC,U,2)
..S MDC24=$P(ICDPROC,U,3)
..S DR="2///^S X=IDENT;5///^S X=MDC24"
..I IDENT=""&(MDC24="") Q
..D ^DIE
..;add 80.171, 80.1711 and 80.17111 records
..F SUBLINE=1:1 S X=$T(REV+LINE+SUBLINE) S DATA=$P(X,";;",2) Q:DATA'["+" D
...I SUBLINE=1 D
....S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
....S FDA(1820,80.171,"+2,?1,",.01)=3071001
....D UPDATE^DIE("","FDA(1820)") K FDA(1820)
...S DATA=$E(DATA,2,99)
...S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
...S FDA(1820,80.171,"?2,?1,",.01)=3071001
...S FDA(1820,80.1711,"+3,?2,?1,",.01)=$P(DATA,U)
...D UPDATE^DIE("","FDA(1820)") K FDA(1820)
...S FDA(1820,80.1,"?1,",.01)="`"_ENTRY
...S FDA(1820,80.171,"?2,?1,",.01)=3071001
...S FDA(1820,80.1711,"?3,?2,?1,",.01)=$P(DATA,U)
...S FDA(1820,80.17111,"+4,?3,?2,?1,",.01)=$P(DATA,U,2)
...I $P(DATA,U,3) S FDA(1820,80.17111,"+5,?3,?2,?1,",.01)=$P(DATA,U,3)
...I $P(DATA,U,4) S FDA(1820,80.17111,"+6,?3,?2,?1,",.01)=$P(DATA,U,4)
...I $P(DATA,U,5) S FDA(1820,80.17111,"+7,?3,?2,?1,",.01)=$P(DATA,U,5)
...I $P(DATA,U,6) S FDA(1820,80.17111,"+8,?3,?2,?1,",.01)=$P(DATA,U,6)
...I $P(DATA,U,7) S FDA(1820,80.17111,"+9,?3,?2,?1,",.01)=$P(DATA,U,7)
...I $P(DATA,U,8) S FDA(1820,80.17111,"+10,?3,?2,?1,",.01)=$P(DATA,U,8)
...I $P(DATA,U,9) S FDA(1820,80.17111,"+11,?3,?2,?1,",.01)=$P(DATA,U,9)
...D UPDATE^DIE("","FDA(1820)") K FDA(1820)
Q
;
REV ;PROC/OP^IDENTIFIER^MDC24^DRG...
;;39.72^OQK^
;;+1^25^26^27^23^24^20^21^22
;;+5^237^238
;;+11^673^374^675
;;+21^907^908^909
;;+24^957^958^959
;;39.74^OQK^
;;+1^25^26^27^23^24
;;+21^907^908^909
;;+24^957^958^959
;;39.79^OQK^
;;+1^25^26^27^23^24^20^21^22
;;+5^237^238
;;+11^673^374^675
;;+21^907^908^909
;;+24^957^958^959
;;00.62^O^
;;+1^25^26^27^23^24
;;+5^237^238
;;+11^673^374^675
;;+21^907^908^909
;;+24^957^958^959
;;00.83^OM^
;;+8^485^486^487^488^489
;;+21^907^908^909
;;+24^957^958^959
;;00.84^OM^
;;+8^485^486^487^488^489
;;+21^907^908^909
;;+24^957^958^959
;;84.59^O^
;;+1^28^29^30
;;+8^490^491
;;+21^907^908^909
;;+24^957^958^959
;;84.65^O^
;;+1^28^29^30
;;+8^490^491
;;+21^907^908^909
;;+24^957^958^959
;;84.62^O^
;;+1^28^29^30
;;+8^490^491
;;+21^907^908^909
;;+24^957^958^959
;;84.82^O^
;;+1^28^29^30
;;+8^490^491
;;+21^907^908^909
;;+24^957^958^959
;;00.52^O^
;;+5^245
;;00.54^O^
;;+5^245
;;37.95^O^
;;+5^245
;;37.96^O^
;;+5^245
;;37.97^O^
;;+5^245
;;37.98^O^
;;+5^245
;;57.83^O^
;;+6^344^345^346
;;+11^653^654^655
;;+12^715^716^718
;;+13^749^750
;;+17^820^821^822^826^827^828
;;+21^907^908^909
;;+24^957^958^959
;;69.42^O^
;;+6^344^345^346
;;+13^736^737^743
;;+21^907^908^909
;;+24^957^958^959
;;70.75^O^
;;+6^344^345^346
;;+13^746^747
;;+17^820^821^822^826^827^828
;;+21^907^908^909
;;+24^957^958^959
;;71.72^O^
;;+6^344^345^346
;;+13^746^747
;;+21^907^908^909
;;+24^957^958^959
;;53.00^OzJ^
;;53.01^OzJ^
;;53.02^OzJ^
;;53.03^OzJ^
;;53.04^OzJ^
;;53.05^OzJ^
;;53.10^OzJ^
;;53.11^OzJ^
;;53.12^OzJ^
;;53.13^OzJ^
;;53.14^OzJ^
;;53.15^OzJ^
;;53.16^OzJ^
;;53.17^OzJ^
;;53.21^OzJ^
;;53.29^OzJ^
;;53.31^OzJ^
;;53.39^OzJ^
;;81.00^O
;;+1^28^29^30
;;+8^456^457^458^459^460
;;+21^907^908^909
;;+24^957^958^959
;;81.01^O
;;+8^471^472^473
;;81.04^O
;;+8^453^454^455^456^457^458
;;81.05^O
;;+8^453^454^455^
;;81.30^O
;;+1^28^29^30
;;+8^456^457^458^459^460
;;+21+21^907^908^909
;;+24^957^958^959
;;81.39^O
;;+1^28^29^30
;;+8^456^457^458^459^460
;;+21+21^907^908^909
;;+24^957^958^959
;;81.32^O
;;+8^453^454^455^471^472^473
;;81.34^O
;;+8^453^454^455^456^457^458
;;81.36^O
;;+8^453^454^455^456^457^458
;;81.03^O
;;+8^453^454^455^471^472^473
;;81.07^O
;;+8^453^454^455^456^457^458
;;81.08^O
;;+8^453^454^455^456^457^458
;;81.31^O
;;+8^471^472^473
;;81.33^O
;;+8^453^454^455^471^472^473
;;81.35^O
;;+8^453^454^455^456^457^458
;;81.37^O
;;+8^453^454^455^456^457^458
;;81.38^O
;;+8^453^454^455^456^457^458
;;81.02^O
;;+8^453^454^455^471^472^473
;;81.06^O
;;+8^453^454^455^456^457^458
;;01.15^OQ
;;+1^23^24^25^26^27
;;+8^477^478^479
;;+10^628^629^630
;;01.19^OQ
;;+1^23^24^25^26^27
;;+8^477^478^479
;;+21^907^908^909
;;+24^957^958^959
;;01.6^OQ
;;+1^23^24^25^26^27
;;+3^131^132
;;+8^495^496^497
;;+17^820^821^822^826^827^828
;;+24^955
;;01.25^OQ
;;+1^23^24^25^26^27
;;+3^131^132
;;+8^515^516^517
;;+17^820^821^822^826^827^828
;;+21^907^908^909
;;+24^955
;;02.01^OQ
;;+1^23^24^25^26^27
;;+3^131^132
;;+8^515^516^517
;;+21^907^908^909
;;+24^955
;;02.02^OQ
;;+1^23^24^25^26^27
;;+3^131^132
;;+8^515^516^517
;;+21^907^908^909
;;+24^955
;;02.03^OQ
;;+1^23^24^25^26^27
;;+3^131^132
;;+8^515^516^517
;;+21^907^908^909
;;+24^955
;;02.04^OQ
;;+1^23^24^25^26^27
;;+3^131^132
;;+8^515^516^517
;;+21^907^908^909
;;+24^955
;;02.05^OQ
;;+1^23^24^25^26^27
;;+3^131^132
;;+8^515^516^517
;;+21^907^908^909
;;+24^955
;;02.06^OQ
;;+1^23^24^25^26^27
;;+3^131^132
;;+8^515^516^517
;;+21^907^908^909
;;+24^955
;;02.07^OQ
;;+1^23^24^25^26^27
;;+3^131^132
;;+8^515^516^517
;;+21^907^908^909
;;+24^955
;;85.22^Om^
;;+9^582^583^584^585
;;+21^907^908^909
;;+24^957^958^959
;;85.23^Om
;;+9^582^583^584^585
;;+21^907^908^909
;;+24^957^958^959
;;EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1831S 6384 printed Apr 09, 2024@20:55:02 Page 2
ICD1831S ;;ALB/EG/JAT - FY 2008 UPDATE; 6/19/05 4:08pm ; 11/14/07 5:22pm
+1 ;;18.0;DRG Grouper;**31**;Oct 13,2000;Build 7
+2 ;
+3 QUIT
+4 ;
PRO ;-update operation/procedure codes
+1 ; from Table 6B in Fed Reg - assumes new codes already added by Lexicon
+2 DO BMES^XPDUTL(">>>Modifying new op/pro codes - file 80.1")
+3 NEW LINE,X,ICDPROC,ENTRY,DA,DIE,DR,IDENT,MDC24,SUBLINE,DATA,FDA
+4 FOR LINE=1:1
SET X=$TEXT(REV+LINE)
SET ICDPROC=$PIECE(X,";;",2)
if ICDPROC="EXIT"
QUIT
Begin DoDot:1
+5 if ICDPROC["+"
QUIT
+6 ; check if already created in case patch being re-installed
+7 SET ENTRY=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",0))
+8 IF $DATA(^ICD0(ENTRY,2,"B",3071001))
Begin DoDot:2
+9 ;kill existing entry for FY
+10 SET DA(1)=ENTRY
SET DA=$ORDER(^ICD0(ENTRY,2,"B",3071001,0))
+11 SET DIK="^ICD0("_DA(1)_",2,"
DO ^DIK
KILL DIK,DA
End DoDot:2
+12 IF ENTRY
Begin DoDot:2
+13 ;check for possible inactive dupe
+14 IF $PIECE($GET(^ICD0(ENTRY,0)),U,9)=1
SET ENTRY=+$ORDER(^ICD0("BA",$PIECE(ICDPROC,U)_" ",ENTRY))
IF 'ENTRY
QUIT
+15 SET DA=ENTRY
SET DIE="^ICD0("
+16 SET IDENT=$PIECE(ICDPROC,U,2)
+17 SET MDC24=$PIECE(ICDPROC,U,3)
+18 SET DR="2///^S X=IDENT;5///^S X=MDC24"
+19 IF IDENT=""&(MDC24="")
QUIT
+20 DO ^DIE
+21 ;add 80.171, 80.1711 and 80.17111 records
+22 FOR SUBLINE=1:1
SET X=$TEXT(REV+LINE+SUBLINE)
SET DATA=$PIECE(X,";;",2)
if DATA'["+"
QUIT
Begin DoDot:3
+23 IF SUBLINE=1
Begin DoDot:4
+24 SET FDA(1820,80.1,"?1,",.01)="`"_ENTRY
+25 SET FDA(1820,80.171,"+2,?1,",.01)=3071001
+26 DO UPDATE^DIE("","FDA(1820)")
KILL FDA(1820)
End DoDot:4
+27 SET DATA=$EXTRACT(DATA,2,99)
+28 SET FDA(1820,80.1,"?1,",.01)="`"_ENTRY
+29 SET FDA(1820,80.171,"?2,?1,",.01)=3071001
+30 SET FDA(1820,80.1711,"+3,?2,?1,",.01)=$PIECE(DATA,U)
+31 DO UPDATE^DIE("","FDA(1820)")
KILL FDA(1820)
+32 SET FDA(1820,80.1,"?1,",.01)="`"_ENTRY
+33 SET FDA(1820,80.171,"?2,?1,",.01)=3071001
+34 SET FDA(1820,80.1711,"?3,?2,?1,",.01)=$PIECE(DATA,U)
+35 SET FDA(1820,80.17111,"+4,?3,?2,?1,",.01)=$PIECE(DATA,U,2)
+36 IF $PIECE(DATA,U,3)
SET FDA(1820,80.17111,"+5,?3,?2,?1,",.01)=$PIECE(DATA,U,3)
+37 IF $PIECE(DATA,U,4)
SET FDA(1820,80.17111,"+6,?3,?2,?1,",.01)=$PIECE(DATA,U,4)
+38 IF $PIECE(DATA,U,5)
SET FDA(1820,80.17111,"+7,?3,?2,?1,",.01)=$PIECE(DATA,U,5)
+39 IF $PIECE(DATA,U,6)
SET FDA(1820,80.17111,"+8,?3,?2,?1,",.01)=$PIECE(DATA,U,6)
+40 IF $PIECE(DATA,U,7)
SET FDA(1820,80.17111,"+9,?3,?2,?1,",.01)=$PIECE(DATA,U,7)
+41 IF $PIECE(DATA,U,8)
SET FDA(1820,80.17111,"+10,?3,?2,?1,",.01)=$PIECE(DATA,U,8)
+42 IF $PIECE(DATA,U,9)
SET FDA(1820,80.17111,"+11,?3,?2,?1,",.01)=$PIECE(DATA,U,9)
+43 DO UPDATE^DIE("","FDA(1820)")
KILL FDA(1820)
End DoDot:3
End DoDot:2
End DoDot:1
+44 QUIT
+45 ;
REV ;PROC/OP^IDENTIFIER^MDC24^DRG...
+1 ;;39.72^OQK^
+2 ;;+1^25^26^27^23^24^20^21^22
+3 ;;+5^237^238
+4 ;;+11^673^374^675
+5 ;;+21^907^908^909
+6 ;;+24^957^958^959
+7 ;;39.74^OQK^
+8 ;;+1^25^26^27^23^24
+9 ;;+21^907^908^909
+10 ;;+24^957^958^959
+11 ;;39.79^OQK^
+12 ;;+1^25^26^27^23^24^20^21^22
+13 ;;+5^237^238
+14 ;;+11^673^374^675
+15 ;;+21^907^908^909
+16 ;;+24^957^958^959
+17 ;;00.62^O^
+18 ;;+1^25^26^27^23^24
+19 ;;+5^237^238
+20 ;;+11^673^374^675
+21 ;;+21^907^908^909
+22 ;;+24^957^958^959
+23 ;;00.83^OM^
+24 ;;+8^485^486^487^488^489
+25 ;;+21^907^908^909
+26 ;;+24^957^958^959
+27 ;;00.84^OM^
+28 ;;+8^485^486^487^488^489
+29 ;;+21^907^908^909
+30 ;;+24^957^958^959
+31 ;;84.59^O^
+32 ;;+1^28^29^30
+33 ;;+8^490^491
+34 ;;+21^907^908^909
+35 ;;+24^957^958^959
+36 ;;84.65^O^
+37 ;;+1^28^29^30
+38 ;;+8^490^491
+39 ;;+21^907^908^909
+40 ;;+24^957^958^959
+41 ;;84.62^O^
+42 ;;+1^28^29^30
+43 ;;+8^490^491
+44 ;;+21^907^908^909
+45 ;;+24^957^958^959
+46 ;;84.82^O^
+47 ;;+1^28^29^30
+48 ;;+8^490^491
+49 ;;+21^907^908^909
+50 ;;+24^957^958^959
+51 ;;00.52^O^
+52 ;;+5^245
+53 ;;00.54^O^
+54 ;;+5^245
+55 ;;37.95^O^
+56 ;;+5^245
+57 ;;37.96^O^
+58 ;;+5^245
+59 ;;37.97^O^
+60 ;;+5^245
+61 ;;37.98^O^
+62 ;;+5^245
+63 ;;57.83^O^
+64 ;;+6^344^345^346
+65 ;;+11^653^654^655
+66 ;;+12^715^716^718
+67 ;;+13^749^750
+68 ;;+17^820^821^822^826^827^828
+69 ;;+21^907^908^909
+70 ;;+24^957^958^959
+71 ;;69.42^O^
+72 ;;+6^344^345^346
+73 ;;+13^736^737^743
+74 ;;+21^907^908^909
+75 ;;+24^957^958^959
+76 ;;70.75^O^
+77 ;;+6^344^345^346
+78 ;;+13^746^747
+79 ;;+17^820^821^822^826^827^828
+80 ;;+21^907^908^909
+81 ;;+24^957^958^959
+82 ;;71.72^O^
+83 ;;+6^344^345^346
+84 ;;+13^746^747
+85 ;;+21^907^908^909
+86 ;;+24^957^958^959
+87 ;;53.00^OzJ^
+88 ;;53.01^OzJ^
+89 ;;53.02^OzJ^
+90 ;;53.03^OzJ^
+91 ;;53.04^OzJ^
+92 ;;53.05^OzJ^
+93 ;;53.10^OzJ^
+94 ;;53.11^OzJ^
+95 ;;53.12^OzJ^
+96 ;;53.13^OzJ^
+97 ;;53.14^OzJ^
+98 ;;53.15^OzJ^
+99 ;;53.16^OzJ^
+100 ;;53.17^OzJ^
+101 ;;53.21^OzJ^
+102 ;;53.29^OzJ^
+103 ;;53.31^OzJ^
+104 ;;53.39^OzJ^
+105 ;;81.00^O
+106 ;;+1^28^29^30
+107 ;;+8^456^457^458^459^460
+108 ;;+21^907^908^909
+109 ;;+24^957^958^959
+110 ;;81.01^O
+111 ;;+8^471^472^473
+112 ;;81.04^O
+113 ;;+8^453^454^455^456^457^458
+114 ;;81.05^O
+115 ;;+8^453^454^455^
+116 ;;81.30^O
+117 ;;+1^28^29^30
+118 ;;+8^456^457^458^459^460
+119 ;;+21+21^907^908^909
+120 ;;+24^957^958^959
+121 ;;81.39^O
+122 ;;+1^28^29^30
+123 ;;+8^456^457^458^459^460
+124 ;;+21+21^907^908^909
+125 ;;+24^957^958^959
+126 ;;81.32^O
+127 ;;+8^453^454^455^471^472^473
+128 ;;81.34^O
+129 ;;+8^453^454^455^456^457^458
+130 ;;81.36^O
+131 ;;+8^453^454^455^456^457^458
+132 ;;81.03^O
+133 ;;+8^453^454^455^471^472^473
+134 ;;81.07^O
+135 ;;+8^453^454^455^456^457^458
+136 ;;81.08^O
+137 ;;+8^453^454^455^456^457^458
+138 ;;81.31^O
+139 ;;+8^471^472^473
+140 ;;81.33^O
+141 ;;+8^453^454^455^471^472^473
+142 ;;81.35^O
+143 ;;+8^453^454^455^456^457^458
+144 ;;81.37^O
+145 ;;+8^453^454^455^456^457^458
+146 ;;81.38^O
+147 ;;+8^453^454^455^456^457^458
+148 ;;81.02^O
+149 ;;+8^453^454^455^471^472^473
+150 ;;81.06^O
+151 ;;+8^453^454^455^456^457^458
+152 ;;01.15^OQ
+153 ;;+1^23^24^25^26^27
+154 ;;+8^477^478^479
+155 ;;+10^628^629^630
+156 ;;01.19^OQ
+157 ;;+1^23^24^25^26^27
+158 ;;+8^477^478^479
+159 ;;+21^907^908^909
+160 ;;+24^957^958^959
+161 ;;01.6^OQ
+162 ;;+1^23^24^25^26^27
+163 ;;+3^131^132
+164 ;;+8^495^496^497
+165 ;;+17^820^821^822^826^827^828
+166 ;;+24^955
+167 ;;01.25^OQ
+168 ;;+1^23^24^25^26^27
+169 ;;+3^131^132
+170 ;;+8^515^516^517
+171 ;;+17^820^821^822^826^827^828
+172 ;;+21^907^908^909
+173 ;;+24^955
+174 ;;02.01^OQ
+175 ;;+1^23^24^25^26^27
+176 ;;+3^131^132
+177 ;;+8^515^516^517
+178 ;;+21^907^908^909
+179 ;;+24^955
+180 ;;02.02^OQ
+181 ;;+1^23^24^25^26^27
+182 ;;+3^131^132
+183 ;;+8^515^516^517
+184 ;;+21^907^908^909
+185 ;;+24^955
+186 ;;02.03^OQ
+187 ;;+1^23^24^25^26^27
+188 ;;+3^131^132
+189 ;;+8^515^516^517
+190 ;;+21^907^908^909
+191 ;;+24^955
+192 ;;02.04^OQ
+193 ;;+1^23^24^25^26^27
+194 ;;+3^131^132
+195 ;;+8^515^516^517
+196 ;;+21^907^908^909
+197 ;;+24^955
+198 ;;02.05^OQ
+199 ;;+1^23^24^25^26^27
+200 ;;+3^131^132
+201 ;;+8^515^516^517
+202 ;;+21^907^908^909
+203 ;;+24^955
+204 ;;02.06^OQ
+205 ;;+1^23^24^25^26^27
+206 ;;+3^131^132
+207 ;;+8^515^516^517
+208 ;;+21^907^908^909
+209 ;;+24^955
+210 ;;02.07^OQ
+211 ;;+1^23^24^25^26^27
+212 ;;+3^131^132
+213 ;;+8^515^516^517
+214 ;;+21^907^908^909
+215 ;;+24^955
+216 ;;85.22^Om^
+217 ;;+9^582^583^584^585
+218 ;;+21^907^908^909
+219 ;;+24^957^958^959
+220 ;;85.23^Om
+221 ;;+9^582^583^584^585
+222 ;;+21^907^908^909
+223 ;;+24^957^958^959
+224 ;;EXIT
