ICD1831V ;;ALB/EG/JAT - FY 2008 UPDATE; 6/19/05 4:08pm ; 11/14/07 5:25pm
;;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
;;07.13^OQ^
;;+1^23^24^25^26^27
;;+10^614^615
;;07.14^OQ^
;;+1^23^24^25^26^27
;;+10^614^615
;;07.15^OQ^
;;+1^23^24^25^26^27
;;+10^614^615
;;07.17^OQ^
;;+1^23^24^25^26^27
;;+10^614^615
;;07.51^OQ^
;;+1^23^24^25^26^27
;;+10^614^615
;;07.52^OQ^
;;+1^23^24^25^26^27
;;+10^614^615
;;07.53^OQ^
;;+1^23^24^25^26^27
;;+10^614^615
;;07.54^OQ^
;;+1^23^24^25^26^27
;;+10^614^615
;;07.59^OQ^
;;+1^23^24^25^26^27
;;+10^614^615
;;07.61^OQ^
;;+1^23^24^25^26^27
;;+10^614^615
;;07.62^OQ^
;;+1^23^24^25^26^27
;;+10^614^615
;;07.63^OQ^
;;+1^23^24^25^26^27
;;+9^579^580^581
;;+10^614^615
;;07.64^OQ^
;;+1^23^24^25^26^27
;;+9^579^580^581
;;+10^614^615
;;07.65^OQ^
;;+1^23^24^25^26^27
;;+9^579^580^581
;;+10^614^615
;;07.68^OQ^
;;+1^23^24^25^26^27
;;+9^579^580^581
;;+10^614^615
;;07.69^OQ^
;;+1^23^24^25^26^27
;;+9^579^580^581
;;+10^614^615
;;07.71^OQ^
;;+1^23^24^25^26^27
;;+10^614^615
;;07.72^OQ^
;;+1^23^24^25^26^27
;;+9^579^580^581
;;+10^614^615
;;07.79^OQ^
;;+1^23^24^25^26^27
;;+9^579^580^581
;;+10^614^615
;;51.23^OT
;;+6^356^357^358
;;+7^411^412^413^417^418^419
;;+17^820^821^822^826^827^828
;;+21^907^908^909
;;+24^957^958^959
;;57.6^O
;;+11^653^654^655
;;+12^707^708
;;+13^749^750
;;+17^820^821^822^826^827^828
;;+21^907^908^909
;;+24^957^958^959
;;57.71^O
;;+11^653^654^655
;;+12^707^708
;;+13^749^750
;;+17^820^821^822^826^827^828
;;57.79^O
;;+11^653^654^655
;;+12^707^708
;;+13^749^750
;;+17^820^821^822^826^827^828
;;+21^907^908^909
;;+24^957^958^959
;;57.71^O
;;+11^653^654^655
;;+12^707^708
;;+13^749^750
;;+17^820^821^822^826^827^828
;;+21^907^908^909
;;+24^957^958^959
;;57.88^O
;;+11^653^654^655
;;+12^707^708
;;+17^820^821^822^826^827^828
;;01.12^OQ
;;+1^23^24^25^26^27
;;+17^820^821^822^826^827^828
;;01.14^OQ
;;+1^23^24^25^26^27
;;+17^820^821^822^826^827^828
;;01.42^OQ
;;+1^23^24^25^26^27
;;+17^820^821^822^826^827^828
;;+24^955
;;01.51^OQ
;;+1^23^24^25^26^27
;;+17^820^821^822^826^827^828
;;+24^955
;;01.52^OQ
;;+1^23^24^25^26^27
;;+17^820^821^822^826^827^828
;;+24^955
;;01.53^OQ
;;+1^23^24^25^26^27
;;+17^820^821^822^826^827^828
;;+24^955
;;01.59^OQ
;;+1^23^24^25^26^27
;;+17^820^821^822^826^827^828
;;+24^955
;;02.99^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.91^OQ
;;+1^23^24^25^26^27
;;+17^820^821^822^826^827^828
;;+21^907^908^909
;;+24^955
;;01.18^OQ
;;+1^23^24^25^26^27
;;+17^820^821^822^826^827^828
;;+21^907^908^909
;;+24^957^958^959
;;01.23^OQ
;;+1^23^24^25^26^27
;;+3^131^132
;;+17^820^821^822^826^827^828
;;+21^907^908^909
;;+24^955
;;01.24^OQ
;;+1^23^24^25^26^27
;;+3^131^132
;;+17^820^821^822^826^827^828
;;+21^907^908^909
;;+24^955
;;01.31^OQ
;;+1^23^24^25^26^27
;;+17^820^821^822^826^827^828
;;+21^907^908^909
;;+24^955
;;01.32^OQ
;;+1^23^24^25^26^27
;;+17^820^821^822^826^827^828
;;+21^907^908^909
;;+24^955
;;01.39^OQ
;;+1^23^24^25^26^27
;;+17^820^821^822^826^827^828
;;+21^907^908^909
;;+24^955
;;01.41^OQ
;;+1^23^24^25^26^27
;;+17^820^821^822^826^827^828
;;+21^907^908^909
;;+24^955
;;EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1831V 5819 printed Nov 22, 2024@16:58:48 Page 2
ICD1831V ;;ALB/EG/JAT - FY 2008 UPDATE; 6/19/05 4:08pm ; 11/14/07 5:25pm
+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 ;D 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 ;;07.13^OQ^
+8 ;;+1^23^24^25^26^27
+9 ;;+10^614^615
+10 ;;07.14^OQ^
+11 ;;+1^23^24^25^26^27
+12 ;;+10^614^615
+13 ;;07.15^OQ^
+14 ;;+1^23^24^25^26^27
+15 ;;+10^614^615
+16 ;;07.17^OQ^
+17 ;;+1^23^24^25^26^27
+18 ;;+10^614^615
+19 ;;07.51^OQ^
+20 ;;+1^23^24^25^26^27
+21 ;;+10^614^615
+22 ;;07.52^OQ^
+23 ;;+1^23^24^25^26^27
+24 ;;+10^614^615
+25 ;;07.53^OQ^
+26 ;;+1^23^24^25^26^27
+27 ;;+10^614^615
+28 ;;07.54^OQ^
+29 ;;+1^23^24^25^26^27
+30 ;;+10^614^615
+31 ;;07.59^OQ^
+32 ;;+1^23^24^25^26^27
+33 ;;+10^614^615
+34 ;;07.61^OQ^
+35 ;;+1^23^24^25^26^27
+36 ;;+10^614^615
+37 ;;07.62^OQ^
+38 ;;+1^23^24^25^26^27
+39 ;;+10^614^615
+40 ;;07.63^OQ^
+41 ;;+1^23^24^25^26^27
+42 ;;+9^579^580^581
+43 ;;+10^614^615
+44 ;;07.64^OQ^
+45 ;;+1^23^24^25^26^27
+46 ;;+9^579^580^581
+47 ;;+10^614^615
+48 ;;07.65^OQ^
+49 ;;+1^23^24^25^26^27
+50 ;;+9^579^580^581
+51 ;;+10^614^615
+52 ;;07.68^OQ^
+53 ;;+1^23^24^25^26^27
+54 ;;+9^579^580^581
+55 ;;+10^614^615
+56 ;;07.69^OQ^
+57 ;;+1^23^24^25^26^27
+58 ;;+9^579^580^581
+59 ;;+10^614^615
+60 ;;07.71^OQ^
+61 ;;+1^23^24^25^26^27
+62 ;;+10^614^615
+63 ;;07.72^OQ^
+64 ;;+1^23^24^25^26^27
+65 ;;+9^579^580^581
+66 ;;+10^614^615
+67 ;;07.79^OQ^
+68 ;;+1^23^24^25^26^27
+69 ;;+9^579^580^581
+70 ;;+10^614^615
+71 ;;51.23^OT
+72 ;;+6^356^357^358
+73 ;;+7^411^412^413^417^418^419
+74 ;;+17^820^821^822^826^827^828
+75 ;;+21^907^908^909
+76 ;;+24^957^958^959
+77 ;;57.6^O
+78 ;;+11^653^654^655
+79 ;;+12^707^708
+80 ;;+13^749^750
+81 ;;+17^820^821^822^826^827^828
+82 ;;+21^907^908^909
+83 ;;+24^957^958^959
+84 ;;57.71^O
+85 ;;+11^653^654^655
+86 ;;+12^707^708
+87 ;;+13^749^750
+88 ;;+17^820^821^822^826^827^828
+89 ;;57.79^O
+90 ;;+11^653^654^655
+91 ;;+12^707^708
+92 ;;+13^749^750
+93 ;;+17^820^821^822^826^827^828
+94 ;;+21^907^908^909
+95 ;;+24^957^958^959
+96 ;;57.71^O
+97 ;;+11^653^654^655
+98 ;;+12^707^708
+99 ;;+13^749^750
+100 ;;+17^820^821^822^826^827^828
+101 ;;+21^907^908^909
+102 ;;+24^957^958^959
+103 ;;57.88^O
+104 ;;+11^653^654^655
+105 ;;+12^707^708
+106 ;;+17^820^821^822^826^827^828
+107 ;;01.12^OQ
+108 ;;+1^23^24^25^26^27
+109 ;;+17^820^821^822^826^827^828
+110 ;;01.14^OQ
+111 ;;+1^23^24^25^26^27
+112 ;;+17^820^821^822^826^827^828
+113 ;;01.42^OQ
+114 ;;+1^23^24^25^26^27
+115 ;;+17^820^821^822^826^827^828
+116 ;;+24^955
+117 ;;01.51^OQ
+118 ;;+1^23^24^25^26^27
+119 ;;+17^820^821^822^826^827^828
+120 ;;+24^955
+121 ;;01.52^OQ
+122 ;;+1^23^24^25^26^27
+123 ;;+17^820^821^822^826^827^828
+124 ;;+24^955
+125 ;;01.53^OQ
+126 ;;+1^23^24^25^26^27
+127 ;;+17^820^821^822^826^827^828
+128 ;;+24^955
+129 ;;01.59^OQ
+130 ;;+1^23^24^25^26^27
+131 ;;+17^820^821^822^826^827^828
+132 ;;+24^955
+133 ;;02.99^OQ
+134 ;;+1^23^24^25^26^27
+135 ;;+3^131^132
+136 ;;+8^515^516^517
+137 ;;+17^820^821^822^826^827^828
+138 ;;+21^907^908^909
+139 ;;+24^955
+140 ;;02.91^OQ
+141 ;;+1^23^24^25^26^27
+142 ;;+17^820^821^822^826^827^828
+143 ;;+21^907^908^909
+144 ;;+24^955
+145 ;;01.18^OQ
+146 ;;+1^23^24^25^26^27
+147 ;;+17^820^821^822^826^827^828
+148 ;;+21^907^908^909
+149 ;;+24^957^958^959
+150 ;;01.23^OQ
+151 ;;+1^23^24^25^26^27
+152 ;;+3^131^132
+153 ;;+17^820^821^822^826^827^828
+154 ;;+21^907^908^909
+155 ;;+24^955
+156 ;;01.24^OQ
+157 ;;+1^23^24^25^26^27
+158 ;;+3^131^132
+159 ;;+17^820^821^822^826^827^828
+160 ;;+21^907^908^909
+161 ;;+24^955
+162 ;;01.31^OQ
+163 ;;+1^23^24^25^26^27
+164 ;;+17^820^821^822^826^827^828
+165 ;;+21^907^908^909
+166 ;;+24^955
+167 ;;01.32^OQ
+168 ;;+1^23^24^25^26^27
+169 ;;+17^820^821^822^826^827^828
+170 ;;+21^907^908^909
+171 ;;+24^955
+172 ;;01.39^OQ
+173 ;;+1^23^24^25^26^27
+174 ;;+17^820^821^822^826^827^828
+175 ;;+21^907^908^909
+176 ;;+24^955
+177 ;;01.41^OQ
+178 ;;+1^23^24^25^26^27
+179 ;;+17^820^821^822^826^827^828
+180 ;;+21^907^908^909
+181 ;;+24^955
+182 ;;EXIT
