Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ICDDRG

ICDDRG.m

Go to the documentation of this file.
  1. ICDDRG ;ALB/GRR/EG/ADL/KUM - Assigns DRG Codes ;07/22/2013
  1. ;;18.0;DRG Grouper;**2,7,10,14,20,31,37,57,64,89**;Oct 20, 2000;Build 9
  1. ;
  1. ; ADL - Updated for Code Set Versioning 03/10/2003
  1. ; KER - Updated for ICD-10 06/30/2012
  1. ; KUM - FIXED TO TAKE FROM 5TH PIECE OF ICDY(0) AFTER CALLING $$ICDDX^ICDEX
  1. ; ICD*18*89 - ICD-10 DRG Redesign
  1. ;
  1. ; Global Variables
  1. ; None
  1. ;
  1. ; External References
  1. ; ^ICDDRG0 ICR N/A
  1. ; EN1^ICDDRG5 ICR N/A
  1. ; EN1^ICDDRG8 ICR N/A
  1. ; $$GETDRG^ICDEX ICR N/A
  1. ; $$ICDDX^ICDEX ICR N/A
  1. ; $$ICDOP^ICDEX ICR N/A
  1. ; $$ISA^ICDEX ICR N/A
  1. ; $$MDCD^ICDEX ICR N/A
  1. ; $$MDCT^ICDEX ICR N/A
  1. ; $$MOR^ICDEX ICR N/A
  1. ; MDCG^ICDEX ICR N/A
  1. ;
  1. ; Local Variables NEWed or KILLed in ICDDRGM and elsewhere
  1. ; ICDDATE,ICDDMS,ICDDRG,ICDDX,ICDEXP,ICDMDC,ICDPRC,ICDRTC
  1. ; ICDS24,ICDTMP,ICDTRS,SEX
  1. ;
  1. ;Input ICDDATE (required) - The date of service
  1. ;Input ICDEXP (required) - Did patient expire during episode? 0/1
  1. ;Input ICDTRS (required) - Patient transfer to acute facility? 0/1
  1. ;Input ICDDMS (required) - Patient have irregular discharge? 0/1
  1. ;Input ICDDX(1,2,..n)=X (required) - Set of pointers (X) to diagnosis codes in file #80.
  1. ;Input ICDPRC(1,2,..n)=X (required) - Set of pointers (X) to procedures in file #80.1.
  1. ;Input SEX (required) - Patient gender (M-Male,F-Female)
  1. ;Input ICDPOA(1,2, - Set of values (Y,N,W,U OR BLANK) corresponding to ICDDX input array to indicate Presence on Admission
  1. ;Output ICDDRG - Pointer to assigned DRG in file #80.2
  1. ;
  1. TOP ; Main Entry Point
  1. K ICDCSYS,ICDCSYS,ICDCDSY,ICDEDT
  1. K ICDDRG,ICDMDC,ICDRTC S (ICDDRG,ICDMDC,ICDRTC)=""
  1. ; Check for Invalid Input Variables
  1. I +($G(ICDDX(1)))'>0 S ICDRTC=1 G ERR
  1. ; Patient Expired?
  1. I ICDEXP'=0&(ICDEXP'=1)&(ICDEXP'="") S ICDRTC=5 G ERR
  1. ; Patient Transferred
  1. I ICDTRS'=0&(ICDTRS'=1)&(ICDTRS'="") S ICDRTC=6 G ERR
  1. ; Patient Discharged against Medical Advice
  1. I ICDDMS'=0&(ICDDMS'=1)&(ICDDMS'="") S ICDRTC=7 G ERR
  1. ; Patient Sex
  1. I SEX'="M"&(SEX'="F")&(SEX'="") S ICDRTC=4 G ERR
  1. ; Default is today's FileMan date
  1. I '$D(ICDDATE) S ICDDATE=DT
  1. I $D(ICDEDT) S ICDDATE=ICDEDT ;ICDEDT can be passed to ICDDRG by other applications
  1. I '$D(ICDCSYS) S ICDCSYS=$S(ICDDATE'<$$IMPDATE^LEXU("10D"):"ICD10",1:"ICD9")
  1. ;********************************************************
  1. ;Review of Diagnoses codes to be included in DRG calculation
  1. I ICDCSYS="ICD10" D ^ICDJC S ICDDRG=ICDJDRG K ICDJDRG Q ; redirect for ICD-10 DRG calculations
  1. I ICDCSYS="ICD10" D DXSCRN^ICDDRGM
  1. ;
  1. PRI ; Primary Diagnosis Related Variables
  1. D KILL S ICDSEX($S(SEX="M":1,SEX="F":2,1:0))=""
  1. S ICDTMP=$$ICDDX^ICDEX(+($G(ICDDX(1))),ICDDATE,$S(ICDCSYS="ICD9":1,ICDCSYS="ICD10":30,1:""),"I")
  1. S $P(ICDTMP,"^",3)=$TR($P(ICDTMP,"^",3),";","")
  1. ; Error if not found
  1. I ICDTMP<0 S ICDRTC=1 G ERR
  1. S ICDY(0)=$P(ICDTMP,U,2,99)
  1. ; Error if unacceptable or inactive
  1. I $P(ICDY(0),"^",4)=1!($P(ICDY(0),"^",9)=0) S ICDRTC=1 G ERR
  1. ;flag has changed from inactive flag to status flag
  1. D ICDIDS^ICDRGAPI("80",+$G(ICDDX(1)),.ICD10PD) ;Get Identifiers of Primary Diagnosis into ICD10PD array
  1. S ICDMDC=$P(ICDY(0),"^",5),ICDPD=$P(ICDY(0),"^",2),ICDRG=0
  1. ; Error if no MDC
  1. I 'ICDMDC S ICDRTC=1 G ERR
  1. D MDCG^ICDEX(+($G(ICDDX(1))),$G(ICDDATE),.ICDMDC)
  1. S:$O(ICDMDC(0))>0 ICDMDC=$P(ICDY(0),"^",5)
  1. I $D(ICDMDC(12))!($D(ICDMDC(13))) S ICDMDC=$S(SEX="F":13,1:12) I SEX="" S ICDRTC=4 G ERR
  1. ;Setup DRG arrays ICDPDRG(x) and ICDDRG(x) and SEX array
  1. S ICDTMP=$$GETDRG^ICDEX(80,+($G(ICDDX(1))),ICDDATE) I ICDTMP>0 S ICDPDRG=$P(ICDTMP,";") D
  1. . F ICDI=1:1 Q:$P(ICDPDRG,"^",ICDI)']"" S ICDPDRG($P(ICDPDRG,"^",ICDI))="",ICDRG($P(ICDPDRG,"^",ICDI))=""
  1. S ICD104=0,ICDP24=$P(ICDY(0),"^",12),ICDP25=$P(ICDY(0),"^",13) D SEX
  1. ; The following establishes Secondary Diagnosis Variables
  1. S (ICDCCT,ICDMCCT,ICDSD)="",ICDCC=0,ICDMCC=0,ICDI=1
  1. F ICDIZ=0:0 S ICDI=$O(ICDDX(ICDI)) Q:ICDI'>0 D G:ICDRTC]"" ERR
  1. . S ICDTMP=$$ICDDX^ICDEX(+($G(ICDDX(ICDI))),ICDDATE,$S(ICDCSYS="ICD9":1,ICDCSYS="ICD10":30,1:""),"I")
  1. . S $P(ICDTMP,"^",3)=$TR($P(ICDTMP,"^",3),";","")
  1. . I ICDTMP<0!'($P(ICDTMP,U,10)) S ICDRTC=8 Q
  1. . S ICDY(0)=$P(ICDTMP,U,2,99),ICDDXT($P(ICDY(0),"^",1))=""
  1. . S ICDP15($S($P(ICDY(0),"^",2)["J":1,1:0))=""
  1. . D SEC,SEX G:ICDRTC]"" ERR
  1. S:$D(ICDCCT(1)) ICDCC=1 K ICDCCT
  1. S:$D(ICDMCCT(1)) ICDMCC=1 S:$D(ICDMCCT(2)) ICDMCC=2 K ICDMCCT
  1. ;
  1. ;CHECK IF PDX IS OWN CC/MCC
  1. S ICDX=$$ISOWNCC^ICDRGAPI(ICDDX(1),ICDDATE,0) I ICDX>0 S ICDMCC=ICDX
  1. ;
  1. ; The following establishes Operation/Prodedure Variables
  1. N ICDOTMP S (ICDMAJ,ICDORNI,ICDOP,ICDOR,ICDOTMP)="",(ICDOCNT,ICDONR,ICDORNR,ICDNOR,ICDOPCT,ICDOPNR)=0
  1. ; Return ICD Operation/Procedure code info check if active
  1. S ICDCSYS=$S(ICDDATE'<$$IMPDATE^LEXU("10D"):"ICD10",1:"ICD9")
  1. S ICDCDSY=$S(ICDCSYS="ICD9":2,1:31)
  1. ;
  1. I $D(ICDPRC) F ICDI=1:1 Q:'$D(ICDPRC(ICDI)) X "S ICDTMP=$$ICDOP^ICDEX(+($G(ICDPRC(ICDI))),ICDDATE,ICDCDSY,""I"") I ICDTMP<0!'($P(ICDTMP,U,10)) S ICDRTC=2 Q" I ICDRTC="" D
  1. . S $P(ICDTMP,"^",3)=$TR($P(ICDTMP,"^",3),";","")
  1. . S ICDY(0)=$P(ICDTMP,U,2,99),ICDNOR=ICDNOR+1,ICDY=+($G(ICDPRC(ICDI))),ICDO24($S($P(ICDY(0),"^",3)'="":$P(ICDY(0),"^",3),1:"N"))="" D OPS,SEX
  1. K ICDO24("N") G:ICDRTC]"" ERR
  1. I ICDCSYS="ICD9" G ^ICDDRG0
  1. E D CLUSTERS^ICDRGAPI G ^ICDDG010
  1. ;
  1. SEC ; Secondary Diagnosis
  1. ; Is Secondary NCC for Primary
  1. I ICDCSYS="ICD9" S ICDMCC=$S(+($$ISA^ICDEX(+($G(ICDDX(ICDI))),+($G(ICDDX(1))),40))>0:0,$P(ICDY(0),"^",18)=2:2,($P(ICDY(0),"^",18)=1)&(ICDMCC'=2):1,1:ICDMCC),ICDMCCT(ICDMCC)=""
  1. I ICDCSYS="ICD10" S ICDMCC=$S($$ISACCEX^ICDRGAPI(+$G(ICDDX(ICDI)),+$G(ICDDX(1))):0,$P(ICDY(0),"^",18)=2:2,($P(ICDY(0),"^",18)=1)&(ICDMCC'=2):1,1:ICDMCC),ICDMCCT(ICDMCC)=""
  1. I 'ICDEXP,$P(ICDY(0),"^",18)=3 S ICDMCC=2,ICDMCCT(2)="" ;MCC if patient discharged alive
  1. ; Group ICD identifiers in one variable
  1. K ICD10SDT
  1. D ICDIDS^ICDRGAPI("80",+($G(ICDDX(ICDI))),.ICD10SDT) ;Get ICD-10 identifiers into ICD10SD
  1. D ICDMRG^ICDRGAPI(.ICD10SD,.ICD10SDT)
  1. I $L($P(ICDY(0),"^",2)) S ICDSD=$$TM(ICDSD,";")_";"_$$TM($P(ICDY(0),"^",2),";"),ICDSD=";"_$$TM(ICDSD,";")_";"
  1. S ICDTMP=$$GETDRG^ICDEX(80,+($G(ICDDX(ICDI))),ICDDATE)
  1. ;
  1. ; If any of the following conditions are met set ICDSDRG array
  1. I ICDCSYS="ICD10" D
  1. . I (($P(ICDY(0),"^",7)=1)!($D(ICD10PD("h")))!($D(ICD10PD("J")))!($D(ICD10SD("h")))),'$P(ICDTMP,";",3) D
  1. . . S ICDSDRG=$P(ICDTMP,";")
  1. . . F ICDK=1:1 Q:$P(ICDSDRG,"^",ICDK)']"" S ICDSDRG($P(ICDSDRG,"^",ICDK))=""
  1. I ICDCSYS="ICD9" D
  1. . I (($P(ICDY(0),"^",7)=1)!(ICDPD["h")!(ICDPD["J")!(ICDSD["h")),'$P(ICDTMP,";",3) D
  1. . . S ICDSDRG=$P(ICDTMP,";")
  1. . . F ICDK=1:1 Q:$P(ICDSDRG,"^",ICDK)']"" S ICDSDRG($P(ICDSDRG,"^",ICDK))=""
  1. 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))=""
  1. K ICDS24("N"),ICDS25(0) Q
  1. ;
  1. OPS ; Operation/Procedures
  1. I '$D(ICDOP(" "_$P(ICDY(0),"^",1))) S ICDOP(" "_$P(ICDY(0),"^",1))="",ICDOCNT=ICDOCNT+1
  1. I $S($D(ICDMDC(12))!($D(ICDMDC(13)))>0:'$$MDCT^ICDEX(ICDY,ICDDATE,.ICDMDC,0),1:'$$MDCD^ICDEX(ICDY,ICDMDC,ICDDATE)) D
  1. . S ICDONR=ICDONR+1
  1. . ;Get ICD-10 Identifier codes into ICD10ORNIT
  1. . K ICD10ORNIT
  1. . D ICDIDS^ICDRGAPI("80.1",ICDY,.ICD10ORNIT)
  1. . D ICDMRG^ICDRGAPI(.ICD10ORNI,.ICD10ORNIT)
  1. . S ICDORNI=ICDORNI_$P(ICDY(0),"^",2),ICDORNI($S($P(ICDY(0),"^",2)'="":$P(ICDY(0),"^",2),1:0))="" S:ICDORNR'=0 ICDORNR=1
  1. ;Group ICD identifiers in one variable
  1. K ICD10ORT
  1. D ICDIDS^ICDRGAPI("80.1",ICDY,.ICD10ORT) ;Get ICD-10 identifiers into ICD10OR
  1. D ICDMRG^ICDRGAPI(.ICD10OR,.ICD10ORT)
  1. I $L($P(ICDY(0),"^",2)) S ICDOR=$$TM(ICDOR,";")_";"_$$TM($P(ICDY(0),"^",2),";"),ICDOR=";"_$$TM(ICDOR,";")_";"
  1. I ICDCSYS="ICD9" D
  1. . I +ICDY(0)>37.69,+ICDY(0)<37.84,ICDOR'["p" D
  1. . . N ICDCC3 D EN1^ICDDRG5 I ICDCC3 S ICDOR=ICDOR_"p" S:ICDOR'["O" ICDOR=ICDOR_"O"
  1. I ICDCSYS="ICD9" D
  1. . I +ICDY(0)>80.999 I +ICDY(0)<81.40 N ICDCC3 D EN1^ICDDRG8 I ICDCC3 S ICDOR=ICDOR_"F"
  1. ; Major OR Procedure
  1. S:$L($$MOR^ICDEX(ICDY)) ICDMAJ=ICDMAJ_$P($$MOR^ICDEX(ICDY),"^")_"^"
  1. ; Set ICDOTMP with DRGs for doing checks
  1. S ICDOTMP=$P($$GETDRG^ICDEX(80.1,ICDY,ICDDATE,$G(ICDMDC)),";",1) S:+ICDOTMP'>0 ICDOTMP=""
  1. I ($P(ICDY(0),"^",2)["O")!($D(ICD10ORT("O"))) D
  1. .S ICDOPCT=ICDOPCT+1
  1. .I ICDOPNR=0 D
  1. ..I $S($D(ICDMDC(12))!($D(ICDMDC(13)))>0:'$$MDCT^ICDEX(ICDY,ICDDATE,.ICDMDC,0),1:'$D(ICDOTMP)) S ICDOPNR=1
  1. I +ICDOTMP>0 S ICDF=ICDOTMP F ICDFX=1:1 Q:$P(ICDF,"^",ICDFX)']"" S ICDODRG($P(ICDF,"^",ICDFX))=$P(ICDF,"^",ICDFX)
  1. ; Translate identifiers into common symbol, check for symbol
  1. S ICD104=$S($P(ICDY(0),"^",2)["P"!$D(ICD10ORT("P")):1,1:0)
  1. S ICDNMDC($S($TR($P(ICDY(0),"^",2),"lqtrB","\\\\")["\"!$D(ICD10ORT("l"))!$D(ICD10ORT("q"))!$D(ICD10ORT("t"))!$D(ICD10ORT("r"))!$D(ICD10ORT("B")):1,1:0))="" Q
  1. ;
  1. ; Miscellaneous
  1. ERR ; Error Occured
  1. I '$D(ICDCSYS) S ICDCSYS=$S(ICDDATE'<$$IMPDATE^LEXU("10D"):"ICD10",1:"ICD9")
  1. I ICDCSYS="ICD10" S ICDDRG=999
  1. I ICDCSYS="ICD9" S ICDDRG=$S(ICDDATE>3070930.9:999,1:470)
  1. Q
  1. SEX ; Get sex for DX or Procedure
  1. S ICDSEX($S($P(ICDY(0),"^",10)="M":1,$P(ICDY(0),"^",10)="F":2,1:0))=""
  1. Q
  1. TM(X,Y) ; Trim Y
  1. S Y=$G(Y) S:'$L(Y) Y=" "
  1. F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
  1. F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
  1. Q X
  1. KILL ; Clean Environment
  1. K ICD104,ICDJ,ICDJJ,ICDOCNT,ICDOR,ICDNOR,ICDP15,ICDPDRG,ICDRG,ICDSEX
  1. K ICDSDRG,ICDODRG,ICDCC,ICDMCC,ICDOP,ICDORNR,ICDORNI,ICDP24,ICDP25,ICDPD
  1. K ICDSD,ICDI,ICDK,ICDF,ICDFX,ICDFK,ICDY,ICDDXT,ICDIZ,ICDONR,ICDOPCT
  1. K ICD,ICDCC2,ICDCC3,ICDGH,ICDL39,ICDMAJ,ICDNMDC,ICDNSD,ICDORNA,ICDREF
  1. K ICDS25,ICDOPNR,ICDO24
  1. K ICD10PD,ICD10SD,ICD10OR,ICD10ORNI,ICD10PDRG ;64 FIX
  1. Q