source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG.m@ 1374

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

initial load of FOIAVistA 6/30/08 version

File size: 5.8 KB
Line 
1ICDDRG ;ALB/GRR/EG/ADL - ASSIGNS DRG CODES ; 11/13/07 4:07pm
2 ;;18.0;DRG Grouper;**2,7,10,14,20,31**;Oct 20, 2000;Build 7
3 ;ADL - UPDATED FOR CSV;3/10/03
4TOP S (ICDDRG,ICDMDC,ICDRTC)=""
5 ;*********************************************************
6 ;FOLLOWING LINES CHECK FOR INVALID INPUT VARIABLES
7 ;
8 I '$D(ICDDX(1)) S ICDRTC=1 G ERR
9 I ICDEXP'=0&(ICDEXP'=1)&(ICDEXP'="") S ICDRTC=5 G ERR
10 I ICDTRS'=0&(ICDTRS'=1)&(ICDTRS'="") S ICDRTC=6 G ERR
11 I ICDDMS'=0&(ICDDMS'=1)&(ICDDMS'="") S ICDRTC=7 G ERR
12 I SEX'="M"&(SEX'="F")&(SEX'="") S ICDRTC=4 G ERR
13 I '$D(ICDDATE) S ICDDATE=DT ;default is today's FileMan date
14 ;********************************************************
15 ;FOLLOWING ESTABLISHES PRIMARY DIAGNOSIS RELATED VARIABLES
16 ;
17 D KILL S ICDSEX($S(SEX="M":1,SEX="F":2,1:0))=""
18 S ICDTMP=$$ICDDX^ICDCODE(ICDDX(1),ICDDATE)
19 I ICDTMP<0 S ICDRTC=1 G ERR
20 S ICDY(0)=$P(ICDTMP,U,2,99) I $P(ICDY(0),"^",4)=1!($P(ICDY(0),"^",9)=0) S ICDRTC=1 G ERR ;flag has changed from inactive flag to status flag
21 S ICDMDC=$P(ICDY(0),"^",5),ICDPD=$P(ICDY(0),"^",2),ICDRG=0 I 'ICDMDC S ICDRTC=1 G ERR
22 D MDCG
23 I $D(ICDMDC(12))!($D(ICDMDC(13))) S ICDMDC=$S(SEX="F":13,1:12) I SEX="" S ICDRTC=4 G ERR
24 ;I $D(^ICD9(ICDDX(1),"DRG")) S ICDPDRG=^("DRG") F ICDI=1:1 Q:$P(ICDPDRG,"^",ICDI)']"" S ICDPDRG($P(ICDPDRG,"^",ICDI))="",ICDRG($P(ICDPDRG,"^",ICDI))=""
25 ;Setup DRG arrays ICDPDRG(x) and ICDDRG(x) and SEX array
26 S ICDTMP=$$GETDRG^ICDGTDRG(ICDDX(1),ICDDATE,9) I ICDTMP>0 S ICDPDRG=$P(ICDTMP,";") D
27 . F ICDI=1:1 Q:$P(ICDPDRG,"^",ICDI)']"" S ICDPDRG($P(ICDPDRG,"^",ICDI))="",ICDRG($P(ICDPDRG,"^",ICDI))=""
28 S ICD104=0,ICDP24=$P(ICDY(0),"^",12),ICDP25=$P(ICDY(0),"^",13) D SEX9
29 ;
30 ;FOLLOWING ESTABLISHES SECONDARY DIAGNOSIS VARIABLES
31 ;
32 S (ICDCCT,ICDMCCT,ICDSD)="",ICDCC=0,ICDMCC=0,ICDI=1
33 F ICDIZ=0:0 S ICDI=$O(ICDDX(ICDI)) Q:ICDI'>0 D G:ICDRTC]"" ERR
34 . S ICDTMP=$$ICDDX^ICDCODE(ICDDX(ICDI),ICDDATE) I ICDTMP<0!'($P(ICDTMP,U,10)) S ICDRTC=8 Q
35 . S ICDY(0)=$P(ICDTMP,U,2,99),ICDDXT($P(ICDY(0),"^",1))=""
36 . S ICDP15($S($P(ICDY(0),"^",2)["J":1,1:0))=""
37 . D SEC,SEX9 G:ICDRTC]"" ERR
38 S:$D(ICDCCT(1)) ICDCC=1 K ICDCCT
39 S:$D(ICDMCCT(1)) ICDMCC=1 S:$D(ICDMCCT(2)) ICDMCC=2 K ICDMCCT
40 ;********************************************************
41 ;FOLLOWING ESTABLISHES OPERATION/PROCEDURE VARIABLES
42 ;
43 N ICDOTMP S (ICDMAJ,ICDORNI,ICDOP,ICDOR,ICDOTMP)="",(ICDOCNT,ICDONR,ICDORNR,ICDNOR,ICDOPCT,ICDOPNR)=0
44 ;Return ICD Operation/Procedure code info check if active
45 I $D(ICDPRC) F ICDI=1:1 Q:'$D(ICDPRC(ICDI)) X "S ICDTMP=$$ICDOP^ICDCODE(ICDPRC(ICDI),ICDDATE) I ICDTMP<0!'($P(ICDTMP,U,10)) S ICDRTC=2 Q" I ICDRTC="" D
46 . S ICDY(0)=$P(ICDTMP,U,2,99),ICDNOR=ICDNOR+1,ICDY=ICDPRC(ICDI),ICDO24($S($P(ICDY(0),"^",3)'="":$P(ICDY(0),"^",3),1:"N"))="" D OPSTUF,SEX9
47 K ICDO24("N") G:ICDRTC]"" ERR
48 G ^ICDDRG0
49SEC I ICDDATE>3070930.9 D
50 .S ICDMCC=$S($D(^ICD9("ACC",ICDDX(ICDI),ICDDX(1))):0,$P(ICDY(0),"^",18)=2:2,($P(ICDY(0),"^",18)=1)&(ICDMCC'=2):1,1:ICDMCC),ICDMCCT(ICDMCC)=""
51 E D
52 .S ICDCC=$S($D(^ICD9("ACC",ICDDX(ICDI),ICDDX(1))):0,$P(ICDY(0),"^",7)=1:1,1:ICDCC),ICDCCT(ICDCC)=""
53 ;Group ICD identifiers in one variable
54 S ICDSD=ICDSD_$P(ICDY(0),"^",2)
55 S ICDTMP=$$GETDRG^ICDGTDRG(ICDDX(ICDI),ICDDATE,9)
56 ;If any of the following conditions are met set ICDSDRG array
57 I (($P(ICDY(0),"^",7)=1)!(ICDPD["h")!(ICDPD["J")!(ICDSD["h")),'$P(ICDTMP,";",3) D
58 . S ICDSDRG=$P(ICDTMP,";")
59 . F ICDK=1:1 Q:$P(ICDSDRG,"^",ICDK)']"" S ICDSDRG($P(ICDSDRG,"^",ICDK))=""
60 S ICDS24($S($P(ICDY(0),"^",12)'="":$P(ICDY(0),"^",12),1:"N"))="",ICDS25($S($P(ICDY(0),"^",13)'="":$P(ICDY(0),"^",13),1:0))=""
61 K ICDS24("N"),ICDS25(0) Q
62OPSTUF I '$D(ICDOP(" "_$P(ICDY(0),"^",1))) S ICDOP(" "_$P(ICDY(0),"^",1))="",ICDOCNT=ICDOCNT+1
63 I $S($D(ICDMDC(12))!($D(ICDMDC(13)))>0:'$$MDCT("ICDMDC",0),1:'$D(^ICD0(ICDY,2,1,1,"B",ICDMDC))) D
64 .S ICDONR=ICDONR+1,ICDORNI=ICDORNI_$P(ICDY(0),"^",2),ICDORNI($S($P(ICDY(0),"^",2)'="":$P(ICDY(0),"^",2),1:0))="" S:ICDORNR'=0 ICDORNR=1
65 S ICDOR=ICDOR_$P(ICDY(0),"^",2)
66 I +ICDY(0)>37.69,+ICDY(0)<37.84,ICDOR'["p" D
67 .N ICDCC3
68 .D EN1^ICDDRG5 I ICDCC3 S ICDOR=ICDOR_"p" S:ICDOR'["O" ICDOR=ICDOR_"O"
69 .Q
70 I +ICDY(0)>80.999 I +ICDY(0)<81.40 N ICDCC3 D EN1^ICDDRG8 I ICDCC3 S ICDOR=ICDOR_"F"
71 S:$D(^ICD0(ICDY,"M")) ICDMAJ=ICDMAJ_$P(^ICD0(ICDY,"M"),"^")_"^"
72 ;Set ICDOTMP with DRGs for doing checks
73 S ICDOTMP=$P($$GETDRG^ICDGTDRG(ICDY,ICDDATE,0),";",1)
74 I $P(ICDY(0),"^",2)["O" D
75 .S ICDOPCT=ICDOPCT+1
76 .I ICDOPNR=0 D
77 ..I $S($D(ICDMDC(12))!($D(ICDMDC(13)))>0:'$$MDCT("ICDMDC",0),1:'$D(ICDOTMP)) S ICDOPNR=1
78 I +ICDOTMP>0 S ICDF=ICDOTMP F ICDFX=1:1 Q:$P(ICDF,"^",ICDFX)']"" S ICDODRG($P(ICDF,"^",ICDFX))=$P(ICDF,"^",ICDFX)
79 ;translate specific identifiers into common symbol, check for symbol
80 S ICD104=$S($P(ICDY(0),"^",2)["P":1,1:0),ICDNMDC($S($TR($P(ICDY(0),"^",2),"lqtrB","\\\\")["\":1,1:0))="" Q
81ERR S ICDDRG=$S(ICDDATE>3070930.9:999,1:470)
82 Q ;ERR
83SEX9 ;get sex for dx or proc
84 S ICDSEX($S($P(ICDY(0),"^",10)="M":1,$P(ICDY(0),"^",10)="F":2,1:0))=""
85 Q
86MDCG ;set up ICDMDC() array
87 N X,Y,I,N,DRG,MDC,ICDTMP
88 S ICDTMP=$$GETDRG^ICDGTDRG(ICDDX(1),ICDDATE,9) Q:'$P(ICDTMP,";",3)
89 S Y=$P(ICDTMP,";")
90 S N=$L(Y)-$L($TR(Y,"^"))
91 F I=1:1:N+1 D
92 .S DRG=$P(Y,"^",I) Q:DRG=""
93 .S MDC=$P($$DRG^ICDGTDRG(DRG,ICDDATE),"^",5) Q:MDC=""
94 .S ICDMDC(MDC)=""
95 Q
96MDCT(MDC,PAR) ;for multiple mdc dx codes
97 ;MDC is array of MDC's (MDC(ICDMDC)=""), PAR global node to test
98 ;
99 N I,MD,BOOL,DRGFY
100 S MD="" F I=1:1 S MD=$O(@MDC@(MD)) Q:MD="" D
101 . S DRGFY=$O(^ICD0(CODE,2,"B",+ICDDATE),-1),DADRGFY=$O(^ICD0(CODE,2,"B",+DRGFY,DADRGFY)),MDC=$O(^ICD0(CODE,2,+DADRGFY,1,"B",MD))
102 .I $D(MDC) S BOOL(1)=""
103 .S BOOL(0)=""
104 I '$D(BOOL(1)) Q 0
105 Q 1
106KILL K ICD104,ICDJ,ICDJJ,ICDOCNT,ICDOR,ICDNOR,ICDP15,ICDPDRG,ICDRG,ICDSEX
107 K ICDSDRG,ICDODRG,ICDCC,ICDMCC,ICDOP,ICDORNR,ICDORNI,ICDP24,ICDP25,ICDPD
108 K ICDSD,ICDI,ICDK,ICDF,ICDFX,ICDFK,ICDY,ICDDXT,ICDIZ,ICDONR,ICDOPCT
109 K ICD,ICDCC2,ICDCC3,ICDGH,ICDL39,ICDMAJ,ICDNMDC,ICDNSD,ICDORNA,ICDREF,ICDS25
110 K ICDOPNR,ICDO24
111 Q
Note: See TracBrowser for help on using the repository browser.