In jomuller/vvs: Analyse des fichiers VisualValoSej

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")

Distinction des cas

Pour une ligne identifier s'il s'agit de :

1. Première valorisation à temps : diagonale dans le tableau EMM où le mois d'envoi correspond au mois de sortie ;
2. Exhaustivité : la première valorisation (= première fois que le montant total am est > 0) est différent du mois de sortie ;
3. Qualité : Une modification qui a eu lieu après une première valorisation à temps ou après l'exhaustivité ;
4. Disparition : le séjours était valorisé jusqu'à ${mois\ envoi}-1$ mais la ligne disparaît au mois d'envoi concerné ;
5. Réapparition : il n'y a pas eu d'envoi pendant un ou plusieurs mois successifs et réapparaît au mois d'envoi concerné ;

Réapparition

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 :

• $${numéro\ mois\ envoi\ précédent} < {numéro\ mois\ envoi\ actuel - 1}$$ ;
• et que l'envoi ne soit pas un premier envoi ;
• et que le mois de sortie précédent soit le même que le mois de sortie de l'observation (cas où le mois de sortie d'un séjour change).

# 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()

Première valorisation à temps

La première valorisation à temps est une observation dont :

• montant total AM est > 0
• mois de sortie = mois d'envoi

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))

Exhaustivité

# 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é")

Qualité

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)

Valeur exhaustivité

# 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)

Valeur recodage

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.

Valeur disparitions

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éapparition

r_reapparition <- db %>%
  filter(est_reapparition) %>%
  group_by(mois_envoi, mois_sortie) %>%
  summarise(n = n(), montant = sum(evol_mnt_tot)) %>%
  mutate(type = 'reapparition') %>%
  ungroup

A temps

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

Autre

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.

Table cumul

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.

Sauvegarder

saveRDS(rez, file = '../produced_data/40-ventile_evolution.rds')

Attention

• Il existe des cas où il y a modification des mois de sortie. Ceci est problématique car on risque de compter deux fois des sorties à temps.

jomuller/vvs documentation built on May 21, 2019, 2:05 p.m.