ICDTBL8E ;ALB/JDG/SS - GROUPER UTILITY FUNCTIONS;08/09/2010
;;18.0;DRG Grouper;**65,64,78**;Oct 20, 2000;Build 15
DRG800 ;
DRG801 S ICDRG=$S(ICDMCC=2:799,ICDMCC=1:800,1:801) Q
DRG802 ;
DRG803 ;
DRG804 S ICDRG=$S(ICDMCC=2:802,ICDMCC=1:803,1:804) Q
DRG808 ;
DRG809 ;
DRG810 I ICDDX(1)=$$CODEBA^ICDEX("288.00",80),$D(ICDDXT("284.11")),ICDMCC=2 S ICDRG=809 Q
S ICDRG=$S(ICDMCC=2:808,ICDMCC=1:809,1:810) Q
DRG811 ;
DRG812 S ICDRG=$S(ICDMCC=2:811,1:812) Q
DRG813 S ICDRG=813 Q
DRG814 ;
DRG815 ;
DRG816 S ICDRG=$S(ICDMCC=2:814,ICDMCC=1:815,1:816) Q
DRG820 ;DRG 820-822
;removed check I ICDPD["L"&('$G(ICDMAJ))
I ICDPD["L"&('$G(ICDMAJ)) D DRG825 Q:"823^824^825^840^841^842^834^835^836"[ICDRG
;removed check I ICDPD["L"
I ICDPD["L"&($G(ICDMAJ)) D Q
.S ICDRG=$S(ICDMCC=2:820,ICDMCC=1:821,1:822)
S ICDRG=$S(ICDMCC=2:826,ICDMCC=1:827,1:828)
Q
DRG821 D DRG820 Q
DRG822 D DRG820 Q
DRG823 ;DRGs 823-825
S ICDRG=$S(ICDPD["l":836,ICDOR["O"!(ICDORNI["O"):825,1:842)
I ICDRG=836 S ICDRG=$S(ICDMCC=2:834,ICDMCC=1:835,1:836) Q
I ICDRG=825 S ICDRG=$S(ICDMCC=2:823,ICDMCC=1:824,1:825) Q
I ICDRG=842 D Q
.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
.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
.S ICDRG=$S(ICDMCC=2:840,ICDMCC=1:841,1:842)
Q
DRG824 D DRG823 Q
DRG825 D DRG823 Q
DRG826 ;DRGs 826-828
I $G(ICDMAJ)="^"!'($G(ICDMAJ)) D DRG829 Q
I ICDOCNT>0!(ICDOR["O") D Q
.S ICDRG=$S(ICDMCC=2:826,ICDMCC=1:827,1:828) Q
S ICDRG=$S(ICDMCC=2:843,ICDMCC=1:844,1:845)
Q
DRG827 ;
DRG828 ;S ICDRG=$S(ICDMCC=2:826,ICDMCC=1:827,1:828) Q
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
I ICDSD["l" D DRG837 Q
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
DRG830 S ICDRG=$S(ICDMCC>0:829,1:830) Q
DRG834 ;DRGs 834-836
DRG835 ;
DRG836 D DRG840 Q
DRG837 ;DRGs 837-839
DRG838 ;
DRG839 I ICDSD["l",ICDMCC=2 S ICDRG=837 Q
I ICDSD["l"&(ICDSD["2") S ICDRG=$S(ICDMCC=2:837,ICDMCC=1:838,1:839)
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
I ICDSD'["l",$D(ICDOP(" 00.15")),ICDMCC=2 S ICDRG=837 Q
I ICDSD["l",'$D(ICDOP(" 00.15")),ICDMCC=1 S ICDRG=838 Q
I ICDSD'["l",$D(ICDOP(" 00.15")) S ICDRG=838 Q
I ICDSD["l",'$D(ICDOP(" 00.15")) S ICDRG=839 Q
I ICDSD'["l"&(ICDOR'["O") D DRG846 Q
D DRG846 Q
DRG840 ;DRGs 840-842
S ICDRG=$S(ICDPD["l":836,ICDOR["O"!(ICDORNI["O"):825,1:842)
I ICDRG=836 S ICDRG=$S(ICDMCC=2:834,ICDMCC=1:835,1:836) Q
I ICDRG=825 S ICDRG=$S(ICDMCC=2:823,ICDMCC=1:824,1:825) Q
S ICDRG=$S(ICDMCC=2:840,ICDMCC=1:841,1:842)
Q
DRG841 D DRG840 Q
DRG842 D DRG840 Q
DRG843 ;
DRG844 ;
DRG845 I ICDPD["L" D DRG840 Q
I ICDDX(1)=$$CODEBA^ICDEX("V58.0",80) S ICDRG=849 Q
I ICDDX(1)=$$CODEBA^ICDEX("V67.1",80) S ICDRG=849 Q
I $D(ICDDX(1))&(ICDOPCT=0) D Q:"837^838^839^846^847^848"[ICDRG
.I ICDDX(1)=$$CODEBA^ICDEX("V58.11",80)!(ICDDX(1)=$$CODEBA^ICDEX("V58.12",80))!(ICDDX(1)=$$CODEBA^ICDEX("V67.2",80)) D
..I ICDSD["2" D DRG837 Q
..I ICDSD'["2" D DRG846 Q
I ICDPD["L" D DRG820 Q
I ICDOR["N"&(ICDOR'["V")&($D(ICDPDRG(844))) S ICDRG=844 Q
S ICDRG=$S(ICDMCC=2:843,ICDMCC=1:844,1:845) Q
Q
DRG846 ;
DRG847 ;
DRG848 I ICDDX(1)=$$CODEBA^ICDEX("V58.11",80)!(ICDDX(1)=$$CODEBA^ICDEX("V58.12",80))!(ICDDX(1)=$$CODEBA^ICDEX("V67.2",80)) S ICDRG=$S(ICDMCC=2:846,ICDMCC=1:847,1:848) Q
D DRG844 Q
DRG849 I ICDDX(1)=$$CODEBA^ICDEX("V58.0",80) S ICDRG=849 Q
I ICDDX(1)=$$CODEBA^ICDEX("V67.1",80) S ICDRG=849 Q
D DRG844 Q
DRG853 ;
DRG854 ;
DRG855 I ICDOR="",ICDDX(1)=7322!(ICDDX(1)=13271)!(ICDDX(1)=13272) D DRG862 Q
I ICDOR["O" S ICDRG=$S(ICDMCC=2:853,ICDMCC=1:854,1:855) Q
I ICDDX(1)=7322 D DRG856 Q
I ICDDX(1)=13271 D DRG856 Q
I ICDDX(1)=13272 D DRG856 Q
I ICDDX(1)=14543 D DRG856 Q
Q
DRG856 ;
DRG857 ;
DRG858 I ICDOR'["O" D DRG862 Q
I ICDOR["O" S ICDRG=$S(ICDMCC=2:856,ICDMCC=1:857,1:858) Q
Q
DRG862 ;
DRG863 I ICDDX(1)'=7322&(ICDDX(1)'=13271)&(ICDDX(1)'=13272) D DRG867 Q
S ICDRG=$S(ICDMCC=2:862,1:863) Q
DRG864 S ICDRG=864 Q
DRG865 ;
DRG866 ;
S ICDRG=$S(ICDMCC=2:865,1:866) Q
DRG867 ;
DRG868 ;
DRG869 I ICDOR["O",$D(ICDOP)>10,ICDDX(1)'=7322!(ICDDX(1)'=13271)!(ICDDX(1)'=13272)!(ICDDX(1)'=14543) D DRG853 Q
S ICDRG=$S(ICDMCC=2:867,ICDMCC=1:868,1:869) Q
DRG870 ;DRGs 870-872
S ICDRG=$S(ICDOR["O":855,1:872) I ICDRG=872&($D(ICDOP(" 96.72"))) S ICDRG=870
I ICDRG=855 S ICDRG=$S(ICDMCC=2:853,ICDMCC=1:854,1:855) Q
I ICDRG=872 S ICDRG=$S(ICDMCC=2:871,1:872) Q
Q
DRG871 D DRG870 Q
DRG872 D DRG870 Q
DRG876 I ICDOR["O" S ICDRG=876 Q
Q
DRG880 S ICDRG=880 I ICDOR["O" S ICDRG=876 Q
Q
DRG881 S ICDRG=881 I ICDOR["O" S ICDRG=876 Q
Q
DRG882 S ICDRG=882 I ICDOR["O" S ICDRG=876 Q
Q
DRG883 S ICDRG=883 I ICDOR["O" S ICDRG=876 Q
Q
DRG884 S ICDRG=884 I ICDOR["O" S ICDRG=876 Q
Q
DRG885 S ICDRG=885 I ICDOR["O" S ICDRG=876 Q
Q
DRG886 S ICDRG=886 I ICDOR["O" S ICDRG=876 Q
Q
DRG887 S ICDRG=887 I ICDOR["O" S ICDRG=876 Q
Q
DRG894 S ICDRG=894 I ICDOR["O" S ICDRG=876 Q
Q
DRG895 I (ICDOR["ND")!(ICDOR["NR") S ICDRG=895 Q
I ICDOR["O" S ICDRG=983 Q
DRG896 ;
DRG897 S ICDRG=$S(ICDMCC=2:896,1:897) Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDTBL8E 5619 printed Nov 22, 2024@17:02:21 Page 2
ICDTBL8E ;ALB/JDG/SS - GROUPER UTILITY FUNCTIONS;08/09/2010
+1 ;;18.0;DRG Grouper;**65,64,78**;Oct 20, 2000;Build 15
DRG800 ;
DRG801 SET ICDRG=$SELECT(ICDMCC=2:799,ICDMCC=1:800,1:801)
QUIT
DRG802 ;
DRG803 ;
DRG804 SET ICDRG=$SELECT(ICDMCC=2:802,ICDMCC=1:803,1:804)
QUIT
DRG808 ;
DRG809 ;
DRG810 IF ICDDX(1)=$$CODEBA^ICDEX("288.00",80)
IF $DATA(ICDDXT("284.11"))
IF ICDMCC=2
SET ICDRG=809
QUIT
+1 SET ICDRG=$SELECT(ICDMCC=2:808,ICDMCC=1:809,1:810)
QUIT
DRG811 ;
DRG812 SET ICDRG=$SELECT(ICDMCC=2:811,1:812)
QUIT
DRG813 SET ICDRG=813
QUIT
DRG814 ;
DRG815 ;
DRG816 SET ICDRG=$SELECT(ICDMCC=2:814,ICDMCC=1:815,1:816)
QUIT
DRG820 ;DRG 820-822
+1 ;removed check I ICDPD["L"&('$G(ICDMAJ))
+2 IF ICDPD["L"&('$GET(ICDMAJ))
DO DRG825
if "823^824^825^840^841^842^834^835^836"[ICDRG
QUIT
+3 ;removed check I ICDPD["L"
+4 IF ICDPD["L"&($GET(ICDMAJ))
Begin DoDot:1
+5 SET ICDRG=$SELECT(ICDMCC=2:820,ICDMCC=1:821,1:822)
End DoDot:1
QUIT
+6 SET ICDRG=$SELECT(ICDMCC=2:826,ICDMCC=1:827,1:828)
+7 QUIT
DRG821 DO DRG820
QUIT
DRG822 DO DRG820
QUIT
DRG823 ;DRGs 823-825
+1 SET ICDRG=$SELECT(ICDPD["l":836,ICDOR["O"!(ICDORNI["O"):825,1:842)
+2 IF ICDRG=836
SET ICDRG=$SELECT(ICDMCC=2:834,ICDMCC=1:835,1:836)
QUIT
+3 IF ICDRG=825
SET ICDRG=$SELECT(ICDMCC=2:823,ICDMCC=1:824,1:825)
QUIT
+4 IF ICDRG=842
Begin DoDot:1
+5 IF ICDPD["L"&($DATA(ICDOP(" 92.30"))!$DATA(ICDOP(" 92.31"))!$DATA(ICDOP(" 92.32"))!$DATA(ICDOP(" 92.33"))!$DATA(ICDOP(" 92.39")))
SET ICDRG=$SELECT(ICDMCC=2:823,ICDMCC=1:824,1:825)
QUIT
+6 IF $DATA(ICDOP(" 92.30"))!$DATA(ICDOP(" 92.31"))!$DATA(ICDOP(" 92.32"))!$DATA(ICDOP(" 92.33"))!$DATA(ICDOP(" 92.39"))
SET ICDRG=$SELECT(ICDMCC>0:829,1:830)
QUIT
+7 SET ICDRG=$SELECT(ICDMCC=2:840,ICDMCC=1:841,1:842)
End DoDot:1
QUIT
+8 QUIT
DRG824 DO DRG823
QUIT
DRG825 DO DRG823
QUIT
DRG826 ;DRGs 826-828
+1 IF $GET(ICDMAJ)="^"!'($GET(ICDMAJ))
DO DRG829
QUIT
+2 IF ICDOCNT>0!(ICDOR["O")
Begin DoDot:1
+3 SET ICDRG=$SELECT(ICDMCC=2:826,ICDMCC=1:827,1:828)
QUIT
End DoDot:1
QUIT
+4 SET ICDRG=$SELECT(ICDMCC=2:843,ICDMCC=1:844,1:845)
+5 QUIT
DRG827 ;
DRG828 ;S ICDRG=$S(ICDMCC=2:826,ICDMCC=1:827,1:828) Q
DRG829 IF ICDPD["L"!($GET(ICDMAJ))
IF ('$DATA(ICDOP(" 92.30")))
IF ('$DATA(ICDOP(" 92.31")))
IF ('$DATA(ICDOP(" 92.32")))
IF ('$DATA(ICDOP(" 92.33")))
IF ('$DATA(ICDOP(" 92.39")))
DO DRG826
QUIT
+1 IF ICDSD["l"
DO DRG837
QUIT
+2 IF ICDSD'["l"&(ICDOR'["O")
IF ('$DATA(ICDOP(" 92.30")))
IF ('$DATA(ICDOP(" 92.31")))
IF ('$DATA(ICDOP(" 92.32")))
IF ('$DATA(ICDOP(" 92.33")))
IF ('$DATA(ICDOP(" 92.39")))
DO DRG846
QUIT
DRG830 SET ICDRG=$SELECT(ICDMCC>0:829,1:830)
QUIT
DRG834 ;DRGs 834-836
DRG835 ;
DRG836 DO DRG840
QUIT
DRG837 ;DRGs 837-839
DRG838 ;
DRG839 IF ICDSD["l"
IF ICDMCC=2
SET ICDRG=837
QUIT
+1 IF ICDSD["l"&(ICDSD["2")
SET ICDRG=$SELECT(ICDMCC=2:837,ICDMCC=1:838,1:839)
+2 IF ICDDX(1)=$ORDER(^ICD9("AB","V58.11 ",0))!(ICDDX(1)=$ORDER(^ICD9("AB","V58.12 ",0)))!(ICDDX(1)=$ORDER(^ICD9("AB","V67.2 ",0)))
IF $DATA(ICDDXT("208.00"))!($DATA(ICDDXT("205.02")))
IF ICDMCC=1
SET ICDRG=839
QUIT
+3 IF ICDSD'["l"
IF $DATA(ICDOP(" 00.15"))
IF ICDMCC=2
SET ICDRG=837
QUIT
+4 IF ICDSD["l"
IF '$DATA(ICDOP(" 00.15"))
IF ICDMCC=1
SET ICDRG=838
QUIT
+5 IF ICDSD'["l"
IF $DATA(ICDOP(" 00.15"))
SET ICDRG=838
QUIT
+6 IF ICDSD["l"
IF '$DATA(ICDOP(" 00.15"))
SET ICDRG=839
QUIT
+7 IF ICDSD'["l"&(ICDOR'["O")
DO DRG846
QUIT
+8 DO DRG846
QUIT
DRG840 ;DRGs 840-842
+1 SET ICDRG=$SELECT(ICDPD["l":836,ICDOR["O"!(ICDORNI["O"):825,1:842)
+2 IF ICDRG=836
SET ICDRG=$SELECT(ICDMCC=2:834,ICDMCC=1:835,1:836)
QUIT
+3 IF ICDRG=825
SET ICDRG=$SELECT(ICDMCC=2:823,ICDMCC=1:824,1:825)
QUIT
+4 SET ICDRG=$SELECT(ICDMCC=2:840,ICDMCC=1:841,1:842)
+5 QUIT
DRG841 DO DRG840
QUIT
DRG842 DO DRG840
QUIT
DRG843 ;
DRG844 ;
DRG845 IF ICDPD["L"
DO DRG840
QUIT
+1 IF ICDDX(1)=$$CODEBA^ICDEX("V58.0",80)
SET ICDRG=849
QUIT
+2 IF ICDDX(1)=$$CODEBA^ICDEX("V67.1",80)
SET ICDRG=849
QUIT
+3 IF $DATA(ICDDX(1))&(ICDOPCT=0)
Begin DoDot:1
+4 IF ICDDX(1)=$$CODEBA^ICDEX("V58.11",80)!(ICDDX(1)=$$CODEBA^ICDEX("V58.12",80))!(ICDDX(1)=$$CODEBA^ICDEX("V67.2",80))
Begin DoDot:2
+5 IF ICDSD["2"
DO DRG837
QUIT
+6 IF ICDSD'["2"
DO DRG846
QUIT
End DoDot:2
End DoDot:1
if "837^838^839^846^847^848"[ICDRG
QUIT
+7 IF ICDPD["L"
DO DRG820
QUIT
+8 IF ICDOR["N"&(ICDOR'["V")&($DATA(ICDPDRG(844)))
SET ICDRG=844
QUIT
+9 SET ICDRG=$SELECT(ICDMCC=2:843,ICDMCC=1:844,1:845)
QUIT
+10 QUIT
DRG846 ;
DRG847 ;
DRG848 IF ICDDX(1)=$$CODEBA^ICDEX("V58.11",80)!(ICDDX(1)=$$CODEBA^ICDEX("V58.12",80))!(ICDDX(1)=$$CODEBA^ICDEX("V67.2",80))
SET ICDRG=$SELECT(ICDMCC=2:846,ICDMCC=1:847,1:848)
QUIT
+1 DO DRG844
QUIT
DRG849 IF ICDDX(1)=$$CODEBA^ICDEX("V58.0",80)
SET ICDRG=849
QUIT
+1 IF ICDDX(1)=$$CODEBA^ICDEX("V67.1",80)
SET ICDRG=849
QUIT
+2 DO DRG844
QUIT
DRG853 ;
DRG854 ;
DRG855 IF ICDOR=""
IF ICDDX(1)=7322!(ICDDX(1)=13271)!(ICDDX(1)=13272)
DO DRG862
QUIT
+1 IF ICDOR["O"
SET ICDRG=$SELECT(ICDMCC=2:853,ICDMCC=1:854,1:855)
QUIT
+2 IF ICDDX(1)=7322
DO DRG856
QUIT
+3 IF ICDDX(1)=13271
DO DRG856
QUIT
+4 IF ICDDX(1)=13272
DO DRG856
QUIT
+5 IF ICDDX(1)=14543
DO DRG856
QUIT
+6 QUIT
DRG856 ;
DRG857 ;
DRG858 IF ICDOR'["O"
DO DRG862
QUIT
+1 IF ICDOR["O"
SET ICDRG=$SELECT(ICDMCC=2:856,ICDMCC=1:857,1:858)
QUIT
+2 QUIT
DRG862 ;
DRG863 IF ICDDX(1)'=7322&(ICDDX(1)'=13271)&(ICDDX(1)'=13272)
DO DRG867
QUIT
+1 SET ICDRG=$SELECT(ICDMCC=2:862,1:863)
QUIT
DRG864 SET ICDRG=864
QUIT
DRG865 ;
DRG866 ;
+1 SET ICDRG=$SELECT(ICDMCC=2:865,1:866)
QUIT
DRG867 ;
DRG868 ;
DRG869 IF ICDOR["O"
IF $DATA(ICDOP)>10
IF ICDDX(1)'=7322!(ICDDX(1)'=13271)!(ICDDX(1)'=13272)!(ICDDX(1)'=14543)
DO DRG853
QUIT
+1 SET ICDRG=$SELECT(ICDMCC=2:867,ICDMCC=1:868,1:869)
QUIT
DRG870 ;DRGs 870-872
+1 SET ICDRG=$SELECT(ICDOR["O":855,1:872)
IF ICDRG=872&($DATA(ICDOP(" 96.72")))
SET ICDRG=870
+2 IF ICDRG=855
SET ICDRG=$SELECT(ICDMCC=2:853,ICDMCC=1:854,1:855)
QUIT
+3 IF ICDRG=872
SET ICDRG=$SELECT(ICDMCC=2:871,1:872)
QUIT
+4 QUIT
DRG871 DO DRG870
QUIT
DRG872 DO DRG870
QUIT
DRG876 IF ICDOR["O"
SET ICDRG=876
QUIT
+1 QUIT
DRG880 SET ICDRG=880
IF ICDOR["O"
SET ICDRG=876
QUIT
+1 QUIT
DRG881 SET ICDRG=881
IF ICDOR["O"
SET ICDRG=876
QUIT
+1 QUIT
DRG882 SET ICDRG=882
IF ICDOR["O"
SET ICDRG=876
QUIT
+1 QUIT
DRG883 SET ICDRG=883
IF ICDOR["O"
SET ICDRG=876
QUIT
+1 QUIT
DRG884 SET ICDRG=884
IF ICDOR["O"
SET ICDRG=876
QUIT
+1 QUIT
DRG885 SET ICDRG=885
IF ICDOR["O"
SET ICDRG=876
QUIT
+1 QUIT
DRG886 SET ICDRG=886
IF ICDOR["O"
SET ICDRG=876
QUIT
+1 QUIT
DRG887 SET ICDRG=887
IF ICDOR["O"
SET ICDRG=876
QUIT
+1 QUIT
DRG894 SET ICDRG=894
IF ICDOR["O"
SET ICDRG=876
QUIT
+1 QUIT
DRG895 IF (ICDOR["ND")!(ICDOR["NR")
SET ICDRG=895
QUIT
+1 IF ICDOR["O"
SET ICDRG=983
QUIT
DRG896 ;
DRG897 SET ICDRG=$SELECT(ICDMCC=2:896,1:897)
QUIT
+1 QUIT
