ICDTBL7D ;ALB/MJB - GROUPER UTILITY FUNCTIONS;08/09/2010
;;18.0;DRG Grouper;**56,61,78**;Oct 20, 2000;Build 15
DRG700 S ICDRG=$S(ICDMCC=2:698,ICDMCC=1:699,1:700) Q
DRG707 ;
DRG708 S ICDRG=$S(ICDMCC>0:707,1:708) Q
DRG709 ;
DRG710 S ICDRG=$S(ICDMCC>0:709,1:710) Q
DRG711 ;
DRG712 S ICDRG=$S(ICDMCC>0:711,1:712) Q
DRG713 ;
DRG714 S ICDRG=$S(ICDMCC>0:713,1:714) Q
DRG715 ;
DRG716 I ICDPD["M" S ICDRG=$S(ICDMCC>0:715,1:716) Q
DRG717 ;
DRG718 I ICDPD["M" S ICDRG=$S(ICDMCC>0:715,1:716) Q
S ICDRG=$S(ICDMCC>0:717,1:718) Q
DRG722 ;
DRG723 ;
DRG724 S ICDRG=$S(ICDMCC=2:722,ICDMCC=1:723,1:724) Q
DRG725 ;
DRG726 S ICDRG=$S(ICDMCC=2:725,1:726) Q
DRG727 ;DRGs 727-728,757-759
S ICDRG=999
S ICDRG=$S(SEX="M":728,1:759) I SEX="" S ICDRG=999,ICDRTC=4 Q
I ICDRG=728 S ICDRG=$S(ICDMCC=2:727,1:728) Q
I ICDRG=759 S ICDRG=$S(ICDMCC=2:757,ICDMCC=1:758,1:759)
Q
DRG728 D DRG727 Q
DRG729 ;
DRG730 S ICDRG=$S(ICDMCC>0:729,1:730) Q
DRG734 ;
DRG735 S ICDRG=$S(ICDMCC>0:734,1:735) Q
DRG736 ;DRGs 736-743
S ICDRG=999
I ICDOR="" D DRG760 Q
S ICDRG=$S(ICDPD["M":$S(ICDPD["o":738,ICDMCC=2:739,1:741),1:743)
I ICDRG=738 S ICDRG=$S(ICDMCC=2:736,ICDMCC=1:737,1:738) Q
I ICDRG=741 S ICDRG=$S(ICDMCC=1:740,1:741) Q
I ICDRG=743 S ICDRG=$S(ICDMCC>0:742,1:743)
Q
DRG737 D DRG736 Q
DRG738 D DRG736 Q
DRG739 D DRG736 Q
DRG740 D DRG736 Q
DRG741 D DRG736 Q
DRG742 D DRG736 Q
DRG743 D DRG736 Q
DRG744 ;
DRG745 S ICDRG=$S(ICDMCC>0:744,1:745) Q
DRG746 ;
DRG747 S ICDRG=$S(ICDMCC>0:746,1:747) Q
DRG748 S ICDRG=748 Q
DRG749 ;
DRG750 S ICDRG=$S(ICDMCC>0:749,1:750) Q
DRG754 ;
DRG755 ;
DRG756 S ICDRG=$S(ICDMCC=2:754,ICDMCC=1:755,1:756) Q
DRG757 D DRG727 Q
DRG758 D DRG727 Q
DRG759 D DRG727 Q
DRG760 ;
DRG761 S ICDRG=$S(ICDMCC>0:760,1:761) Q
DRG765 ;
DRG766 I ICDPD["D" S ICDRG=$S(ICDMCC>0:765,1:766) Q
S ICDRG=""
DRG767 I ICDPD["D",ICDOR["s" S ICDRG=767 Q
DRG768 I ICDPD["D" S ICDRG=768 Q
I ICDRG="",ICDPD["v",ICDOR="" D DRG775
Q
DRG769 I ICDOR["" S ICDRG=776 Q
S ICDRG=769 Q
DRG770 S ICDRG=770 Q
DRG774 ;
I ICDPD'["v" Q
I ICDPD["v",ICDOR'["O" S ICDDRG=774
D ONLY
N I,J S I="",J=0 F S I=$O(ICDOP(I)) Q:I']"" D
. I '$D(A(I)) S J=1
I J=0 S ICDRG=774 Q
Q
DRG775 ;S ICDRG=775 Q
I ICDPD'["v" S DRG=775 Q
I ICDPD["v"&(ICDOR["") D DRG774 Q
I ICDPD["v" Q
I ICDPD'["v",ICDOR'["O" S DRG=775
D ONLY
N I,J S I="",J=0 F S I=$O(ICDOP(I)) Q:I']"" D
. I '$D(A(I)) S J=1
I J=0 S ICDRG=775 Q
Q
DRG776 S ICDRG=776 Q
DRG777 S ICDRG=777 Q
DRG778 S ICDRG=778 Q
DRG779 S ICDRG=779
I $D(ICDOP(" 69.01")) S ICDRG=770 Q
I $D(ICDOP(" 69.02")) S ICDRG=770 Q
I $D(ICDOP(" 69.09")) S ICDRG=770 Q
I $D(ICDOP(" 69.51")) S ICDRG=770 Q
I $D(ICDOP(" 69.52")) S ICDRG=770 Q
I $D(ICDOP(" 74.91")) S ICDRG=770 Q
Q
DRG780 S ICDRG=780 Q
DRG781 I ICDPD["u"!(ICDPD["u") S ICDRG=781 Q
DRG782 S ICDRG=782 Q
DRG789 S ICDRG=789 Q
DRG790 S ICDRG=790 Q
DRG791 S ICDRG=791 Q
DRG792 S ICDRG=792 Q
DRG793 S ICDRG=793 Q
DRG794 S ICDRG=794 Q
DRG795 I ICDSD["S" D DRG794 Q
S ICDRG=795 Q
DRG799 S ICDRG=$S(ICDMCC=2:799,ICDMCC=1:800,1:801) Q
Q
ONLY ;this is a list of op for 774 and 775 to use
N A
S A(" 48.71")=""
S A(" 49.59")=""
S A(" 67.51")=""
S A(" 67.59")=""
S A(" 67.61")=""
S A(" 67.69")=""
S A(" 70.13")=""
S A(" 70.14")=""
S A(" 70.24")=""
S A(" 70.31")=""
S A(" 70.33")=""
S A(" 70.71")=""
S A(" 70.79")=""
S A(" 71.01")=""
S A(" 71.09")=""
S A(" 71.11")=""
S A(" 77.19")=""
S A(" 71.3")=""
S A(" 71.71")=""
S A(" 71.79")=""
S A(" 73.99")=""
S A(" 75.50")=""
S A(" 75.51")=""
S A(" 75.61")=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDTBL7D 3617 printed Dec 13, 2024@01:52:03 Page 2
ICDTBL7D ;ALB/MJB - GROUPER UTILITY FUNCTIONS;08/09/2010
+1 ;;18.0;DRG Grouper;**56,61,78**;Oct 20, 2000;Build 15
DRG700 SET ICDRG=$SELECT(ICDMCC=2:698,ICDMCC=1:699,1:700)
QUIT
DRG707 ;
DRG708 SET ICDRG=$SELECT(ICDMCC>0:707,1:708)
QUIT
DRG709 ;
DRG710 SET ICDRG=$SELECT(ICDMCC>0:709,1:710)
QUIT
DRG711 ;
DRG712 SET ICDRG=$SELECT(ICDMCC>0:711,1:712)
QUIT
DRG713 ;
DRG714 SET ICDRG=$SELECT(ICDMCC>0:713,1:714)
QUIT
DRG715 ;
DRG716 IF ICDPD["M"
SET ICDRG=$SELECT(ICDMCC>0:715,1:716)
QUIT
DRG717 ;
DRG718 IF ICDPD["M"
SET ICDRG=$SELECT(ICDMCC>0:715,1:716)
QUIT
+1 SET ICDRG=$SELECT(ICDMCC>0:717,1:718)
QUIT
DRG722 ;
DRG723 ;
DRG724 SET ICDRG=$SELECT(ICDMCC=2:722,ICDMCC=1:723,1:724)
QUIT
DRG725 ;
DRG726 SET ICDRG=$SELECT(ICDMCC=2:725,1:726)
QUIT
DRG727 ;DRGs 727-728,757-759
+1 SET ICDRG=999
+2 SET ICDRG=$SELECT(SEX="M":728,1:759)
IF SEX=""
SET ICDRG=999
SET ICDRTC=4
QUIT
+3 IF ICDRG=728
SET ICDRG=$SELECT(ICDMCC=2:727,1:728)
QUIT
+4 IF ICDRG=759
SET ICDRG=$SELECT(ICDMCC=2:757,ICDMCC=1:758,1:759)
+5 QUIT
DRG728 DO DRG727
QUIT
DRG729 ;
DRG730 SET ICDRG=$SELECT(ICDMCC>0:729,1:730)
QUIT
DRG734 ;
DRG735 SET ICDRG=$SELECT(ICDMCC>0:734,1:735)
QUIT
DRG736 ;DRGs 736-743
+1 SET ICDRG=999
+2 IF ICDOR=""
DO DRG760
QUIT
+3 SET ICDRG=$SELECT(ICDPD["M":$SELECT(ICDPD["o":738,ICDMCC=2:739,1:741),1:743)
+4 IF ICDRG=738
SET ICDRG=$SELECT(ICDMCC=2:736,ICDMCC=1:737,1:738)
QUIT
+5 IF ICDRG=741
SET ICDRG=$SELECT(ICDMCC=1:740,1:741)
QUIT
+6 IF ICDRG=743
SET ICDRG=$SELECT(ICDMCC>0:742,1:743)
+7 QUIT
DRG737 DO DRG736
QUIT
DRG738 DO DRG736
QUIT
DRG739 DO DRG736
QUIT
DRG740 DO DRG736
QUIT
DRG741 DO DRG736
QUIT
DRG742 DO DRG736
QUIT
DRG743 DO DRG736
QUIT
DRG744 ;
DRG745 SET ICDRG=$SELECT(ICDMCC>0:744,1:745)
QUIT
DRG746 ;
DRG747 SET ICDRG=$SELECT(ICDMCC>0:746,1:747)
QUIT
DRG748 SET ICDRG=748
QUIT
DRG749 ;
DRG750 SET ICDRG=$SELECT(ICDMCC>0:749,1:750)
QUIT
DRG754 ;
DRG755 ;
DRG756 SET ICDRG=$SELECT(ICDMCC=2:754,ICDMCC=1:755,1:756)
QUIT
DRG757 DO DRG727
QUIT
DRG758 DO DRG727
QUIT
DRG759 DO DRG727
QUIT
DRG760 ;
DRG761 SET ICDRG=$SELECT(ICDMCC>0:760,1:761)
QUIT
DRG765 ;
DRG766 IF ICDPD["D"
SET ICDRG=$SELECT(ICDMCC>0:765,1:766)
QUIT
+1 SET ICDRG=""
DRG767 IF ICDPD["D"
IF ICDOR["s"
SET ICDRG=767
QUIT
DRG768 IF ICDPD["D"
SET ICDRG=768
QUIT
+1 IF ICDRG=""
IF ICDPD["v"
IF ICDOR=""
DO DRG775
+2 QUIT
DRG769 IF ICDOR[""
SET ICDRG=776
QUIT
+1 SET ICDRG=769
QUIT
DRG770 SET ICDRG=770
QUIT
DRG774 ;
+1 IF ICDPD'["v"
QUIT
+2 IF ICDPD["v"
IF ICDOR'["O"
SET ICDDRG=774
+3 DO ONLY
+4 NEW I,J
SET I=""
SET J=0
FOR
SET I=$ORDER(ICDOP(I))
if I']""
QUIT
Begin DoDot:1
+5 IF '$DATA(A(I))
SET J=1
End DoDot:1
+6 IF J=0
SET ICDRG=774
QUIT
+7 QUIT
DRG775 ;S ICDRG=775 Q
+1 IF ICDPD'["v"
SET DRG=775
QUIT
+2 IF ICDPD["v"&(ICDOR["")
DO DRG774
QUIT
+3 IF ICDPD["v"
QUIT
+4 IF ICDPD'["v"
IF ICDOR'["O"
SET DRG=775
+5 DO ONLY
+6 NEW I,J
SET I=""
SET J=0
FOR
SET I=$ORDER(ICDOP(I))
if I']""
QUIT
Begin DoDot:1
+7 IF '$DATA(A(I))
SET J=1
End DoDot:1
+8 IF J=0
SET ICDRG=775
QUIT
+9 QUIT
DRG776 SET ICDRG=776
QUIT
DRG777 SET ICDRG=777
QUIT
DRG778 SET ICDRG=778
QUIT
DRG779 SET ICDRG=779
+1 IF $DATA(ICDOP(" 69.01"))
SET ICDRG=770
QUIT
+2 IF $DATA(ICDOP(" 69.02"))
SET ICDRG=770
QUIT
+3 IF $DATA(ICDOP(" 69.09"))
SET ICDRG=770
QUIT
+4 IF $DATA(ICDOP(" 69.51"))
SET ICDRG=770
QUIT
+5 IF $DATA(ICDOP(" 69.52"))
SET ICDRG=770
QUIT
+6 IF $DATA(ICDOP(" 74.91"))
SET ICDRG=770
QUIT
+7 QUIT
DRG780 SET ICDRG=780
QUIT
DRG781 IF ICDPD["u"!(ICDPD["u")
SET ICDRG=781
QUIT
DRG782 SET ICDRG=782
QUIT
DRG789 SET ICDRG=789
QUIT
DRG790 SET ICDRG=790
QUIT
DRG791 SET ICDRG=791
QUIT
DRG792 SET ICDRG=792
QUIT
DRG793 SET ICDRG=793
QUIT
DRG794 SET ICDRG=794
QUIT
DRG795 IF ICDSD["S"
DO DRG794
QUIT
+1 SET ICDRG=795
QUIT
DRG799 SET ICDRG=$SELECT(ICDMCC=2:799,ICDMCC=1:800,1:801)
QUIT
+1 QUIT
ONLY ;this is a list of op for 774 and 775 to use
+1 NEW A
+2 SET A(" 48.71")=""
+3 SET A(" 49.59")=""
+4 SET A(" 67.51")=""
+5 SET A(" 67.59")=""
+6 SET A(" 67.61")=""
+7 SET A(" 67.69")=""
+8 SET A(" 70.13")=""
+9 SET A(" 70.14")=""
+10 SET A(" 70.24")=""
+11 SET A(" 70.31")=""
+12 SET A(" 70.33")=""
+13 SET A(" 70.71")=""
+14 SET A(" 70.79")=""
+15 SET A(" 71.01")=""
+16 SET A(" 71.09")=""
+17 SET A(" 71.11")=""
+18 SET A(" 77.19")=""
+19 SET A(" 71.3")=""
+20 SET A(" 71.71")=""
+21 SET A(" 71.79")=""
+22 SET A(" 73.99")=""
+23 SET A(" 75.50")=""
+24 SET A(" 75.51")=""
+25 SET A(" 75.61")=""
+26 QUIT
