R/ADRGGrouper5.R

In sontron/ZJDRG: ZJDRG deal the data grouping using ZJ-DRG rules

#' ADRGGrouper5
#' 
#' @export

ADRGGrouper5<-function(data,lstmat=lstMat){
  require('data.table')
  require('stringi')
  as.data.frame(data)->data
  lstmat$PDXMat->pdxMat
  lstmat$ADXMat->adxMat
  lstmat$PROCMat->procMat
  lstmat$bornWtMat->bornWtMat
  lstmat$sexMat->sexMat
  lstmat$ageMat->ageMat
  lstmat$ADRGRanks->ADRGRanks
  ADRGRanks[order(ADRGRanks$Rank,decreasing = F),'ADRGCode']->adrgOrders
  ifelse(data$sex==1,'male',ifelse(data$sex==2,'female','OutOfRange'))->data$sexGroup
  ifelse(data$age<=28/365,'0-28d',ifelse(data$age<=1,'28d-1y','1y-Inf'))->data$ageGroup
  
  data$bornWtGroup<-ifelse(data$bornWt<1500,'0-1500',ifelse(data$bornWt<2500,'1500-2500','2500-Inf'))
  ifelse(is.na(data$bornWtGroup),'OutOfRange',data$bornWtGroup)->data$bornWtGroup
  ifelse(is.na(data$ageGroup),'OutOfRange',data$ageGroup)->data$ageGroup
  ifelse(is.na(data$sexGroup),'OutOfRange',data$sexGroup)->data$sexGroup
  
  data->dt
  
  #### 判断诊断和操作编码是否在两个Matrix里，如果否则处理为OutOfRange
  ifelse(dt$PDX%in%rownames(pdxMat),dt$PDX,'OutOfRange')->dt$PDX
  dt$PDX[is.na(dt$PDX)]<-'OutOfRange'
  for(i in 1:15){
    ifelse(dt[,paste0('ADX',i)]%in%rownames(pdxMat),dt[,paste0('ADX',i)],'OutOfRange')->dt[,paste0('ADX',i)]
    ifelse(is.na(dt[,paste0('ADX',i)]),'OutOfRange',dt[,paste0('ADX',i)])->dt[,paste0('ADX',i)]
  }
  
  for(i in 1:8){
    ifelse(dt[,paste0('PROC',i)]%in%rownames(procMat),dt[,paste0('PROC',i)],'OutOfRange')->dt[,paste0('PROC',i)]
    ifelse(is.na(dt[,paste0('PROC',i)]),'OutOfRange',dt[,paste0('PROC',i)])->dt[,paste0('PROC',i)]
  }
  
  
  #### 主诊断编码的矩阵判断，其他诊断的矩阵判断(主要是MDCZ),以及将主诊断的MDCZ的子矩阵进行修改.
  pdxMat[dt$PDX,,drop=F]->matPDX
  
  adxMat[dt$ADX1,,drop=F]->matADX1
  
  for(i in 2:15){
    adxMat[dt[,paste0('ADX',i)],,drop=F]|matADX1->matADX1
  }
  
  matPDX[,colnames(matADX1)]<-matPDX[,colnames(matADX1)]|matADX1
  
  
  #### MDCZ的修改
  colnames(matPDX)[which(nchar(colnames(matPDX))>3)]->mdcZ
  
  matZ<-matrix(NA,ncol=4,nrow=nrow(matPDX))
  colnames(matZ)<-unique(substr(mdcZ,1,3))
  for(i in unique(substr(mdcZ,1,3))){
    matPDX[,which(stri_startswith_fixed(colnames(matPDX),i)),drop=F]->matZi
    apply(matZi,1,sum,na.rm=T)->resi
    ifelse(resi>1,T,F)->resI
    matZ[resI,i]<-T
    
  }
  
  cbind(matPDX[,-which(colnames(matPDX)%in%mdcZ),drop=F],matZ)->dxADRG1
  
  matA<-matrix(T,ncol=9,nrow=nrow(dxADRG1))
  colnames(matA)<-c('AA1','AB1','AC1','AD1','AE1','AF1','AG1','AG2','AH1')
  cbind(matA,dxADRG1)->dxADRG
  
  
  #### 操作编码的矩阵判断
  procMat[dt$PROC1,,drop=F]->matPROC1
  
  for(i in 2:8){
    procMat[dt[,paste0('PROC',i)],,drop=F]|matPROC1->matPROC1
  }
  
  colnames(matPROC1)[which(nchar(colnames(matPROC1))>3)]->mdc2
  
  mat2<-matrix(NA,ncol=8,nrow=nrow(matPDX))
  colnames(mat2)<-unique(substr(mdc2,1,3))
  for(i in unique(substr(mdc2,1,3))){
    matPROC1[,which(stri_startswith_fixed(colnames(matPROC1),i)),drop=F]->mat2i
    apply(mat2i[,drop=F],1,sum,na.rm=T)->resi
    ifelse(resi>1,T,F)->resI
    mat2[resI,i]<-T
    
  }
  
  
  cbind(matPROC1[,-which(colnames(matPROC1)%in%mdc2),drop=F],mat2)->procADRG1
  
  
  dxADRG[,colnames(procADRG1)]<-dxADRG[,colnames(procADRG1)]&procADRG1[,colnames(procADRG1)]
  
  dxADRG->PDXPROCADRG
  
  
  
  ageMat[dt$ageGroup,adrgOrders,drop=F]&
    bornWtMat[dt$bornWtGroup,adrgOrders,drop=F]&
    sexMat[dt$sexGroup,adrgOrders,drop=F]&
    PDXPROCADRG[,adrgOrders,drop=F]->adrgMatRes
  
  
  
  apply(adrgMatRes[,,drop=F],1,function(i){
    which(i)[1]->indi
    ifelse(length(indi)>0,adrgOrders[indi],NA)
  })->adrgcodes
  
  
  
dt$ADRGCode<-adrgcodes
dt$MDCCode<-paste0('MDC',substr(dt$ADRGCode,1,1))
ifelse(is.na(dt$ADRGCode),NA,dt$MDCCode)->dt$MDCCode

return(as.data.table(dt))

  
}