source: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD1831U.m@ 636

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