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