ICDJC1.m

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 ---ICDJC1   14463     printed  Mar 13, 2025@20:55:35                                                                                                                                                                                                     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      ;