ICD1832U ; ALB/DHH - FY 2008 UPDATE; 7/27/05 14:50;
;;18.0;DRG Grouper;**32**;Oct 13,2000;Build 9
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 MDC24=$P(ICDDIAG,U,5)
..S DR="2///^S X=IDENT;5///^S X=MDC;5.9///^S X=MDC25;5.7///^S X=MDC24"
..D ^DIE
..Q:$D(^ICD9(ENTRY,4,"B",3071001))
..N FDA
..S FDA(1820,80,"?1,",.01)="`"_ENTRY
..S FDA(1820,80.072,"+3,?1,",.01)=3071001
..S FDA(1820,80.072,"+3,?1,",1)=$P(ICDDIAG,U,3)
..D UPDATE^DIE("","FDA(1820)") K FDA(1820)
Q
;
REVD ;DIAG^IDEN^MDC^MDC25
;;338.4^^1
;;040.41^^18
;;040.42^^18
;;058.10^^18
;;058.11^^18
;;058.12^^18
;;058.81^^9
;;058.82^^9
;;058.89^^9
;;079.83^^18
;;233.30^^13
;;233.31^^13
;;233.32^^13
;;233.39^^13
;;255.41^^10
;;255.42^^10
;;258.01^^10
;;258.02^^10
;;258.03^^10
;;288.66^^16
;;315.34^^19
;;331.5^^1
;;359.21^^1
;;359.22^^1
;;359.23^^1
;;359.24^^1
;;359.29^^1
;;364.81^^2
;;364.89^^2
;;388.45^^19
;;389.05^^3
;;389.06^^3
;;389.13^^3
;;389.17^^3
;;389.20^^3
;;389.21^^3
;;389.22^^3
;;414.2^^4
;;415.12^^4
;;423.3^^5
;;440.4^^5
;;449.^^5
;;488.^^3
;;525.71^^3
;;525.72^^3
;;525.73^^3
;;525.79^^3
;;569.43^^6
;;624.01^^13
;;624.02^^13
;;624.09^^13
;;664.60^^14
;;664.61^^14
;;664.64^^14
;;733.45^^8
;;787.20^^6
;;787.21^^6
;;787.22^^6
;;787.23^^6
;;787.24^^6
;;787.29^^6
;;789.51^^23
;;789.59^^23
;;999.31^^5
;;999.39^^18
;;V12.53^^23
;;V12.54^^23
;;V13.22^^17
;;V16.52^^23
;;V17.41^^23
;;V17.49^^23
;;V18.11^^23
;;V18.19^^23
;;V25.04^^23
;;V26.41^^23
;;V26.49^^23
;;V26.81^^23
;;V26.89^^23
;;V49.85^^23
;;V68.01^^23
;;V68.09^^23
;;V72.12^^23
;;V73.81^^23
;;V84.81^^23
;;V84.89^^23
;;EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1832U 2428 printed Sep 23, 2025@19:24:44 Page 2
ICD1832U ; ALB/DHH - FY 2008 UPDATE; 7/27/05 14:50;
+1 ;;18.0;DRG Grouper;**32**;Oct 13,2000;Build 9
+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 MDC24=$PIECE(ICDDIAG,U,5)
+16 SET DR="2///^S X=IDENT;5///^S X=MDC;5.9///^S X=MDC25;5.7///^S X=MDC24"
+17 DO ^DIE
+18 if $DATA(^ICD9(ENTRY,4,"B",3071001))
QUIT
+19 NEW FDA
+20 SET FDA(1820,80,"?1,",.01)="`"_ENTRY
+21 SET FDA(1820,80.072,"+3,?1,",.01)=3071001
+22 SET FDA(1820,80.072,"+3,?1,",1)=$PIECE(ICDDIAG,U,3)
+23 DO UPDATE^DIE("","FDA(1820)")
KILL FDA(1820)
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
REVD ;DIAG^IDEN^MDC^MDC25
+1 ;;338.4^^1
+2 ;;040.41^^18
+3 ;;040.42^^18
+4 ;;058.10^^18
+5 ;;058.11^^18
+6 ;;058.12^^18
+7 ;;058.81^^9
+8 ;;058.82^^9
+9 ;;058.89^^9
+10 ;;079.83^^18
+11 ;;233.30^^13
+12 ;;233.31^^13
+13 ;;233.32^^13
+14 ;;233.39^^13
+15 ;;255.41^^10
+16 ;;255.42^^10
+17 ;;258.01^^10
+18 ;;258.02^^10
+19 ;;258.03^^10
+20 ;;288.66^^16
+21 ;;315.34^^19
+22 ;;331.5^^1
+23 ;;359.21^^1
+24 ;;359.22^^1
+25 ;;359.23^^1
+26 ;;359.24^^1
+27 ;;359.29^^1
+28 ;;364.81^^2
+29 ;;364.89^^2
+30 ;;388.45^^19
+31 ;;389.05^^3
+32 ;;389.06^^3
+33 ;;389.13^^3
+34 ;;389.17^^3
+35 ;;389.20^^3
+36 ;;389.21^^3
+37 ;;389.22^^3
+38 ;;414.2^^4
+39 ;;415.12^^4
+40 ;;423.3^^5
+41 ;;440.4^^5
+42 ;;449.^^5
+43 ;;488.^^3
+44 ;;525.71^^3
+45 ;;525.72^^3
+46 ;;525.73^^3
+47 ;;525.79^^3
+48 ;;569.43^^6
+49 ;;624.01^^13
+50 ;;624.02^^13
+51 ;;624.09^^13
+52 ;;664.60^^14
+53 ;;664.61^^14
+54 ;;664.64^^14
+55 ;;733.45^^8
+56 ;;787.20^^6
+57 ;;787.21^^6
+58 ;;787.22^^6
+59 ;;787.23^^6
+60 ;;787.24^^6
+61 ;;787.29^^6
+62 ;;789.51^^23
+63 ;;789.59^^23
+64 ;;999.31^^5
+65 ;;999.39^^18
+66 ;;V12.53^^23
+67 ;;V12.54^^23
+68 ;;V13.22^^17
+69 ;;V16.52^^23
+70 ;;V17.41^^23
+71 ;;V17.49^^23
+72 ;;V18.11^^23
+73 ;;V18.19^^23
+74 ;;V25.04^^23
+75 ;;V26.41^^23
+76 ;;V26.49^^23
+77 ;;V26.81^^23
+78 ;;V26.89^^23
+79 ;;V49.85^^23
+80 ;;V68.01^^23
+81 ;;V68.09^^23
+82 ;;V72.12^^23
+83 ;;V73.81^^23
+84 ;;V84.81^^23
+85 ;;V84.89^^23
+86 ;;EXIT
