Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ICDTBL8G

ICDTBL8G.m

Go to the documentation of this file.
  1. ICDTBL8G ;ALB/JDG - GROUPER UTILITY FUNCTIONS;08/09/2010
  1. ;;18.0;DRG Grouper;**77,78**;Oct 20, 2000;Build 15
  1. DRG800 ;
  1. DRG801 S ICDRG=$S(ICDMCC=2:799,ICDMCC=1:800,1:801) Q
  1. DRG802 ;
  1. DRG803 ;
  1. DRG804 S ICDRG=$S(ICDMCC=2:802,ICDMCC=1:803,1:804) Q
  1. DRG808 ;
  1. DRG809 ;
  1. DRG810 I ICDDX(1)=$O(^ICD9("AB","288.00 ",0)),$D(ICDDXT("284.11")),ICDMCC=2 S ICDRG=809 Q
  1. S ICDRG=$S(ICDMCC=2:808,ICDMCC=1:809,1:810) Q
  1. DRG811 ;
  1. DRG812 S ICDRG=$S(ICDMCC=2:811,1:812) Q
  1. DRG813 S ICDRG=813 Q
  1. DRG814 ;
  1. DRG815 ;
  1. DRG816 S ICDRG=$S(ICDMCC=2:814,ICDMCC=1:815,1:816) Q
  1. DRG820 ;DRG 820-822
  1. ;removed check I ICDPD["L"&('$G(ICDMAJ))
  1. I ICDPD["L"&('$G(ICDMAJ)) D DRG825 Q:"823^824^825^840^841^842^834^835^836"[ICDRG
  1. ;removed check I ICDPD["L"
  1. I ICDPD["L"&($G(ICDMAJ)) D Q
  1. .S ICDRG=$S(ICDMCC=2:820,ICDMCC=1:821,1:822)
  1. S ICDRG=$S(ICDMCC=2:826,ICDMCC=1:827,1:828)
  1. Q
  1. DRG821 D DRG820 Q
  1. DRG822 D DRG820 Q
  1. DRG823 ;DRGs 823-825
  1. S ICDRG=$S(ICDPD["l":836,ICDOR["O"!(ICDORNI["O"):825,1:842)
  1. I ICDRG=836 S ICDRG=$S(ICDMCC=2:834,ICDMCC=1:835,1:836) Q
  1. I ICDRG=825 S ICDRG=$S(ICDMCC=2:823,ICDMCC=1:824,1:825) Q
  1. I ICDRG=842 D Q
  1. .I ICDPD["L"&($D(ICDOP(" 92.30"))!$D(ICDOP(" 92.31"))!$D(ICDOP(" 92.32"))!$D(ICDOP(" 92.33"))!$D(ICDOP(" 92.39"))) S ICDRG=$S(ICDMCC=2:823,ICDMCC=1:824,1:825) Q
  1. .I $D(ICDOP(" 92.30"))!$D(ICDOP(" 92.31"))!$D(ICDOP(" 92.32"))!$D(ICDOP(" 92.33"))!$D(ICDOP(" 92.39")) S ICDRG=$S(ICDMCC>0:829,1:830) Q
  1. .S ICDRG=$S(ICDMCC=2:840,ICDMCC=1:841,1:842)
  1. Q
  1. DRG824 D DRG823 Q
  1. DRG825 D DRG823 Q
  1. DRG826 ;DRGs 826-828
  1. I $G(ICDMAJ)="^"!'($G(ICDMAJ)) D DRG829 Q
  1. I ICDOCNT>0!(ICDOR["O") D Q
  1. .S ICDRG=$S(ICDMCC=2:826,ICDMCC=1:827,1:828) Q
  1. S ICDRG=$S(ICDMCC=2:843,ICDMCC=1:844,1:845)
  1. Q
  1. DRG827 ;
  1. DRG828 ;S ICDRG=$S(ICDMCC=2:826,ICDMCC=1:827,1:828) Q
  1. DRG829 I ICDPD["L"!($G(ICDMAJ)),('$D(ICDOP(" 92.30"))),('$D(ICDOP(" 92.31"))),('$D(ICDOP(" 92.32"))),('$D(ICDOP(" 92.33"))),('$D(ICDOP(" 92.39"))) D DRG826 Q
  1. I ICDSD["l" D DRG837 Q
  1. I ICDSD'["l"&(ICDOR'["O"),('$D(ICDOP(" 92.30"))),('$D(ICDOP(" 92.31"))),('$D(ICDOP(" 92.32"))),('$D(ICDOP(" 92.33"))),('$D(ICDOP(" 92.39"))) D DRG846 Q
  1. DRG830 S ICDRG=$S(ICDMCC>0:829,1:830) Q
  1. DRG834 ;DRGs 834-836
  1. DRG835 ;
  1. DRG836 D DRG840 Q
  1. DRG837 ;DRGs 837-839
  1. DRG838 ;
  1. DRG839 I ICDSD["l",ICDMCC=2 S ICDRG=837 Q
  1. I ICDSD["l"&(ICDSD["2") S ICDRG=$S(ICDMCC=2:837,ICDMCC=1:838,1:839)
  1. I ICDDX(1)=$O(^ICD9("AB","V58.11 ",0))!(ICDDX(1)=$O(^ICD9("AB","V58.12 ",0)))!(ICDDX(1)=$O(^ICD9("AB","V67.2 ",0))),$D(ICDDXT("208.00"))!($D(ICDDXT("205.02"))),ICDMCC=1 S ICDRG=839 Q
  1. I ICDSD'["l",$D(ICDOP(" 00.15")),ICDMCC=2 S ICDRG=837 Q
  1. I ICDSD["l",'$D(ICDOP(" 00.15")),ICDMCC=1 S ICDRG=838 Q
  1. I ICDSD'["l",$D(ICDOP(" 00.15")) S ICDRG=838 Q
  1. I ICDSD["l",'$D(ICDOP(" 00.15")) S ICDRG=839 Q
  1. I ICDSD'["l"&(ICDOR'["O") D DRG846 Q
  1. D DRG846 Q
  1. DRG840 ;DRGs 840-842
  1. S ICDRG=$S(ICDPD["l":836,ICDOR["O"!(ICDORNI["O"):825,1:842)
  1. I ICDRG=836 S ICDRG=$S(ICDMCC=2:834,ICDMCC=1:835,1:836) Q
  1. I ICDRG=825 S ICDRG=$S(ICDMCC=2:823,ICDMCC=1:824,1:825) Q
  1. S ICDRG=$S(ICDMCC=2:840,ICDMCC=1:841,1:842)
  1. Q
  1. DRG841 D DRG840 Q
  1. DRG842 D DRG840 Q
  1. DRG843 ;
  1. DRG844 ;
  1. DRG845 I ICDPD["L" D DRG840 Q
  1. I ICDDX(1)=$O(^ICD9("AB","V58.0 ",0)) S ICDRG=849 Q
  1. I ICDDX(1)=$O(^ICD9("AB","V67.1 ",0)) S ICDRG=849 Q
  1. I $D(ICDDX(1))&(ICDOPCT=0) D Q:"837^838^839^846^847^848"[ICDRG
  1. .I ICDDX(1)=$O(^ICD9("AB","V58.11 ",0))!(ICDDX(1)=$O(^ICD9("AB","V58.12 ",0)))!(ICDDX(1)=$O(^ICD9("AB","V67.2 ",0))) D
  1. ..I ICDSD["2" D DRG837 Q
  1. ..I ICDSD'["2" D DRG846 Q
  1. I ICDPD["L" D DRG820 Q
  1. I ICDOR["N"&(ICDOR'["V")&($D(ICDPDRG(844))) S ICDRG=844 Q
  1. S ICDRG=$S(ICDMCC=2:843,ICDMCC=1:844,1:845) Q
  1. Q
  1. DRG846 ;
  1. DRG847 ;
  1. DRG848 I ICDDX(1)=$O(^ICD9("AB","V58.11 ",0))!(ICDDX(1)=$O(^ICD9("AB","V58.12 ",0)))!(ICDDX(1)=$O(^ICD9("AB","V67.2 ",0))) S ICDRG=$S(ICDMCC=2:846,ICDMCC=1:847,1:848) Q
  1. D DRG844 Q
  1. DRG849 I ICDDX(1)=$O(^ICD9("AB","V58.0 ",0)) S ICDRG=849 Q
  1. I ICDDX(1)=$O(^ICD9("AB","V67.1 ",0)) S ICDRG=849 Q
  1. D DRG844 Q
  1. DRG853 ;
  1. DRG854 ;
  1. DRG855 I ICDOR="",ICDDX(1)=7322!(ICDDX(1)=13271)!(ICDDX(1)=13272) D DRG862 Q
  1. I ICDOR["O" S ICDRG=$S(ICDMCC=2:853,ICDMCC=1:854,1:855) Q
  1. I ICDDX(1)=7322 D DRG856 Q
  1. I ICDDX(1)=13271 D DRG856 Q
  1. I ICDDX(1)=13272 D DRG856 Q
  1. I ICDDX(1)=14543 D DRG856 Q
  1. Q
  1. DRG856 ;
  1. DRG857 ;
  1. DRG858 I ICDOR'["O" D DRG862 Q
  1. I ICDOR["O" S ICDRG=$S(ICDMCC=2:856,ICDMCC=1:857,1:858) Q
  1. Q
  1. DRG862 ;
  1. DRG863 I ICDDX(1)'=7322&(ICDDX(1)'=13271)&(ICDDX(1)'=13272) D DRG867 Q
  1. S ICDRG=$S(ICDMCC=2:862,1:863) Q
  1. DRG864 S ICDRG=864 Q
  1. DRG865 ;
  1. DRG866 ;
  1. S ICDRG=$S(ICDMCC=2:865,1:866) Q
  1. DRG867 ;
  1. DRG868 ;
  1. DRG869 I ICDOR["O",$D(ICDOP)>10,ICDDX(1)'=7322!(ICDDX(1)'=13271)!(ICDDX(1)'=13272)!(ICDDX(1)'=14543) D DRG853 Q
  1. S ICDRG=$S(ICDMCC=2:867,ICDMCC=1:868,1:869) Q
  1. DRG870 ;DRGs 870-872
  1. S ICDRG=$S(ICDOR["O":855,1:872) I ICDRG=872&($D(ICDOP(" 96.72"))) S ICDRG=870
  1. I ICDRG=855 S ICDRG=$S(ICDMCC=2:853,ICDMCC=1:854,1:855) Q
  1. I ICDRG=872 S ICDRG=$S(ICDMCC=2:871,1:872) Q
  1. Q
  1. DRG871 D DRG870 Q
  1. DRG872 D DRG870 Q
  1. DRG876 I ICDOR["O" S ICDRG=876 Q
  1. Q
  1. DRG880 S ICDRG=880 I ICDOR["O" S ICDRG=876 Q
  1. Q
  1. DRG881 S ICDRG=881 I ICDOR["O" S ICDRG=876 Q
  1. Q
  1. DRG882 S ICDRG=882 I ICDOR["O" S ICDRG=876 Q
  1. Q
  1. DRG883 S ICDRG=883 I ICDOR["O" S ICDRG=876 Q
  1. Q
  1. DRG884 S ICDRG=884 I ICDOR["O" S ICDRG=876 Q
  1. Q
  1. DRG885 S ICDRG=885 I ICDOR["O" S ICDRG=876 Q
  1. Q
  1. DRG886 S ICDRG=886 I ICDOR["O" S ICDRG=876 Q
  1. Q
  1. DRG887 S ICDRG=887 I ICDOR["O" S ICDRG=876 Q
  1. Q
  1. DRG894 S ICDRG=894 I ICDOR["O" S ICDRG=876 Q
  1. Q
  1. DRG895 I (ICDOR["ND")!(ICDOR["NR") S ICDRG=895 Q
  1. I ICDOR["O" S ICDRG=983 Q
  1. DRG896 ;
  1. DRG897 S ICDRG=$S(ICDMCC=2:896,1:897) Q
  1. Q