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

ICDTBL0B.m

Go to the documentation of this file.
  1. ICDTBL0B ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS;11/5/07 11:07am
  1. ;;18.0;DRG Grouper;**45,46,48,55**;Oct 20, 2000;Build 20
  1. DRG1 ;line tag for 001,002
  1. DRG2 ;
  1. S ICDRG=$S(ICDMCC=2:1,1:2) Q
  1. DRG3 ;S ICDRG=3 Q
  1. DRG4 S ICDRG=$S(ICDMAJ'="":3,1:4) Q
  1. I ICDOR["O" S ICDRG=3 Q
  1. S ICDRG=$S(ICDMCC=1:3,1:4) Q
  1. DRG5 ;line tag for 005,006
  1. DRG6 S ICDRG=$S(ICDMCC=2:5,1:6) D Q
  1. . I $D(ICDOP(" 46.97")) S ICDRG=5
  1. DRG7 S ICDRG=7 Q
  1. DRG8 S ICDRG=8 Q
  1. DRG9 S ICDRG=9 Q
  1. DRG10 S ICDRG=10 Q
  1. DRG11 ;line tag for 011,012,013
  1. DRG12 ;
  1. DRG13 ;
  1. S ICDRG=$S(ICDMCC=2:11,ICDMCC=1:12,1:13) Q
  1. DRG20 ;line tag for 020,021,022
  1. DRG21 ;
  1. DRG22 ;
  1. S ICDRG=$S((ICDPD["K")&(ICDOR["K")&(ICDMCC=2):20,(ICDPD["K")&(ICDOR["K")&(ICDMCC=1):21,(ICDPD["K")&(ICDOR["K"):22,1:ICDRG) Q
  1. DRG23 ;line tag for 023,024
  1. DRG24 ;
  1. I ICDPD["k"!(ICDSD["k") D DRG97 Q
  1. S ICDRG=$S($D(ICDOP(" 00.10")):23,1:ICDRG) Q:(ICDRG=23)
  1. S ICDRG=$S((ICDPD["Q")&(ICDOR["Q")&(ICDMCC=2):23,(ICDPD["Q")&(ICDOR["Q"):24,1:ICDRG) Q:(ICDRG=23)
  1. S ICDRG=$S($D(ICDOP(" 02.93"))&($D(ICDOP(" 86.95")))&(ICDMCC=2):23,$D(ICDOP(" 02.93"))&($D(ICDOP(" 86.95"))):24,1:ICDRG) Q
  1. S ICDRG=$S(ICDMCC=2:25,ICDMCC=1:26,1:27)
  1. Q
  1. DRG25 ;line tag for 025,026,027
  1. DRG26 ;
  1. DRG27 ;
  1. I ICDMAJ["B" D DRG28 Q
  1. D DRG20 D:'((ICDRG>19)&(ICDRG<23)) DRG23 D:'((ICDRG>22)&(ICDRG<25)) DRG31
  1. S ICDRG=$S(ICDRG=20:20,ICDRG=21:21,ICDRG=22:22,ICDRG=23:23,ICDRG=24:24,ICDRG=31:31,ICDRG=32:32,ICDRG=33:33,ICDMCC=2:25,ICDMCC=1:26,1:27)
  1. I $D(ICDOP(" 00.62")),'$D(ICDOP(" 00.65")) S ICDRG=999
  1. Q
  1. DRG28 ;line tag for 028,029,030
  1. DRG29 ;
  1. DRG30 ;S ICDRG=$S((ICDMAJ["B")&ICDMCC=2:28,(ICDMAJ["B")&ICDMCC=1:29,ICDMAJ["B":30,1:ICDRG) D Q
  1. ;I $D(ICDOP(" 02.93")) D DRG24
  1. S ICDRG=$S(ICDMCC=2:28,ICDMCC=1:29,1:30) D Q
  1. . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.94")) S ICDRG=29
  1. . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.95")) S ICDRG=29
  1. . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.97")) S ICDRG=29
  1. . I $D(ICDOP(" 03.93")),$D(ICDOP(" 86.98")) S ICDRG=29
  1. . Q
  1. DRG31 ;line tag for 031,032,033
  1. DRG32 ;
  1. DRG33 ;
  1. S ICDRG=$S((ICDOR["S")&(ICDMCC=2):31,(ICDOR["S")&(ICDMCC=1):32,ICDOR["S":33,1:ICDRG) Q
  1. DRG34 ;line tag for 034,035,036
  1. DRG35 ;
  1. DRG36 ;
  1. S ICDRG=$S(ICDMCC=2:34,ICDMCC=1:35,1:36) Q
  1. DRG37 ;line tag for 037,038,039
  1. DRG38 ;
  1. DRG39 ;
  1. S ICDRG=$S(ICDMCC=2:37,ICDMCC=1:38,1:39) D Q
  1. . I $D(ICDOP(" 00.61"))&($D(ICDOP(" 00.63")))&(ICDMCC=2) S ICDRG=34
  1. . I $D(ICDOP(" 00.61"))&($D(ICDOP(" 00.63")))&(ICDMCC=1) S ICDRG=35
  1. . I $D(ICDOP(" 00.61"))&($D(ICDOP(" 00.63"))) S ICDRG=36
  1. DRG40 ;line tag for 040,041,042
  1. DRG41 ;
  1. DRG42 ;
  1. S ICDRG=$S(ICDMCC=2:40,ICDMCC=1:41,1:42) D Q
  1. . I $D(ICDOP(" 04.92")),$D(ICDOP(" 86.94")) S ICDRG=41
  1. . I $D(ICDOP(" 04.92")),$D(ICDOP(" 86.95")) S ICDRG=41
  1. . I $D(ICDOP(" 04.92")),$D(ICDOP(" 86.97")) S ICDRG=41
  1. . I $D(ICDOP(" 04.92")),$D(ICDOP(" 86.98")) S ICDRG=41
  1. DRG52 ;line tag for 052,053
  1. DRG53 ;
  1. S ICDRG=$S(ICDMCC>0:52,1:53) Q
  1. DRG54 ;line tag for 054,055
  1. DRG55 ;
  1. S ICDRG=$S(ICDMCC=2:54,1:55) Q
  1. DRG56 ;line taf for 056,057
  1. DRG57 ;
  1. S ICDRG=$S(ICDMCC=2:56,1:57) Q
  1. DRG58 ;line tag for 058,059,060
  1. DRG59 ;
  1. DRG60 ;
  1. S ICDRG=$S(ICDMCC=2:58,ICDMCC=1:59,1:60) Q
  1. DRG61 ;line tag for 061,062,063
  1. DRG62 ;
  1. DRG63 ;
  1. I $D(ICDPDRG(69)) D DRG69 Q
  1. S ICDRG=$S(ICDMCC=2:61,ICDMCC=1:62,1:63) Q
  1. DRG64 ;line tag for 064,065,066
  1. DRG65 ;
  1. DRG66 ;
  1. I ICDOR="" S ICDRG=$S(ICDMCC=2:64,ICDMCC=1:65,1:66) Q
  1. I ICDOR["O" D
  1. . S ICDRG=$S(ICDOR["O"&(ICDMCC)=2:64,ICDOR["O"&(ICDMCC=1):65,1:66) Q
  1. S ICDRG=$S(ICDMCC=2:64,ICDMCC=1:65,1:66) Q
  1. DRG67 ;line tag for 067,068
  1. DRG68 ;
  1. S ICDRG=$S(ICDMCC=2:67,1:68) Q
  1. DRG69 S ICDRG=69 Q
  1. DRG70 ;line tag for 070,071,072
  1. DRG71 ;
  1. DRG72 ;
  1. S ICDRG=$S(ICDMCC=2:70,ICDMCC=1:71,1:72) Q
  1. DRG73 ;line tag for 073,074
  1. DRG74 ;
  1. S ICDRG=$S(ICDMCC=2:73,1:74) Q
  1. DRG75 ;line tag for 075,076
  1. DRG76 ;
  1. S ICDRG=$S(ICDMCC>0:75,1:76) Q
  1. DRG77 ;line tag for 077,078,079
  1. DRG78 ;
  1. DRG79 ;
  1. S ICDRG=$S(ICDMCC=2:77,ICDMCC=1:78,1:79) Q
  1. DRG80 ;line tag for 080,081
  1. DRG81 ;
  1. S ICDRG=$S(ICDMCC=2:80,1:81) Q
  1. DRG82 ;line tag for 082,083,084
  1. DRG83 ;
  1. DRG84 ;
  1. I ICDSD'["1" D DRG85 Q
  1. S ICDRG=$S(ICDMCC=2:82,ICDMCC=1:83,1:84) Q
  1. DRG85 ;line tag for 085,086,087
  1. DRG86 ;
  1. DRG87 ;
  1. S ICDRG=$S(ICDMCC=2:85,ICDMCC=1:86,1:87) Q
  1. DRG88 ;line tag for 088,089,090
  1. DRG89 ;
  1. DRG90 ;
  1. S ICDRG=$S(ICDMCC=2:88,ICDMCC=1:89,1:90) Q
  1. DRG91 ;line tag for 091,092,093
  1. DRG92 ;
  1. DRG93 ;
  1. S ICDRG=$S(ICDMCC=2:91,ICDMCC=1:92,1:93) Q
  1. DRG94 ;line tag for 094,095,096
  1. DRG95 ;
  1. DRG96 ;
  1. S ICDRG=$S(ICDMCC=2:94,ICDMCC=1:95,1:96) Q
  1. DRG97 ;line tag for 097,098,099
  1. DRG98 ;
  1. DRG99 ;
  1. S ICDRG=$S(ICDMCC=2:97,ICDMCC=1:98,1:99) Q
  1. Q