library(dplyr) library(magrittr) library(knitr) library(ggplot2)
# Import des données préparées dans les précédentes étapes db <- readRDS("../produced_data/30-calcul_evol.rds")
Pour une ligne identifier s'il s'agit de :
Les réapparition sont à traiter en premier, pour les éliminer par la suite. Pour affirmer qu'une observation est une réapparition, il faut que :
# Détecter les réapparition db %<>% # Grouper par RSS group_by(ida) %>% # Trier par mois d'envoi arrange(mois_envoi) %>% # Créer de nouvelles variables intermédiaires mutate( # Numéro du mois d'envoi précédent mois_envoi_precedent = c(0, mois_envoi[seq_len(n()-1)]), mois_sortie_precedent = c(0, mois_sortie[seq_len(n()-1)]), # Logique pour déterminer si l'envoi précédent est virtuel envoi_precedent_virtuel = c(FALSE, obs_virtuelle[seq_len(n()-1)]), # Logique pour déterminer si l'envoi précédent est manquant envoi_precedent_manquant = mois_envoi - mois_envoi_precedent != 1 | envoi_precedent_virtuel, # Logique pour déterminer si l'envoi actuel est une réapparition est_reapparition = envoi_precedent_manquant & envoi_rang != 1 & mois_sortie == mois_sortie_precedent ) %>% ungroup %>% # Retirer les variables intermédiaires non utiles pour la suite select(-mois_envoi_precedent, -envoi_precedent_manquant, -envoi_precedent_virtuel)
Analyser ces réapparitions.
n_reapparition <- sum(db$est_reapparition)
Il n'y a que r n_reapparition
cas de réapparitions.
Exemple sur 3 cas
# Fixer une racine pour être reproductible set.seed(1664) db %>% filter( # Sélectionner trois séjours avec réapparition au hasard ida %in% sample(db$ida[db$est_reapparition], 3), # Retirer les observations virtuelles pour avoir une image correpondant au # données sources !obs_virtuelle ) %>% arrange(ida, mois_envoi, mois_sortie) %>% select(ida, mois_sortie, mois_envoi, mnt_tot_am, est_reapparition) %>% knitr::kable()
La première valorisation à temps est une observation dont :
db %<>% mutate( est_premiere_valo_a_temps = mois_sortie == mois_envoi & premiere_valo ) # Faire un tableau résumant ces premières valorisation à temps stat_premiere_valo_a_temps <- db %>% group_by(mois_envoi) %>% summarise(nombre = sum(est_premiere_valo_a_temps), # Proportion de première valo à temps parmi toutes les premières valo proportion = nombre/sum(premiere_valo)) stat_premiere_valo_a_temps %>% mutate(proportion = sprintf("%3.0f %%", proportion * 100)) %>% kable(caption = "Nombre et proportion de premières valorisation à temps en fonction du mois d'envoi") with(stat_premiere_valo_a_temps, plot(x = as.factor(mois_envoi), y = proportion))
# Détecter les cas de correction d'exhaustivité db %<>% mutate( est_exhaustivite = (mois_sortie < mois_envoi) & premiere_valo ) # Vérifier db %>% group_by(mois_envoi) %>% summarise(nombre = sum(est_exhaustivite), # Proportion de première valo à temps parmi toutes les premières valo proportion = nombre/sum(premiere_valo)) %>% mutate(proportion = sprintf("%3.0f %%", proportion * 100)) %>% kable(caption = "Nombre et proportion de séjours valorisé au titre de l'exhaustivité")
Dans la qualité on intègre les pertes de droits. Les pertes de droits sont des RSS pour lesquels le taux était > 0 au mois d'envoi précédent et passe à 0 au mois d'envoi donné.
db %<>% mutate( # Détecter les pertes de droits. Nécessaire pour qualifier un envoi de qualité est_perte_droit = (taux == 0 | is.na(taux)) & (taux_prev > 0 & !is.na(taux_prev)) & ! obs_virtuelle, # Détecter les actions de qualité. # Il faut qu'il y ai une evolution du montant, que ce ne soit pas une observation virtuelle # pas une première valorisation, n'est pas une réapparition ou est une perte de de droit est_qualite = evol_mnt_tot & !obs_virtuelle & !premiere_valo & !est_reapparition | est_perte_droit ) db %>% select(starts_with('est')) %>% summary length(unique(db$ida[db$valo != 0 | is.na(db$valo)]))
Vérifier qu'une observation n'est pas comptée dans plusieurs de ces cas
# Compter le nombre de classes possible par observation db$nb_classes <- rowSums(select(db, est_premiere_valo_a_temps, est_exhaustivite, est_qualite, obs_virtuelle, est_reapparition)) # Voir le nombre de cas où le nb de classes est supérieur à 1 (anomalie) sum(db$nb_classes > 1)
# Calcul de la valeur d'exhaustivité r_exhau <- db %>% filter(est_exhaustivite) %>% group_by(mois_envoi, mois_sortie) %>% summarise(n = n(), montant = sum(evol_mnt_tot)) %>% mutate(type = 'exhaustivite') %>% ungroup DT::datatable(r_exhau) xtabs(montant ~ mois_envoi + mois_sortie, data = r_exhau)
summ <- function(x) sum(x, na.rm = TRUE) r_recodage <- db %>% filter(est_qualite) %>% mutate(evol_perte_droit = ifelse(est_perte_droit, evol_mnt_tot, 0)) %>% group_by(mois_envoi, mois_sortie) %>% summarise(n = n(), # Nombre de recodage montant = sum(evol_mnt_tot), # Montant total du recodage taux = summ(ec_taux), # Montant lié à la variation du taux (calculé à part) fj = summ(evol_mnt_fj), perte_droit = summ(evol_perte_droit), facturation = taux + fj + perte_droit, # Aggrégat pmsi = summ(ec_ghs), # Montant PMSI (calculé à part) mo = summ(evol_mnt_mo), dmi = summ(evol_mnt_dmi), po = summ(evol_mnt_po), med_atu = summ(evol_mnt_med_atu), scd = summ(evol_mnt_scd), autre = summ(summ(ec_autre)) - fj - mo - dmi - po - med_atu - scd - perte_droit, diff = round(montant - facturation- pmsi - mo - dmi - po - med_atu - scd - autre - perte_droit)) %>% mutate(type = 'recodage') %>% ungroup sum(r_recodage$diff) saveRDS(r_recodage, '../produced_data/40-recodage.rds') write.csv2(r_recodage, 'recodage.csv') DT::datatable(r_recodage)
Attention : La somme des différents éléments de qualité ne correpond pas à l'ensemble de la qualité. Je ne suis pas encore parvenu à trouver une explication fiable. Il est probable qu'il s'agisse d'un montant, par exemple celui des supplément défibrillateur cardiaque, qui soit mal calculé quelque part dans l'analyse.
La seule valeur fiable est le montant total d'exhaustivité et qualité. Le ventialtion entre psmi et taux ou autre est juste à titre indicatif (et certainement à retirer des tableaux présentés à la DAF). Il y a trop de cas particulier pour que ceci soit fiable.
r_disparition <- db %>% filter(obs_virtuelle) %>% group_by(mois_envoi, mois_sortie) %>% summarise(n = n(), montant = sum(evol_mnt_tot)) %>% mutate(type = 'disparition') %>% ungroup head(r_disparition)
Vérifier les sommes
sum(db$evol_mnt_tot)
r_reapparition <- db %>% filter(est_reapparition) %>% group_by(mois_envoi, mois_sortie) %>% summarise(n = n(), montant = sum(evol_mnt_tot)) %>% mutate(type = 'reapparition') %>% ungroup
r_atemps <- db %>% filter(mois_envoi == mois_sortie & !est_reapparition & premiere_valo) %>% group_by(mois_envoi, mois_sortie) %>% summarise(n = n(), montant = sum(evol_mnt_tot)) %>% mutate(type = 'a_temps') %>% ungroup
Ce qui n'est pas expliqué par les précédentes catégories
r_autre <- db %>% filter(!obs_virtuelle & !est_premiere_valo_a_temps & !est_exhaustivite & !est_qualite & !est_perte_droit & evol_mnt_tot != 0 & !est_reapparition) %>% group_by(mois_envoi, mois_sortie) %>% summarise(n = n(), montant = sum(evol_mnt_tot), pmsi = sum(ec_ghs, na.rm = TRUE), taux = sum(ec_taux, na.rm = TRUE), autre = sum(sum(ec_autre, na.rm = TRUE))) nrow(r_autre)
Aucun autre cas. Donc nos analyses prennent bien compte tous les cas.
Nombre d'observations sans aucune modification au final (donc inutiles).
nb_obs_sans_evol <- sum(db$evol_mnt_tot == 0) prop_obs_sans_evol <- round(nb_obs_sans_evol/nrow(db)*100)
Parmis les r nrow(db)
, la majorité (n = r nb_obs_sans_evol
, r prop_obs_sans_evol
%) est inutile. On peut rendre la base plus simple à manipuler en supprimant ces observations une fois l'ensemble des calculs effectués.
En faire une table cumulée
r_recodage2 <- r_recodage %>% select(mois_envoi, mois_sortie, n, montant, type) rez <- rbind(r_total, r_exhau, r_disparition, r_recodage2, r_reapparition)
Présenter
library(tidyr) rez_montant <- select(rez, -n) rez_montant_large <- spread(rez_montant, key = type, value = montant) rez_montant_large %<>% select(mois_envoi, mois_sortie, total, exhaustivite, recodage, disparition, reapparition) %>% rename(qualite = recodage) prefix <- function(x, pre = 'qualite_') paste0(pre, x) qualite <- r_recodage %>% select(-n, -diff, -type) %>% rename_at(c('pmsi', 'taux', 'mo', 'dmi', 'autre'), prefix) space <- function(x) gsub('_', ' ', x = x) rez_montant_large %<>% left_join(qualite) %>% rename_all(space) head(rez_montant_large) write.csv2(rez_montant_large, '../ventile_emm.csv', row.names = FALSE, na = '0') save(rez_montant_large, file = '../produced_data/40-ventile_emm.RData') # Même chose en nombre rez_nb <- select(rez, -montant) rez_nb_large <- spread(rez_nb, key = type, value = n) rez_nb_large %<>% select(mois_envoi, mois_sortie, total, exhaustivite, recodage, disparition, reapparition) write.csv2(rez_nb_large, '../ventile_emm_nb.csv', row.names = FALSE)
Par rapport aux tableaux EMM il peut y avoir un décalage sur les totaux mais la somme est juste. Peut être provoqué par des changement de mois de sortie.
saveRDS(rez, file = '../produced_data/40-ventile_evolution.rds')
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.