ICDJC1 ;ALB/ARH - DRG GROUPER CALCULATOR 2015 - ATTRIBUTES ;05/26/2016
;;18.0;DRG Grouper;**89,97**;Oct 20, 2000;Build 5
;
; DRG Calcuation for re-designed grouper ICD-10 2015, continuation
;
PRATT(ICDPR,ICDDATE,PRARR) ; get all attributes of Procedures - determine if event is Surgical or Medical and MDCs
; returns array with the Procedure Attributes only, later updated to include Cluster Attributes
;
; Input: ICDPR(x) - array of Procedures into API, ICDDATE - event date
; Output: PRARR - 'O' if any procedure/cluster is an Operating Room procedure, 'N' if Non-OR only or blank
; - list of all MDC's associated with any of the Operating Room procedures, separated by ';'
; PRARR(x) - pr ifn (#80.1) ^ Procedure (OR/NOR) ^ (reserved Clstr) ^ (reserved Clstr Type) ^ ^ ^ OR/NOR applies
; w/ OR/NOR = O/N/blank for specific procedure and w/'x' corresponds to entry in ICDPR array
N PRI,PR,PRIFN,ATTLN K PRARR S PRARR=""
;
S PRI=0 F S PRI=$O(ICDPR(PRI)) Q:'PRI S PR=+$G(ICDPR(PRI)) S PRARR(PRI)=PR D
. S PRIFN=$O(^ICDD(83.6,"B",PR,0)) Q:'PRIFN
. S ATTLN=$$GETATT("PR",PRIFN,$G(ICDDATE))
. S PRARR(PRI)=PR_U_$P(ATTLN,U,3)_U_U_U_U_U_$P(ATTLN,U,3) I PRARR'="O",$P(ATTLN,U,3)'="" S PRARR=$P(ATTLN,U,3)
;
S PRARR=PRARR_U_$$GETMDC("PR",.ICDPR,$G(ICDDATE)) ; set event procedure attibutes - final OR/NonOR and MDC list
Q
;
;
DXATT(ICDDX,ICDDATE,ICDEXP,DXARR) ; get all attributes of Diagnosis - determine if MCC or CC apply to event and MDCs
; returns array with the Diagnosis Attributes only, later updated to include updates due to HAC
; the diagnosis event MDCs are determined by the primary Dx, based on the MDCs of its assigned code sets
; event MCC/CC is determined by secondary Dxs and the primary Dx if it is an MCC/CC of its Own
; the MCC/CC of a secondary Dx may be applied to the event DRG unless overridden by one of two cases:
; PDX is a member of the secondarys exclusion group or if patient has expired and MCC only if Alive
;
; Input: ICDDX(x) - array of Dx into API, ICDDATE - event date, ICDEXP - 1 if patient died before discharge
; Output: DXARR - 'MCC' or 'CC' for event if either result from the diagnosis or blank
; - list if all MDC's associated with the Primary Diagnosis, separated by ';'
; DXARR(x) - dx ifn (#80) ^ MCC/CC ^ exclude grp ^ alive exclude ^ (reserved HAC) ^ ^ MCC/CC applies
N DXI,PDX,DX,DXIFN,ATTLN,DXCC,DXEXCL,DXALIVE,EXCLUDE,EXPIRED,CCMCC K DXARR S DXARR=""
;
; get primary diagnosis attributes to determine MCC/CC
S DXI=+$O(ICDDX(0)),PDX=$G(ICDDX(DXI)) Q:'PDX S DXARR(DXI)=PDX
;
S DXIFN=$O(^ICDD(83.5,"B",PDX,0)) Q:'DXIFN
S ATTLN=$$GETATT("DX",DXIFN,$G(ICDDATE))
S DXCC=$S(+$P(ATTLN,U,4):"MCC",+$P(ATTLN,U,5):"CC",1:"") ; MCC/CC of its own
S DXARR(DXI)=PDX_U_DXCC_U_0_U_0_U_U_U_DXCC
;
; get secondary diagnosis attributes to determine MCC/CC
F S DXI=$O(ICDDX(DXI)) Q:'DXI S DX=+$G(ICDDX(DXI)) S DXARR(DXI)=DX D
. ;
. S DXIFN=$O(^ICDD(83.5,"B",DX,0)) Q:'DXIFN
. S ATTLN=$$GETATT("DX",DXIFN,$G(ICDDATE))
. S DXCC=$S(+$P(ATTLN,U,7):"MCC",+$P(ATTLN,U,8):"CC",1:"") ; MCC/CC
. ;
. S (EXPIRED,EXCLUDE)=0
. S DXALIVE=$P(ATTLN,U,6) I +DXALIVE,+$G(ICDEXP) S EXPIRED=1 ; mcc only if alive but patient expired
. S DXEXCL=$P(ATTLN,U,3) I DXEXCL'="",+$$EXCLD(PDX,DXEXCL,$G(ICDDATE)) S EXCLUDE=DXEXCL ; pdx in exclusion grp
. ;
. S CCMCC="" I 'EXCLUDE,'EXPIRED S CCMCC=DXCC
. S DXARR(DXI)=DX_U_DXCC_U_EXCLUDE_U_EXPIRED_U_U_U_CCMCC
;
S DXARR=$$GETEVT(.DXARR)_U_$$GETMDC("DX",.ICDDX,$G(ICDDATE)) ; get event attributes - final MCC/CC and MDC list
Q
;
;
GETATT(TYP,CDIFN,DATE) ; get one codes Attributes for date, either diagnosis (83.5,10) or procedure (83.6,10) or cluster (83.61,10)
; only one set of attributes may be active on a given date, returns entire node
; input: TYP - type of codes 'DX' or 'PR' or 'CL', CDIFN - ptr to code in 83.5 or 83.6 or 83.61
; output: node of codes attributes active on date, if any, 83.5,10 or 83.6,10 or 86.61,10
N IX,LINE,CDFILE,BEGIN,END,ATTLN S TYP=$G(TYP),CDIFN=+$G(CDIFN) S ATTLN="" I '$G(DATE) S DATE=DT
S CDFILE=$S(TYP="DX":83.5,TYP="PR":83.6,TYP="CL":83.61,1:0)
;
S BEGIN=DATE+.00001 S BEGIN=+$O(^ICDD(CDFILE,CDIFN,10,"B",BEGIN),-1)
S IX=+$O(^ICDD(CDFILE,CDIFN,10,"B",BEGIN,0))
S LINE=$G(^ICDD(CDFILE,CDIFN,10,IX,0))
S BEGIN=$P(LINE,U,1),END=$P(LINE,U,2) I 'END S END=9999999
I DATE'<BEGIN,DATE'>END S ATTLN=LINE
Q ATTLN
;
GETMDC(TYP,ICDARR,ICDDATE) ; get list of all MDC's the diagnosis/procedure codes are assigned to
; compile list of MDC's based on the codes assigned code sets (83.5,20&83.6,20), Primary Dx and OR Procedures only
; input: TYP - type of codes 'DX' or 'PR', ICDARR is either diagnoais ICDDX or procedures ICDPRC
; output: returns list of codes MDC ID's - 00;03... for Primary DX or all OR Procedures only
N IX,CDFILE,CDIFN,CD,SETIFN,MDCIFN,MDC,MLIST,ARRCDS,ARRMDC S TYP=$G(TYP) S MLIST=""
S CDFILE=$S(TYP="DX":83.5,TYP="PR":83.6,1:0)
;
S IX=0 F S IX=$O(ICDARR(IX)) Q:'IX S CD=+$G(ICDARR(IX)) D I TYP="DX" Q
. S CDIFN=$O(^ICDD(CDFILE,"B",CD,0)) Q:'CDIFN
. ;
. I TYP="PR",$P($$GETATT("PR",CDIFN,$G(ICDDATE)),U,3)'="O" Q
. ;
. D GETCDS^ICDJC2(TYP,CDIFN,$G(ICDDATE),.ARRCDS,.ICDARR) ; get code sets on date for individual code
. ;
. S SETIFN=0 F S SETIFN=$O(ARRCDS(SETIFN)) Q:'SETIFN D ; get MDC of all code sets the code is a member of
.. S MDCIFN=$P($G(^ICDD(83.3,SETIFN,0)),U,2),MDC=$P($G(^ICDD(83,MDCIFN,0)),U,2) I MDC'="" S ARRMDC(MDC_";")=""
;
; list in order and no dups, separated by ';'
S MDC="" F S MDC=$O(ARRMDC(MDC)) Q:MDC="" S MLIST=MLIST_MDC
I MLIST'="" S MLIST=$E(MLIST,1,$L(MLIST)-1)
Q MLIST
;
GETEVT(DXARR) ; get the events MCC/CC attribute, compiled from all diagnosis attributes
; check each dx for an MCC/CC that was not overridden and still applies, MCC highest priority then CC
; input: DXARR list of each diagnosis attributes
; output: returns either MCC or CC or blank as the event attribute
N DXEVT,DXI,CCMCC S DXEVT=""
S DXI=0 F S DXI=$O(DXARR(DXI)) Q:'DXI S CCMCC=$P(DXARR(DXI),U,7) I CCMCC'="" S DXEVT=CCMCC I CCMCC="MCC" Q
Q DXEVT
;
EXCLD(DX,EXCLGRP,DATE) ; determine if the Diagnosis is in the Exclusion group
; if primary Dx is member of a secondary Dxs Exclusion group then that secondary Dx can not impart MCC/CC to event
; input: DX - ptr to 80, EXCLGRP - 4 character Exclusion Group ID (83.51, .01 and 83.5,10,.03)
; output: returns true if PDx is in SDx Exclusion group (83.51) on date and secondary Dxs MCC/CC should be ignored
N LINE,EXIFN,BEGIN,END,EXCLUDE S EXCLUDE=0 S DX=+$G(DX) I '$G(DATE) S DATE=DT
;
I $G(EXCLGRP)?4N S EXIFN=0 F S EXIFN=$O(^ICDD(83.51,"ADE",DX,EXCLGRP,EXIFN)) Q:'EXIFN D Q:EXCLUDE
. S LINE=$G(^ICDD(83.51,EXIFN,0))
. S BEGIN=$P(LINE,U,3),END=$P(LINE,U,4) I 'END S END=9999999
. I DATE'<BEGIN,DATE'>END S EXCLUDE=1
Q EXCLUDE
;
;
;
DXHAC(ICDDX,ICDPR,ICDDATE,ICDPOA,DXARR) ; reset DXATT for HAC, determine HAC for each Dx not POA (N,U), if found then re-set event MCC/CC
; identify any diagnosis defined as a HAC, if a Dx is HAC then its MCC/CC should be ignored
; a HAC applies only to diagnosis Not Present on Admission (N or U)
; if a Dx is Not Present on Admission (N,U) and a member of a HAC group then it can not impart MCC/CC to the event
; if the HAC group requires multiple Dx codes then the MCC/CC of all are screened out
;
; Input: ICDDX(x) and ICDPR(x) - array of Dx/procedures input to API, ICDDATE - date of event
; ICDPOA(x) - array of Dx POA input to API
; DXARR(x) - dx ifn ^ MCC/CC ^ exclude grp ^ alive exclude ^ (reserved HAC) ^ ^ MCC/CC applies
; Output: DXARR - 'MCC' or 'CC' or blank, updated for any HAC Dx found
; DXARR(x) - (dx ifn) ^ (MCC/CC) ^ (exclude grp) ^ (alive exclude) ^ HAC Grp ^ ^ MCC/CC applies
; - if Dx is a member of a HAC group then 'HAC Grp' is set and 'MCC/CC applies' is updated
; to remove the Dxs MCC/CC from the event
N FND,LINE,HCSIFN,HACCSE,HACIFN,HACID,DXI,ARRHCS,ARRHAC
;
D HACSET(.ICDDX,.ICDPR,$G(ICDDATE),.ICDPOA,.ARRHCS) ; get all hac code sets defined by the event
;
; get HAC groups the identified hac code sets belong to, by case
S HCSIFN=0 F S HCSIFN=$O(ARRHCS(HCSIFN)) Q:'HCSIFN D
. S LINE=$G(^ICDD(83.71,HCSIFN,0)),HACCSE=$P(LINE,U,2)_U_+$P(LINE,U,5) S ARRHAC(HACCSE,HCSIFN)=""
;
; find the hac groups/cases with all code sets defined and update the diagnosis affected
S HACCSE=0 F S HACCSE=$O(ARRHAC(HACCSE)) Q:'HACCSE S HACIFN=+HACCSE D
. ;
. ; for the hac group/case determine if all hac code sets are defined
. S FND=1 S HCSIFN=0 F S HCSIFN=$O(^ICDD(83.71,"D",+HACIFN,HCSIFN)) Q:'HCSIFN D Q:'FND
.. I +$P($G(^ICDD(83.71,+HCSIFN,0)),U,5)=+$P(HACCSE,U,2) I '$D(ARRHCS(HCSIFN)) S FND=0
. ;
. ; if hac group fully defined, update each diagnosis in the group to indicate MCC/CC removed by hac
. I +FND S HCSIFN=0 F S HCSIFN=$O(ARRHAC(HACCSE,HCSIFN)) Q:'HCSIFN D
.. S HACID=$P($G(^ICDD(83.7,+HACIFN,0)),U,1)
.. ;
.. S DXI=0 F S DXI=$O(ARRHCS(HCSIFN,"DX",DXI)) Q:'DXI I $D(DXARR(DXI)) S $P(DXARR(DXI),U,5)=HACID,$P(DXARR(DXI),U,7)=""
;
S DXARR=$$GETEVT(.DXARR)_U_$$GETMDC("DX",.ICDDX,$G(ICDDATE)) ; get event attributes, final MCC/CC and MDC list
;
Q
;
HACSET(ICDDX,ICDPR,ICDDATE,ICDPOA,HCSARR) ; get all HAC Code Sets defined by event Diagnosis and Procedure codes
; a HAC only applies if Dx was not present on admission (N,U) and possibly only to secondary or primary Dx
; input: ICDDX(x) and ICDPR(x) - array of Dx/procedures input to API, ICDDATE - date of event
; ICDPOA(x) - array of Dx POA input to API
; output: returns array of all HAC code sets applicable to the specific event
; HCSARR( hac code set (83.71), "DX", x - code entry in ICDDX ) = ""
; HCSARR( hac code set (83.71), "PR", x - code entry in ICDPR ) = ""
N DXI,DX,DXIFN,POA,HCSIFN,LINE,PRI,PR,PRIFN,ARRHSX K HCSARR
;
; get all HAC sets defined by event diagnosis that are not POA
S DXI=0 F S DXI=$O(ICDDX(DXI)) Q:'DXI S POA=$G(ICDPOA(DXI)) I (POA="N")!(POA="U") D
. ;
. ; get all hac code sets the dx is assigned to on date
. S DX=+$G(ICDDX(DXI)) S DXIFN=$O(^ICDD(83.5,"B",DX,0)) Q:'DXIFN D GETCDH("DX",DXIFN,$G(ICDDATE),.ARRHSX)
. ;
. ; for each hac set the dx is assigned, check if for this event the dx passes the hac set criteria (P/S)
. S HCSIFN=0 F S HCSIFN=$O(ARRHSX(HCSIFN)) Q:'HCSIFN D
.. S LINE=$G(^ICDD(83.71,HCSIFN,0)) Q:'HCSIFN
.. ;
.. I $P(LINE,U,4)="" S HCSARR(HCSIFN,"DX",DXI)="" Q ; set for any type of dx
.. I $P(LINE,U,4)="P",$O(ICDDX(0))=DXI S HCSARR(HCSIFN,"DX",DXI)="" Q ; set for primary dx
.. I $P(LINE,U,4)="S",$O(ICDDX(0))'=DXI S HCSARR(HCSIFN,"DX",DXI)="" Q ; set for secondary dx
;
; get all HAC sets defined by the event procedures
S PRI=0 F S PRI=$O(ICDPR(PRI)) Q:'PRI D
. S PR=+$G(ICDPR(PRI)) S PRIFN=$O(^ICDD(83.6,"B",PR,0)) Q:'PRIFN D GETCDH("PR",PRIFN,$G(ICDDATE),.ARRHSX)
. ;
. S HCSIFN=0 F S HCSIFN=$O(ARRHSX(HCSIFN)) Q:'HCSIFN S HCSARR(HCSIFN,"PR",PRI)=""
;
Q
;
GETCDH(TYP,CDIFN,DATE,ARRHSX) ; get HAC code sets for a single code on a date, either diagnosis (83.5,30) or procedure (83.6,30)
; input: TYP - type of codes 'DX' or 'PR', CDIFN - ptr to code in 83.5 or 83.6
; output: ARRHSX - array of HAC code sets the Code is a member of on the date
; ARRHSX(hac code set ifn (83.71)) = CDIFN
N IX,LINE,CDFILE,BEGIN,END S TYP=$G(TYP),CDIFN=+$G(CDIFN) K ARRHSX I '$G(DATE) S DATE=DT
S CDFILE=$S(TYP="DX":83.5,TYP="PR":83.6,1:0) I 'CDFILE Q
;
S IX=0 F S IX=$O(^ICDD(CDFILE,CDIFN,30,IX)) Q:'IX D
. S LINE=$G(^ICDD(CDFILE,CDIFN,30,IX,0)) Q:'LINE
. S BEGIN=$P(LINE,U,1),END=$P(LINE,U,2) I 'END S END=9999999
. I DATE'<BEGIN,DATE'>END S ARRHSX(+$P(LINE,U,3))=CDIFN
Q
;
;
PRCLS(ICDPR,ICDDATE,PRARR) ; reset PRATT for Clusters, determine Cluster OR/NOR attribute for each event Procedure, if found then re-set event OR/NOR
; identify all active clusters satified by the event procedures, set all cluster procedures OR/NOR to the Clusters OR/NOR
; the cluster identified is an indicator and not definitive, each procedure may be assigned to multiple clusters
; assumes that all clusters a procedure is a member of is the same type, either all OR clusters or all NOR clusters
;
; Input: ICDPR(x) - array of Procedures into API, ICDDATE - event date
; PRARR(x) - pr ifn (#80.1) ^ Procedure (OR/NOR) ^ (reserved Cltr) ^ (reserved Clst Type) ^ ^ ^ OR/NOR applies
; Output: PRARR - 'O' if any procedure/cluster is an Operating Room procedure, 'N' if Non-OR only or blank
; - list of all MDC's associated with any of the Operating Room procedures, separated by ';'
; PRARR(x) - pr ifn (#80.1) ^ Procedure (OR/NOR) ^ Cluster IFN ^ Cluster (OR/NOR) ^ ^ ^ OR/NOR applies
; w/ OR/NOR = O/N/blank for specific procedure/cluster and w/'x' corresponds to entry in ICDPR array
; - if Procedure is a member of an active cluster then 'Cluster IFN' and 'Cluster (OR/NOR)' are set and
; 'OR/NOR applies' is updated to the Clusters OR/NOR attribute
N PRI,PR,CLSIFN,ATTLN,ARRCLS
;
; get list of all potential clusters, any cluster one of the event procedures belongs to
S PRI=0 F S PRI=$O(ICDPR(PRI)) Q:'PRI S PR=+$G(ICDPR(PRI)) D
. S CLSIFN=0 F S CLSIFN=$O(^ICDD(83.61,"ACL",PR,CLSIFN)) Q:'CLSIFN S ARRCLS(CLSIFN,PRI)=""
;
; find all active satisfied clusters and update the procedures affected
S CLSIFN=0 F S CLSIFN=$O(ARRCLS(CLSIFN)) Q:'CLSIFN D
. ;
. I '$$CLSTR^ICDJC2(CLSIFN,.ICDPR) Q ; determine if cluster is satified by event procedures
. ;
. S ATTLN=$$GETATT("CL",CLSIFN,$G(ICDDATE)) I 'ATTLN Q ; determine if cluster is active, if active get its attribute
. ;
. S PRI=0 F S PRI=$O(ARRCLS(CLSIFN,PRI)) Q:'PRI I $D(PRARR(PRI)) D
.. S $P(PRARR(PRI),U,3)=CLSIFN,$P(PRARR(PRI),U,4)=$P(ATTLN,U,3),$P(PRARR(PRI),U,7)=$P(ATTLN,U,3)
;
S ATTLN="" S PRI=0 F S PRI=$O(PRARR(PRI)) Q:'PRI I ATTLN'="O",$P(PRARR(PRI),U,7)'="" S ATTLN=$P(PRARR(PRI),U,7)
;
S PRARR=ATTLN_U_$$GETMDC("PR",.ICDPR,$G(ICDDATE)) ; set event procedure/cluster attibutes - final OR/NonOR and MDC list
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDJC1 14463 printed Sep 23, 2025@19:26:59 Page 2
ICDJC1 ;ALB/ARH - DRG GROUPER CALCULATOR 2015 - ATTRIBUTES ;05/26/2016
+1 ;;18.0;DRG Grouper;**89,97**;Oct 20, 2000;Build 5
+2 ;
+3 ; DRG Calcuation for re-designed grouper ICD-10 2015, continuation
+4 ;
PRATT(ICDPR,ICDDATE,PRARR) ; get all attributes of Procedures - determine if event is Surgical or Medical and MDCs
+1 ; returns array with the Procedure Attributes only, later updated to include Cluster Attributes
+2 ;
+3 ; Input: ICDPR(x) - array of Procedures into API, ICDDATE - event date
+4 ; Output: PRARR - 'O' if any procedure/cluster is an Operating Room procedure, 'N' if Non-OR only or blank
+5 ; - list of all MDC's associated with any of the Operating Room procedures, separated by ';'
+6 ; PRARR(x) - pr ifn (#80.1) ^ Procedure (OR/NOR) ^ (reserved Clstr) ^ (reserved Clstr Type) ^ ^ ^ OR/NOR applies
+7 ; w/ OR/NOR = O/N/blank for specific procedure and w/'x' corresponds to entry in ICDPR array
+8 NEW PRI,PR,PRIFN,ATTLN
KILL PRARR
SET PRARR=""
+9 ;
+10 SET PRI=0
FOR
SET PRI=$ORDER(ICDPR(PRI))
if 'PRI
QUIT
SET PR=+$GET(ICDPR(PRI))
SET PRARR(PRI)=PR
Begin DoDot:1
+11 SET PRIFN=$ORDER(^ICDD(83.6,"B",PR,0))
if 'PRIFN
QUIT
+12 SET ATTLN=$$GETATT("PR",PRIFN,$GET(ICDDATE))
+13 SET PRARR(PRI)=PR_U_$PIECE(ATTLN,U,3)_U_U_U_U_U_$PIECE(ATTLN,U,3)
IF PRARR'="O"
IF $PIECE(ATTLN,U,3)'=""
SET PRARR=$PIECE(ATTLN,U,3)
End DoDot:1
+14 ;
+15 ; set event procedure attibutes - final OR/NonOR and MDC list
SET PRARR=PRARR_U_$$GETMDC("PR",.ICDPR,$GET(ICDDATE))
+16 QUIT
+17 ;
+18 ;
DXATT(ICDDX,ICDDATE,ICDEXP,DXARR) ; get all attributes of Diagnosis - determine if MCC or CC apply to event and MDCs
+1 ; returns array with the Diagnosis Attributes only, later updated to include updates due to HAC
+2 ; the diagnosis event MDCs are determined by the primary Dx, based on the MDCs of its assigned code sets
+3 ; event MCC/CC is determined by secondary Dxs and the primary Dx if it is an MCC/CC of its Own
+4 ; the MCC/CC of a secondary Dx may be applied to the event DRG unless overridden by one of two cases:
+5 ; PDX is a member of the secondarys exclusion group or if patient has expired and MCC only if Alive
+6 ;
+7 ; Input: ICDDX(x) - array of Dx into API, ICDDATE - event date, ICDEXP - 1 if patient died before discharge
+8 ; Output: DXARR - 'MCC' or 'CC' for event if either result from the diagnosis or blank
+9 ; - list if all MDC's associated with the Primary Diagnosis, separated by ';'
+10 ; DXARR(x) - dx ifn (#80) ^ MCC/CC ^ exclude grp ^ alive exclude ^ (reserved HAC) ^ ^ MCC/CC applies
+11 NEW DXI,PDX,DX,DXIFN,ATTLN,DXCC,DXEXCL,DXALIVE,EXCLUDE,EXPIRED,CCMCC
KILL DXARR
SET DXARR=""
+12 ;
+13 ; get primary diagnosis attributes to determine MCC/CC
+14 SET DXI=+$ORDER(ICDDX(0))
SET PDX=$GET(ICDDX(DXI))
if 'PDX
QUIT
SET DXARR(DXI)=PDX
+15 ;
+16 SET DXIFN=$ORDER(^ICDD(83.5,"B",PDX,0))
if 'DXIFN
QUIT
+17 SET ATTLN=$$GETATT("DX",DXIFN,$GET(ICDDATE))
+18 ; MCC/CC of its own
SET DXCC=$SELECT(+$PIECE(ATTLN,U,4):"MCC",+$PIECE(ATTLN,U,5):"CC",1:"")
+19 SET DXARR(DXI)=PDX_U_DXCC_U_0_U_0_U_U_U_DXCC
+20 ;
+21 ; get secondary diagnosis attributes to determine MCC/CC
+22 FOR
SET DXI=$ORDER(ICDDX(DXI))
if 'DXI
QUIT
SET DX=+$GET(ICDDX(DXI))
SET DXARR(DXI)=DX
Begin DoDot:1
+23 ;
+24 SET DXIFN=$ORDER(^ICDD(83.5,"B",DX,0))
if 'DXIFN
QUIT
+25 SET ATTLN=$$GETATT("DX",DXIFN,$GET(ICDDATE))
+26 ; MCC/CC
SET DXCC=$SELECT(+$PIECE(ATTLN,U,7):"MCC",+$PIECE(ATTLN,U,8):"CC",1:"")
+27 ;
+28 SET (EXPIRED,EXCLUDE)=0
+29 ; mcc only if alive but patient expired
SET DXALIVE=$PIECE(ATTLN,U,6)
IF +DXALIVE
IF +$GET(ICDEXP)
SET EXPIRED=1
+30 ; pdx in exclusion grp
SET DXEXCL=$PIECE(ATTLN,U,3)
IF DXEXCL'=""
IF +$$EXCLD(PDX,DXEXCL,$GET(ICDDATE))
SET EXCLUDE=DXEXCL
+31 ;
+32 SET CCMCC=""
IF 'EXCLUDE
IF 'EXPIRED
SET CCMCC=DXCC
+33 SET DXARR(DXI)=DX_U_DXCC_U_EXCLUDE_U_EXPIRED_U_U_U_CCMCC
End DoDot:1
+34 ;
+35 ; get event attributes - final MCC/CC and MDC list
SET DXARR=$$GETEVT(.DXARR)_U_$$GETMDC("DX",.ICDDX,$GET(ICDDATE))
+36 QUIT
+37 ;
+38 ;
GETATT(TYP,CDIFN,DATE) ; get one codes Attributes for date, either diagnosis (83.5,10) or procedure (83.6,10) or cluster (83.61,10)
+1 ; only one set of attributes may be active on a given date, returns entire node
+2 ; input: TYP - type of codes 'DX' or 'PR' or 'CL', CDIFN - ptr to code in 83.5 or 83.6 or 83.61
+3 ; output: node of codes attributes active on date, if any, 83.5,10 or 83.6,10 or 86.61,10
+4 NEW IX,LINE,CDFILE,BEGIN,END,ATTLN
SET TYP=$GET(TYP)
SET CDIFN=+$GET(CDIFN)
SET ATTLN=""
IF '$GET(DATE)
SET DATE=DT
+5 SET CDFILE=$SELECT(TYP="DX":83.5,TYP="PR":83.6,TYP="CL":83.61,1:0)
+6 ;
+7 SET BEGIN=DATE+.00001
SET BEGIN=+$ORDER(^ICDD(CDFILE,CDIFN,10,"B",BEGIN),-1)
+8 SET IX=+$ORDER(^ICDD(CDFILE,CDIFN,10,"B",BEGIN,0))
+9 SET LINE=$GET(^ICDD(CDFILE,CDIFN,10,IX,0))
+10 SET BEGIN=$PIECE(LINE,U,1)
SET END=$PIECE(LINE,U,2)
IF 'END
SET END=9999999
+11 IF DATE'<BEGIN
IF DATE'>END
SET ATTLN=LINE
+12 QUIT ATTLN
+13 ;
GETMDC(TYP,ICDARR,ICDDATE) ; get list of all MDC's the diagnosis/procedure codes are assigned to
+1 ; compile list of MDC's based on the codes assigned code sets (83.5,20&83.6,20), Primary Dx and OR Procedures only
+2 ; input: TYP - type of codes 'DX' or 'PR', ICDARR is either diagnoais ICDDX or procedures ICDPRC
+3 ; output: returns list of codes MDC ID's - 00;03... for Primary DX or all OR Procedures only
+4 NEW IX,CDFILE,CDIFN,CD,SETIFN,MDCIFN,MDC,MLIST,ARRCDS,ARRMDC
SET TYP=$GET(TYP)
SET MLIST=""
+5 SET CDFILE=$SELECT(TYP="DX":83.5,TYP="PR":83.6,1:0)
+6 ;
+7 SET IX=0
FOR
SET IX=$ORDER(ICDARR(IX))
if 'IX
QUIT
SET CD=+$GET(ICDARR(IX))
Begin DoDot:1
+8 SET CDIFN=$ORDER(^ICDD(CDFILE,"B",CD,0))
if 'CDIFN
QUIT
+9 ;
+10 IF TYP="PR"
IF $PIECE($$GETATT("PR",CDIFN,$GET(ICDDATE)),U,3)'="O"
QUIT
+11 ;
+12 ; get code sets on date for individual code
DO GETCDS^ICDJC2(TYP,CDIFN,$GET(ICDDATE),.ARRCDS,.ICDARR)
+13 ;
+14 ; get MDC of all code sets the code is a member of
SET SETIFN=0
FOR
SET SETIFN=$ORDER(ARRCDS(SETIFN))
if 'SETIFN
QUIT
Begin DoDot:2
+15 SET MDCIFN=$PIECE($GET(^ICDD(83.3,SETIFN,0)),U,2)
SET MDC=$PIECE($GET(^ICDD(83,MDCIFN,0)),U,2)
IF MDC'=""
SET ARRMDC(MDC_";")=""
End DoDot:2
End DoDot:1
IF TYP="DX"
QUIT
+16 ;
+17 ; list in order and no dups, separated by ';'
+18 SET MDC=""
FOR
SET MDC=$ORDER(ARRMDC(MDC))
if MDC=""
QUIT
SET MLIST=MLIST_MDC
+19 IF MLIST'=""
SET MLIST=$EXTRACT(MLIST,1,$LENGTH(MLIST)-1)
+20 QUIT MLIST
+21 ;
GETEVT(DXARR) ; get the events MCC/CC attribute, compiled from all diagnosis attributes
+1 ; check each dx for an MCC/CC that was not overridden and still applies, MCC highest priority then CC
+2 ; input: DXARR list of each diagnosis attributes
+3 ; output: returns either MCC or CC or blank as the event attribute
+4 NEW DXEVT,DXI,CCMCC
SET DXEVT=""
+5 SET DXI=0
FOR
SET DXI=$ORDER(DXARR(DXI))
if 'DXI
QUIT
SET CCMCC=$PIECE(DXARR(DXI),U,7)
IF CCMCC'=""
SET DXEVT=CCMCC
IF CCMCC="MCC"
QUIT
+6 QUIT DXEVT
+7 ;
EXCLD(DX,EXCLGRP,DATE) ; determine if the Diagnosis is in the Exclusion group
+1 ; if primary Dx is member of a secondary Dxs Exclusion group then that secondary Dx can not impart MCC/CC to event
+2 ; input: DX - ptr to 80, EXCLGRP - 4 character Exclusion Group ID (83.51, .01 and 83.5,10,.03)
+3 ; output: returns true if PDx is in SDx Exclusion group (83.51) on date and secondary Dxs MCC/CC should be ignored
+4 NEW LINE,EXIFN,BEGIN,END,EXCLUDE
SET EXCLUDE=0
SET DX=+$GET(DX)
IF '$GET(DATE)
SET DATE=DT
+5 ;
+6 IF $GET(EXCLGRP)?4N
SET EXIFN=0
FOR
SET EXIFN=$ORDER(^ICDD(83.51,"ADE",DX,EXCLGRP,EXIFN))
if 'EXIFN
QUIT
Begin DoDot:1
+7 SET LINE=$GET(^ICDD(83.51,EXIFN,0))
+8 SET BEGIN=$PIECE(LINE,U,3)
SET END=$PIECE(LINE,U,4)
IF 'END
SET END=9999999
+9 IF DATE'<BEGIN
IF DATE'>END
SET EXCLUDE=1
End DoDot:1
if EXCLUDE
QUIT
+10 QUIT EXCLUDE
+11 ;
+12 ;
+13 ;
DXHAC(ICDDX,ICDPR,ICDDATE,ICDPOA,DXARR) ; reset DXATT for HAC, determine HAC for each Dx not POA (N,U), if found then re-set event MCC/CC
+1 ; identify any diagnosis defined as a HAC, if a Dx is HAC then its MCC/CC should be ignored
+2 ; a HAC applies only to diagnosis Not Present on Admission (N or U)
+3 ; if a Dx is Not Present on Admission (N,U) and a member of a HAC group then it can not impart MCC/CC to the event
+4 ; if the HAC group requires multiple Dx codes then the MCC/CC of all are screened out
+5 ;
+6 ; Input: ICDDX(x) and ICDPR(x) - array of Dx/procedures input to API, ICDDATE - date of event
+7 ; ICDPOA(x) - array of Dx POA input to API
+8 ; DXARR(x) - dx ifn ^ MCC/CC ^ exclude grp ^ alive exclude ^ (reserved HAC) ^ ^ MCC/CC applies
+9 ; Output: DXARR - 'MCC' or 'CC' or blank, updated for any HAC Dx found
+10 ; DXARR(x) - (dx ifn) ^ (MCC/CC) ^ (exclude grp) ^ (alive exclude) ^ HAC Grp ^ ^ MCC/CC applies
+11 ; - if Dx is a member of a HAC group then 'HAC Grp' is set and 'MCC/CC applies' is updated
+12 ; to remove the Dxs MCC/CC from the event
+13 NEW FND,LINE,HCSIFN,HACCSE,HACIFN,HACID,DXI,ARRHCS,ARRHAC
+14 ;
+15 ; get all hac code sets defined by the event
DO HACSET(.ICDDX,.ICDPR,$GET(ICDDATE),.ICDPOA,.ARRHCS)
+16 ;
+17 ; get HAC groups the identified hac code sets belong to, by case
+18 SET HCSIFN=0
FOR
SET HCSIFN=$ORDER(ARRHCS(HCSIFN))
if 'HCSIFN
QUIT
Begin DoDot:1
+19 SET LINE=$GET(^ICDD(83.71,HCSIFN,0))
SET HACCSE=$PIECE(LINE,U,2)_U_+$PIECE(LINE,U,5)
SET ARRHAC(HACCSE,HCSIFN)=""
End DoDot:1
+20 ;
+21 ; find the hac groups/cases with all code sets defined and update the diagnosis affected
+22 SET HACCSE=0
FOR
SET HACCSE=$ORDER(ARRHAC(HACCSE))
if 'HACCSE
QUIT
SET HACIFN=+HACCSE
Begin DoDot:1
+23 ;
+24 ; for the hac group/case determine if all hac code sets are defined
+25 SET FND=1
SET HCSIFN=0
FOR
SET HCSIFN=$ORDER(^ICDD(83.71,"D",+HACIFN,HCSIFN))
if 'HCSIFN
QUIT
Begin DoDot:2
+26 IF +$PIECE($GET(^ICDD(83.71,+HCSIFN,0)),U,5)=+$PIECE(HACCSE,U,2)
IF '$DATA(ARRHCS(HCSIFN))
SET FND=0
End DoDot:2
if 'FND
QUIT
+27 ;
+28 ; if hac group fully defined, update each diagnosis in the group to indicate MCC/CC removed by hac
+29 IF +FND
SET HCSIFN=0
FOR
SET HCSIFN=$ORDER(ARRHAC(HACCSE,HCSIFN))
if 'HCSIFN
QUIT
Begin DoDot:2
+30 SET HACID=$PIECE($GET(^ICDD(83.7,+HACIFN,0)),U,1)
+31 ;
+32 SET DXI=0
FOR
SET DXI=$ORDER(ARRHCS(HCSIFN,"DX",DXI))
if 'DXI
QUIT
IF $DATA(DXARR(DXI))
SET $PIECE(DXARR(DXI),U,5)=HACID
SET $PIECE(DXARR(DXI),U,7)=""
End DoDot:2
End DoDot:1
+33 ;
+34 ; get event attributes, final MCC/CC and MDC list
SET DXARR=$$GETEVT(.DXARR)_U_$$GETMDC("DX",.ICDDX,$GET(ICDDATE))
+35 ;
+36 QUIT
+37 ;
HACSET(ICDDX,ICDPR,ICDDATE,ICDPOA,HCSARR) ; get all HAC Code Sets defined by event Diagnosis and Procedure codes
+1 ; a HAC only applies if Dx was not present on admission (N,U) and possibly only to secondary or primary Dx
+2 ; input: ICDDX(x) and ICDPR(x) - array of Dx/procedures input to API, ICDDATE - date of event
+3 ; ICDPOA(x) - array of Dx POA input to API
+4 ; output: returns array of all HAC code sets applicable to the specific event
+5 ; HCSARR( hac code set (83.71), "DX", x - code entry in ICDDX ) = ""
+6 ; HCSARR( hac code set (83.71), "PR", x - code entry in ICDPR ) = ""
+7 NEW DXI,DX,DXIFN,POA,HCSIFN,LINE,PRI,PR,PRIFN,ARRHSX
KILL HCSARR
+8 ;
+9 ; get all HAC sets defined by event diagnosis that are not POA
+10 SET DXI=0
FOR
SET DXI=$ORDER(ICDDX(DXI))
if 'DXI
QUIT
SET POA=$GET(ICDPOA(DXI))
IF (POA="N")!(POA="U")
Begin DoDot:1
+11 ;
+12 ; get all hac code sets the dx is assigned to on date
+13 SET DX=+$GET(ICDDX(DXI))
SET DXIFN=$ORDER(^ICDD(83.5,"B",DX,0))
if 'DXIFN
QUIT
DO GETCDH("DX",DXIFN,$GET(ICDDATE),.ARRHSX)
+14 ;
+15 ; for each hac set the dx is assigned, check if for this event the dx passes the hac set criteria (P/S)
+16 SET HCSIFN=0
FOR
SET HCSIFN=$ORDER(ARRHSX(HCSIFN))
if 'HCSIFN
QUIT
Begin DoDot:2
+17 SET LINE=$GET(^ICDD(83.71,HCSIFN,0))
if 'HCSIFN
QUIT
+18 ;
+19 ; set for any type of dx
IF $PIECE(LINE,U,4)=""
SET HCSARR(HCSIFN,"DX",DXI)=""
QUIT
+20 ; set for primary dx
IF $PIECE(LINE,U,4)="P"
IF $ORDER(ICDDX(0))=DXI
SET HCSARR(HCSIFN,"DX",DXI)=""
QUIT
+21 ; set for secondary dx
IF $PIECE(LINE,U,4)="S"
IF $ORDER(ICDDX(0))'=DXI
SET HCSARR(HCSIFN,"DX",DXI)=""
QUIT
End DoDot:2
End DoDot:1
+22 ;
+23 ; get all HAC sets defined by the event procedures
+24 SET PRI=0
FOR
SET PRI=$ORDER(ICDPR(PRI))
if 'PRI
QUIT
Begin DoDot:1
+25 SET PR=+$GET(ICDPR(PRI))
SET PRIFN=$ORDER(^ICDD(83.6,"B",PR,0))
if 'PRIFN
QUIT
DO GETCDH("PR",PRIFN,$GET(ICDDATE),.ARRHSX)
+26 ;
+27 SET HCSIFN=0
FOR
SET HCSIFN=$ORDER(ARRHSX(HCSIFN))
if 'HCSIFN
QUIT
SET HCSARR(HCSIFN,"PR",PRI)=""
End DoDot:1
+28 ;
+29 QUIT
+30 ;
GETCDH(TYP,CDIFN,DATE,ARRHSX) ; get HAC code sets for a single code on a date, either diagnosis (83.5,30) or procedure (83.6,30)
+1 ; input: TYP - type of codes 'DX' or 'PR', CDIFN - ptr to code in 83.5 or 83.6
+2 ; output: ARRHSX - array of HAC code sets the Code is a member of on the date
+3 ; ARRHSX(hac code set ifn (83.71)) = CDIFN
+4 NEW IX,LINE,CDFILE,BEGIN,END
SET TYP=$GET(TYP)
SET CDIFN=+$GET(CDIFN)
KILL ARRHSX
IF '$GET(DATE)
SET DATE=DT
+5 SET CDFILE=$SELECT(TYP="DX":83.5,TYP="PR":83.6,1:0)
IF 'CDFILE
QUIT
+6 ;
+7 SET IX=0
FOR
SET IX=$ORDER(^ICDD(CDFILE,CDIFN,30,IX))
if 'IX
QUIT
Begin DoDot:1
+8 SET LINE=$GET(^ICDD(CDFILE,CDIFN,30,IX,0))
if 'LINE
QUIT
+9 SET BEGIN=$PIECE(LINE,U,1)
SET END=$PIECE(LINE,U,2)
IF 'END
SET END=9999999
+10 IF DATE'<BEGIN
IF DATE'>END
SET ARRHSX(+$PIECE(LINE,U,3))=CDIFN
End DoDot:1
+11 QUIT
+12 ;
+13 ;
PRCLS(ICDPR,ICDDATE,PRARR) ; reset PRATT for Clusters, determine Cluster OR/NOR attribute for each event Procedure, if found then re-set event OR/NOR
+1 ; identify all active clusters satified by the event procedures, set all cluster procedures OR/NOR to the Clusters OR/NOR
+2 ; the cluster identified is an indicator and not definitive, each procedure may be assigned to multiple clusters
+3 ; assumes that all clusters a procedure is a member of is the same type, either all OR clusters or all NOR clusters
+4 ;
+5 ; Input: ICDPR(x) - array of Procedures into API, ICDDATE - event date
+6 ; PRARR(x) - pr ifn (#80.1) ^ Procedure (OR/NOR) ^ (reserved Cltr) ^ (reserved Clst Type) ^ ^ ^ OR/NOR applies
+7 ; Output: PRARR - 'O' if any procedure/cluster is an Operating Room procedure, 'N' if Non-OR only or blank
+8 ; - list of all MDC's associated with any of the Operating Room procedures, separated by ';'
+9 ; PRARR(x) - pr ifn (#80.1) ^ Procedure (OR/NOR) ^ Cluster IFN ^ Cluster (OR/NOR) ^ ^ ^ OR/NOR applies
+10 ; w/ OR/NOR = O/N/blank for specific procedure/cluster and w/'x' corresponds to entry in ICDPR array
+11 ; - if Procedure is a member of an active cluster then 'Cluster IFN' and 'Cluster (OR/NOR)' are set and
+12 ; 'OR/NOR applies' is updated to the Clusters OR/NOR attribute
+13 NEW PRI,PR,CLSIFN,ATTLN,ARRCLS
+14 ;
+15 ; get list of all potential clusters, any cluster one of the event procedures belongs to
+16 SET PRI=0
FOR
SET PRI=$ORDER(ICDPR(PRI))
if 'PRI
QUIT
SET PR=+$GET(ICDPR(PRI))
Begin DoDot:1
+17 SET CLSIFN=0
FOR
SET CLSIFN=$ORDER(^ICDD(83.61,"ACL",PR,CLSIFN))
if 'CLSIFN
QUIT
SET ARRCLS(CLSIFN,PRI)=""
End DoDot:1
+18 ;
+19 ; find all active satisfied clusters and update the procedures affected
+20 SET CLSIFN=0
FOR
SET CLSIFN=$ORDER(ARRCLS(CLSIFN))
if 'CLSIFN
QUIT
Begin DoDot:1
+21 ;
+22 ; determine if cluster is satified by event procedures
IF '$$CLSTR^ICDJC2(CLSIFN,.ICDPR)
QUIT
+23 ;
+24 ; determine if cluster is active, if active get its attribute
SET ATTLN=$$GETATT("CL",CLSIFN,$GET(ICDDATE))
IF 'ATTLN
QUIT
+25 ;
+26 SET PRI=0
FOR
SET PRI=$ORDER(ARRCLS(CLSIFN,PRI))
if 'PRI
QUIT
IF $DATA(PRARR(PRI))
Begin DoDot:2
+27 SET $PIECE(PRARR(PRI),U,3)=CLSIFN
SET $PIECE(PRARR(PRI),U,4)=$PIECE(ATTLN,U,3)
SET $PIECE(PRARR(PRI),U,7)=$PIECE(ATTLN,U,3)
End DoDot:2
End DoDot:1
+28 ;
+29 SET ATTLN=""
SET PRI=0
FOR
SET PRI=$ORDER(PRARR(PRI))
if 'PRI
QUIT
IF ATTLN'="O"
IF $PIECE(PRARR(PRI),U,7)'=""
SET ATTLN=$PIECE(PRARR(PRI),U,7)
+30 ;
+31 ; set event procedure/cluster attibutes - final OR/NonOR and MDC list
SET PRARR=ATTLN_U_$$GETMDC("PR",.ICDPR,$GET(ICDDATE))
+32 QUIT
