ICDJC3 ;ALB/ARH - DRG GROUPER CALCULATOR 2015 - DRG SELECT ;05/26/2016
;;18.0;DRG Grouper;**89,97**;Oct 20, 2000;Build 5
;
; DRG Calcuation for re-designed grouper ICD-10 2015, continuation
;
;
DRGLS(ICDDATE,PRATT,DXATT,CDSET,DRGARR) ; get all possible satisfied DRGs and their MCC/CC defined by the event diagnosis, procedures and attributes
; DRGs are selected based on Code Sets, defined by the event diagnosis and procedures
; each DRG may have one or more sets of Code Sets (Cases) that lead to the DRG
;
; selected DRGs have at least one DRG Case with all required Code Sets defined and following criteria met:
; a DRGs MDC must match the MDC of the events Primary diagnosis, except DRG MDCs 00 and 99
; a Medical DRG may not have an event OR procedure unless it is specifically assigned to the Case Code Set
; if a DRG that is a member of an Exclusive MDC has a Case initially satisfied then no General MDC DRG is allowed
; if a DRG Case includes an 'EXCEPT' Code Set (Set or Case level), that code set must not be defined by the event
; if a DRG Case requires Any OR procedure, it may not be satisfied by a code used to satisfy any other code set
; if a DRG Case requires a Secondary Dx then that Dxs MCC/CC may not affect the MCC/CC designation of that DRG
; when this occurs the MCC/CC applied to that specific DRG is updated and may be different than the event MCC/CC
;
; Input: PRATT - event Procedure Attributes array
; DXATT - event Diagnosis Attributes array
; CDSET - Code Sets defined by event Diagnosis and Procedures array
; Output: DRGARR - array of DRGs (83.1) with at least one Case (83.2) defined by event Code Sets and attributes
; DRGARR(drg ifn) = MCC or CC or null - DRG valid for event, applicable MCC/CC (event or DRG specific)
; DRGARR(drg ifn, case ifn) [ 1 if Case is valid for event and selects the DRG
; DRGARR(drg ifn, case ifn) [ 2 ^ MCC or CC or null if Case is valid for event and selects the DRG,
; with a DRG specific MCC/CC that overrides the event MCC/CC
; DRGARR(drg ifn, case ifn) [ 3 if there are any unassigned Operating Room Procedures for the Case
N SETIFN,CSEIFN,DRGIFN,DRG0,MDCIFN,MDC0,MDCTYP,DRGCFND,CASEFND,RESET,ARRCSE,ARRDRG
S DXATT=$G(DXATT),PRATT=$G(PRATT) K DRGARR
;
; get list of all potential DRGs: for each satified code set, find all cases, then for those cases find all drgs
S SETIFN=0 F S SETIFN=$O(CDSET(SETIFN)) Q:'SETIFN D
. S CSEIFN=0 F S CSEIFN=$O(^ICDD(83.2,"ACS",SETIFN,CSEIFN)) Q:'CSEIFN D
.. S DRGIFN=0 F S DRGIFN=$O(^ICDD(83.1,"ACE",CSEIFN,DRGIFN)) Q:'DRGIFN S ARRDRG(DRGIFN)=""
;
; for each potential DRG check that all criteria is met and determine if any of its individual Cases are satisfied
S DRGIFN=0 F S DRGIFN=$O(ARRDRG(DRGIFN)) Q:'DRGIFN D
. S DRG0=$G(^ICDD(83.1,DRGIFN,0)) S MDCIFN=+$P(DRG0,U,2),MDC0=$G(^ICDD(83,MDCIFN,0)),MDCTYP=$P(MDC0,U,4)
. ;
. I '$$DRGACT(+DRG0,$G(ICDDATE)) Q ; is DRG active
. ;
. I $P(MDC0,U,2)'="00",$P(MDC0,U,2)'="99",$P(DXATT,U,2)'[$P(MDC0,U,2) Q ; DRG MDC must match Primary Dx MDC
. ;
. D GETCSE(DRGIFN,$G(ICDDATE),.ARRCSE) ; get active Cases associated with the DRG
. ;
. ; for each Case associated with a potential DRG, determine if it is defined by the event and meets criteria
. S CSEIFN=0 F S CSEIFN=$O(ARRCSE(CSEIFN)) Q:'CSEIFN D
.. ;
.. S CASEFND=$$CSESET(MDCIFN,CSEIFN,.CDSET,.DXATT,.PRATT,.DRGCFND) ; determine if case and criteria satisfied
.. ;
.. I MDCTYP=1,+DRGCFND S ARRDRG=1 ; DRGs MDC Type is Exclusive and DRGs Case code sets satisfied, MDC Exclusive applies
.. ;
.. I +CASEFND[3,$P(DRG0,U,4)="M" Q ; medical DRGs should not have OR procedures
.. ;
.. S ARRDRG(DRGIFN)=MDCTYP S ARRDRG(DRGIFN,CSEIFN)=CASEFND ; DRGs MDC Type and Case Results
;
; for each potential DRG that met all selection criteria then create the selected DRG list with Dx Secondary MCC/CC
S DRGIFN=0 F S DRGIFN=$O(ARRDRG(DRGIFN)) Q:'DRGIFN S RESET=0 D
. S CSEIFN=0 F S CSEIFN=$O(ARRDRG(DRGIFN,CSEIFN)) Q:'CSEIFN D
.. ;
.. I +$G(ARRDRG),ARRDRG(DRGIFN)>1 Q ; MDC Exclusive applies, reject DRGs in General MDCs
.. ;
.. S CASEFND=ARRDRG(DRGIFN,CSEIFN) Q:'CASEFND ; all criteria met and at least one DRG Case satisfied or reject
.. ;
.. S DRGARR(DRGIFN,CSEIFN)=CASEFND
.. S DRGARR(DRGIFN)=$S(+CASEFND[2&'RESET:$P(CASEFND,U,2),1:$P(DXATT,U,1)) I +CASEFND'[2 S RESET=1 ; 2nd Dx MCC/CC
;
Q
;
DRGACT(DRG,DATE) ; get the status of the DRG on a date DRG STATUS (#80.2,66,.03)
; input: DRG - ptr to 80.2, DATE - date to determine status
; output: return true if the DRG is active on the date
N DRGSB,DRGSTAT S (DRGSB,DRGSTAT)=0 I '$G(DATE) S DATE=DT
I +$G(DRG) S DATE=DATE+.0001 S DATE=+$O(^ICD(+DRG,66,"B",DATE),-1) S DRGSB=$O(^ICD(+DRG,66,"B",+DATE,0))
I +DRGSB S DRGSTAT=+$P($G(^ICD(+DRG,66,DRGSB,0)),U,3)
Q DRGSTAT
;
GETCSE(DRGIFN,DATE,ARRCSE) ; get all active Cases associated with the DRG (83.1,10)
; input: DRGIFN - ptr to mdc drg (83.1)
; output: ARRCSE(case ifn (83.2)) = DRGIFN - array of active Cases (83.2) linked to the DRG (83.1)
N IX,LINE,BEGIN,END S DRGIFN=+$G(DRGIFN) K ARRCSE I '$G(DATE) S DATE=DT
;
S IX=0 F S IX=$O(^ICDD(83.1,DRGIFN,10,IX)) Q:'IX D
. S LINE=$G(^ICDD(83.1,DRGIFN,10,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 ARRCSE(+$P(LINE,U,3))=DRGIFN
Q
;
CSESET(MDCIFN,CSEIFN,CDSET,DXATT,PRATT,DRGCFND) ; determine if a Case is fully satisfied by the event
; all Code Sets required by a Case have event codes assigned (CDSET) and satisfy the criteria
; input: MDCIFN - ptr to DRGs MDC (83), CSEIFN - ptr to a Case (83.2)
; output: return true if all the code sets for the case have event codes assigned and meet the criteria
; 1 if all case codes sets and criteria satisfied, MCC/CC not affected
; 3 if any Operating Room Procedures unassigned to a case code set
; 2 ^ MCC or CC or null if all case code sets and criteria satisfied and reset the MCC/CC for the DRG
; DRGCFND returns true if the case is initially satisfied before screening for extra/unassigned OR procedures
; a code set identified as EXCEPT, at case or set level, invalidates the case, unless AnyOR overrides it
; the codes used to satisfy the ANY OR Procedure Code Set must not be used to satisfy any of the cases other code sets
; clusters apply within the MDC of its Set and if no other procedure is necessary to select the case
; therefore a cluster with members incompletely assigned to the case may override the selection
; if a Secondary Diagnosis is used to select the DRG then its MCC/CC are removed from the DRGs MCC/CC
N IX,LINE,SETIFN,SET0,LINK,LNKSET,EXCEPT,ANYOR,EXTRAOR,DXSND,ARRSET,FND S CSEIFN=+$G(CSEIFN) S (FND,DRGCFND)=0
;
; get all code sets required by a Case, add linked sets with codes assigned so all criteria can be applied
S IX=0 F S IX=$O(^ICDD(83.2,CSEIFN,10,IX)) Q:'IX D
. S LINE=$G(^ICDD(83.2,CSEIFN,10,IX,0)),SETIFN=+LINE S SET0=$G(^ICDD(83.3,SETIFN,0))
. ;
. S ARRSET(SETIFN)=LINE
. I $P(SET0,U,6)>3 S LINK=$P(SET0,U,7) I LINK'="" D ; unpack linked sets
.. S LNKSET=0 F S LNKSET=$O(^ICDD(83.3,"ACSL",LINK,LNKSET)) Q:'LNKSET I $O(CDSET(LNKSET,0)) S ARRSET(LNKSET)=LINE
;
S (FND,ANYOR,DXSND)=0 S SETIFN=$O(^ICDD(83.3,"ACSC",1,0)) I $D(ARRSET(SETIFN)) S ANYOR=1 ; ANY OPERATING ROOM PROCEDURE
;
; for each Code Set required by the Case, check if it is defined for the event and passes all criteria
S SETIFN=0 F S SETIFN=$O(ARRSET(SETIFN)) Q:'SETIFN D Q:'FND
. S LINE=ARRSET(SETIFN) S SET0=$G(^ICDD(83.3,SETIFN,0))
. I $P(SET0,U,3)="DX",$P(SET0,U,4)'="P" S DXSND=1 ; a specific secondary dx is required for set
. ;
. S FND=1
. ;
. S EXCEPT=0 I ($P(LINE,U,2)=1)!($P(SET0,U,5)=1) S EXCEPT=1 I '$D(CDSET(SETIFN)) Q ; code set except not defined
. I EXCEPT I ($P(SET0,U,3)'="PR")!('ANYOR) S FND=0 Q ; code set except exists, may be overriden by Any OR Procedure
. ;
. I '$D(CDSET(SETIFN)) S FND=0 Q ; code set required for case is not found
;
; if a Case is selected by individual Code Sets, check Case for relationships between Code Sets
;
S DRGCFND=FND ; codes sets and case initially satisfied
;
I FND S EXTRAOR=$$PRCOR($G(MDCIFN),.ARRSET,.CDSET,.PRATT) I +EXTRAOR S FND=FND_3 ; OR Procedures unassigned
;
I FND,ANYOR,'EXTRAOR S FND=0 ; No OR Procedure unassigned, fails ANY OR set
;
I FND,'$$PRCLR($G(MDCIFN),.ARRSET,.CDSET) S FND=0 ; Procedure Cluster incompletely used by a set
;
I FND,DXSND S DXSND=$$DXSND(.ARRSET,.CDSET,.DXATT) I +DXSND=2 S FND=FND_DXSND ; Secondary selects case, reset MCC/CC
;
Q FND
;
PRCOR(DRGMDCFN,ARRSET,CDSET,PRATT) ; determine if any event OR Procedures are unassigned or unused
; input: ARRSET(SETIFN) - all code sets that define the case, codes assigned to these sets are considered used
; output: returns true if any event OR Procedure codes are unused - not assigned to any of the cases code sets
; checks if any OR procedure is unassigned to the Case Sets, excludes generic code sets like Any OR
; also excludes as unused members of clusters defined outside the DRGs MDC that are cluster members only, not singles
N LINE,IX,M0,DRGCAT,DRGMDC,SETIFN,SETCAT,SETMDC,FND,ARRCDX S FND=0
S M0=$G(^ICDD(83,+$G(DRGMDCFN),0)) S DRGCAT=$P(M0,U,1),DRGMDC=$P(M0,U,2)
;
; get all event procedure codes assigned to the cases procedure code sets (non-generic)
S SETIFN=0 F S SETIFN=$O(ARRSET(SETIFN)) Q:'SETIFN D
. S LINE=$G(^ICDD(83.3,SETIFN,0)) I $P(LINE,U,3)="PR",+$P(LINE,U,2) D
.. S M0=$G(^ICDD(83,+$P(LINE,U,2),0)) S SETCAT=$P(M0,U,1),SETMDC=$P(M0,U,2)
.. S IX=0 F S IX=$O(CDSET(SETIFN,IX)) Q:'IX I (DRGMDC=SETMDC)!($P(CDSET(SETIFN,IX),U,3)) S ARRCDX(IX)=""
;
; find if any event OR procedure/cluster is not assigned to the case code sets
S IX=0 F S IX=$O(PRATT(IX)) Q:'IX I $P(PRATT(IX),U,7)="O",'$D(ARRCDX(IX)) S FND=1 Q
;
Q FND
;
PRCLR(DRGMDCFN,ARRSET,CDSET) ; Cluster/MDC Rule - deterime if a cluster is defined by the event and affects the case
; procedures within a cluster must all exist for the cluster to satisfy a set
; the cluster applies only within the MDC of its Set and if no other procedure is necessary to select the case
; input: ARRSET(SETIFN) - all code sets that define the case, codes assigned to these sets are considered used
; output: returns true (1) if a procedure cluster does not invalidate the set
; returns false (0) if cluster is defined and invalidates the case
; if a cluster is defined by the event, it may or may not need to be fully assigned to the case sets
; when applied to cases, the clusters individual procedures may be used outside the clusters MDC or if there
; are non-cluster procedures necessary to select the case
; Cluster/MDC Rule does not apply to MDC 00, single procedures of clusters within MDC 00 may satisfy an MDC 00 set
N IX,M0,DRGCAT,DRGMDC,SETIFN,SET0,SETCAT,SETMDC,CLSTR,ARRCDX,ARRCLS,FND S FND=1
S M0=$G(^ICDD(83,+$G(DRGMDCFN),0)) S DRGCAT=$P(M0,U,1),DRGMDC=$P(M0,U,2)
;
I DRGMDC="00" Q 1 ; Cluster/MDC Rule does not apply to clusters in MDC 00
;
; find event procedures that satisfy the Case procedure Sets, Case MDC and Category
S SETIFN=0 F S SETIFN=$O(ARRSET(SETIFN)) Q:'SETIFN D
. S SET0=$G(^ICDD(83.3,SETIFN,0)) I $P(SET0,U,3)="PR" S IX=0 F S IX=$O(CDSET(SETIFN,IX)) Q:'IX S ARRCDX(IX)=""
;
; find event procedure clusters in the Case MDC but not assigned to the Case MDC Category (not used)
I $O(ARRCDX(0)) S SETIFN=0 F S SETIFN=$O(CDSET(SETIFN)) Q:'SETIFN D
. S IX=0 F S IX=$O(CDSET(SETIFN,IX)) Q:'IX S CLSTR=$P(CDSET(SETIFN,IX),U,4) I +CLSTR D
.. S SET0=$G(^ICDD(83.3,SETIFN,0)) S M0=$G(^ICDD(83,+$P(SET0,U,2),0)) S SETCAT=$P(M0,U,1),SETMDC=$P(M0,U,2)
.. I SETMDC=DRGMDC,SETCAT'=DRGCAT S ARRCLS(IX)=""
;
; reject if event cluster is not used to satisfy the Case unless there is also a non-cluster procedure required
I +FND S IX=0 F S IX=$O(ARRCLS(IX)) Q:'IX I '$D(ARRCDX(IX)) S FND=0 ; not all cluster proc defined for event
I 'FND S IX=0 F S IX=$O(ARRCDX(IX)) Q:'IX I '$D(ARRCLS(IX)) S FND=1 ; non-cluster proc defined, overrides cluster
Q FND
;
DXSND(ARRSET,CDSET,DXATT) ; Case Secondary Dx Rule - get updated DRG MCC/CC if a Secondary Dx was used to select the DRG Case
; if an event diagnosis is assigned to a cases secondary dx code set then remove its MCC/CC from the DRGs MCC/CC
; input: ARRSET(SETIFN) - all code sets that define the case, codes assigned to these sets are considered used
; output: 2 ^ MCC or CC or null - updated DRG MCC/CC
; null if secondary dx code sets did not affect the MCC/CC
; if a Secondary Diagnosis is used to select the DRG then its MCC/CC may not be used for the DRGs MCC/CC
N SETIFN,LINE,IX,NEWMCC,DXCC,FND,ARRCDX S NEWMCC="",FND=""
;
; get secondary event diagnosis codes assigned to the cases secondary dx code sets
S SETIFN=0 F S SETIFN=$O(ARRSET(SETIFN)) Q:'SETIFN S LINE=$G(^ICDD(83.3,SETIFN,0)) D
. I $P(LINE,U,3)="DX" S IX=0 F S IX=$O(CDSET(SETIFN,IX)) Q:'IX I IX'=$O(DXATT(0)) S ARRCDX(IX)=""
;
; if an event diagnosis is assigned to a case secondary dx code set then remove its MCC/CC from use on the DRG
; recalculate the MCC/CC based on the event diagnosis not assigned to the cases secondary dx code sets
I $O(ARRCDX(0)) S NEWMCC="" S IX=0 F S IX=$O(DXATT(IX)) Q:'IX D I NEWMCC="MCC" Q
. S DXCC=$P(DXATT(IX),U,7) I DXCC'="",'$D(ARRCDX(IX)) S NEWMCC=DXCC
;
I $O(ARRCDX(0)),NEWMCC'=$P(DXATT,U,1) S FND=2_U_NEWMCC
;
Q FND
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDJC3 13758 printed Sep 23, 2025@19:27:01 Page 2
ICDJC3 ;ALB/ARH - DRG GROUPER CALCULATOR 2015 - DRG SELECT ;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 ;
+5 ;
DRGLS(ICDDATE,PRATT,DXATT,CDSET,DRGARR) ; get all possible satisfied DRGs and their MCC/CC defined by the event diagnosis, procedures and attributes
+1 ; DRGs are selected based on Code Sets, defined by the event diagnosis and procedures
+2 ; each DRG may have one or more sets of Code Sets (Cases) that lead to the DRG
+3 ;
+4 ; selected DRGs have at least one DRG Case with all required Code Sets defined and following criteria met:
+5 ; a DRGs MDC must match the MDC of the events Primary diagnosis, except DRG MDCs 00 and 99
+6 ; a Medical DRG may not have an event OR procedure unless it is specifically assigned to the Case Code Set
+7 ; if a DRG that is a member of an Exclusive MDC has a Case initially satisfied then no General MDC DRG is allowed
+8 ; if a DRG Case includes an 'EXCEPT' Code Set (Set or Case level), that code set must not be defined by the event
+9 ; if a DRG Case requires Any OR procedure, it may not be satisfied by a code used to satisfy any other code set
+10 ; if a DRG Case requires a Secondary Dx then that Dxs MCC/CC may not affect the MCC/CC designation of that DRG
+11 ; when this occurs the MCC/CC applied to that specific DRG is updated and may be different than the event MCC/CC
+12 ;
+13 ; Input: PRATT - event Procedure Attributes array
+14 ; DXATT - event Diagnosis Attributes array
+15 ; CDSET - Code Sets defined by event Diagnosis and Procedures array
+16 ; Output: DRGARR - array of DRGs (83.1) with at least one Case (83.2) defined by event Code Sets and attributes
+17 ; DRGARR(drg ifn) = MCC or CC or null - DRG valid for event, applicable MCC/CC (event or DRG specific)
+18 ; DRGARR(drg ifn, case ifn) [ 1 if Case is valid for event and selects the DRG
+19 ; DRGARR(drg ifn, case ifn) [ 2 ^ MCC or CC or null if Case is valid for event and selects the DRG,
+20 ; with a DRG specific MCC/CC that overrides the event MCC/CC
+21 ; DRGARR(drg ifn, case ifn) [ 3 if there are any unassigned Operating Room Procedures for the Case
+22 NEW SETIFN,CSEIFN,DRGIFN,DRG0,MDCIFN,MDC0,MDCTYP,DRGCFND,CASEFND,RESET,ARRCSE,ARRDRG
+23 SET DXATT=$GET(DXATT)
SET PRATT=$GET(PRATT)
KILL DRGARR
+24 ;
+25 ; get list of all potential DRGs: for each satified code set, find all cases, then for those cases find all drgs
+26 SET SETIFN=0
FOR
SET SETIFN=$ORDER(CDSET(SETIFN))
if 'SETIFN
QUIT
Begin DoDot:1
+27 SET CSEIFN=0
FOR
SET CSEIFN=$ORDER(^ICDD(83.2,"ACS",SETIFN,CSEIFN))
if 'CSEIFN
QUIT
Begin DoDot:2
+28 SET DRGIFN=0
FOR
SET DRGIFN=$ORDER(^ICDD(83.1,"ACE",CSEIFN,DRGIFN))
if 'DRGIFN
QUIT
SET ARRDRG(DRGIFN)=""
End DoDot:2
End DoDot:1
+29 ;
+30 ; for each potential DRG check that all criteria is met and determine if any of its individual Cases are satisfied
+31 SET DRGIFN=0
FOR
SET DRGIFN=$ORDER(ARRDRG(DRGIFN))
if 'DRGIFN
QUIT
Begin DoDot:1
+32 SET DRG0=$GET(^ICDD(83.1,DRGIFN,0))
SET MDCIFN=+$PIECE(DRG0,U,2)
SET MDC0=$GET(^ICDD(83,MDCIFN,0))
SET MDCTYP=$PIECE(MDC0,U,4)
+33 ;
+34 ; is DRG active
IF '$$DRGACT(+DRG0,$GET(ICDDATE))
QUIT
+35 ;
+36 ; DRG MDC must match Primary Dx MDC
IF $PIECE(MDC0,U,2)'="00"
IF $PIECE(MDC0,U,2)'="99"
IF $PIECE(DXATT,U,2)'[$PIECE(MDC0,U,2)
QUIT
+37 ;
+38 ; get active Cases associated with the DRG
DO GETCSE(DRGIFN,$GET(ICDDATE),.ARRCSE)
+39 ;
+40 ; for each Case associated with a potential DRG, determine if it is defined by the event and meets criteria
+41 SET CSEIFN=0
FOR
SET CSEIFN=$ORDER(ARRCSE(CSEIFN))
if 'CSEIFN
QUIT
Begin DoDot:2
+42 ;
+43 ; determine if case and criteria satisfied
SET CASEFND=$$CSESET(MDCIFN,CSEIFN,.CDSET,.DXATT,.PRATT,.DRGCFND)
+44 ;
+45 ; DRGs MDC Type is Exclusive and DRGs Case code sets satisfied, MDC Exclusive applies
IF MDCTYP=1
IF +DRGCFND
SET ARRDRG=1
+46 ;
+47 ; medical DRGs should not have OR procedures
IF +CASEFND[3
IF $PIECE(DRG0,U,4)="M"
QUIT
+48 ;
+49 ; DRGs MDC Type and Case Results
SET ARRDRG(DRGIFN)=MDCTYP
SET ARRDRG(DRGIFN,CSEIFN)=CASEFND
End DoDot:2
End DoDot:1
+50 ;
+51 ; for each potential DRG that met all selection criteria then create the selected DRG list with Dx Secondary MCC/CC
+52 SET DRGIFN=0
FOR
SET DRGIFN=$ORDER(ARRDRG(DRGIFN))
if 'DRGIFN
QUIT
SET RESET=0
Begin DoDot:1
+53 SET CSEIFN=0
FOR
SET CSEIFN=$ORDER(ARRDRG(DRGIFN,CSEIFN))
if 'CSEIFN
QUIT
Begin DoDot:2
+54 ;
+55 ; MDC Exclusive applies, reject DRGs in General MDCs
IF +$GET(ARRDRG)
IF ARRDRG(DRGIFN)>1
QUIT
+56 ;
+57 ; all criteria met and at least one DRG Case satisfied or reject
SET CASEFND=ARRDRG(DRGIFN,CSEIFN)
if 'CASEFND
QUIT
+58 ;
+59 SET DRGARR(DRGIFN,CSEIFN)=CASEFND
+60 ; 2nd Dx MCC/CC
SET DRGARR(DRGIFN)=$SELECT(+CASEFND[2&'RESET:$PIECE(CASEFND,U,2),1:$PIECE(DXATT,U,1))
IF +CASEFND'[2
SET RESET=1
End DoDot:2
End DoDot:1
+61 ;
+62 QUIT
+63 ;
DRGACT(DRG,DATE) ; get the status of the DRG on a date DRG STATUS (#80.2,66,.03)
+1 ; input: DRG - ptr to 80.2, DATE - date to determine status
+2 ; output: return true if the DRG is active on the date
+3 NEW DRGSB,DRGSTAT
SET (DRGSB,DRGSTAT)=0
IF '$GET(DATE)
SET DATE=DT
+4 IF +$GET(DRG)
SET DATE=DATE+.0001
SET DATE=+$ORDER(^ICD(+DRG,66,"B",DATE),-1)
SET DRGSB=$ORDER(^ICD(+DRG,66,"B",+DATE,0))
+5 IF +DRGSB
SET DRGSTAT=+$PIECE($GET(^ICD(+DRG,66,DRGSB,0)),U,3)
+6 QUIT DRGSTAT
+7 ;
GETCSE(DRGIFN,DATE,ARRCSE) ; get all active Cases associated with the DRG (83.1,10)
+1 ; input: DRGIFN - ptr to mdc drg (83.1)
+2 ; output: ARRCSE(case ifn (83.2)) = DRGIFN - array of active Cases (83.2) linked to the DRG (83.1)
+3 NEW IX,LINE,BEGIN,END
SET DRGIFN=+$GET(DRGIFN)
KILL ARRCSE
IF '$GET(DATE)
SET DATE=DT
+4 ;
+5 SET IX=0
FOR
SET IX=$ORDER(^ICDD(83.1,DRGIFN,10,IX))
if 'IX
QUIT
Begin DoDot:1
+6 SET LINE=$GET(^ICDD(83.1,DRGIFN,10,IX,0))
if 'LINE
QUIT
+7 SET BEGIN=$PIECE(LINE,U,1)
SET END=$PIECE(LINE,U,2)
IF 'END
SET END=9999999
+8 IF DATE'<BEGIN
IF DATE'>END
SET ARRCSE(+$PIECE(LINE,U,3))=DRGIFN
End DoDot:1
+9 QUIT
+10 ;
CSESET(MDCIFN,CSEIFN,CDSET,DXATT,PRATT,DRGCFND) ; determine if a Case is fully satisfied by the event
+1 ; all Code Sets required by a Case have event codes assigned (CDSET) and satisfy the criteria
+2 ; input: MDCIFN - ptr to DRGs MDC (83), CSEIFN - ptr to a Case (83.2)
+3 ; output: return true if all the code sets for the case have event codes assigned and meet the criteria
+4 ; 1 if all case codes sets and criteria satisfied, MCC/CC not affected
+5 ; 3 if any Operating Room Procedures unassigned to a case code set
+6 ; 2 ^ MCC or CC or null if all case code sets and criteria satisfied and reset the MCC/CC for the DRG
+7 ; DRGCFND returns true if the case is initially satisfied before screening for extra/unassigned OR procedures
+8 ; a code set identified as EXCEPT, at case or set level, invalidates the case, unless AnyOR overrides it
+9 ; the codes used to satisfy the ANY OR Procedure Code Set must not be used to satisfy any of the cases other code sets
+10 ; clusters apply within the MDC of its Set and if no other procedure is necessary to select the case
+11 ; therefore a cluster with members incompletely assigned to the case may override the selection
+12 ; if a Secondary Diagnosis is used to select the DRG then its MCC/CC are removed from the DRGs MCC/CC
+13 NEW IX,LINE,SETIFN,SET0,LINK,LNKSET,EXCEPT,ANYOR,EXTRAOR,DXSND,ARRSET,FND
SET CSEIFN=+$GET(CSEIFN)
SET (FND,DRGCFND)=0
+14 ;
+15 ; get all code sets required by a Case, add linked sets with codes assigned so all criteria can be applied
+16 SET IX=0
FOR
SET IX=$ORDER(^ICDD(83.2,CSEIFN,10,IX))
if 'IX
QUIT
Begin DoDot:1
+17 SET LINE=$GET(^ICDD(83.2,CSEIFN,10,IX,0))
SET SETIFN=+LINE
SET SET0=$GET(^ICDD(83.3,SETIFN,0))
+18 ;
+19 SET ARRSET(SETIFN)=LINE
+20 ; unpack linked sets
IF $PIECE(SET0,U,6)>3
SET LINK=$PIECE(SET0,U,7)
IF LINK'=""
Begin DoDot:2
+21 SET LNKSET=0
FOR
SET LNKSET=$ORDER(^ICDD(83.3,"ACSL",LINK,LNKSET))
if 'LNKSET
QUIT
IF $ORDER(CDSET(LNKSET,0))
SET ARRSET(LNKSET)=LINE
End DoDot:2
End DoDot:1
+22 ;
+23 ; ANY OPERATING ROOM PROCEDURE
SET (FND,ANYOR,DXSND)=0
SET SETIFN=$ORDER(^ICDD(83.3,"ACSC",1,0))
IF $DATA(ARRSET(SETIFN))
SET ANYOR=1
+24 ;
+25 ; for each Code Set required by the Case, check if it is defined for the event and passes all criteria
+26 SET SETIFN=0
FOR
SET SETIFN=$ORDER(ARRSET(SETIFN))
if 'SETIFN
QUIT
Begin DoDot:1
+27 SET LINE=ARRSET(SETIFN)
SET SET0=$GET(^ICDD(83.3,SETIFN,0))
+28 ; a specific secondary dx is required for set
IF $PIECE(SET0,U,3)="DX"
IF $PIECE(SET0,U,4)'="P"
SET DXSND=1
+29 ;
+30 SET FND=1
+31 ;
+32 ; code set except not defined
SET EXCEPT=0
IF ($PIECE(LINE,U,2)=1)!($PIECE(SET0,U,5)=1)
SET EXCEPT=1
IF '$DATA(CDSET(SETIFN))
QUIT
+33 ; code set except exists, may be overriden by Any OR Procedure
IF EXCEPT
IF ($PIECE(SET0,U,3)'="PR")!('ANYOR)
SET FND=0
QUIT
+34 ;
+35 ; code set required for case is not found
IF '$DATA(CDSET(SETIFN))
SET FND=0
QUIT
End DoDot:1
if 'FND
QUIT
+36 ;
+37 ; if a Case is selected by individual Code Sets, check Case for relationships between Code Sets
+38 ;
+39 ; codes sets and case initially satisfied
SET DRGCFND=FND
+40 ;
+41 ; OR Procedures unassigned
IF FND
SET EXTRAOR=$$PRCOR($GET(MDCIFN),.ARRSET,.CDSET,.PRATT)
IF +EXTRAOR
SET FND=FND_3
+42 ;
+43 ; No OR Procedure unassigned, fails ANY OR set
IF FND
IF ANYOR
IF 'EXTRAOR
SET FND=0
+44 ;
+45 ; Procedure Cluster incompletely used by a set
IF FND
IF '$$PRCLR($GET(MDCIFN),.ARRSET,.CDSET)
SET FND=0
+46 ;
+47 ; Secondary selects case, reset MCC/CC
IF FND
IF DXSND
SET DXSND=$$DXSND(.ARRSET,.CDSET,.DXATT)
IF +DXSND=2
SET FND=FND_DXSND
+48 ;
+49 QUIT FND
+50 ;
PRCOR(DRGMDCFN,ARRSET,CDSET,PRATT) ; determine if any event OR Procedures are unassigned or unused
+1 ; input: ARRSET(SETIFN) - all code sets that define the case, codes assigned to these sets are considered used
+2 ; output: returns true if any event OR Procedure codes are unused - not assigned to any of the cases code sets
+3 ; checks if any OR procedure is unassigned to the Case Sets, excludes generic code sets like Any OR
+4 ; also excludes as unused members of clusters defined outside the DRGs MDC that are cluster members only, not singles
+5 NEW LINE,IX,M0,DRGCAT,DRGMDC,SETIFN,SETCAT,SETMDC,FND,ARRCDX
SET FND=0
+6 SET M0=$GET(^ICDD(83,+$GET(DRGMDCFN),0))
SET DRGCAT=$PIECE(M0,U,1)
SET DRGMDC=$PIECE(M0,U,2)
+7 ;
+8 ; get all event procedure codes assigned to the cases procedure code sets (non-generic)
+9 SET SETIFN=0
FOR
SET SETIFN=$ORDER(ARRSET(SETIFN))
if 'SETIFN
QUIT
Begin DoDot:1
+10 SET LINE=$GET(^ICDD(83.3,SETIFN,0))
IF $PIECE(LINE,U,3)="PR"
IF +$PIECE(LINE,U,2)
Begin DoDot:2
+11 SET M0=$GET(^ICDD(83,+$PIECE(LINE,U,2),0))
SET SETCAT=$PIECE(M0,U,1)
SET SETMDC=$PIECE(M0,U,2)
+12 SET IX=0
FOR
SET IX=$ORDER(CDSET(SETIFN,IX))
if 'IX
QUIT
IF (DRGMDC=SETMDC)!($PIECE(CDSET(SETIFN,IX),U,3))
SET ARRCDX(IX)=""
End DoDot:2
End DoDot:1
+13 ;
+14 ; find if any event OR procedure/cluster is not assigned to the case code sets
+15 SET IX=0
FOR
SET IX=$ORDER(PRATT(IX))
if 'IX
QUIT
IF $PIECE(PRATT(IX),U,7)="O"
IF '$DATA(ARRCDX(IX))
SET FND=1
QUIT
+16 ;
+17 QUIT FND
+18 ;
PRCLR(DRGMDCFN,ARRSET,CDSET) ; Cluster/MDC Rule - deterime if a cluster is defined by the event and affects the case
+1 ; procedures within a cluster must all exist for the cluster to satisfy a set
+2 ; the cluster applies only within the MDC of its Set and if no other procedure is necessary to select the case
+3 ; input: ARRSET(SETIFN) - all code sets that define the case, codes assigned to these sets are considered used
+4 ; output: returns true (1) if a procedure cluster does not invalidate the set
+5 ; returns false (0) if cluster is defined and invalidates the case
+6 ; if a cluster is defined by the event, it may or may not need to be fully assigned to the case sets
+7 ; when applied to cases, the clusters individual procedures may be used outside the clusters MDC or if there
+8 ; are non-cluster procedures necessary to select the case
+9 ; Cluster/MDC Rule does not apply to MDC 00, single procedures of clusters within MDC 00 may satisfy an MDC 00 set
+10 NEW IX,M0,DRGCAT,DRGMDC,SETIFN,SET0,SETCAT,SETMDC,CLSTR,ARRCDX,ARRCLS,FND
SET FND=1
+11 SET M0=$GET(^ICDD(83,+$GET(DRGMDCFN),0))
SET DRGCAT=$PIECE(M0,U,1)
SET DRGMDC=$PIECE(M0,U,2)
+12 ;
+13 ; Cluster/MDC Rule does not apply to clusters in MDC 00
IF DRGMDC="00"
QUIT 1
+14 ;
+15 ; find event procedures that satisfy the Case procedure Sets, Case MDC and Category
+16 SET SETIFN=0
FOR
SET SETIFN=$ORDER(ARRSET(SETIFN))
if 'SETIFN
QUIT
Begin DoDot:1
+17 SET SET0=$GET(^ICDD(83.3,SETIFN,0))
IF $PIECE(SET0,U,3)="PR"
SET IX=0
FOR
SET IX=$ORDER(CDSET(SETIFN,IX))
if 'IX
QUIT
SET ARRCDX(IX)=""
End DoDot:1
+18 ;
+19 ; find event procedure clusters in the Case MDC but not assigned to the Case MDC Category (not used)
+20 IF $ORDER(ARRCDX(0))
SET SETIFN=0
FOR
SET SETIFN=$ORDER(CDSET(SETIFN))
if 'SETIFN
QUIT
Begin DoDot:1
+21 SET IX=0
FOR
SET IX=$ORDER(CDSET(SETIFN,IX))
if 'IX
QUIT
SET CLSTR=$PIECE(CDSET(SETIFN,IX),U,4)
IF +CLSTR
Begin DoDot:2
+22 SET SET0=$GET(^ICDD(83.3,SETIFN,0))
SET M0=$GET(^ICDD(83,+$PIECE(SET0,U,2),0))
SET SETCAT=$PIECE(M0,U,1)
SET SETMDC=$PIECE(M0,U,2)
+23 IF SETMDC=DRGMDC
IF SETCAT'=DRGCAT
SET ARRCLS(IX)=""
End DoDot:2
End DoDot:1
+24 ;
+25 ; reject if event cluster is not used to satisfy the Case unless there is also a non-cluster procedure required
+26 ; not all cluster proc defined for event
IF +FND
SET IX=0
FOR
SET IX=$ORDER(ARRCLS(IX))
if 'IX
QUIT
IF '$DATA(ARRCDX(IX))
SET FND=0
+27 ; non-cluster proc defined, overrides cluster
IF 'FND
SET IX=0
FOR
SET IX=$ORDER(ARRCDX(IX))
if 'IX
QUIT
IF '$DATA(ARRCLS(IX))
SET FND=1
+28 QUIT FND
+29 ;
DXSND(ARRSET,CDSET,DXATT) ; Case Secondary Dx Rule - get updated DRG MCC/CC if a Secondary Dx was used to select the DRG Case
+1 ; if an event diagnosis is assigned to a cases secondary dx code set then remove its MCC/CC from the DRGs MCC/CC
+2 ; input: ARRSET(SETIFN) - all code sets that define the case, codes assigned to these sets are considered used
+3 ; output: 2 ^ MCC or CC or null - updated DRG MCC/CC
+4 ; null if secondary dx code sets did not affect the MCC/CC
+5 ; if a Secondary Diagnosis is used to select the DRG then its MCC/CC may not be used for the DRGs MCC/CC
+6 NEW SETIFN,LINE,IX,NEWMCC,DXCC,FND,ARRCDX
SET NEWMCC=""
SET FND=""
+7 ;
+8 ; get secondary event diagnosis codes assigned to the cases secondary dx code sets
+9 SET SETIFN=0
FOR
SET SETIFN=$ORDER(ARRSET(SETIFN))
if 'SETIFN
QUIT
SET LINE=$GET(^ICDD(83.3,SETIFN,0))
Begin DoDot:1
+10 IF $PIECE(LINE,U,3)="DX"
SET IX=0
FOR
SET IX=$ORDER(CDSET(SETIFN,IX))
if 'IX
QUIT
IF IX'=$ORDER(DXATT(0))
SET ARRCDX(IX)=""
End DoDot:1
+11 ;
+12 ; if an event diagnosis is assigned to a case secondary dx code set then remove its MCC/CC from use on the DRG
+13 ; recalculate the MCC/CC based on the event diagnosis not assigned to the cases secondary dx code sets
+14 IF $ORDER(ARRCDX(0))
SET NEWMCC=""
SET IX=0
FOR
SET IX=$ORDER(DXATT(IX))
if 'IX
QUIT
Begin DoDot:1
+15 SET DXCC=$PIECE(DXATT(IX),U,7)
IF DXCC'=""
IF '$DATA(ARRCDX(IX))
SET NEWMCC=DXCC
End DoDot:1
IF NEWMCC="MCC"
QUIT
+16 ;
+17 IF $ORDER(ARRCDX(0))
IF NEWMCC'=$PIECE(DXATT,U,1)
SET FND=2_U_NEWMCC
+18 ;
+19 QUIT FND
