Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ICDJC2

ICDJC2.m

Go to the documentation of this file. 
  1. ICDJC2 ;ALB/ARH - DRG GROUPER CALCULATOR 2015 - CODE SETS ;05/26/2016
  1.  ;;18.0;DRG Grouper;**89,97**;Oct 20, 2000;Build 5
  1.  ;
  1.  ; DRG Calcuation for re-designed grouper ICD-10 2015, continuation
  1.  ;
  1. 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)
  1.  ; Dx Code Sets may be specific to primary or secondary event dx, all members of procedure Clusters must be defined
  1.  ; an 'ONLY' Code Set is selected only if all the codes defined for the event are in the Code Set
  1.  ; computed generic and linked group Code Sets are selected if all criteria are met
  1.  ; 
  1.  ; Input:   ICDDX(x) and ICDPR(x)  - array of Dx/procedures input to API, ICDDATE - date of event, PRATT pr attributes
  1.  ; Output:  CDSARR - array of all Code Sets (83.3) satisfied by the event diagnosis and procedures
  1.  ;          CDSARR(code set ifn, icdxx number) = code ien (80/80.1) ^ DX/PR ^ single(1)/cluster only(0) ^ cluster ien
  1.  ;          CDSARR(code set ifn, 99_cmpt #) = ^ type of codes in set 'DX' or 'PR' - for computed codes sets
  1.  N LINE,PDX,DXI,DX,DXIFN,PRI,PR,PRIFN,SETIFN,ONLY,LINK,ARRCDS S ICDDATE=$G(ICDDATE) K CDSARR
  1.  S PDX=$O(ICDDX(0))
  1.  ;
  1.  ;
  1.  ; get all Diagnosis Code Sets
  1.  S DXI=0 F  S DXI=$O(ICDDX(DXI)) Q:'DXI  D
  1.  . ;
  1.  . ; get all code sets the dx is assigned to on date
  1.  . S DX=+$G(ICDDX(DXI)) S DXIFN=$O(^ICDD(83.5,"B",DX,0)) Q:'DXIFN  D GETCDS("DX",DXIFN,ICDDATE,.ARRCDS)
  1.  . ;
  1.  . ; for each code set the dx is assigned to check that for this event it passes the set criteria
  1.  . S SETIFN=0 F  S SETIFN=$O(ARRCDS(SETIFN)) Q:'SETIFN  D
  1.  .. S LINE=$G(^ICDD(83.3,SETIFN,0))
  1.  .. ;
  1.  .. I $P(LINE,U,3)'="DX" Q
  1.  .. I $P(LINE,U,4)="P",DXI'=PDX Q  ; code set for primary dx
  1.  .. I $P(LINE,U,4)="S",DXI=PDX Q  ; code set for secondary dx
  1.  .. ;
  1.  .. I $P(LINE,U,7)'="" S LINK($P(LINE,U,7),SETIFN)=$G(LINK($P(LINE,U,7),SETIFN))+1 ; linked set
  1.  .. I $P(LINE,U,5)=2 S ONLY(DXI)=SETIFN_U_DX_U_"DX" Q  ; only secondary dxs contained in the set allowed
  1.  .. ;
  1.  .. S CDSARR(SETIFN,DXI)=DX_U_"DX"_U_1
  1.  ;
  1.  I $O(ONLY(0)) D ONLY(.ONLY,.ICDDX,.CDSARR) ; add ONLY code sets that may apply
  1.  K ARRCDS,ONLY
  1.  ;
  1.  ;
  1.  ; get all Procedure Code Sets
  1.  S PRI=0 F  S PRI=$O(ICDPR(PRI)) Q:'PRI  D
  1.  . ;
  1.  . ; get all code sets the procedure is assigned to on date
  1.  . S PR=+$G(ICDPR(PRI)) S PRIFN=$O(^ICDD(83.6,"B",PR,0)) Q:'PRIFN  D GETCDS("PR",PRIFN,ICDDATE,.ARRCDS,.ICDPR)
  1.  . ;
  1.  . ; for each code set the procedure is assigned to check that for this event it passes the set criteria
  1.  . S SETIFN=0 F  S SETIFN=$O(ARRCDS(SETIFN)) Q:'SETIFN  D
  1.  .. S LINE=$G(^ICDD(83.3,SETIFN,0))
  1.  .. ;
  1.  .. I $P(LINE,U,3)'="PR" Q
  1.  .. ;
  1.  .. I $P(LINE,U,7)'="" S LINK($P(LINE,U,7),SETIFN)=$G(LINK($P(LINE,U,7),SETIFN))+1 ; linked set
  1.  .. I $P(LINE,U,5)=2 S ONLY(PRI)=SETIFN_U_PR_U_"PR" Q  ; only procedures contained in the set allowed
  1.  .. ;
  1.  .. S CDSARR(SETIFN,PRI)=PR_U_"PR"_U_$P(ARRCDS(SETIFN),U,3,4)
  1.  ;
  1.  I $O(ONLY(0)) D ONLY(.ONLY,.ICDPR,.CDSARR,.PRATT) ; add ONLY code sets that may apply
  1.  ;
  1.  ;
  1.  I $O(LINK(""))'="" D LINK(.LINK,.CDSARR) ; add any computed LNK code sets that may apply
  1.  ;
  1.  ; check for generic or calculated code sets that may apply
  1.  S SETIFN=$$CALC1(.ICDPR,.PRATT) I +SETIFN S CDSARR(+SETIFN,991)=U_"PR"  ; ANY OPERATING ROOM PROCEDURE
  1.  S SETIFN=$$CALC2(.ICDPR,.PRATT) I +SETIFN S CDSARR(+SETIFN,992)=U_"PR"  ; NO OPERATING ROOM PROCEDURE
  1.  S SETIFN=$$CALC3(.ICDDX) I +SETIFN S CDSARR(+SETIFN,993)=U_"DX"  ; NO SECONDARY DIAGNOSIS
  1.  Q
  1.  ;
  1. 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
  1.  ; output: ARRCDS - array of code sets the code is a member of on the date
  1.  ;         ARRCDS(code set ifn (83.3)) = TYP ^ code set ifn ^ single(1)/cluster only(0) in set ^ cluster ptr 83.61
  1.  ; a procedure may be assigned to a Code Set as a single procedure and/or as a member of a cluster, all members 
  1.  ; of a cluster (83.6,20,.04) must be defined for the cluster only procedures to select a Code Set
  1.  N IX,CDFILE,LINE,BEGIN,END,SETIFN,CLUSTER,SINGLE S TYP=$G(TYP),CDIFN=+$G(CDIFN) K ARRCDS I '$G(DATE) S DATE=DT
  1.  S CDFILE=$S(TYP="DX":83.5,TYP="PR":83.6,1:0) I 'CDFILE Q
  1.  ;
  1.  S IX=0 F  S IX=$O(^ICDD(CDFILE,CDIFN,20,IX)) Q:'IX  D
  1.  . S LINE=$G(^ICDD(CDFILE,CDIFN,20,IX,0)),SETIFN=+$P(LINE,U,3)
  1.  . S BEGIN=$P(LINE,U,1),END=$P(LINE,U,2) I 'END S END=9999999
  1.  . I (BEGIN>DATE)!(END<DATE) Q
  1.  . ;
  1.  . I TYP="DX" S ARRCDS(SETIFN)=TYP_U_SETIFN_U_1 Q
  1.  . ;
  1.  . S CLUSTER=$P(LINE,U,4) I +CLUSTER,'$$CLSTR(CLUSTER,.ICDPR) Q
  1.  . S LINE=$G(ARRCDS(SETIFN)) S SINGLE=+$P(LINE,U,3) I 'CLUSTER S SINGLE=1 S CLUSTER=$P(LINE,U,4)
  1.  . ;
  1.  . S ARRCDS(SETIFN)=TYP_U_SETIFN_U_SINGLE_U_CLUSTER Q
  1.  Q
  1.  ;
  1. 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
  1.  ; input:  CLUSTER - ptr to a cluster (83.61),  ICDPR - array of event procedures
  1.  N PR,PRI,FND,ARRPR S CLUSTER=+$G(CLUSTER) S FND=0
  1.  ; 
  1.  ; get list of event procedures by procedure ifn
  1.  S PRI=0 F  S PRI=$O(ICDPR(PRI)) Q:'PRI  S PR=+$G(ICDPR(PRI)) S ARRPR(PR)=PRI
  1.  ;
  1.  ; determine if all procedures assigned to the cluster are assigned to the event
  1.  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
  1.  ;
  1.  Q FND
  1.  ;
  1.  ;
  1. 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
  1.  N CMPTSET1,PRI,FND S FND=0
  1.  ;
  1.  S CMPTSET1=$O(^ICDD(83.3,"ACSC",1,0))
  1.  ;
  1.  S PRI=0 F  S PRI=$O(ICDPR(PRI)) Q:'PRI  I $P($G(PRATT(PRI)),U,7)="O" S FND=1 Q
  1.  ;
  1.  I +FND S FND=+CMPTSET1
  1.  ;
  1.  Q FND
  1.  ;
  1. 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
  1.  N CMPTSET2,PRI,FND S FND=1
  1.  ;
  1.  S CMPTSET2=$O(^ICDD(83.3,"ACSC",2,0))
  1.  ;
  1.  S PRI=0 F  S PRI=$O(ICDPR(PRI)) Q:'PRI  I $P($G(PRATT(PRI)),U,7)="O" S FND=0 Q
  1.  ;
  1.  I +FND S FND=+CMPTSET2
  1.  ;
  1.  Q FND
  1.  ;
  1. 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)
  1.  N IX,CMPTSET3,FND S FND=1
  1.  ;
  1.  S CMPTSET3=$O(^ICDD(83.3,"ACSC",3,0))
  1.  ;
  1.  S IX=$O(ICDDX(0)) S IX=$O(ICDDX(IX)) I +IX S FND=0
  1.  ;
  1.  I +FND S FND=+CMPTSET3
  1.  ;
  1.  Q FND
  1.  ;
  1. 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
  1.  ; for diagnosis this is only applied to the secondary codes
  1.  ; for procedures this is only applied to operating room procedures, non-or procedures outside the set are allowed
  1.  ; input:  ONLYARR(icdxx number) = ONLY code set ifn ^ code ifn (ptr #80, #80.1) ^ code type
  1.  ;         ICDARR - may be either ICDDX or ICDPRC, PRATT compiled procedure attributes
  1.  ; output: CDSARR modified - if meets criteria the ONLY Code Set is added to CDSARR array of selected code sets
  1.  ;         CDSARR(ONLY code set ifn, idcxx number) = code ien (80/80.1) ^ code type ^ 1 (single)
  1.  N IX,LINE,CODTYP,CNT,FND S CNT=0,FND=0
  1.  ;
  1.  S IX=$O(ONLYARR(0)) Q:'IX  S CODTYP=$P(ONLYARR(IX),U,3)
  1.  ;
  1.  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
  1.  ;
  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
  1.  ;
  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
  1.  Q
  1.  ;
  1.  ; for any selected Code Set in a Linked group, check if the Link criteria is satisfied 
  1.  ; if the Link criteria is met then add the generic LNK Computed Code Set to the list of selected Code Sets
  1.  ; input:  LINKARR(link group, LINKED code set ifn) = count of selected Code Sets with the link group
  1.  ;         CDSARR(code set ifn, icdxx number) = code ifn (ptr #80, #80.1) ^ code type
  1.  ; output: CDSARR modified, any LNK Computed Code Set satisfied is added to CDSARR array of all selected Sets
  1.  ;         CDSARR(LNK Computed code set ifn, 99x) =  ^ code type   w/x is the LNK set value
  1.  ; difference between CDN and MLT is Condition is not exclusive, one code can satisfy more than one condition
  1.  ; number of sets required is in link text after '-', count link number a group satisfies is in the set name
  1.  N LINK,CMPTSET,CSET0,LINE,SETIFN,MDCCAT,CMPTD,NUM,COUNT,CNT,IX,ARRLNK
  1.  ;
  1.  ; find the generic LNK Computed Code Set for any of the Linked Code Sets defined by the event
  1.  S LINK="" F  S LINK=$O(LINKARR(LINK)) Q:LINK=""  D
  1.  . S CMPTSET=0 F  S CMPTSET=$O(^ICDD(83.3,"ACSL",LINK,CMPTSET)) Q:'CMPTSET  D
  1.  .. S LINE=$G(^ICDD(83.3,CMPTSET,0)) I +$P(LINE,U,6) S ARRLNK(CMPTSET)=""  ; computed set
  1.  ;
  1.  ; for each generic LNK Computed Code Set found, determine if all linked sets defined and/or criteria met
  1.  ; if they are then add the generic set to the list of Code Sets defined for the event.
  1.  S CMPTSET=0 F  S CMPTSET=$O(ARRLNK(CMPTSET)) Q:'CMPTSET  D
  1.  . S CSET0=$G(^ICDD(83.3,CMPTSET,0))
  1.  . S MDCCAT=$P(CSET0,U,2),CMPTD=$P(CSET0,U,6),LINK=$P(CSET0,U,7),NUM=$P(LINK,"-",2),CNT=0
  1.  . ;
  1.  . S SETIFN=0 F  S SETIFN=$O(^ICDD(83.3,"ACSL",LINK,SETIFN)) Q:'SETIFN  I SETIFN'=CMPTSET D
  1.  .. S LINE=$G(^ICDD(83.3,SETIFN,0)) S COUNT=$P($P(LINE,U,8)," ",1) I $P(LINE,U,2)'=MDCCAT Q
  1.  .. ;
  1.  .. I CMPTD=6 I $D(CDSARR(SETIFN)) S CNT=CNT+1 ; one or more sets in group required
  1.  .. ;
  1.  .. I CMPTD=5 I $D(CDSARR(SETIFN)) S CNT=CNT+1 ; one or more sets necessary for condition
  1.  .. ;
  1.  .. 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)))
  1.  . ;
  1.  . I +CNT,CNT'<NUM S IX=99_CMPTD S CDSARR(CMPTSET,IX)=U_$P(CSET0,U,3)
  1.  ;
  1.  Q