source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB5.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.0 KB
Line 
1ICDTLB5 ;ALB/EG/ADL - GROUPER UTILITY FUNCTIONS ; 10/23/00 11:49am
2 ;;18.0;DRG Grouper;**7**;Oct 20, 2000
3 ;;ADL;UPDATE FOR CSV PROJECT;Mar 12, 2003
4DRG334 S ICDRG=$S(ICDCC:334,1:335) Q
5DRG335 S ICDRG=$S(ICDCC:334,1:335) Q
6DRG336 S ICDRG=$S(ICDCC:336,1:337) Q
7DRG337 S ICDRG=$S(ICDCC:336,1:337) Q
8DRG338 I SEX="M" D Q
9 .S ICDRG=$S(ICDPD["M":338,AGE="":470,AGE>17:339,SEX="":470,1:340),ICDRTC=$S(ICDRG=470:3,SEX="":4,1:ICDRTC) Q
10 I SEX="F" D Q
11 .I ICDOR["O" D DRG354 Q
12 .I ICDOR["Ogz" D DRG363 Q
13 .I ICDOR=""!(ICDOR["N") D DRG366
14 Q
15DRG339 D DRG338 Q
16DRG340 D DRG338 Q
17DRG342 S ICDRG=$S(AGE>17:342,1:343) I AGE="" S ICDRG=470,ICDRTC=3
18 Q
19DRG343 S ICDRG=$S(AGE>17:342,1:343) I AGE="" S ICDRG=470,ICDRTC=3
20 Q
21DRG344 S ICDRG=$S(ICDPD["M":344,1:345) Q
22DRG345 S ICDRG=$S(ICDPD["M":344,1:345) Q
23DRG346 S ICDRG=$S(ICDCC:346,1:347) I ICDMDC=13 S ICDRG=$S(ICDRG=346:366,1:367)
24 Q
25DRG347 S ICDRG=$S(ICDCC:346,1:347) I ICDMDC=13 S ICDRG=$S(ICDRG=346:366,1:367)
26 Q
27DRG348 S ICDRG=$S(ICDCC:348,1:349) Q
28DRG349 S ICDRG=$S(ICDCC:348,1:349) Q
29DRG350 S ICDRG=$S(SEX="M":350,1:368) I SEX="" S ICDRG=470,ICDRTC=4
30 Q
31DRG351 S ICDRG=$S('$D(ICDODRG)&(ICDORNR>0):468,SEX="":470,SEX="F":369,1:351),ICDRTC=$S(ICDRG=470:4,1:ICDRTC) Q
32DRG352 S ICDRG=$S(SEX="M":352,ICDPD["P":368,1:369) I SEX="" S ICDRG=470,ICDRTC=4
33 Q
34DRG354 S ICDRG=$S(ICDPD["M":$S(ICDPD["o":357,ICDCC:354,1:355),ICDCC:358,1:359) Q
35DRG355 D DRG354 Q
36DRG357 S ICDRG=$S(ICDPD["M":$S(ICDPD["o":357,ICDCC:354,1:355),ICDCC:358,1:359) D:'ICDOPCT DRG368 Q
37DRG358 D DRG357 Q
38DRG359 D DRG357 Q
39DRG363 S ICDRG=$S(ICDPD["M":363,1:364) Q
40DRG364 S ICDRG=$S(ICDPD["M":363,1:364) Q
41DRG366 S ICDRG=$S(ICDCC:366,1:367) Q
42DRG367 S ICDRG=$S(ICDCC:366,1:367) Q
43DRG368 S ICDRG=$S(SEX="F":368,1:470) I SEX="" S ICDRG=470,ICDRTC=4
44 Q
45DRG370 S ICDRG=$S(ICDOR["c"&(ICDCC):370,ICDOR["c":371,ICDOR'["s"&(ICDOR'["g")&(ICDSD["v"!(ICDPD["v")):372,ICDOR'["s"&(ICDOR'["g"):373,ICDOR["s":374,ICDOR["g":375,1:470) Q
46DRG371 S ICDRG=$S(ICDPD["D"&(ICDCC):370,ICDPD["D":371,1:469) I $D(ICDOR)<11!(ICDOR["n") D DRG372
47 Q
48DRG372 S ICDRG=$S(ICDPD["v"!(ICDSD["v"):372,ICDOR["s":374,ICDOR["g":375,1:373) Q
49DRG373 S ICDRG=$S(ICDPD["D"&(ICDPD["v"!(ICDPD["D"&(ICDSD["v"))):372,1:373) Q
50DRG374 S ICDRG=$S($D(ICDPDRG(374)):374,1:"") Q
51DRG375 S ICDRG=$S(ICDPD["D"!(ICDSD["D"):375,1:"") Q
52DRG376 S ICDRG=$S(ICDOR["O":377,1:376) Q
53DRG377 S ICDRG=$S(ICDOR["O":377,1:376) Q
54DRG380 S ICDRG=$S(ICDOR["d":381,1:380) Q
55DRG381 S ICDRG=$S('$D(ICDPDRG(381)):"",ICDOR["d":381,1:380) Q
56DRG383 S ICDRG=$S(ICDPD["F"&(ICDSD["u"):383,ICDSD["u"!(ICDPD["v"):383,ICDPD["u":383,1:384) Q
57DRG384 D DRG383 Q
58DRG387 ;
59 S ICDRG=$S(ICDPD["E":386,ICDSD["E":386,ICDPD["Hp"&(ICDSD["J"):387,ICDPD["J"&(ICDSD["Hp"):387,ICDPD["p"!(ICDSD["p")&((ICDPD'["J")!(ICDSD'["J")):388,1:"") D:ICDRG="" DRG389 Q
60DRG388 D DRG387 Q
61DRG389 S ICDRG=$S(ICDPD["HR"&(ICDSD["J"):389,ICDPD["J"&(ICDSD["HR"):389,ICDSD["J":389,ICDPD["J":389,'$D(ICDODRG)&('$D(ICDSDRG)):391,1:390) D:ICDRG=391 DRG391 Q
62DRG390 D DRG389 Q
63DRG391 S ICDRG=$S(ICDPD["E"!(ICDSD["E"):386,ICDPD["J"&(ICDPD["p"):387,ICDSD["J"&(ICDSD["p"):387,ICDPD["p"&(ICDPD'["J"):388,ICDSD["p"&(ICDSD'["J"):388,ICDPD["J"!(ICDSD["J"):389,1:"") I ICDRG'="" Q
64 I ICDPD["R" D Q:ICDRG=391
65 .I '$D(ICDDX(2)) S ICDRG=391 Q
66 .;ALL SECONDARIES CONTAIN "R", DRG=>391
67 .N I
68 .F I=1:1 Q:'$D(ICDDX(I)) S ICDRG=$S($P($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3)["R":391,1:390) Q:ICDRG=390
69 I ICDSD["R"&('$D(ICDDX(3))) S ICDRG=391 Q
70 S ICDRG=390
71 Q
72DRG392 S ICDRG=$S(AGE>17:392,1:393) I AGE="" S ICDRG=470,ICDRTC=3
73 Q
74DRG393 S ICDRG=$S(AGE>17:392,1:393) I AGE="" S ICDRG=470,ICDRTC=3
75 Q
76DRG395 S ICDRG=$S(AGE>17:395,1:396) I AGE="" S ICDRG=470,ICDRTC=3
77 Q
78DRG396 S ICDRG=$S(AGE>17:395,1:396) I AGE="" S ICDRG=470,ICDRTC=3
79 Q
80DRG398 S ICDRG=$S(ICDCC:398,1:399) Q
81DRG399 S ICDRG=$S(ICDCC:398,1:399) Q
82DRG400 I ICDPD["L"&(ICDMAJ'[3) D DRG401 Q:"401^402^403^404^405^470^473"[ICDRG
83 S ICDRG=$S(ICDPD["L":400,ICDCC:406,1:407) Q
84DRG401 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC)
85 Q
86DRG402 D DRG401
87 Q
Note: See TracBrowser for help on using the repository browser.