ICDJC2 ;ALB/ARH - DRG GROUPER CALCULATOR 2015 - CODE SETS ;05/26/2016
;;18.0;DRG Grouper;**89,97**;Oct 20, 2000;Build 5
;
; DRG Calcuation for re-designed grouper ICD-10 2015, continuation
;
CDSET(ICDDX,ICDPR,ICDDATE,PRATT,CDSARR) ; get all Code Sets defined by event Diagnosis and Procedure codes
; most Code Sets are specific to an event code, either Diagnosis (83.5,20) or Procedure (83.6,20)
; Dx Code Sets may be specific to primary or secondary event dx, all members of procedure Clusters must be defined
; an 'ONLY' Code Set is selected only if all the codes defined for the event are in the Code Set
; computed generic and linked group Code Sets are selected if all criteria are met
;
; Input: ICDDX(x) and ICDPR(x) - array of Dx/procedures input to API, ICDDATE - date of event, PRATT pr attributes
; Output: CDSARR - array of all Code Sets (83.3) satisfied by the event diagnosis and procedures
; CDSARR(code set ifn, icdxx number) = code ien (80/80.1) ^ DX/PR ^ single(1)/cluster only(0) ^ cluster ien
; CDSARR(code set ifn, 99_cmpt #) = ^ type of codes in set 'DX' or 'PR' - for computed codes sets
N LINE,PDX,DXI,DX,DXIFN,PRI,PR,PRIFN,SETIFN,ONLY,LINK,ARRCDS S ICDDATE=$G(ICDDATE) K CDSARR
S PDX=$O(ICDDX(0))
;
;
; get all Diagnosis Code Sets
S DXI=0 F S DXI=$O(ICDDX(DXI)) Q:'DXI D
. ;
. ; get all 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 GETCDS("DX",DXIFN,ICDDATE,.ARRCDS)
. ;
. ; for each code set the dx is assigned to check that for this event it passes the set criteria
. S SETIFN=0 F S SETIFN=$O(ARRCDS(SETIFN)) Q:'SETIFN D
.. S LINE=$G(^ICDD(83.3,SETIFN,0))
.. ;
.. I $P(LINE,U,3)'="DX" Q
.. I $P(LINE,U,4)="P",DXI'=PDX Q ; code set for primary dx
.. I $P(LINE,U,4)="S",DXI=PDX Q ; code set for secondary dx
.. ;
.. I $P(LINE,U,7)'="" S LINK($P(LINE,U,7),SETIFN)=$G(LINK($P(LINE,U,7),SETIFN))+1 ; linked set
.. I $P(LINE,U,5)=2 S ONLY(DXI)=SETIFN_U_DX_U_"DX" Q ; only secondary dxs contained in the set allowed
.. ;
.. S CDSARR(SETIFN,DXI)=DX_U_"DX"_U_1
;
I $O(ONLY(0)) D ONLY(.ONLY,.ICDDX,.CDSARR) ; add ONLY code sets that may apply
K ARRCDS,ONLY
;
;
; get all Procedure Code Sets
S PRI=0 F S PRI=$O(ICDPR(PRI)) Q:'PRI D
. ;
. ; get all code sets the procedure is assigned to on date
. S PR=+$G(ICDPR(PRI)) S PRIFN=$O(^ICDD(83.6,"B",PR,0)) Q:'PRIFN D GETCDS("PR",PRIFN,ICDDATE,.ARRCDS,.ICDPR)
. ;
. ; for each code set the procedure is assigned to check that for this event it passes the set criteria
. S SETIFN=0 F S SETIFN=$O(ARRCDS(SETIFN)) Q:'SETIFN D
.. S LINE=$G(^ICDD(83.3,SETIFN,0))
.. ;
.. I $P(LINE,U,3)'="PR" Q
.. ;
.. I $P(LINE,U,7)'="" S LINK($P(LINE,U,7),SETIFN)=$G(LINK($P(LINE,U,7),SETIFN))+1 ; linked set
.. I $P(LINE,U,5)=2 S ONLY(PRI)=SETIFN_U_PR_U_"PR" Q ; only procedures contained in the set allowed
.. ;
.. S CDSARR(SETIFN,PRI)=PR_U_"PR"_U_$P(ARRCDS(SETIFN),U,3,4)
;
I $O(ONLY(0)) D ONLY(.ONLY,.ICDPR,.CDSARR,.PRATT) ; add ONLY code sets that may apply
;
;
I $O(LINK(""))'="" D LINK(.LINK,.CDSARR) ; add any computed LNK code sets that may apply
;
; check for generic or calculated code sets that may apply
S SETIFN=$$CALC1(.ICDPR,.PRATT) I +SETIFN S CDSARR(+SETIFN,991)=U_"PR" ; ANY OPERATING ROOM PROCEDURE
S SETIFN=$$CALC2(.ICDPR,.PRATT) I +SETIFN S CDSARR(+SETIFN,992)=U_"PR" ; NO OPERATING ROOM PROCEDURE
S SETIFN=$$CALC3(.ICDDX) I +SETIFN S CDSARR(+SETIFN,993)=U_"DX" ; NO SECONDARY DIAGNOSIS
Q
;
GETCDS(TYP,CDIFN,DATE,ARRCDS,ICDPR) ; get Code Sets for a single code on a date, either diagnosis (83.5,20) or procedure (83.6,20)
; input: TYP - type of codes 'DX' or 'PR', CDIFN - ptr to code in 83.5 or 83.6
; output: ARRCDS - array of code sets the code is a member of on the date
; ARRCDS(code set ifn (83.3)) = TYP ^ code set ifn ^ single(1)/cluster only(0) in set ^ cluster ptr 83.61
; a procedure may be assigned to a Code Set as a single procedure and/or as a member of a cluster, all members
; of a cluster (83.6,20,.04) must be defined for the cluster only procedures to select a Code Set
N IX,CDFILE,LINE,BEGIN,END,SETIFN,CLUSTER,SINGLE S TYP=$G(TYP),CDIFN=+$G(CDIFN) K ARRCDS 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,20,IX)) Q:'IX D
. S LINE=$G(^ICDD(CDFILE,CDIFN,20,IX,0)),SETIFN=+$P(LINE,U,3)
. S BEGIN=$P(LINE,U,1),END=$P(LINE,U,2) I 'END S END=9999999
. I (BEGIN>DATE)!(END<DATE) Q
. ;
. I TYP="DX" S ARRCDS(SETIFN)=TYP_U_SETIFN_U_1 Q
. ;
. S CLUSTER=$P(LINE,U,4) I +CLUSTER,'$$CLSTR(CLUSTER,.ICDPR) Q
. S LINE=$G(ARRCDS(SETIFN)) S SINGLE=+$P(LINE,U,3) I 'CLUSTER S SINGLE=1 S CLUSTER=$P(LINE,U,4)
. ;
. S ARRCDS(SETIFN)=TYP_U_SETIFN_U_SINGLE_U_CLUSTER Q
Q
;
CLSTR(CLUSTER,ICDPR) ; determine if the event procedures satisfy the cluster
; returns true if all the procedures assigned to the cluster (83.61) are defined on the event
; input: CLUSTER - ptr to a cluster (83.61), ICDPR - array of event procedures
N PR,PRI,FND,ARRPR S CLUSTER=+$G(CLUSTER) S FND=0
;
; get list of event procedures by procedure ifn
S PRI=0 F S PRI=$O(ICDPR(PRI)) Q:'PRI S PR=+$G(ICDPR(PRI)) S ARRPR(PR)=PRI
;
; determine if all procedures assigned to the cluster are assigned to the event
S PR=0 F S PR=$O(^ICDD(83.61,CLUSTER,20,"B",PR)) Q:'PR S FND=0 S:+$G(ARRPR(PR)) FND=1 I 'FND Q
;
Q FND
;
;
CALC1(ICDPR,PRATT) ; Computed generic Code Set: ANY OPERATING ROOM PROCEDURE
; returns the generic Code Set IFN if there is one or more O.R. or Surgical event procedures
N CMPTSET1,PRI,FND S FND=0
;
S CMPTSET1=$O(^ICDD(83.3,"ACSC",1,0))
;
S PRI=0 F S PRI=$O(ICDPR(PRI)) Q:'PRI I $P($G(PRATT(PRI)),U,7)="O" S FND=1 Q
;
I +FND S FND=+CMPTSET1
;
Q FND
;
CALC2(ICDPR,PRATT) ; Computed generic Code Set: NO OPERATING ROOM PROCEDURE
; returns the generic Code Set IFN if there are no O.R or Surgical event procedures
N CMPTSET2,PRI,FND S FND=1
;
S CMPTSET2=$O(^ICDD(83.3,"ACSC",2,0))
;
S PRI=0 F S PRI=$O(ICDPR(PRI)) Q:'PRI I $P($G(PRATT(PRI)),U,7)="O" S FND=0 Q
;
I +FND S FND=+CMPTSET2
;
Q FND
;
CALC3(ICDDX) ; Computed generic Code Set: NO SECONDARY DIAGNOSIS
; returns the generic Code Set IFN if there are no Secondary diagnosis on the event (only 1 dx)
N IX,CMPTSET3,FND S FND=1
;
S CMPTSET3=$O(^ICDD(83.3,"ACSC",3,0))
;
S IX=$O(ICDDX(0)) S IX=$O(ICDDX(IX)) I +IX S FND=0
;
I +FND S FND=+CMPTSET3
;
Q FND
;
ONLY(ONLYARR,ICDARR,CDSARR,PRATT) ; add 'ONLY' Code Set if all codes assigned to the event are in the Set
; if all the event codes are in the set then add the Only Code Set to the list of all selected Code Sets
; for diagnosis this is only applied to the secondary codes
; for procedures this is only applied to operating room procedures, non-or procedures outside the set are allowed
; input: ONLYARR(icdxx number) = ONLY code set ifn ^ code ifn (ptr #80, #80.1) ^ code type
; ICDARR - may be either ICDDX or ICDPRC, PRATT compiled procedure attributes
; output: CDSARR modified - if meets criteria the ONLY Code Set is added to CDSARR array of selected code sets
; CDSARR(ONLY code set ifn, idcxx number) = code ien (80/80.1) ^ code type ^ 1 (single)
N IX,LINE,CODTYP,CNT,FND S CNT=0,FND=0
;
S IX=$O(ONLYARR(0)) Q:'IX S CODTYP=$P(ONLYARR(IX),U,3)
;
I CODTYP="DX" S IX=$O(ICDARR(0)) F S IX=$O(ICDARR(IX)) Q:'IX S CNT=CNT+1 I $D(ONLYARR(IX)) S FND=FND+1
;
I CODTYP="PR" S IX=0 F S IX=$O(ICDARR(IX)) Q:'IX I $P($G(PRATT(IX)),U,7)="O" S CNT=CNT+1 I $D(ONLYARR(IX)) S FND=FND+1
;
I +FND,FND=CNT S IX=0 F S IX=$O(ONLYARR(IX)) Q:'IX S LINE=ONLYARR(IX) S CDSARR(+LINE,IX)=$P(LINE,U,2,3)_U_1
Q
;
LINK(LINKARR,CDSARR) ; add any Computed LNK Code Set that apply
; for any selected Code Set in a Linked group, check if the Link criteria is satisfied
; if the Link criteria is met then add the generic LNK Computed Code Set to the list of selected Code Sets
; input: LINKARR(link group, LINKED code set ifn) = count of selected Code Sets with the link group
; CDSARR(code set ifn, icdxx number) = code ifn (ptr #80, #80.1) ^ code type
; output: CDSARR modified, any LNK Computed Code Set satisfied is added to CDSARR array of all selected Sets
; CDSARR(LNK Computed code set ifn, 99x) = ^ code type w/x is the LNK set value
; difference between CDN and MLT is Condition is not exclusive, one code can satisfy more than one condition
; number of sets required is in link text after '-', count link number a group satisfies is in the set name
N LINK,CMPTSET,CSET0,LINE,SETIFN,MDCCAT,CMPTD,NUM,COUNT,CNT,IX,ARRLNK
;
; find the generic LNK Computed Code Set for any of the Linked Code Sets defined by the event
S LINK="" F S LINK=$O(LINKARR(LINK)) Q:LINK="" D
. S CMPTSET=0 F S CMPTSET=$O(^ICDD(83.3,"ACSL",LINK,CMPTSET)) Q:'CMPTSET D
.. S LINE=$G(^ICDD(83.3,CMPTSET,0)) I +$P(LINE,U,6) S ARRLNK(CMPTSET)="" ; computed set
;
; for each generic LNK Computed Code Set found, determine if all linked sets defined and/or criteria met
; if they are then add the generic set to the list of Code Sets defined for the event.
S CMPTSET=0 F S CMPTSET=$O(ARRLNK(CMPTSET)) Q:'CMPTSET D
. S CSET0=$G(^ICDD(83.3,CMPTSET,0))
. S MDCCAT=$P(CSET0,U,2),CMPTD=$P(CSET0,U,6),LINK=$P(CSET0,U,7),NUM=$P(LINK,"-",2),CNT=0
. ;
. S SETIFN=0 F S SETIFN=$O(^ICDD(83.3,"ACSL",LINK,SETIFN)) Q:'SETIFN I SETIFN'=CMPTSET D
.. S LINE=$G(^ICDD(83.3,SETIFN,0)) S COUNT=$P($P(LINE,U,8)," ",1) I $P(LINE,U,2)'=MDCCAT Q
.. ;
.. I CMPTD=6 I $D(CDSARR(SETIFN)) S CNT=CNT+1 ; one or more sets in group required
.. ;
.. I CMPTD=5 I $D(CDSARR(SETIFN)) S CNT=CNT+1 ; one or more sets necessary for condition
.. ;
.. I CMPTD=4 S CNT=CNT+($S(COUNT="ONE":1,COUNT="TWO":2,COUNT="THREE":3,COUNT="FOUR":4,1:0)*$G(LINKARR(LINK,SETIFN)))
. ;
. I +CNT,CNT'<NUM S IX=99_CMPTD S CDSARR(CMPTSET,IX)=U_$P(CSET0,U,3)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HICDJC2 10138 printed Apr 09, 2024@20:53:03 Page 2
ICDJC2 ;ALB/ARH - DRG GROUPER CALCULATOR 2015 - CODE SETS ;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 ;
CDSET(ICDDX,ICDPR,ICDDATE,PRATT,CDSARR) ; get all Code Sets defined by event Diagnosis and Procedure codes
+1 ; most Code Sets are specific to an event code, either Diagnosis (83.5,20) or Procedure (83.6,20)
+2 ; Dx Code Sets may be specific to primary or secondary event dx, all members of procedure Clusters must be defined
+3 ; an 'ONLY' Code Set is selected only if all the codes defined for the event are in the Code Set
+4 ; computed generic and linked group Code Sets are selected if all criteria are met
+5 ;
+6 ; Input: ICDDX(x) and ICDPR(x) - array of Dx/procedures input to API, ICDDATE - date of event, PRATT pr attributes
+7 ; Output: CDSARR - array of all Code Sets (83.3) satisfied by the event diagnosis and procedures
+8 ; CDSARR(code set ifn, icdxx number) = code ien (80/80.1) ^ DX/PR ^ single(1)/cluster only(0) ^ cluster ien
+9 ; CDSARR(code set ifn, 99_cmpt #) = ^ type of codes in set 'DX' or 'PR' - for computed codes sets
+10 NEW LINE,PDX,DXI,DX,DXIFN,PRI,PR,PRIFN,SETIFN,ONLY,LINK,ARRCDS
SET ICDDATE=$GET(ICDDATE)
KILL CDSARR
+11 SET PDX=$ORDER(ICDDX(0))
+12 ;
+13 ;
+14 ; get all Diagnosis Code Sets
+15 SET DXI=0
FOR
SET DXI=$ORDER(ICDDX(DXI))
if 'DXI
QUIT
Begin DoDot:1
+16 ;
+17 ; get all code sets the dx is assigned to on date
+18 SET DX=+$GET(ICDDX(DXI))
SET DXIFN=$ORDER(^ICDD(83.5,"B",DX,0))
if 'DXIFN
QUIT
DO GETCDS("DX",DXIFN,ICDDATE,.ARRCDS)
+19 ;
+20 ; for each code set the dx is assigned to check that for this event it passes the set criteria
+21 SET SETIFN=0
FOR
SET SETIFN=$ORDER(ARRCDS(SETIFN))
if 'SETIFN
QUIT
Begin DoDot:2
+22 SET LINE=$GET(^ICDD(83.3,SETIFN,0))
+23 ;
+24 IF $PIECE(LINE,U,3)'="DX"
QUIT
+25 ; code set for primary dx
IF $PIECE(LINE,U,4)="P"
IF DXI'=PDX
QUIT
+26 ; code set for secondary dx
IF $PIECE(LINE,U,4)="S"
IF DXI=PDX
QUIT
+27 ;
+28 ; linked set
IF $PIECE(LINE,U,7)'=""
SET LINK($PIECE(LINE,U,7),SETIFN)=$GET(LINK($PIECE(LINE,U,7),SETIFN))+1
+29 ; only secondary dxs contained in the set allowed
IF $PIECE(LINE,U,5)=2
SET ONLY(DXI)=SETIFN_U_DX_U_"DX"
QUIT
+30 ;
+31 SET CDSARR(SETIFN,DXI)=DX_U_"DX"_U_1
End DoDot:2
End DoDot:1
+32 ;
+33 ; add ONLY code sets that may apply
IF $ORDER(ONLY(0))
DO ONLY(.ONLY,.ICDDX,.CDSARR)
+34 KILL ARRCDS,ONLY
+35 ;
+36 ;
+37 ; get all Procedure Code Sets
+38 SET PRI=0
FOR
SET PRI=$ORDER(ICDPR(PRI))
if 'PRI
QUIT
Begin DoDot:1
+39 ;
+40 ; get all code sets the procedure is assigned to on date
+41 SET PR=+$GET(ICDPR(PRI))
SET PRIFN=$ORDER(^ICDD(83.6,"B",PR,0))
if 'PRIFN
QUIT
DO GETCDS("PR",PRIFN,ICDDATE,.ARRCDS,.ICDPR)
+42 ;
+43 ; for each code set the procedure is assigned to check that for this event it passes the set criteria
+44 SET SETIFN=0
FOR
SET SETIFN=$ORDER(ARRCDS(SETIFN))
if 'SETIFN
QUIT
Begin DoDot:2
+45 SET LINE=$GET(^ICDD(83.3,SETIFN,0))
+46 ;
+47 IF $PIECE(LINE,U,3)'="PR"
QUIT
+48 ;
+49 ; linked set
IF $PIECE(LINE,U,7)'=""
SET LINK($PIECE(LINE,U,7),SETIFN)=$GET(LINK($PIECE(LINE,U,7),SETIFN))+1
+50 ; only procedures contained in the set allowed
IF $PIECE(LINE,U,5)=2
SET ONLY(PRI)=SETIFN_U_PR_U_"PR"
QUIT
+51 ;
+52 SET CDSARR(SETIFN,PRI)=PR_U_"PR"_U_$PIECE(ARRCDS(SETIFN),U,3,4)
End DoDot:2
End DoDot:1
+53 ;
+54 ; add ONLY code sets that may apply
IF $ORDER(ONLY(0))
DO ONLY(.ONLY,.ICDPR,.CDSARR,.PRATT)
+55 ;
+56 ;
+57 ; add any computed LNK code sets that may apply
IF $ORDER(LINK(""))'=""
DO LINK(.LINK,.CDSARR)
+58 ;
+59 ; check for generic or calculated code sets that may apply
+60 ; ANY OPERATING ROOM PROCEDURE
SET SETIFN=$$CALC1(.ICDPR,.PRATT)
IF +SETIFN
SET CDSARR(+SETIFN,991)=U_"PR"
+61 ; NO OPERATING ROOM PROCEDURE
SET SETIFN=$$CALC2(.ICDPR,.PRATT)
IF +SETIFN
SET CDSARR(+SETIFN,992)=U_"PR"
+62 ; NO SECONDARY DIAGNOSIS
SET SETIFN=$$CALC3(.ICDDX)
IF +SETIFN
SET CDSARR(+SETIFN,993)=U_"DX"
+63 QUIT
+64 ;
GETCDS(TYP,CDIFN,DATE,ARRCDS,ICDPR) ; get Code Sets for a single code on a date, either diagnosis (83.5,20) or procedure (83.6,20)
+1 ; input: TYP - type of codes 'DX' or 'PR', CDIFN - ptr to code in 83.5 or 83.6
+2 ; output: ARRCDS - array of code sets the code is a member of on the date
+3 ; ARRCDS(code set ifn (83.3)) = TYP ^ code set ifn ^ single(1)/cluster only(0) in set ^ cluster ptr 83.61
+4 ; a procedure may be assigned to a Code Set as a single procedure and/or as a member of a cluster, all members
+5 ; of a cluster (83.6,20,.04) must be defined for the cluster only procedures to select a Code Set
+6 NEW IX,CDFILE,LINE,BEGIN,END,SETIFN,CLUSTER,SINGLE
SET TYP=$GET(TYP)
SET CDIFN=+$GET(CDIFN)
KILL ARRCDS
IF '$GET(DATE)
SET DATE=DT
+7 SET CDFILE=$SELECT(TYP="DX":83.5,TYP="PR":83.6,1:0)
IF 'CDFILE
QUIT
+8 ;
+9 SET IX=0
FOR
SET IX=$ORDER(^ICDD(CDFILE,CDIFN,20,IX))
if 'IX
QUIT
Begin DoDot:1
+10 SET LINE=$GET(^ICDD(CDFILE,CDIFN,20,IX,0))
SET SETIFN=+$PIECE(LINE,U,3)
+11 SET BEGIN=$PIECE(LINE,U,1)
SET END=$PIECE(LINE,U,2)
IF 'END
SET END=9999999
+12 IF (BEGIN>DATE)!(END<DATE)
QUIT
+13 ;
+14 IF TYP="DX"
SET ARRCDS(SETIFN)=TYP_U_SETIFN_U_1
QUIT
+15 ;
+16 SET CLUSTER=$PIECE(LINE,U,4)
IF +CLUSTER
IF '$$CLSTR(CLUSTER,.ICDPR)
QUIT
+17 SET LINE=$GET(ARRCDS(SETIFN))
SET SINGLE=+$PIECE(LINE,U,3)
IF 'CLUSTER
SET SINGLE=1
SET CLUSTER=$PIECE(LINE,U,4)
+18 ;
+19 SET ARRCDS(SETIFN)=TYP_U_SETIFN_U_SINGLE_U_CLUSTER
QUIT
End DoDot:1
+20 QUIT
+21 ;
CLSTR(CLUSTER,ICDPR) ; determine if the event procedures satisfy the cluster
+1 ; returns true if all the procedures assigned to the cluster (83.61) are defined on the event
+2 ; input: CLUSTER - ptr to a cluster (83.61), ICDPR - array of event procedures
+3 NEW PR,PRI,FND,ARRPR
SET CLUSTER=+$GET(CLUSTER)
SET FND=0
+4 ;
+5 ; get list of event procedures by procedure ifn
+6 SET PRI=0
FOR
SET PRI=$ORDER(ICDPR(PRI))
if 'PRI
QUIT
SET PR=+$GET(ICDPR(PRI))
SET ARRPR(PR)=PRI
+7 ;
+8 ; determine if all procedures assigned to the cluster are assigned to the event
+9 SET PR=0
FOR
SET PR=$ORDER(^ICDD(83.61,CLUSTER,20,"B",PR))
if 'PR
QUIT
SET FND=0
if +$GET(ARRPR(PR))
SET FND=1
IF 'FND
QUIT
+10 ;
+11 QUIT FND
+12 ;
+13 ;
CALC1(ICDPR,PRATT) ; Computed generic Code Set: ANY OPERATING ROOM PROCEDURE
+1 ; returns the generic Code Set IFN if there is one or more O.R. or Surgical event procedures
+2 NEW CMPTSET1,PRI,FND
SET FND=0
+3 ;
+4 SET CMPTSET1=$ORDER(^ICDD(83.3,"ACSC",1,0))
+5 ;
+6 SET PRI=0
FOR
SET PRI=$ORDER(ICDPR(PRI))
if 'PRI
QUIT
IF $PIECE($GET(PRATT(PRI)),U,7)="O"
SET FND=1
QUIT
+7 ;
+8 IF +FND
SET FND=+CMPTSET1
+9 ;
+10 QUIT FND
+11 ;
CALC2(ICDPR,PRATT) ; Computed generic Code Set: NO OPERATING ROOM PROCEDURE
+1 ; returns the generic Code Set IFN if there are no O.R or Surgical event procedures
+2 NEW CMPTSET2,PRI,FND
SET FND=1
+3 ;
+4 SET CMPTSET2=$ORDER(^ICDD(83.3,"ACSC",2,0))
+5 ;
+6 SET PRI=0
FOR
SET PRI=$ORDER(ICDPR(PRI))
if 'PRI
QUIT
IF $PIECE($GET(PRATT(PRI)),U,7)="O"
SET FND=0
QUIT
+7 ;
+8 IF +FND
SET FND=+CMPTSET2
+9 ;
+10 QUIT FND
+11 ;
CALC3(ICDDX) ; Computed generic Code Set: NO SECONDARY DIAGNOSIS
+1 ; returns the generic Code Set IFN if there are no Secondary diagnosis on the event (only 1 dx)
+2 NEW IX,CMPTSET3,FND
SET FND=1
+3 ;
+4 SET CMPTSET3=$ORDER(^ICDD(83.3,"ACSC",3,0))
+5 ;
+6 SET IX=$ORDER(ICDDX(0))
SET IX=$ORDER(ICDDX(IX))
IF +IX
SET FND=0
+7 ;
+8 IF +FND
SET FND=+CMPTSET3
+9 ;
+10 QUIT FND
+11 ;
ONLY(ONLYARR,ICDARR,CDSARR,PRATT) ; add 'ONLY' Code Set if all codes assigned to the event are in the Set
+1 ; if all the event codes are in the set then add the Only Code Set to the list of all selected Code Sets
+2 ; for diagnosis this is only applied to the secondary codes
+3 ; for procedures this is only applied to operating room procedures, non-or procedures outside the set are allowed
+4 ; input: ONLYARR(icdxx number) = ONLY code set ifn ^ code ifn (ptr #80, #80.1) ^ code type
+5 ; ICDARR - may be either ICDDX or ICDPRC, PRATT compiled procedure attributes
+6 ; output: CDSARR modified - if meets criteria the ONLY Code Set is added to CDSARR array of selected code sets
+7 ; CDSARR(ONLY code set ifn, idcxx number) = code ien (80/80.1) ^ code type ^ 1 (single)
+8 NEW IX,LINE,CODTYP,CNT,FND
SET CNT=0
SET FND=0
+9 ;
+10 SET IX=$ORDER(ONLYARR(0))
if 'IX
QUIT
SET CODTYP=$PIECE(ONLYARR(IX),U,3)
+11 ;
+12 IF CODTYP="DX"
SET IX=$ORDER(ICDARR(0))
FOR
SET IX=$ORDER(ICDARR(IX))
if 'IX
QUIT
SET CNT=CNT+1
IF $DATA(ONLYARR(IX))
SET FND=FND+1
+13 ;
+14 IF CODTYP="PR"
SET IX=0
FOR
SET IX=$ORDER(ICDARR(IX))
if 'IX
QUIT
IF $PIECE($GET(PRATT(IX)),U,7)="O"
SET CNT=CNT+1
IF $DATA(ONLYARR(IX))
SET FND=FND+1
+15 ;
+16 IF +FND
IF FND=CNT
SET IX=0
FOR
SET IX=$ORDER(ONLYARR(IX))
if 'IX
QUIT
SET LINE=ONLYARR(IX)
SET CDSARR(+LINE,IX)=$PIECE(LINE,U,2,3)_U_1
+17 QUIT
+18 ;
LINK(LINKARR,CDSARR) ; add any Computed LNK Code Set that apply
+1 ; for any selected Code Set in a Linked group, check if the Link criteria is satisfied
+2 ; if the Link criteria is met then add the generic LNK Computed Code Set to the list of selected Code Sets
+3 ; input: LINKARR(link group, LINKED code set ifn) = count of selected Code Sets with the link group
+4 ; CDSARR(code set ifn, icdxx number) = code ifn (ptr #80, #80.1) ^ code type
+5 ; output: CDSARR modified, any LNK Computed Code Set satisfied is added to CDSARR array of all selected Sets
+6 ; CDSARR(LNK Computed code set ifn, 99x) = ^ code type w/x is the LNK set value
+7 ; difference between CDN and MLT is Condition is not exclusive, one code can satisfy more than one condition
+8 ; number of sets required is in link text after '-', count link number a group satisfies is in the set name
+9 NEW LINK,CMPTSET,CSET0,LINE,SETIFN,MDCCAT,CMPTD,NUM,COUNT,CNT,IX,ARRLNK
+10 ;
+11 ; find the generic LNK Computed Code Set for any of the Linked Code Sets defined by the event
+12 SET LINK=""
FOR
SET LINK=$ORDER(LINKARR(LINK))
if LINK=""
QUIT
Begin DoDot:1
+13 SET CMPTSET=0
FOR
SET CMPTSET=$ORDER(^ICDD(83.3,"ACSL",LINK,CMPTSET))
if 'CMPTSET
QUIT
Begin DoDot:2
+14 ; computed set
SET LINE=$GET(^ICDD(83.3,CMPTSET,0))
IF +$PIECE(LINE,U,6)
SET ARRLNK(CMPTSET)=""
End DoDot:2
End DoDot:1
+15 ;
+16 ; for each generic LNK Computed Code Set found, determine if all linked sets defined and/or criteria met
+17 ; if they are then add the generic set to the list of Code Sets defined for the event.
+18 SET CMPTSET=0
FOR
SET CMPTSET=$ORDER(ARRLNK(CMPTSET))
if 'CMPTSET
QUIT
Begin DoDot:1
+19 SET CSET0=$GET(^ICDD(83.3,CMPTSET,0))
+20 SET MDCCAT=$PIECE(CSET0,U,2)
SET CMPTD=$PIECE(CSET0,U,6)
SET LINK=$PIECE(CSET0,U,7)
SET NUM=$PIECE(LINK,"-",2)
SET CNT=0
+21 ;
+22 SET SETIFN=0
FOR
SET SETIFN=$ORDER(^ICDD(83.3,"ACSL",LINK,SETIFN))
if 'SETIFN
QUIT
IF SETIFN'=CMPTSET
Begin DoDot:2
+23 SET LINE=$GET(^ICDD(83.3,SETIFN,0))
SET COUNT=$PIECE($PIECE(LINE,U,8)," ",1)
IF $PIECE(LINE,U,2)'=MDCCAT
QUIT
+24 ;
+25 ; one or more sets in group required
IF CMPTD=6
IF $DATA(CDSARR(SETIFN))
SET CNT=CNT+1
+26 ;
+27 ; one or more sets necessary for condition
IF CMPTD=5
IF $DATA(CDSARR(SETIFN))
SET CNT=CNT+1
+28 ;
+29 IF CMPTD=4
SET CNT=CNT+($SELECT(COUNT="ONE":1,COUNT="TWO":2,COUNT="THREE":3,COUNT="FOUR":4,1:0)*$GET(LINKARR(LINK,SETIFN)))
End DoDot:2
+30 ;
+31 IF +CNT
IF CNT'<NUM
SET IX=99_CMPTD
SET CDSARR(CMPTSET,IX)=U_$PIECE(CSET0,U,3)
End DoDot:1
+32 ;
+33 QUIT
