ICD1831U.m

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 ---ICD1831U   2795     printed  Apr 23, 2025@18:03:03                                                                                                                                                                                                    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