R/DRGGrouper.R

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

#' DRGGrouper
#' 
#' DRG grouping 
#' 
#' @export


DRGGrouper<-function(data,drgRulesDf=DRGRulesDfZJ){
  as.data.frame(data)->data
  subset(data,is.na(ADRGCode))->datNoGroup
  subset(data,!is.na(ADRGCode))->datGroup
  
  if(is.character(drgRulesDf)){
    eval(as.name(drgRulesDf))->rulesDf
  } else {
    drgRulesDf->rulesDf
  }
  
  lapply(unique(datGroup$ADRGCode),function(i){
    datGroup[which(datGroup$ADRGCode==i),]->dati
    rulesDf[which(rulesDf$ADRGCode==i),]->rulesDfi
    
    if(rulesDfi$Fac1=='NULL'){
      dati$DRGCode1<-paste(dati$ADRGCode,'Z',sep='')
      
    } else {
      
      unlist(stri_split_fixed(rulesDfi$Fac1,'|'))->facs1
      
      sapply(facs1,function(i){
        validateVec(dati[,rulesDfi$type1],i)
      })->resMat
      
      if(is.vector(resMat)){
        which(resMat)->indi
      } else {
        apply(resMat,1,function(i)which(i))->indi
      }
      
      
      
      if(rulesDfi$type1=='age'){
        paste(dati$ADRGCode,LETTERS[indi],sep='')->dati$DRGCode1
      } else {
        paste(dati$ADRGCode,c('P','Q','R','S','T')[indi],sep='')->dati$DRGCode1
        
      }
      
    }
    
    if(rulesDfi$Fac2=='NULL'){
      dati$DRGCode<-paste(dati$DRGCode1,'Z',sep='')
      
    } else {
      
      
      unlist(stri_split_fixed(rulesDfi$Fac2,'|'))->facs2
      
      sapply(facs2,function(i){
        validateVec(dati[,'CCStatus'],i)
      })->resMat
      
      if(is.vector(resMat)){
        which(resMat)->indi
      } else {
        apply(resMat,1,function(i)which(i))->indi
      }
      
      
      
      
      
      CCNames<-c('A','B','C','D','E')
      
      names(CCNames)<-c('[2]','[1,2]','[1]','[0,1]','[0]')
      
      dati$DRGCode<-paste(dati$DRGCode1,CCNames[facs2[indi]],sep='')
      
      
      
    }
    
    return(dati)
    
    
    
  })->lstRes
  
  do.call(rbind,lstRes)->dtGroupFinal
  if(nrow(datNoGroup)>0){
    datNoGroup[,'DRGCode1']<-NA
    datNoGroup[,'DRGCode']<-NA
    rbind(dtGroupFinal,datNoGroup)->ResFinal
  } else {
    ResFinal<-dtGroupFinal
  }
  
  
  return(ResFinal)
  
  
  
}