ICD1832U.m

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 ---ICD1832U   2428     printed  Feb 18, 2025@23:15:04                                                                                                                                                                                                    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