source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRGX.m@ 757

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

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1ICDDRGX ;ALB/EG/MRY/ADL - GROUPER PROCESS ; 11/13/07 3:44pm
2 ;;18.0;DRG Grouper;**1,2,5,7,10,14,20,24,27,31**;Oct 20, 2000;Build 7
3CKHIV ;MDC25 grouping
4 I ICDDATE>3070930.9 G CKHIV^ICDDRGXM ;MS-DRG
5 ;Q:ICDP25=""
6 I ICDPD'["h"&(ICDSD'["h") Q
7 S ICDRG=$S(ICDOR["x":488,ICDPD["i"&($D(ICDS25(1))):490,1:ICDRG)
8 S ICDGH=$S("488^489^490"[ICDRG:1,1:0),ICDORNI=$S(ICDOCNT>0:ICDORNI,1:0),ICDORNA=$F(ICDORNI,"O",$F(ICDORNI,"O"))
9 S:ICDORNI="" ICDORNI=ICDOR
10 S ICDRG=$S(ICDP25=1&(ICDORNA>0):488,1:ICDRG) I 'ICDGH&(ICDRG=488) Q
11 S:(ICDOCNT>0) ICDRG=$S(ICDP25>1&(ICDORNA>0)&($D(ICDS25(1))):488,1:ICDRG) I 'ICDGH&(ICDRG=488) Q
12 I ICDOPCT>0 D I ICDRG=488 Q
13 .;count the non-extensive "z" vs the "O"
14 .N K1,K2,I
15 .S (K1,K2)=0
16 .F I=1:1:$L(ICDORNI) S:$E(ICDORNI,I,I)="z" K1=K1+1 S:$E(ICDORNI,I,I)="O" K2=K2+1
17 .I ICDP25=1!(ICDP25>1&($D(ICDS25)>0)) D
18 ..I K1<K2&(K1<ICDOPCT) D
19 ...S ICDRG=488 Q
20 ..I ICDOPCT=1&(ICDORNI'["z") D
21 ...S ICDRG=488 Q
22 S ICDRG=$S(ICDP25=1&('$D(ICDS25))&('$O(^ICD9(ICDDX(1),"R",0))):490,1:ICDRG) I 'ICDGH&(ICDRG=490) Q
23 S ICDRG=$S(ICDP25=1&($D(ICDS25(2))):489,ICDP25=1&($D(ICDS25(3))):490,1:ICDRG) I 'ICDGH&((ICDRG=489)!(ICDRG=490)) Q
24 S ICDRG=$S(ICDP25=2&($D(ICDS25(1))):489,ICDP25=3&($D(ICDS25(1))):490,1:ICDRG) I 'ICDGH&((ICDRG=489)!(ICDRG=490)) Q
25 S ICDRG=$S((ICDP25&(ICDOCNT=0)&('$D(ICDS25))):490,1:ICDRG) I 'ICDGH&(ICDRG=490) Q
26 S:(ICDRG=488)!(ICDRG=489)!(ICDRG=490) ICDRTC=0
27 K ICDGH,ICDP25,ICDS25,ICDORNA Q
28CKMST ;MDC24 grouping; MS-DRG additions
29 S ICDAJ=0 F ICDS24K=1:1 S ICDAJ=$O(ICDS24(ICDAJ)) Q:ICDAJ=""
30 S ICDS24K=ICDS24K-1,ICDS24L=0 F ICDI=1:1:8 S:$D(ICDS24(ICDI))&(ICDI'=ICDP24) ICDS24L=$S($D(ICDS24(ICDI)):1,1:0)
31 I ICDOR["u" S ICDS24K=ICDS24K+1
32 G:((ICDP24=0)&(ICDS24K<2))!((ICDP24>0)&('ICDS24L)) CKMSTE
33 N CKMST S CKMST=0
34 I ICDDATE>3070930.9 D Q:CKMST ;MS-DRG
35 . S ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(1))):955,ICDP24>0&($D(ICDO24(1)))&(ICDS24L):955,1:ICDRG) I ICDRG=955 D CKMSTE S CKMST=1 Q
36 . S:ICDRG'=955 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(2))):956,ICDP24>0&($D(ICDO24(2)))&(ICDS24L):956,1:ICDRG) I ICDRG=956 D CKMSTE S CKMST=1 Q
37 . S:ICDRG'=956 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(3))):959,ICDP24>0&($D(ICDO24(3)))&(ICDS24L):959,1:ICDRG) I ICDRG=959 D CKMSTE S CKMST=1 Q
38 . S ICDRG=$S(ICDP24=0&(ICDS24K>1):965,ICDP24>0&ICDS24L:965,1:ICDRG)
39 . S:(ICDRG>954)&(ICDRG<966) ICDRTC=0
40 E D Q:CKMST ;CMS-DRG
41 . S ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(1))):484,ICDP24>0&($D(ICDO24(1)))&(ICDS24L):484,1:ICDRG) I ICDRG=484 D CKMSTE S CKMST=1 Q
42 . S:ICDRG'=484 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(2))):485,ICDP24>0&($D(ICDO24(2)))&(ICDS24L):485,1:ICDRG) I ICDRG=485 D CKMSTE S CKMST=1 Q
43 . S:ICDRG'=485 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(3))):486,ICDP24>0&($D(ICDO24(3)))&(ICDS24L):486,1:ICDRG) I ICDRG=486 D CKMSTE S CKMST=1 Q
44 . S ICDRG=$S(ICDP24=0&(ICDS24K>1):487,ICDP24>0&ICDS24L:487,1:ICDRG)
45 . S:(ICDRG>483)&(ICDRG<488) ICDRTC=0
46CKMSTE K ICDAJ,ICDP24,ICDS24,ICDO24,ICDS24K,ICDO24,ICDS24L
47 Q
48CKNMDC ;non MDC drg's
49 I ICDDATE>3070930.9 G CKNMDC^ICDDRGXM ;MS-DRG
50 S:(ICDRG>479)&(ICDRG<484) ICDRG=470
51 ; ICD*18*1 - reorder drg 103 higher than all Pre-MDCs 480-83 & 495
52 I ICDRG=103 S ICDRTC=0 Q
53 ;use FY logic to resolve DRG if no FY defined user current FY
54 N ICDDXFY S ICDDXFY=""
55 I ICDDATE>3040930.9 D I ICDRG=541!(ICDRG=542) S ICDRTC=0 Q ;Use DRG FY 05 logic
56 .;S ICDRG=$S($D(ICDOP(" 31.1"))!($D(ICDOP(" 31.21")))!($D(ICDOP(" 31.29")))&(($P($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3)'["Y")!($D(ICDOP(" 96.72")))):541,1:ICDRG)
57 .;I ICDRG=541&(($P($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3))["Y") S ICDRG=542 S ICDRTC=0
58 .I $D(ICDOP(" 39.65")) S ICDRG=541 Q
59 .I $D(ICDOP(" 31.1"))!($D(ICDOP(" 31.21")))!($D(ICDOP(" 31.29"))) I $P($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3)'["Y"!(($D(ICDOP(" 96.72")))) S ICDRG=542
60 .I $D(ICDOP(" 31.1"))!($D(ICDOP(" 31.21")))!($D(ICDOP(" 31.29"))) I $P($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3)'["Y"!(($D(ICDOP(" 96.72")))) I ICDOR["O"&(ICDOR'["z")&(ICDOR'["y") S ICDRG=541
61 I ICDDATE<3041001 D Q:ICDRG=483 ;Use DRG FY 04 logic
62 .S ICDRG=$S($D(ICDOP(" 31.1"))!($D(ICDOP(" 31.21")))!($D(ICDOP(" 31.29")))&(($P($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3)'["Y")!($D(ICDOP(" 96.72")))):483,1:ICDRG) I ICDRG=483 S ICDRTC=0
63 S ICDRG=$S(ICDOR["l":480,1:ICDRG) I ICDRG=480 S ICDRTC=0 Q
64 I ICDRG=512!(ICDRG=513) S ICDRTC=0 Q
65 S ICDRG=$S(ICDOR["r":495,1:ICDRG) I ICDRG=495 S ICDRTC=0 Q ;check for lung tx
66 S ICDRG=$S(ICDOR["q":103,1:ICDRG) I ICDRG=103 S ICDRTC=0 Q ;check for heart tx
67 S ICDRG=$S(ICDOR["B":481,1:ICDRG) I ICDRG=481 S ICDRTC=0 Q
68 S ICDRG=$S($D(ICDOP(" 30.3"))!$D(ICDOP(" 30.4")):482,1:ICDRG) I ICDRG=482 S ICDRTC=0 Q
69 S ICDRG=$S(ICDOR["t"&($P($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3)["Y"):482,1:ICDRG) I ICDRG=482 S ICDRTC=0 Q
70 Q
71 ;
72 ;
73CHKMDC4 ;MDC 4 drg's
74 I ICDDATE>3070930.9 D ;MS-DRG
75 . I (ICDMDC=4!(ICDMDC=98)),(ICDOR["f") S ICDRG=168
76 . I ICDDRG=983,$G(ICDMDC)=5,$D(ICDOP(" 86.06")) S ICDRG=264
77 . I ICDDRG=983,$G(ICDMDC)=5,$D(ICDOP(" 92.27")),ICDNOR=1 S ICDRG=264 ;ICD*18*5
78 E D ;CMS-DRG
79 . I (ICDMDC=4!(ICDMDC=98)),(ICDOR["f") S ICDRG=76
80 . I ICDDRG=468,$G(ICDMDC)=5,$D(ICDOP(" 86.06")) S ICDRG=120
81 . I ICDDRG=468,$G(ICDMDC)=5,$D(ICDOP(" 92.27")),ICDNOR=1 S ICDRG=120 ;ICD*18*5
82 Q
Note: See TracBrowser for help on using the repository browser.