ICD1831U ; ALB/DHH - FY 2008 UPDATE; 7/27/05 14:50;
;;18.0;DRG Grouper;**31**;Oct 13,2000;Build 7
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.0^^1
;;338.21^^1
;;338.22^^1
;;338.28^^1
;;338.29^^1
;;807.14^^4^^0
;;807.15^^4^^0
;;807.16^^4^^0
;;807.17^^4^^0
;;807.18^^4^^0
;;807.19^^4^^0
;;807.3^^4^^0
;;807.4^^4^^0
;;839.71^^4^^0
;;861.22^^4^^0
;;861.32^^4^^0
;;862.0^^4^^0
;;862.1^^4^^0
;;862.21^^4^^0
;;862.31^^4^^0
;;874.12^^4^^0
;;860.0^^4^^0
;;860.1^^4^^0
;;860.3^^4^^0
;;860.5^^4^^0
;;015.02^6^8
;;015.04^6^8
;;015.05^6^8
;;730.28^6^8
;;737.40^6^8
;;737.41^6^8
;;737.42^6^8
;;737.43^6^8
;;V58.11^^17
;;V58.12^^17
;;V67.2^^17
;;V58.0^^17
;;V67.1^^17
;;200.30^L^17^2
;;200.31^L^17^2
;;200.32^L^17^2
;;200.33^L^17^2
;;200.34^L^17^2
;;200.35^L^17^2
;;200.36^L^17^2
;;200.37^L^17^2
;;200.38^L^17^2
;;200.40^L^17^2
;;200.41^L^17^2
;;200.42^L^17^2
;;200.43^L^17^2
;;200.44^L^17^2
;;200.45^L^17^2
;;200.46^L^17^2
;;200.47^L^17^2
;;200.48^L^17^2
;;200.50^L^17^2
;;200.51^L^17^2
;;200.52^L^17^2
;;200.53^L^17^2
;;200.54^L^17^2
;;200.55^L^17^2
;;200.56^L^17^2
;;200.57^L^17^2
;;200.58^L^17^2
;;200.60^L^17^2
;;200.61^L^17^2
;;200.62^L^17^2
;;200.63^L^17^2
;;200.64^L^17^2
;;200.65^L^17^2
;;200.66^L^17^2
;;200.67^L^17^2
;;200.68^L^17^2
;;200.70^L^17^2
;;200.71^L^17^2
;;200.72^L^17^2
;;200.73^L^17^2
;;200.74^L^17^2
;;200.75^L^17^2
;;200.76^L^17^2
;;200.77^L^17^2
;;200.78^L^17^2
;;202.70^L^17^2
;;202.71^L^17^2
;;202.72^L^17^2
;;202.73^L^17^2
;;202.74^L^17^2
;;202.75^L^17^2
;;202.76^L^17^2
;;202.77^L^17^2
;;202.78^L^17^2
;;058.21^Q^1
;;058.29^Q^1
;;EXIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICD1831U 2795 printed Dec 13, 2024@01:48:37 Page 2
ICD1831U ; ALB/DHH - FY 2008 UPDATE; 7/27/05 14:50;
+1 ;;18.0;DRG Grouper;**31**;Oct 13,2000;Build 7
+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.0^^1
+2 ;;338.21^^1
+3 ;;338.22^^1
+4 ;;338.28^^1
+5 ;;338.29^^1
+6 ;;807.14^^4^^0
+7 ;;807.15^^4^^0
+8 ;;807.16^^4^^0
+9 ;;807.17^^4^^0
+10 ;;807.18^^4^^0
+11 ;;807.19^^4^^0
+12 ;;807.3^^4^^0
+13 ;;807.4^^4^^0
+14 ;;839.71^^4^^0
+15 ;;861.22^^4^^0
+16 ;;861.32^^4^^0
+17 ;;862.0^^4^^0
+18 ;;862.1^^4^^0
+19 ;;862.21^^4^^0
+20 ;;862.31^^4^^0
+21 ;;874.12^^4^^0
+22 ;;860.0^^4^^0
+23 ;;860.1^^4^^0
+24 ;;860.3^^4^^0
+25 ;;860.5^^4^^0
+26 ;;015.02^6^8
+27 ;;015.04^6^8
+28 ;;015.05^6^8
+29 ;;730.28^6^8
+30 ;;737.40^6^8
+31 ;;737.41^6^8
+32 ;;737.42^6^8
+33 ;;737.43^6^8
+34 ;;V58.11^^17
+35 ;;V58.12^^17
+36 ;;V67.2^^17
+37 ;;V58.0^^17
+38 ;;V67.1^^17
+39 ;;200.30^L^17^2
+40 ;;200.31^L^17^2
+41 ;;200.32^L^17^2
+42 ;;200.33^L^17^2
+43 ;;200.34^L^17^2
+44 ;;200.35^L^17^2
+45 ;;200.36^L^17^2
+46 ;;200.37^L^17^2
+47 ;;200.38^L^17^2
+48 ;;200.40^L^17^2
+49 ;;200.41^L^17^2
+50 ;;200.42^L^17^2
+51 ;;200.43^L^17^2
+52 ;;200.44^L^17^2
+53 ;;200.45^L^17^2
+54 ;;200.46^L^17^2
+55 ;;200.47^L^17^2
+56 ;;200.48^L^17^2
+57 ;;200.50^L^17^2
+58 ;;200.51^L^17^2
+59 ;;200.52^L^17^2
+60 ;;200.53^L^17^2
+61 ;;200.54^L^17^2
+62 ;;200.55^L^17^2
+63 ;;200.56^L^17^2
+64 ;;200.57^L^17^2
+65 ;;200.58^L^17^2
+66 ;;200.60^L^17^2
+67 ;;200.61^L^17^2
+68 ;;200.62^L^17^2
+69 ;;200.63^L^17^2
+70 ;;200.64^L^17^2
+71 ;;200.65^L^17^2
+72 ;;200.66^L^17^2
+73 ;;200.67^L^17^2
+74 ;;200.68^L^17^2
+75 ;;200.70^L^17^2
+76 ;;200.71^L^17^2
+77 ;;200.72^L^17^2
+78 ;;200.73^L^17^2
+79 ;;200.74^L^17^2
+80 ;;200.75^L^17^2
+81 ;;200.76^L^17^2
+82 ;;200.77^L^17^2
+83 ;;200.78^L^17^2
+84 ;;202.70^L^17^2
+85 ;;202.71^L^17^2
+86 ;;202.72^L^17^2
+87 ;;202.73^L^17^2
+88 ;;202.74^L^17^2
+89 ;;202.75^L^17^2
+90 ;;202.76^L^17^2
+91 ;;202.77^L^17^2
+92 ;;202.78^L^17^2
+93 ;;058.21^Q^1
+94 ;;058.29^Q^1
+95 ;;EXIT
