- 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 Feb 18, 2025@23:16:28 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