ICD1824C ; ALB/JAT - FY 2007 UPDATE; 7/27/05 14:50;
;;18.0;DRG Grouper;**24**;Oct 13,2000;Build 5
Q
;
DIAG ; - update diagnosis codes
; from Table 6A in Fed Reg - assumes new codes already added by Lexicon
D BMES^XPDUTL(">>>Modifying new diagnosis codes - file 80")
N LINE,X,ICDDIAG,ENTRY,DA,DIE,DR,IDENT,MDC,MDC25,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
..S DA=ENTRY,DIE="^ICD9("
..S IDENT=$P(ICDDIAG,U,2)
..S MDC=$P(ICDDIAG,U,3)
..;this would only apply to diagnoses who have no other MDC than a pre-MDC
..I MDC="PRE" S MDC=98
..S MDC25=$P(ICDDIAG,U,4)
..S DR="2///^S X=IDENT;5///^S X=MDC;5.9///^S X=MDC25"
..D ^DIE
..;check if already created in case patch being re-installed
..Q:$D(^ICD9(ENTRY,3,"B",3061001))
..; add 80.071 and 80.711 and 80.072 records
..N FDA
..S FDA(1820,80,"?1,",.01)="`"_ENTRY
..S FDA(1820,80.071,"+2,?1,",.01)=3061001
..S FDA(1820,80.072,"+3,?1,",.01)=3061001
..S FDA(1820,80.072,"+3,?1,",1)=$P(ICDDIAG,U,3)
..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,5)
..I $P(ICDDIAG,U,6) S FDA(1820,80.711,"+4,?2,?1,",.01)=$P(ICDDIAG,U,6)
..I $P(ICDDIAG,U,7) S FDA(1820,80.711,"+5,?2,?1,",.01)=$P(ICDDIAG,U,7)
..I $P(ICDDIAG,U,8) S FDA(1820,80.711,"+6,?2,?1,",.01)=$P(ICDDIAG,U,8)
..I $P(ICDDIAG,U,9) S FDA(1820,80.711,"+7,?2,?1,",.01)=$P(ICDDIAG,U,9)
..I $P(ICDDIAG,U,10) S FDA(1820,80.711,"+8,?2,?1,",.01)=$P(ICDDIAG,U,10)
..D UPDATE^DIE("","FDA(1820)") K FDA(1820)
Q
;
REVD ;
;;052.2^Q^1^^543^561
;;053.14^Q^1^^543^561
;;054.74^Q^1^^543^561
;;238.71^^16^^398^399
;;238.72^^16^^395^396
;;238.73^^16^^395^396
;;238.74^^16^^395^396
;;238.75^^16^^395^396
;;238.76^^17^^401^402^403^404^539^540
;;238.79^^17^^401^402^403^404^539^540
;;277.30^^8^^240^241
;;277.31^^8^^240^241
;;277.39^^8^^240^241
;;284.01^^16^^574
;;284.09^^16^^574
;;284.1^^16^^395^396
;;284.2^^17^^401^402^403^404^539^540
;;288.00^^16^3^574^490
;;288.01^^16^3^574^490
;;288.02^^16^3^574^490
;;288.03^^16^3^574^490
;;288.04^^16^3^574^490
;;288.09^^16^3^574^490
;;288.4^^16^^398^399
;;288.50^^16^^398^399
;;288.51^^16^^398^399
;;288.59^^16^^398^399
;;288.60^^16^^398^398
;;288.61^^16^^398^398
;;288.62^^16^^398^398
;;288.63^^16^^398^398
;;288.64^^16^^398^398
;;288.65^^16^^398^398
;;288.69^^16^^398^398
;;289.53^^16^^398^399
;;289.83^^17^^401^402^403^404^539^540
;;323.01^Q^1^^543^561
;;323.02^Q^1^^543^561
;;323.41^Q^1^^543^561
;;323.42^Q^1^^543^561
;;323.51^Q^1^^543^561
;;323.52^Q^1^^543^561
;;323.61^Q^1^^543^561
;;323.62^Q^1^^543^561
;;323.63^Q^1^^543^561
;;323.71^Q^1^^34^35^543
;;323.72^Q^1^^34^35^543
;;323.81^Q^1^3^543^561^489
;;323.82^Q^1^3^543^561^489
;;331.83^^1^^12
;;333.71^^1^^12
;;333.72^^1^^34^35
;;333.79^^1^^34^35
;;333.85^^1^^34^35
;;333.94^^1^^12
;;338.0^^23^^463^464
;;338.11^^23^^463^464
;;338.12^^23^^463^464
;;338.18^^23^^463^464
;;338.19^^23^^463^464
;;338.21^^23^^463^464
;;338.22^^23^^463^464
;;338.28^^23^^463^464
;;338.29^^23^^463^464
;;338.3^^23^^463^464
;;338.4^^23^^463^464
;;341.20^^1^^543^561
;;341.21^^1^^543^561
;;341.22^^1^^543^561
;;377.43^^2^^45
;;379.60^^2^^46^47^48
;;379.61^^2^^46^47^48
;;379.62^^2^^46^47^48
;;379.63^^2^^46^47^48
;;389.15^^3^^73^74
;;389.16^^3^^73^74
;;429.83^^5^^144^145
;;478.11^^3^^73^74
;;478.19^^3^^73^74
;;518.7^^4^^101^102
;;519.11^Y^4^^96^97^98
;;519.19^Y^4^^96^97^98
;;521.81^Y^3^^185^186^187
;;521.89^Y^3^^185^186^187
;;523.00^Y^3^^185^186^187
;;523.01^Y^3^^185^186^187
;;523.10^Y^3^^185^186^187
;;523.11^Y^3^^185^186^187
;;523.30^Y^3^^185^186^187
;;523.31^Y^3^^185^186^187
;;523.32^Y^3^^185^186^187
;;523.33^Y^3^^185^186^187
;;523.40^Y^3^^185^186^187
;;523.41^Y^3^^185^186^187
;;523.42^Y^3^^185^186^187
;;525.60^Y^3^^185^186^187
;;525.61^Y^3^^185^186^187
;;525.62^Y^3^^185^186^187
;;525.63^Y^3^^185^186^187
;;525.64^Y^3^^185^186^187
;;525.65^Y^3^^185^186^187
;;525.66^Y^3^^185^186^187
;;525.67^Y^3^^185^186^187
;;525.69^Y^3^^185^186^187
;;526.61^Y^3^^185^186^187
;;526.62^Y^3^^185^186^187
;;526.63^Y^3^^185^186^187
;;526.69^Y^3^^185^186^187
;;528.00^Y^3^^185^186^187
;;528.01^Y^3^^185^186^187
;;528.02^Y^3^^185^186^187
;;528.09^Y^3^^185^186^187
;;538.^^6^^182^183^184
;;608.20^^12^^352
;;608.21^^12^^352
;;608.22^^12^^352
;;608.23^^12^^352
;;608.24^^12^^352
;;616.81^^13^^358^359^368
;;616.89^^13^^358^359^368
;;618.84^^13^^358^359^369
;;629.29^^13^^358^359^369
;;629.81^^13^^358^359^369
;;629.89^^13^^358^359^369
;;649.00^^14^^469
;;649.01^^14^^370^371^372^373^374^375
;;649.02^^14^^370^371^372^373^374^375
;;649.03^^14^^383^384
;;649.04^^14^^376^377
;;649.10^^14^^469
;;649.11^^14^^370^371^372^373^374^375
;;649.12^^14^^370^371^372^373^374^375
;;649.13^^14^^383^384
;;649.14^^14^^376^377
;;649.20^^14^^469
;;649.21^^14^^370^371^372^373^374^375
;;649.22^^14^^370^371^372^373^374^375
;;649.23^^14^^383^384
;;649.24^^14^^376^377
;;649.30^^14^^469
;;649.31^^14^^370^371^372^373^374^375
;;649.32^^14^^370^371^372^373^374^375
;;649.33^^14^^383^384
;;649.34^^14^^376^377
;;649.40^^14^^469
;;649.41^^14^^370^371^372^373^374^375
;;649.42^^14^^370^371^372^373^374^375
;;649.43^^14^^383^384
;;649.44^^14^^376^377
;;649.50^^14^^469
;;649.51^^14^^370^371^372^373^374^375
;;649.53^^14^^383^384
;;649.60^^14^^469
;;649.61^^14^^370^371^372^373^374^375
;;649.62^^14^^370^371^372^373^374^375
;;649.63^^14^^383^384
;;649.64^^14^^376^377
;;729.71^^8^^248
;;729.72^^8^^248
;;729.73^^8^^248
;;729.79^^8^^248
;;731.3^^8^^244^245
;;768.7^^15^^390
;;770.87^^15^^390
;;770.88^^15^^390
;;775.81^^15^^390
;;775.89^^15^^390
;;779.85^^15^^387^389
;;780.32^^1^^26^562^563
;;780.96^^23^^463^464
;;780.97^^23^^463^464
;;784.91^^3^^73^74
;;784.99^^3^^73^74
;;788.64^^11^^325^326^327
;;788.65^^11^^325^326^327
;;793.91^^23^^463^464
;;793.99^^23^^463^464
;;795.06^^13^^358^359^369
;;795.81^^23^^463^464
;;795.82^^23^^463^464
;;795.89^^23^^463^464
;;958.90^^21^^454^455
;;958.91^^21^^454^455
;;958.92^^21^^454^455
;;958.93^^21^^454^455
;;958.99^^21^^454^455
;;995.20^^21^^449^450^451
;;995.21^^21^^449^450^451
;;995.22^^21^^449^450^451
;;995.23^^21^^449^450^451
;;995.27^^21^^449^450^451
;;995.29^^21^^449^450^451
;;V18.51^^23^^467
;;V18.59^^23^^467
;;V26.34^^23^^467
;;V26.35^^23^^467
;;V26.39^^23^^467
;;V45.86^^23^^467
;;V58.30^^23^^467
;;V58.31^^23^^467
;;V58.32^^23^^467
;;V72.11^^23^^467
;;V72.19^^23^^467
;;V82.71^^23^^467
;;V82.79^^23^^467
;;V85.51^^23^^467
;;V85.52^^23^^467
;;V85.53^^23^^467
;;V85.54^^23^^467
;;V86.0^^23^^467
;;V86.1^^23^^467
;;EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1824C 7137 printed Dec 13, 2024@01:48:09 Page 2
ICD1824C ; 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 ; - update diagnosis codes
+1 ; from Table 6A in Fed Reg - assumes new codes already added by Lexicon
+2 DO BMES^XPDUTL(">>>Modifying new diagnosis codes - file 80")
+3 NEW LINE,X,ICDDIAG,ENTRY,DA,DIE,DR,IDENT,MDC,MDC25,FDA
+4 FOR LINE=1:1
SET X=$TEXT(REVD+LINE)
SET ICDDIAG=$PIECE(X,";;",2)
if ICDDIAG="EXIT"
QUIT
Begin DoDot:1
+5 SET ENTRY=+$ORDER(^ICD9("BA",$PIECE(ICDDIAG,U)_" ",0))
+6 IF ENTRY
Begin DoDot:2
+7 ;check for possible inactive dupe
+8 IF $PIECE($GET(^ICD9(ENTRY,0)),U,9)=1
SET ENTRY=+$ORDER(^ICD9("BA",$PIECE(ICDDIAG,U)_" ",ENTRY))
IF 'ENTRY
QUIT
+9 SET DA=ENTRY
SET DIE="^ICD9("
+10 SET IDENT=$PIECE(ICDDIAG,U,2)
+11 SET MDC=$PIECE(ICDDIAG,U,3)
+12 ;this would only apply to diagnoses who have no other MDC than a pre-MDC
+13 IF MDC="PRE"
SET MDC=98
+14 SET MDC25=$PIECE(ICDDIAG,U,4)
+15 SET DR="2///^S X=IDENT;5///^S X=MDC;5.9///^S X=MDC25"
+16 DO ^DIE
+17 ;check if already created in case patch being re-installed
+18 if $DATA(^ICD9(ENTRY,3,"B",3061001))
QUIT
+19 ; add 80.071 and 80.711 and 80.072 records
+20 NEW FDA
+21 SET FDA(1820,80,"?1,",.01)="`"_ENTRY
+22 SET FDA(1820,80.071,"+2,?1,",.01)=3061001
+23 SET FDA(1820,80.072,"+3,?1,",.01)=3061001
+24 SET FDA(1820,80.072,"+3,?1,",1)=$PIECE(ICDDIAG,U,3)
+25 DO UPDATE^DIE("","FDA(1820)")
KILL FDA(1820)
+26 SET FDA(1820,80,"?1,",.01)="`"_ENTRY
+27 SET FDA(1820,80.071,"?2,?1,",.01)=3061001
+28 SET FDA(1820,80.711,"+3,?2,?1,",.01)=$PIECE(ICDDIAG,U,5)
+29 IF $PIECE(ICDDIAG,U,6)
SET FDA(1820,80.711,"+4,?2,?1,",.01)=$PIECE(ICDDIAG,U,6)
+30 IF $PIECE(ICDDIAG,U,7)
SET FDA(1820,80.711,"+5,?2,?1,",.01)=$PIECE(ICDDIAG,U,7)
+31 IF $PIECE(ICDDIAG,U,8)
SET FDA(1820,80.711,"+6,?2,?1,",.01)=$PIECE(ICDDIAG,U,8)
+32 IF $PIECE(ICDDIAG,U,9)
SET FDA(1820,80.711,"+7,?2,?1,",.01)=$PIECE(ICDDIAG,U,9)
+33 IF $PIECE(ICDDIAG,U,10)
SET FDA(1820,80.711,"+8,?2,?1,",.01)=$PIECE(ICDDIAG,U,10)
+34 DO UPDATE^DIE("","FDA(1820)")
KILL FDA(1820)
End DoDot:2
End DoDot:1
+35 QUIT
+36 ;
REVD ;
+1 ;;052.2^Q^1^^543^561
+2 ;;053.14^Q^1^^543^561
+3 ;;054.74^Q^1^^543^561
+4 ;;238.71^^16^^398^399
+5 ;;238.72^^16^^395^396
+6 ;;238.73^^16^^395^396
+7 ;;238.74^^16^^395^396
+8 ;;238.75^^16^^395^396
+9 ;;238.76^^17^^401^402^403^404^539^540
+10 ;;238.79^^17^^401^402^403^404^539^540
+11 ;;277.30^^8^^240^241
+12 ;;277.31^^8^^240^241
+13 ;;277.39^^8^^240^241
+14 ;;284.01^^16^^574
+15 ;;284.09^^16^^574
+16 ;;284.1^^16^^395^396
+17 ;;284.2^^17^^401^402^403^404^539^540
+18 ;;288.00^^16^3^574^490
+19 ;;288.01^^16^3^574^490
+20 ;;288.02^^16^3^574^490
+21 ;;288.03^^16^3^574^490
+22 ;;288.04^^16^3^574^490
+23 ;;288.09^^16^3^574^490
+24 ;;288.4^^16^^398^399
+25 ;;288.50^^16^^398^399
+26 ;;288.51^^16^^398^399
+27 ;;288.59^^16^^398^399
+28 ;;288.60^^16^^398^398
+29 ;;288.61^^16^^398^398
+30 ;;288.62^^16^^398^398
+31 ;;288.63^^16^^398^398
+32 ;;288.64^^16^^398^398
+33 ;;288.65^^16^^398^398
+34 ;;288.69^^16^^398^398
+35 ;;289.53^^16^^398^399
+36 ;;289.83^^17^^401^402^403^404^539^540
+37 ;;323.01^Q^1^^543^561
+38 ;;323.02^Q^1^^543^561
+39 ;;323.41^Q^1^^543^561
+40 ;;323.42^Q^1^^543^561
+41 ;;323.51^Q^1^^543^561
+42 ;;323.52^Q^1^^543^561
+43 ;;323.61^Q^1^^543^561
+44 ;;323.62^Q^1^^543^561
+45 ;;323.63^Q^1^^543^561
+46 ;;323.71^Q^1^^34^35^543
+47 ;;323.72^Q^1^^34^35^543
+48 ;;323.81^Q^1^3^543^561^489
+49 ;;323.82^Q^1^3^543^561^489
+50 ;;331.83^^1^^12
+51 ;;333.71^^1^^12
+52 ;;333.72^^1^^34^35
+53 ;;333.79^^1^^34^35
+54 ;;333.85^^1^^34^35
+55 ;;333.94^^1^^12
+56 ;;338.0^^23^^463^464
+57 ;;338.11^^23^^463^464
+58 ;;338.12^^23^^463^464
+59 ;;338.18^^23^^463^464
+60 ;;338.19^^23^^463^464
+61 ;;338.21^^23^^463^464
+62 ;;338.22^^23^^463^464
+63 ;;338.28^^23^^463^464
+64 ;;338.29^^23^^463^464
+65 ;;338.3^^23^^463^464
+66 ;;338.4^^23^^463^464
+67 ;;341.20^^1^^543^561
+68 ;;341.21^^1^^543^561
+69 ;;341.22^^1^^543^561
+70 ;;377.43^^2^^45
+71 ;;379.60^^2^^46^47^48
+72 ;;379.61^^2^^46^47^48
+73 ;;379.62^^2^^46^47^48
+74 ;;379.63^^2^^46^47^48
+75 ;;389.15^^3^^73^74
+76 ;;389.16^^3^^73^74
+77 ;;429.83^^5^^144^145
+78 ;;478.11^^3^^73^74
+79 ;;478.19^^3^^73^74
+80 ;;518.7^^4^^101^102
+81 ;;519.11^Y^4^^96^97^98
+82 ;;519.19^Y^4^^96^97^98
+83 ;;521.81^Y^3^^185^186^187
+84 ;;521.89^Y^3^^185^186^187
+85 ;;523.00^Y^3^^185^186^187
+86 ;;523.01^Y^3^^185^186^187
+87 ;;523.10^Y^3^^185^186^187
+88 ;;523.11^Y^3^^185^186^187
+89 ;;523.30^Y^3^^185^186^187
+90 ;;523.31^Y^3^^185^186^187
+91 ;;523.32^Y^3^^185^186^187
+92 ;;523.33^Y^3^^185^186^187
+93 ;;523.40^Y^3^^185^186^187
+94 ;;523.41^Y^3^^185^186^187
+95 ;;523.42^Y^3^^185^186^187
+96 ;;525.60^Y^3^^185^186^187
+97 ;;525.61^Y^3^^185^186^187
+98 ;;525.62^Y^3^^185^186^187
+99 ;;525.63^Y^3^^185^186^187
+100 ;;525.64^Y^3^^185^186^187
+101 ;;525.65^Y^3^^185^186^187
+102 ;;525.66^Y^3^^185^186^187
+103 ;;525.67^Y^3^^185^186^187
+104 ;;525.69^Y^3^^185^186^187
+105 ;;526.61^Y^3^^185^186^187
+106 ;;526.62^Y^3^^185^186^187
+107 ;;526.63^Y^3^^185^186^187
+108 ;;526.69^Y^3^^185^186^187
+109 ;;528.00^Y^3^^185^186^187
+110 ;;528.01^Y^3^^185^186^187
+111 ;;528.02^Y^3^^185^186^187
+112 ;;528.09^Y^3^^185^186^187
+113 ;;538.^^6^^182^183^184
+114 ;;608.20^^12^^352
+115 ;;608.21^^12^^352
+116 ;;608.22^^12^^352
+117 ;;608.23^^12^^352
+118 ;;608.24^^12^^352
+119 ;;616.81^^13^^358^359^368
+120 ;;616.89^^13^^358^359^368
+121 ;;618.84^^13^^358^359^369
+122 ;;629.29^^13^^358^359^369
+123 ;;629.81^^13^^358^359^369
+124 ;;629.89^^13^^358^359^369
+125 ;;649.00^^14^^469
+126 ;;649.01^^14^^370^371^372^373^374^375
+127 ;;649.02^^14^^370^371^372^373^374^375
+128 ;;649.03^^14^^383^384
+129 ;;649.04^^14^^376^377
+130 ;;649.10^^14^^469
+131 ;;649.11^^14^^370^371^372^373^374^375
+132 ;;649.12^^14^^370^371^372^373^374^375
+133 ;;649.13^^14^^383^384
+134 ;;649.14^^14^^376^377
+135 ;;649.20^^14^^469
+136 ;;649.21^^14^^370^371^372^373^374^375
+137 ;;649.22^^14^^370^371^372^373^374^375
+138 ;;649.23^^14^^383^384
+139 ;;649.24^^14^^376^377
+140 ;;649.30^^14^^469
+141 ;;649.31^^14^^370^371^372^373^374^375
+142 ;;649.32^^14^^370^371^372^373^374^375
+143 ;;649.33^^14^^383^384
+144 ;;649.34^^14^^376^377
+145 ;;649.40^^14^^469
+146 ;;649.41^^14^^370^371^372^373^374^375
+147 ;;649.42^^14^^370^371^372^373^374^375
+148 ;;649.43^^14^^383^384
+149 ;;649.44^^14^^376^377
+150 ;;649.50^^14^^469
+151 ;;649.51^^14^^370^371^372^373^374^375
+152 ;;649.53^^14^^383^384
+153 ;;649.60^^14^^469
+154 ;;649.61^^14^^370^371^372^373^374^375
+155 ;;649.62^^14^^370^371^372^373^374^375
+156 ;;649.63^^14^^383^384
+157 ;;649.64^^14^^376^377
+158 ;;729.71^^8^^248
+159 ;;729.72^^8^^248
+160 ;;729.73^^8^^248
+161 ;;729.79^^8^^248
+162 ;;731.3^^8^^244^245
+163 ;;768.7^^15^^390
+164 ;;770.87^^15^^390
+165 ;;770.88^^15^^390
+166 ;;775.81^^15^^390
+167 ;;775.89^^15^^390
+168 ;;779.85^^15^^387^389
+169 ;;780.32^^1^^26^562^563
+170 ;;780.96^^23^^463^464
+171 ;;780.97^^23^^463^464
+172 ;;784.91^^3^^73^74
+173 ;;784.99^^3^^73^74
+174 ;;788.64^^11^^325^326^327
+175 ;;788.65^^11^^325^326^327
+176 ;;793.91^^23^^463^464
+177 ;;793.99^^23^^463^464
+178 ;;795.06^^13^^358^359^369
+179 ;;795.81^^23^^463^464
+180 ;;795.82^^23^^463^464
+181 ;;795.89^^23^^463^464
+182 ;;958.90^^21^^454^455
+183 ;;958.91^^21^^454^455
+184 ;;958.92^^21^^454^455
+185 ;;958.93^^21^^454^455
+186 ;;958.99^^21^^454^455
+187 ;;995.20^^21^^449^450^451
+188 ;;995.21^^21^^449^450^451
+189 ;;995.22^^21^^449^450^451
+190 ;;995.23^^21^^449^450^451
+191 ;;995.27^^21^^449^450^451
+192 ;;995.29^^21^^449^450^451
+193 ;;V18.51^^23^^467
+194 ;;V18.59^^23^^467
+195 ;;V26.34^^23^^467
+196 ;;V26.35^^23^^467
+197 ;;V26.39^^23^^467
+198 ;;V45.86^^23^^467
+199 ;;V58.30^^23^^467
+200 ;;V58.31^^23^^467
+201 ;;V58.32^^23^^467
+202 ;;V72.11^^23^^467
+203 ;;V72.19^^23^^467
+204 ;;V82.71^^23^^467
+205 ;;V82.79^^23^^467
+206 ;;V85.51^^23^^467
+207 ;;V85.52^^23^^467
+208 ;;V85.53^^23^^467
+209 ;;V85.54^^23^^467
+210 ;;V86.0^^23^^467
+211 ;;V86.1^^23^^467
+212 ;;EXIT
