source: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 5.5 KB
Line 
1ICDDRG ;ALB/GRR/EG/ADL - ASSIGNS DRG CODES ; 5/19/05 12:52pm
2 ;;18.0;DRG Grouper;**2,7,10,14,20**;Oct 20, 2000;Build 1
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 ICDDRG=469,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,ICDSD)="",ICDCC=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 ;********************************************************
40 ;FOLLOWING ESTABLISHES OPERATION/PROCEDURE VARIABLES
41 ;
42 N ICDOTMP S (ICDMAJ,ICDORNI,ICDOP,ICDOR,ICDOTMP)="",(ICDOCNT,ICDONR,ICDORNR,ICDNOR,ICDOPCT,ICDOPNR)=0
43 ;Return ICD Operation/Procedure code info check if active
44 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
45 . 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
46 K ICDO24("N") G:ICDRTC]"" ERR
47 G ^ICDDRG0
48SEC S ICDCC=$S($D(^ICD9("ACC",ICDDX(ICDI),ICDDX(1))):0,$P(ICDY(0),"^",7)=1:1,1:ICDCC),ICDCCT(ICDCC)=""
49 ;Group ICD identifiers in one variable
50 S ICDSD=ICDSD_$P(ICDY(0),"^",2)
51 S ICDTMP=$$GETDRG^ICDGTDRG(ICDDX(ICDI),ICDDATE,9)
52 ;If any of the following conditions are met set ICDSDRG array
53 I (($P(ICDY(0),"^",7)=1)!(ICDPD["h")!(ICDPD["J")!(ICDSD["h")),'$P(ICDTMP,";",3) D
54 . S ICDSDRG=$P(ICDTMP,";")
55 . F ICDK=1:1 Q:$P(ICDSDRG,"^",ICDK)']"" S ICDSDRG($P(ICDSDRG,"^",ICDK))=""
56 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))=""
57 K ICDS24("N"),ICDS25(0) Q
58OPSTUF I '$D(ICDOP(" "_$P(ICDY(0),"^",1))) S ICDOP(" "_$P(ICDY(0),"^",1))="",ICDOCNT=ICDOCNT+1
59 I $S($D(ICDMDC(12))!($D(ICDMDC(13)))>0:'$$MDCT("ICDMDC",0),1:'$D(^ICD0(ICDY,2,1,1,"B",ICDMDC))) D
60 .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
61 S ICDOR=ICDOR_$P(ICDY(0),"^",2)
62 I +ICDY(0)>37.69,+ICDY(0)<37.84,ICDOR'["p" D
63 .N ICDCC3
64 .D EN1^ICDDRG5 I ICDCC3 S ICDOR=ICDOR_"p" S:ICDOR'["O" ICDOR=ICDOR_"O"
65 .Q
66 I +ICDY(0)>80.999 I +ICDY(0)<81.40 N ICDCC3 D EN1^ICDDRG8 I ICDCC3 S ICDOR=ICDOR_"F"
67 S:$D(^ICD0(ICDY,"M")) ICDMAJ=ICDMAJ_$P(^ICD0(ICDY,"M"),"^")_"^"
68 ;Set ICDOTMP with DRGs for doing checks
69 S ICDOTMP=$P($$GETDRG^ICDGTDRG(ICDY,ICDDATE,0),";",1)
70 I $P(ICDY(0),"^",2)["O" D
71 .S ICDOPCT=ICDOPCT+1
72 .I ICDOPNR=0 D
73 ..I $S($D(ICDMDC(12))!($D(ICDMDC(13)))>0:'$$MDCT("ICDMDC",0),1:'$D(ICDOTMP)) S ICDOPNR=1
74 I +ICDOTMP>0 S ICDF=ICDOTMP F ICDFX=1:1 Q:$P(ICDF,"^",ICDFX)']"" S ICDODRG($P(ICDF,"^",ICDFX))=$P(ICDF,"^",ICDFX)
75 ;translate specific identifiers into common symbol, check for symbol
76 S ICD104=$S($P(ICDY(0),"^",2)["P":1,1:0),ICDNMDC($S($TR($P(ICDY(0),"^",2),"lqtrB","\\\\")["\":1,1:0))="" Q
77ERR S ICDDRG=470
78 Q ;ERR
79SEX9 ;get sex for dx or proc
80 S ICDSEX($S($P(ICDY(0),"^",10)="M":1,$P(ICDY(0),"^",10)="F":2,1:0))=""
81 Q
82MDCG ;set up ICDMDC() array
83 N X,Y,I,N,DRG,MDC,ICDTMP
84 S ICDTMP=$$GETDRG^ICDGTDRG(ICDDX(1),ICDDATE,9) Q:'$P(ICDTMP,";",3)
85 S Y=$P(ICDTMP,";")
86 S N=$L(Y)-$L($TR(Y,"^"))
87 F I=1:1:N+1 D
88 .S DRG=$P(Y,"^",I) Q:DRG=""
89 .S MDC=$P($$DRG^ICDGTDRG(DRG,ICDDATE),"^",5) Q:MDC=""
90 .S ICDMDC(MDC)=""
91 Q
92MDCT(MDC,PAR) ;for multiple mdc dx codes
93 ;MDC is array of MDC's (MDC(ICDMDC)=""), PAR global node to test
94 ;
95 N I,MD,BOOL,DRGFY
96 S MD="" F I=1:1 S MD=$O(@MDC@(MD)) Q:MD="" D
97 . 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))
98 .I $D(MDC) S BOOL(1)=""
99 .S BOOL(0)=""
100 I '$D(BOOL(1)) Q 0
101 Q 1
102KILL K ICD104,ICDJ,ICDJJ,ICDOCNT,ICDOR,ICDNOR,ICDP15,ICDPDRG,ICDRG,ICDSEX
103 K ICDSDRG,ICDODRG,ICDCC,ICDOP,ICDORNR,ICDORNI,ICDP24,ICDP25,ICDPD
104 K ICDSD,ICDI,ICDK,ICDF,ICDFX,ICDFK,ICDY,ICDDXT,ICDIZ,ICDONR,ICDOPCT
105 K ICD,ICDCC2,ICDCC3,ICDGH,ICDL39,ICDMAJ,ICDNMDC,ICDNSD,ICDORNA,ICDREF,ICDS25
106 K ICDOPNR,ICDO24
107 Q
Note: See TracBrowser for help on using the repository browser.