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