- ICDTBL7G ;ALB/JDG - GROUPER UTILITY FUNCTIONS;08/09/2010
- ;;18.0;DRG Grouper;**77,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"!(ICDSD["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 I $D(ICDDXT("V17.0"))!$D(ICDDXT("V17.2"))!$D(ICDDXT("V17.49")) S ICDRG=795 Q
- I $D(ICDDXT("V18.0"))!$D(ICDDXT("V18.19"))!$D(ICDDXT("V18.8")) S ICDRG=795 Q
- I $D(ICDDXT("V50.3")) S ICDRG=795 Q
- S ICDRG=794 Q
- DRG795 I $D(ICDDXT("V64.41"))!$D(ICDDXT("V64.42"))!$D(ICDDXT("V64.43")) D DRG794 Q
- I ICDSD["S"&('$D(ICDDXT("V64.06"))) 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[HICDTBL7G 3912 printed Feb 18, 2025@23:18:27 Page 2
- ICDTBL7G ;ALB/JDG - GROUPER UTILITY FUNCTIONS;08/09/2010
- +1 ;;18.0;DRG Grouper;**77,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"!(ICDSD["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 IF $DATA(ICDDXT("V17.0"))!$DATA(ICDDXT("V17.2"))!$DATA(ICDDXT("V17.49"))
- SET ICDRG=795
- QUIT
- +1 IF $DATA(ICDDXT("V18.0"))!$DATA(ICDDXT("V18.19"))!$DATA(ICDDXT("V18.8"))
- SET ICDRG=795
- QUIT
- +2 IF $DATA(ICDDXT("V50.3"))
- SET ICDRG=795
- QUIT
- +3 SET ICDRG=794
- QUIT
- DRG795 IF $DATA(ICDDXT("V64.41"))!$DATA(ICDDXT("V64.42"))!$DATA(ICDDXT("V64.43"))
- DO DRG794
- QUIT
- +1 IF ICDSD["S"&('$DATA(ICDDXT("V64.06")))
- DO DRG794
- QUIT
- +2 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
