source: WorldVistAEHR/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG.m@ 1639

ICDDRG ;ALB/GRR/EG/ADL - ASSIGNS DRG CODES ; 5/19/05 12:52pm
 ;;18.0;DRG Grouper;**2,7,10,14,20**;Oct 20, 2000;Build 1
 ;ADL - UPDATED FOR CSV;3/10/03
TOP S (ICDDRG,ICDMDC,ICDRTC)=""
 ;*********************************************************
 ;FOLLOWING LINES CHECK FOR INVALID INPUT VARIABLES
 ;
 I '$D(ICDDX(1)) S ICDRTC=1 G ERR
 I ICDEXP'=0&(ICDEXP'=1)&(ICDEXP'="") S ICDRTC=5 G ERR
 I ICDTRS'=0&(ICDTRS'=1)&(ICDTRS'="") S ICDRTC=6 G ERR
 I ICDDMS'=0&(ICDDMS'=1)&(ICDDMS'="") S ICDRTC=7 G ERR
 I SEX'="M"&(SEX'="F")&(SEX'="") S ICDRTC=4 G ERR
 I '$D(ICDDATE) S ICDDATE=DT  ;default is today's FileMan date
 ;********************************************************
 ;FOLLOWING ESTABLISHES PRIMARY DIAGNOSIS RELATED VARIABLES
 ;
 D KILL S ICDSEX($S(SEX="M":1,SEX="F":2,1:0))=""
 S ICDTMP=$$ICDDX^ICDCODE(ICDDX(1),ICDDATE)
 I ICDTMP<0 S ICDRTC=1 G ERR
 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
 S ICDMDC=$P(ICDY(0),"^",5),ICDPD=$P(ICDY(0),"^",2),ICDRG=0 I 'ICDMDC S ICDDRG=469,ICDRTC=1 G ERR
 D MDCG
 I $D(ICDMDC(12))!($D(ICDMDC(13))) S ICDMDC=$S(SEX="F":13,1:12) I SEX="" S ICDRTC=4 G ERR
 ;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))=""
 ;Setup DRG arrays ICDPDRG(x) and ICDDRG(x) and SEX array
 S ICDTMP=$$GETDRG^ICDGTDRG(ICDDX(1),ICDDATE,9) I ICDTMP>0 S ICDPDRG=$P(ICDTMP,";") D
 . F ICDI=1:1 Q:$P(ICDPDRG,"^",ICDI)']""  S ICDPDRG($P(ICDPDRG,"^",ICDI))="",ICDRG($P(ICDPDRG,"^",ICDI))=""
 S ICD104=0,ICDP24=$P(ICDY(0),"^",12),ICDP25=$P(ICDY(0),"^",13) D SEX9
 ;
 ;FOLLOWING ESTABLISHES SECONDARY DIAGNOSIS VARIABLES
 ;
 S (ICDCCT,ICDSD)="",ICDCC=0,ICDI=1
 F ICDIZ=0:0 S ICDI=$O(ICDDX(ICDI)) Q:ICDI'>0  D  G:ICDRTC]"" ERR
 . S ICDTMP=$$ICDDX^ICDCODE(ICDDX(ICDI),ICDDATE) I ICDTMP<0!'($P(ICDTMP,U,10)) S ICDRTC=8 Q
 . S ICDY(0)=$P(ICDTMP,U,2,99),ICDDXT($P(ICDY(0),"^",1))=""
 . S ICDP15($S($P(ICDY(0),"^",2)["J":1,1:0))=""
 . D SEC,SEX9 G:ICDRTC]"" ERR
 S:$D(ICDCCT(1)) ICDCC=1 K ICDCCT
 ;********************************************************
 ;FOLLOWING ESTABLISHES OPERATION/PROCEDURE VARIABLES
 ;
 N ICDOTMP S (ICDMAJ,ICDORNI,ICDOP,ICDOR,ICDOTMP)="",(ICDOCNT,ICDONR,ICDORNR,ICDNOR,ICDOPCT,ICDOPNR)=0
 ;Return ICD Operation/Procedure code info check if active
 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 
 . 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
 K ICDO24("N") G:ICDRTC]"" ERR
 G ^ICDDRG0
SEC S ICDCC=$S($D(^ICD9("ACC",ICDDX(ICDI),ICDDX(1))):0,$P(ICDY(0),"^",7)=1:1,1:ICDCC),ICDCCT(ICDCC)=""
 ;Group ICD identifiers in one variable
 S ICDSD=ICDSD_$P(ICDY(0),"^",2)
 S ICDTMP=$$GETDRG^ICDGTDRG(ICDDX(ICDI),ICDDATE,9)
 ;If any of the following conditions are met set ICDSDRG array
 I (($P(ICDY(0),"^",7)=1)!(ICDPD["h")!(ICDPD["J")!(ICDSD["h")),'$P(ICDTMP,";",3) D
 . S ICDSDRG=$P(ICDTMP,";")
 . F ICDK=1:1 Q:$P(ICDSDRG,"^",ICDK)']""  S ICDSDRG($P(ICDSDRG,"^",ICDK))=""
 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))=""
 K ICDS24("N"),ICDS25(0) Q
OPSTUF I '$D(ICDOP(" "_$P(ICDY(0),"^",1))) S ICDOP(" "_$P(ICDY(0),"^",1))="",ICDOCNT=ICDOCNT+1
 I $S($D(ICDMDC(12))!($D(ICDMDC(13)))>0:'$$MDCT("ICDMDC",0),1:'$D(^ICD0(ICDY,2,1,1,"B",ICDMDC))) D
 .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
 S ICDOR=ICDOR_$P(ICDY(0),"^",2)
 I +ICDY(0)>37.69,+ICDY(0)<37.84,ICDOR'["p" D
 .N ICDCC3
 .D EN1^ICDDRG5 I ICDCC3 S ICDOR=ICDOR_"p" S:ICDOR'["O" ICDOR=ICDOR_"O"
 .Q
 I +ICDY(0)>80.999 I +ICDY(0)<81.40 N ICDCC3 D EN1^ICDDRG8 I ICDCC3 S ICDOR=ICDOR_"F"
 S:$D(^ICD0(ICDY,"M")) ICDMAJ=ICDMAJ_$P(^ICD0(ICDY,"M"),"^")_"^"
 ;Set ICDOTMP with DRGs for doing checks
 S ICDOTMP=$P($$GETDRG^ICDGTDRG(ICDY,ICDDATE,0),";",1)
 I $P(ICDY(0),"^",2)["O" D
 .S ICDOPCT=ICDOPCT+1
 .I ICDOPNR=0 D
 ..I $S($D(ICDMDC(12))!($D(ICDMDC(13)))>0:'$$MDCT("ICDMDC",0),1:'$D(ICDOTMP)) S ICDOPNR=1
 I +ICDOTMP>0 S ICDF=ICDOTMP F ICDFX=1:1 Q:$P(ICDF,"^",ICDFX)']""  S ICDODRG($P(ICDF,"^",ICDFX))=$P(ICDF,"^",ICDFX)
 ;translate specific identifiers into common symbol, check for symbol
 S ICD104=$S($P(ICDY(0),"^",2)["P":1,1:0),ICDNMDC($S($TR($P(ICDY(0),"^",2),"lqtrB","\\\\")["\":1,1:0))="" Q
ERR S ICDDRG=470
 Q  ;ERR
SEX9 ;get sex for dx or proc
 S ICDSEX($S($P(ICDY(0),"^",10)="M":1,$P(ICDY(0),"^",10)="F":2,1:0))=""
 Q
MDCG ;set up ICDMDC() array
 N X,Y,I,N,DRG,MDC,ICDTMP
 S ICDTMP=$$GETDRG^ICDGTDRG(ICDDX(1),ICDDATE,9) Q:'$P(ICDTMP,";",3)
 S Y=$P(ICDTMP,";")
 S N=$L(Y)-$L($TR(Y,"^"))
 F I=1:1:N+1 D
 .S DRG=$P(Y,"^",I) Q:DRG=""
 .S MDC=$P($$DRG^ICDGTDRG(DRG,ICDDATE),"^",5) Q:MDC=""
 .S ICDMDC(MDC)=""
 Q
MDCT(MDC,PAR) ;for multiple mdc dx codes
 ;MDC is array of MDC's (MDC(ICDMDC)=""), PAR global node to test
 ;
 N I,MD,BOOL,DRGFY
 S MD="" F I=1:1 S MD=$O(@MDC@(MD)) Q:MD=""  D
 . 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))
 .I $D(MDC) S BOOL(1)=""
 .S BOOL(0)=""
 I '$D(BOOL(1)) Q 0
 Q 1
KILL K ICD104,ICDJ,ICDJJ,ICDOCNT,ICDOR,ICDNOR,ICDP15,ICDPDRG,ICDRG,ICDSEX
 K ICDSDRG,ICDODRG,ICDCC,ICDOP,ICDORNR,ICDORNI,ICDP24,ICDP25,ICDPD
 K ICDSD,ICDI,ICDK,ICDF,ICDFX,ICDFK,ICDY,ICDDXT,ICDIZ,ICDONR,ICDOPCT
 K ICD,ICDCC2,ICDCC3,ICDGH,ICDL39,ICDMAJ,ICDNMDC,ICDNSD,ICDORNA,ICDREF,ICDS25
 K ICDOPNR,ICDO24
 Q