R/main_before_utf.R
In IM-APHP/pmeasyr: Donnees PMSI avec R
Defines functions
creer_json
collect_rsa_from_db
prepare_rsa
lancer_requete
lancer_requete_db
enrobeur
db_generique
tbl_psy
tbl_had
tbl_ssr
tbl_rsf
tbl_mco
db_liste_tables
`%+%`
labeleasier
noyau_skeleton
print.pm_param
noyau_pmeasyr
iano_rafael.default
iano_rafael.list
iano_rafael.pm_param
iano_rafael
irafael.default
irafael.list
irafael.pm_param
irafael
dico
iano_psy.default
iano_psy.list
iano_psy.pm_param
iano_psy
ir3a.default
ir3a.list
ir3a.pm_param
ir3a
irpsa.default
irpsa.list
irpsa.pm_param
irpsa
iium_ssr.default
iium_ssr.list
iium_ssr.pm_param
iium_ssr
imed_ssr.default
imed_ssr.list
imed_ssr.pm_param
imed_ssr
ileg_ssr.default
ileg_ssr.list
ileg_ssr.pm_param
ileg_ssr
issrha.default
issrha.list
issrha.pm_param
issrha
iano_ssr.default
iano_ssr.list
iano_ssr.pm_param
iano_ssr
irha.default
irha.list
irha.pm_param
irha
ileg_had.default
ileg_had.list
ileg_had.pm_param
ileg_had
imed_had.default
imed_had.list
imed_had.pm_param
imed_had
iano_had.default
iano_had.list
iano_had.pm_param
iano_had
irapss.default
irapss.list
irapss.pm_param
irapss
ipo.default
ipo.list
ipo.pm_param
ipo
iium_corresp.default
iium_corresp.list
iium_corresp.pm_param
iium_corresp
iium.default
iium.list
iium.pm_param
iium
idiap.default
idiap.list
idiap.pm_param
idiap
inner_tra
ileg_mco.default
ileg_mco.list
ileg_mco.pm_param
ileg_mco
itpt_mco.default
itpt_mco.list
itpt_mco.pm_param
itpt_mco
iivg_mco.default
iivg_mco.list
iivg_mco.pm_param
iivg_mco
idmi_mco.default
idmi_mco.list
idmi_mco.pm_param
idmi_mco
imed_mco.default
imed_mco.list
imed_mco.pm_param
imed_mco
iano_mco.default
iano_mco.list
iano_mco.pm_param
iano_mco
itra.default
itra.list
itra.pm_param
itra
irsa.default
irsa.list
irsa.pm_param
irsa
irum.default
irum.list
irum.pm_param
irum
Documented in
collect_rsa_from_db
creer_json
db_generique
db_liste_tables
dico
enrobeur
iano_had
iano_mco
iano_psy
iano_rafael
iano_ssr
idiap
idmi_mco
iium
iium_corresp
iium_ssr
iivg_mco
ileg_had
ileg_mco
ileg_ssr
imed_had
imed_mco
imed_ssr
inner_tra
ipo
ir3a
irafael
irapss
irha
irpsa
irsa
irum
issrha
itpt_mco
itra
labeleasier
lancer_requete
lancer_requete_db
noyau_pmeasyr
noyau_skeleton
prepare_rsa
print.pm_param
tbl_had
tbl_mco
tbl_psy
tbl_rsf
tbl_ssr
##############################################
####################### MCO ##################
##############################################
#' ~ MCO - Import des RUM
#'
#' Import des RUM. 4 types d'imports possibles.
#'
#' Formats depuis 2011 pris en charge
#'
#' Structure du nom du fichier attendu (entrée pour Genrsa) :
#' \emph{finess.annee.moisc.rum}
#'
#' \strong{750712184.2016.2.rum}
#'
#' Types d'imports :
#' \tabular{ll}{
#' 1 XLight : \tab partie fixe\cr
#' 2 Light : \tab partie fixe + streaming des actes, dad et das\cr
#' 3 Standard : \tab partie fixe + table acdi\cr
#' 4 Standard+ : \tab Import standard (3) + stream\cr
#' }
#'
#' \strong{Principe du streaming :}
#' Mise en chaîne de caractères de la succession d'actes CCAM au cours du RUM, par exemple, pour un RUM :
#' \samp{"ACQK001, LFQK002, MCQK001, NAQK015, PAQK002, PAQK900, YYYY600, ZZQP004"}
#'
#' La recherche d'un (ou d'une liste d') acte(s) sur un RUM est largement accélérée, comparée à une requête sur la large table acdi par une requête du type :
#'
#' \code{grepl("ZZQP004",rum$actes)} # toutes les lignes de RUM avec au moins un ZZQP004
#' \code{grepl("ZZQP004|EBLA003",rum$actes)} # toutes les lignes de RUM avec au moins un ZZQP004 ou un EBLA003
#'
#' @param finess Finess du In a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param typi Type d'import, par defaut a 3, a 0 : propose a l'utilisateur de choisir au lancement
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une classe S3 contenant les tables (data.frame, tibble) importées (rum, actes, das et dad si import 3 et 4)
#'
#' @examples
#' \dontrun{
#' irum('750712184',2015,12,'~/Documents/data/mco', typi = 1) -> rum15
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irsa}}, \code{\link{ileg_mco}}, \code{\link{iano_mco}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @importFrom utils View data unzip modifyList
#' @importFrom magrittr '%>%'
#' @export irum
#' @usage irum(finess, annee, mois, path, lib = T, typi = 3, tolower_names = F, ...)
#' @export
irum <- function(finess, annee, mois, path, lib = T, typi = 3, tolower_names = F, ...){
UseMethod("irum")
}
#' @export
irum.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(irum.default, param2)
}
#' @export
irum.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(irum.default, param2)
}
#' @export
irum.default <- function(finess, annee, mois, path, lib = T, typi = 3, tolower_names = F, ...){
if (annee < 2011 | annee > 2024){
stop("Année PMSI non prise en charge\n")
}
if (mois < 1 | mois > 12){
stop("Mois incorrect\n")
}
if (!(typi %in% 0:4)){
stop("Type d'import incorrect : 0 ou 1, 2, 3 et 4\n")
}
# op <- options(digits.secs = 6)
un<-Sys.time()
# Import de la table
# cat(paste("Import des RUM",annee,paste0("M",mois),"\n"))
# cat(paste("L'objet retourné prendra la forme d'une classe S3.
# $rum pour accéder à la table RUM
# $das pour accéder à la table DAS
# $dad pour accéder à la table DAD
# $actes pour accéder à la table ACTES\n\n"))
extz <- function(x,pat){unlist(lapply(stringr::str_extract_all(x,pat),toString) )}
format <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rum", an == substr(annee,3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
pmeasyr::formats %>% dplyr::filter(table == "rum", substr(an,1,4) == as.character(annee)) -> rg
# regexpr et curseurs par version
if (length(unique(rg$an)) == 1) {
situation_al = 1
zac <- rg$rg[rg$z == "zac"]
zd <- rg$rg[rg$z == "zd"]
zal <- rg$rg[rg$z == "zal"]
zdad <- rg$rg[rg$z == "zdad"]
curs_al <- rg$curseur[rg$z == "zal"]
curs_d <- rg$curseur[rg$z == "zd"]
curs_dad <- rg$curseur[rg$z == "zdad"]
} else {
levan <- sort(unique(rg$an))
vers <- substr(sort(unique(rg$an)),6,9)
# Regpexpr
# Curseurs
zac <- unique(rg$rg[rg$z == "zac"])
if (length(unique(rg$rg[rg$z == "zd"])) > 1){
zd1 <- rg$rg[rg$z == "zd" & rg$an == levan[1]]
zd2 <- rg$rg[rg$z == "zd" & rg$an == levan[2]]
curs_d1 <- rg$curseur[rg$z == "zd" & rg$an == levan[1]]
curs_d2 <- rg$curseur[rg$z == "zd" & rg$an == levan[2]]
situation_d = 2
} else {
situation_d = 1
zd <- unique(rg$rg[rg$z == "zd"])
curs_d <- unique(rg$curseur[rg$z == "zd"])
}
if (length(unique(rg$rg[rg$z == "zdad"])) > 1){
zdad1 <- rg$rg[rg$z == "zdad" & rg$an == levan[1]]
zdad2 <- rg$rg[rg$z == "zdad" & rg$an == levan[2]]
curs_dad1 <- rg$rg[rg$z == "zdad" & rg$an == levan[1]]
curs_dad2 <- rg$rg[rg$z == "zdad" & rg$an == levan[2]]
situation_dad = 2
} else {
situation_dad = 1
zdad <- unique(rg$rg[rg$z == "zdad"])
curs_dad <- unique(rg$curseur[rg$z == "zdad"])
}
if (length(unique(rg$rg[rg$z == "zal"])) > 1){
zal1 <- rg$rg[rg$z == "zal" & rg$an == levan[1]]
zal2 <- rg$rg[rg$z == "zal" & rg$an == levan[2]]
curs_al1 <- rg$curseur[rg$z == "zal" & rg$an == levan[1]]
curs_al2 <- rg$curseur[rg$z == "zal" & rg$an == levan[2]]
situation_al = 2
} else {
situation_al = 1
zal <- unique(rg$rg[rg$z == "zal"])
curs_al <- unique(rg$curseur[rg$z == "zal"])
}
}
zad <- function(rum_i){
if (situation_al == 1){
rum_i %>% dplyr::mutate(
ac = ifelse(NBACTE>0,stringr::str_sub(ZAD,curs_d*NBDAS+curs_dad*NBDAD+1,curs_d*NBDAS+curs_dad*NBDAD+curs_al*NBACTE),""),
lactes = stringr::str_extract_all(ac,zal),
actes = extz(ac,zac),
das_ = ifelse(NBDAS>0,stringr::str_sub(ZAD,1,curs_d*NBDAS),""),
ldas= stringr::str_extract_all(das_,zd),
das = extz(das_,zd),
dad_ = ifelse(NBDAD>0,stringr::str_sub(ZAD,curs_d*NBDAS+1,curs_d*NBDAD+curs_dad*NBDAS),""),
ldad = stringr::str_extract_all(dad_,zdad),
dad = extz(dad_,zdad)
) %>% dplyr::select(-ac,-das_,-dad_)
} else {
rum_i %>% dplyr::mutate(
ac = ifelse(NBACTE>0,dplyr::if_else(NOVERG == vers[1],
stringr::str_sub(ZAD,curs_d*NBDAS+curs_dad*NBDAD+1,
curs_d*NBDAS+curs_dad*NBDAD+curs_al1*NBACTE),
stringr::str_sub(ZAD,curs_d*NBDAS+curs_dad*NBDAD+1,
curs_d*NBDAS+curs_dad*NBDAD+curs_al2*NBACTE)), ""),
lactes = dplyr::if_else(NOVERG == vers[1], stringr::str_extract_all(ac,zal1),stringr::str_extract_all(ac,zal2)),
actes = extz(ac,zac),
das_ = dplyr::if_else(NBDAS>0,stringr::str_sub(ZAD,1,curs_d*NBDAS),""),
ldas= stringr::str_extract_all(das_,zd),
das = extz(das_,zd),
dad_ = dplyr::if_else(NBDAD>0,stringr::str_sub(ZAD,curs_d*NBDAS+1,curs_dad*NBDAD+curs_d*NBDAS),""),
ldad = stringr::str_extract_all(dad_,zdad),
dad = extz(dad_,zdad)
) %>% dplyr::select(-ac,-das_,-dad_)
}
}
zad3 <- function(rum_i){
if (situation_al == 1){
rum_i %>% dplyr::mutate(
ac = ifelse(NBACTE>0,stringr::str_sub(ZAD,curs_d*NBDAS+curs_dad*NBDAD+1,
curs_d*NBDAS+curs_dad*NBDAD+curs_al*NBACTE),""),
lactes = stringr::str_extract_all(ac,zal),
das_ = ifelse(NBDAS>0,stringr::str_sub(ZAD,1,curs_d*NBDAS),""),
ldas= stringr::str_extract_all(das_,zd),
dad_ = ifelse(NBDAD>0,stringr::str_sub(ZAD,8*NBDAS+1,8*NBDAD+8*NBDAS),""),
ldad = stringr::str_extract_all(dad_,zdad)
) %>% dplyr::select(-ac,-das_,-dad_)
} else {
rum_i %>% dplyr::mutate(
ac = ifelse(NBACTE>0 & NOVERG == vers[1],
stringr::str_sub(ZAD,curs_d*NBDAS+curs_dad*NBDAD+1,
curs_d*NBDAS+curs_dad*NBDAD+curs_al1*NBACTE),
ifelse(NBACTE>0 & NOVERG == vers[2],
stringr::str_sub(ZAD,curs_d*NBDAS+curs_dad*NBDAD+1,
curs_d*NBDAS+curs_dad*NBDAD+curs_al2*NBACTE), "")),
lactes = dplyr::if_else(NOVERG == vers[1], stringr::str_extract_all(ac,zal1),stringr::str_extract_all(ac,zal2)),
das_ = dplyr::if_else(NBDAS>0,stringr::str_sub(ZAD,1,curs_d*NBDAS),""),
ldas= stringr::str_extract_all(das_,zd),
dad_ = dplyr::if_else(NBDAD>0,stringr::str_sub(ZAD,curs_d*NBDAS+1,curs_dad*NBDAD+curs_d*NBDAS),""),
ldad = stringr::str_extract_all(dad_,zdad)
) %>% dplyr::select(-ac,-das_,-dad_)
}
}
if (annee==2011){
i <- function(annee,mois){
rum_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rss.ini.txt"),
readr::fwf_widths(c(2,6,1,3,NA),c("NOCLAS","CDGHM","Fil1","NOVERG","RUM")),
col_types = readr::cols('c','c','c','c','c'), trim_ws = FALSE,
na=character(), ...) %>%
dplyr::mutate(
CDERG = stringr::str_sub(RUM,1,3),
NOFINESS = stringr::str_sub(RUM,4,12),
NOVERS = stringr::str_sub(RUM,13,15),
NORSS = stringr::str_sub(RUM,16,35),
NAS = stringr::str_sub(RUM,36,55),
NORUM = stringr::str_sub(RUM,56,65),
DTNAIS = stringr::str_sub(RUM,66,73),
SXPMSI = stringr::str_sub(RUM,74,74),
CDURM = stringr::str_sub(RUM,75,78),
KYTYPAUTLIT = stringr::str_sub(RUM,79,80),
D8EEUE = stringr::str_sub(RUM,81,88),
MDEEUE = stringr::str_sub(RUM,89,89),
TYTRPR = stringr::str_sub(RUM,90,90),
D8SOUE = stringr::str_sub(RUM,91,98),
MDSOUE = stringr::str_sub(RUM,99,99),
TYTRDS = stringr::str_sub(RUM,100,100),
CDRESI = stringr::str_sub(RUM,101,105),
PDNAIS = stringr::str_sub(RUM,106,109) %>% as.numeric(),
AGEGEST = stringr::str_sub(RUM,110,111) %>% as.integer(),
DDR2 = ifelse(NOVERG=='115', "" , stringr::str_sub(RUM,112,119)),
NBSEAN = ifelse(NOVERG=='115', stringr::str_sub(RUM,112,113) , stringr::str_sub(RUM,120,121)) %>% as.integer(),
NBDAS = ifelse(NOVERG=='115', stringr::str_sub(RUM,114,115) , stringr::str_sub(RUM,122,123)) %>% as.integer(),
NBDAD = ifelse(NOVERG=='115', stringr::str_sub(RUM,116,117) , stringr::str_sub(RUM,124,125)) %>% as.integer(),
NBACTE = ifelse(NOVERG=='115', stringr::str_sub(RUM,118,120) , stringr::str_sub(RUM,126,128)) %>% as.integer(),
DP = ifelse(NOVERG=='115', stringr::str_sub(RUM,121,128) , stringr::str_sub(RUM,129,137)),
DR = ifelse(NOVERG=='115', stringr::str_sub(RUM,129,136) , stringr::str_sub(RUM,138,146)),
IGS = ifelse(NOVERG=='115', stringr::str_sub(RUM,137,138) , stringr::str_sub(RUM,147,149)),
CONFCDRSS = ifelse(NOVERG=='115', stringr::str_sub(RUM,139,140) , stringr::str_sub(RUM,150,150)),
RDT_TYPMACH = ifelse(NOVERG=='115', stringr::str_sub(RUM,141,141) , stringr::str_sub(RUM,151,151)),
RDT_TYPDOSIM = ifelse(NOVERG=='115', stringr::str_sub(RUM,142,142) , stringr::str_sub(RUM,152,152)),
NBFAISC = ifelse(NOVERG=='115', stringr::str_sub(RUM,143,143) , stringr::str_sub(RUM,153,153)) %>% as.integer(),
ZAD = ifelse(NOVERG=='115', stringr::str_sub(RUM,154,stringr::str_length(RUM)) , stringr::str_sub(RUM,181,stringr::str_length(RUM)))
) %>% dplyr::select(-RUM)
}
}
if (annee>=2012){
i <- function(annee,mois){
suppressWarnings(readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rss.ini.txt"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...))}
}
former <- function(cla, col1){
switch(cla,
'trim' = col1 %>% stringr::str_trim(),
'c' = col1,
'i' = col1 %>% as.integer(),
'n2' = (col1 %>% as.numeric() )/100,
'n3' = (col1 %>% as.numeric() )/1000,
'dmy' = lubridate::dmy(col1, quiet = TRUE))
}
if (typi !=0){
#cat("Lecture du fichier / parsing fixe...\n")
rum_i <- i(annee,mois) %>% dplyr::mutate(
DTNAIS=lubridate::dmy(DTNAIS, quiet = TRUE),
D8EEUE=lubridate::dmy(D8EEUE, quiet = TRUE),
D8SOUE=lubridate::dmy(D8SOUE, quiet = TRUE),
DP = stringr::str_trim(DP),
DR = stringr::str_trim(DR)) %>%
dplyr::mutate(DUREESEJPART = as.integer(difftime(D8SOUE, D8EEUE, units= c("days"))))
readr::problems(rum_i) -> synthese_import
}
if (typi== 1){
Fillers <- names(rum_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="Fil"]
rum_i <- rum_i[,!(names(rum_i) %in% Fillers)] %>% dplyr::select(-ZAD)
# Libelles
if (lib==T){
v <- libelles
v <- v[!is.na(v)]
rum_i <- rum_i %>% sjlabelled::set_label(c(v, "Durée rum"))
}
if (tolower_names){
names(rum_i) <- tolower(names(rum_i))
}
rum_1 <- list(rum = rum_i)
class(rum_1) <- append(class(rum_1),"RUM")
deux<-Sys.time()
#cat(paste("MCO RUM XLight",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
#cat("(Seule la partie fixe du RUM a été chargée)\n")
return(rum_1)
}
if (typi== 2){
#cat("Traitement | Parsing variable...\n")
rum_i <- zad(rum_i) %>% dplyr::select(-lactes,-ldas,-ldad,-ZAD )
rum_i <- rum_i %>%
dplyr::mutate(das = stringr::str_replace_all(das, "\\s{1,},", ","),
dad = stringr::str_replace_all(dad, "\\s{1,},", ","))
Fillers <- names(rum_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="Fil"]
rum_i <- rum_i[,!(names(rum_i) %in% Fillers)]
if (lib==T){
v <- libelles
v <- c(v[!is.na(v)], "Durée rum", "Stream Actes","Stream Das", "Stream Dad")
rum_i <- rum_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(rum_i) <- tolower(names(rum_i))
}
rum_1 <- list(rum = rum_i)
class(rum_1) <- append(class(rum_1),"RUM")
deux<-Sys.time()
#cat(paste("MCO RUM Light",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
return(rum_1)
}
if (typi== 3){
#cat("Traitement | Parsing variable...\n")
rum_i <- zad3(rum_i)
if (situation_al == 1){
#cat("Actes en ligne : ")
un_i<-Sys.time()
actes <- purrr::flatten_chr(rum_i$lactes)
df <- rum_i %>% dplyr::select(NAS, NORUM, NBACTE)
df <- as.data.frame(lapply(df, rep, df$NBACTE), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(var = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rum_actes", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(actes$var, i)))
names(temp) <- fa$nom[i]
actes <- dplyr::bind_cols(actes, temp)
}
actes %>% dplyr::select(-var, - NBACTE) -> actes
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
} else {
#cat("Actes en ligne : ")
un_i<-Sys.time()
actes <- purrr::flatten_chr(rum_i$lactes)
df <- rum_i %>% dplyr::select(NAS, NORUM, NOVERG, NBACTE)
df <- as.data.frame(lapply(df, rep, df$NBACTE), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(var = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa1 <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rum_actes",
an == paste0(substr(annee,3,4), '_',vers[1]))
deb1 <- fa1$position
fin1 <- fa1$fin
fa2 <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rum_actes",
an == paste0(substr(annee,3,4), '_',vers[2]))
deb2 <- fa2$position
fin2 <- fa2$fin
u <- function( i, actes){
as.vector(as.matrix(actes %>%
dplyr::mutate(temp = dplyr::if_else(NOVERG == vers[1], stringr::str_sub(var, deb1[i], fin1[i]),
stringr::str_sub(var, deb2[i], fin2[i]))) %>%
dplyr::select(temp)))}
for (i in 1:length(deb1)){
temp <- dplyr::as_tibble(former(fa1$type[i], u(i, actes)))
names(temp) <- fa1$nom[i]
actes <- dplyr::bind_cols(actes, temp)
}
actes %>% dplyr::select(-var, - NBACTE, - NOVERG) -> actes
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
fa <- fa2
}
#cat("Das en ligne : ")
un_i<-Sys.time()
das <- purrr::flatten_chr(rum_i$ldas) %>% stringr::str_trim()
df <- rum_i %>% dplyr::select(NAS,NORUM,NBDAS)
df <- as.data.frame(lapply(df, rep, df$NBDAS), stringsAsFactors = F) %>% tibble::as_tibble()
das <- dplyr::bind_cols(df,data.frame(DAS = stringr::str_trim(das), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDAS)
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
#cat("Dad en ligne : ")
un_i<-Sys.time()
dad <- purrr::flatten_chr(rum_i$ldad)
df <- rum_i %>% dplyr::select(NAS,NORUM,NBDAD)
df <- as.data.frame(lapply(df, rep, df$NBDAD), stringsAsFactors = F) %>% tibble::as_tibble()
dad <- dplyr::bind_cols(df,data.frame(DAD = stringr::str_trim(dad), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDAD)
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
if (lib == T){
actes %>% sjlabelled::set_label(c('N° administratif du séjour','N° du RUM', fa$libelle)) -> actes
das %>% sjlabelled::set_label(c('N° administratif du séjour','N° du RUM', 'Diagnostic associé')) -> das
dad %>% sjlabelled::set_label(c('N° administratif du séjour','N° du RUM', 'Donnée à visée documentaire')) -> dad
}
Fillers <- names(rum_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="Fil"]
rum_i <- rum_i[,!(names(rum_i) %in% Fillers)] %>% dplyr::select(-ZAD, -ldad, -lactes, -ldas)
# Libelles
if (lib==T){
v <- libelles
v <- v[!is.na(v)]
rum_i <- rum_i %>% sjlabelled::set_label(c(v, "Durée rum"))
}
if (tolower_names){
names(rum_i) <- tolower(names(rum_i))
names(actes) <- tolower(names(actes))
names(das) <- tolower(names(das))
names(dad) <- tolower(names(dad))
}
rum_1 <- list(rum = rum_i, actes = actes, das = das, dad = dad)
class(rum_1) <- append(class(rum_1),"RUM")
deux<-Sys.time()
#cat(paste("MCO RUM Standard",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
return(rum_1)
}
if (typi== 4){
#cat("Traitement | Parsing variable...\n")
rum_i <- zad(rum_i)
if (situation_al == 1){
#cat("Actes en ligne : ")
un_i<-Sys.time()
actes <- purrr::flatten_chr(rum_i$lactes)
df <- rum_i %>% dplyr::select(NAS, NORUM, NBACTE)
df <- as.data.frame(lapply(df, rep, df$NBACTE), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(var = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rum_actes", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(actes$var, i)))
names(temp) <- fa$nom[i]
actes <- dplyr::bind_cols(actes, temp)
}
actes %>% dplyr::select(-var, - NBACTE) -> actes
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
} else {
#cat("Actes en ligne : ")
un_i<-Sys.time()
actes <- purrr::flatten_chr(rum_i$lactes)
df <- rum_i %>% dplyr::select(NAS, NORUM, NOVERG, NBACTE)
df <- as.data.frame(lapply(df, rep, df$NBACTE), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(var = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa1 <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rum_actes",
an == paste0(substr(annee,3,4), '_',vers[1]))
deb1 <- fa1$position
fin1 <- fa1$fin
fa2 <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rum_actes",
an == paste0(substr(annee,3,4), '_',vers[2]))
deb2 <- fa2$position
fin2 <- fa2$fin
u <- function( i, actes){
as.vector(as.matrix(actes %>%
dplyr::mutate(temp = dplyr::if_else(NOVERG == vers[1], stringr::str_sub(var, deb1[i], fin1[i]),
stringr::str_sub(var, deb2[i], fin2[i]))) %>%
dplyr::select(temp)))}
for (i in 1:length(deb1)){
temp <- dplyr::as_tibble(former(fa1$type[i], u(i, actes)))
names(temp) <- fa1$nom[i]
actes <- dplyr::bind_cols(actes, temp)
}
actes %>% dplyr::select(-var, -NBACTE, - NOVERG) -> actes
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
fa <- fa2
}
#cat("Das en ligne : ")
un_i<-Sys.time()
das <- purrr::flatten_chr(rum_i$ldas) %>% stringr::str_trim()
df <- rum_i %>% dplyr::select(NAS,NORUM,NBDAS)
df <- as.data.frame(lapply(df, rep, df$NBDAS), stringsAsFactors = F) %>% tibble::as_tibble()
das <- dplyr::bind_cols(df,data.frame(DAS = stringr::str_trim(das), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDAS)
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
#cat("Dad en ligne : ")
un_i<-Sys.time()
dad <- purrr::flatten_chr(rum_i$ldad)
df <- rum_i %>% dplyr::select(NAS,NORUM,NBDAD)
df <- as.data.frame(lapply(df, rep, df$NBDAD), stringsAsFactors = F) %>% tibble::as_tibble()
dad <- dplyr::bind_cols(df,data.frame(DAD = stringr::str_trim(dad), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDAD)
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
if (lib == T){
actes %>% sjlabelled::set_label(c('N° administratif du séjour','N° du RUM', fa$libelle)) -> actes
das %>% sjlabelled::set_label(c('N° administratif du séjour','N° du RUM', 'Diagnostic associé')) -> das
dad %>% sjlabelled::set_label(c('N° administratif du séjour','N° du RUM', 'Donnée à visée documentaire')) -> dad
}
rum_i <- rum_i %>% dplyr::select(-lactes,-ldas,-ldad,-ZAD ) %>%
dplyr::mutate(das = stringr::str_replace_all(das, "\\s{1,},", ","),
dad = stringr::str_replace_all(dad, "\\s{1,},", ","))
Fillers <- names(rum_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="Fil"]
rum_i <- rum_i[,!(names(rum_i) %in% Fillers)]
# Libelles
if (lib==T){
v <- libelles
v <- c(v[!is.na(v)], "Durée rum", "Stream Actes","Stream Das", "Stream Dad")
rum_i <- rum_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(rum_i) <- tolower(names(rum_i))
names(actes) <- tolower(names(actes))
names(das) <- tolower(names(das))
names(dad) <- tolower(names(dad))
}
rum_1 <- list(rum = rum_i, actes = actes, das = das, dad = dad)
class(rum_1) <- append(class(rum_1),"RUM")
deux<-Sys.time()
attr(rum_i,"problems") <- synthese_import
#cat(paste("MCO RUM Standard+",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
return(rum_1)
}
cat("Quel type d'import ?\n")
typo <- data.frame(Type=c(1,
2,
3,
4),
Import=c('XLight : Partie fixe',
'Light : Partie fixe + stream en ligne des actes, das et dad',
'Standard : Partie fixe + table acdi',
'Standard+ : Partie fixe + stream + table acdi '),
Temps=c('Très Rapide','Rapide','Rapide','Long'),
`Temps rapporté`=c('= 1','* 5 (~)','* 4 (~)','* 7 (~)'))
cat(knitr::kable(typo), sep = "\n")
n <- readline(prompt="Taper le type d'import voulu : ")
return(irum(finess,annee,mois,path,lib,n, ...))
}
#' ~ MCO - Import des RSA
#'
#' Import des RSA. 6 types d'imports possibles.
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu (sortie de Genrsa) :
#' \emph{finess.annee.moisc.rsa}
#'
#' \strong{750712184.2016.2.rsa}
#'
#' Types d'imports :
#' \tabular{ll}{
#' 1 Light : \tab partie fixe (très rapide)\cr
#' 2 Light+ : \tab Partie fixe + stream en ligne (+) actes et das\cr
#' 3 Light++ : \tab Partie fixe + stream en ligne (++) actes, das, typaut um et dpdr des um\cr
#' 4 Standard : \tab Partie fixe + création des tables acdi et rsa_um\cr
#' 5 Standard+ : \tab Partie fixe + création des tables acdi et rsa_um + stream (+)\cr
#' 6 Standard++ : \tab Partie fixe + création des tables acdi et rsa_um + stream (++)\cr
#' }
#'
#'
#' \strong{Principe du streaming :}
#' Mise en chaîne de caractères de la succession d'actes CCAM au cours du RUM, par exemple, pour un RUM :
#' \samp{"ACQK001, LFQK002, MCQK001, NAQK015, PAQK002, PAQK900, YYYY600, ZZQP004"}
#'
#' La recherche d'un (ou d'une liste d') acte(s) sur un RUM est largement accélérée, comparée à une requête sur la large table acdi par une requête du type :
#'
#' \code{grepl("ZZQP004",rsa$actes)} # toutes les lignes de RSA avec au moins un ZZQP004
#'
#' \code{e66 <- grepl('E66',das)|grepl('E66',dpdrum)} # toutes les lignes de RSA avec un diagnostic E66
#'
#' Cela permet de n'utiliser que la seule table rsa avec stream et d'avoir les infos sur les séjours directement :
#' nb séjours, journées, entrée / sortie (...) plutôt que d'avoir à utiliser et croiser les tables acdi, rsa_um avec rsa.
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param typi Type d'import, par defaut a 4, a 0 : propose a l'utilisateur de choisir au lancement
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une classe S3 contenant les tables (data.frame, tibble ou tbl) importées (rsa, rsa_um, actes et das si import > 3)
#'
#' @examples
#' \dontrun{
#' irsa('750712184',2015,12,'~/Documents/data/mco') -> rsa15
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irum}}, \code{\link{ileg_mco}}, \code{\link{iano_mco}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage irsa(finess, annee, mois, path, lib = T, typi = 4, tolower_names = F, ...)
#' @export irsa
#' @export
irsa <- function(finess, annee, mois, path, lib = T, typi = 4, tolower_names = F, ...){
UseMethod('irsa')
}
#' @export
irsa.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(irsa.default, param2)
}
#' @export
irsa.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(irsa.default, param2)
}
#' @export
irsa.default <- function(finess, annee, mois, path, lib = T, typi = 4, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
if (!(typi %in% 0:6)){
stop("Type d'import incorrect : 0 ou 1, 2, 3, 4, 5 et 6\n")
}
#op <- options(digits.secs = 6)
un<-Sys.time()
# cat(paste("L'objet retourné prendra la forme d'une classe S3.
# $rsa pour accéder à la table RSA
# $rsa_um pour accéder à la table RSA_UM
# $das pour accéder à la table des DAS
# $actes pour accéder à la table des ACTES\n\n"))
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
extz <- function(x,pat){unlist(lapply(stringr::str_extract_all(x,pat),toString) )}
former <- function(cla, col1){
switch(cla,
'trim' = col1 %>% stringr::str_trim(),
'c' = col1,
'i' = col1 %>% as.integer(),
'n2' = (col1 %>% as.numeric() )/100,
'n3' = (col1 %>% as.numeric() )/1000,
'dmy' = lubridate::dmy(col1, quiet = TRUE))
}
if (typi !=0){
#cat('Lecture du fichier | Parsing partie fixe...\n')
rsa_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rsa"),
readr::fwf_widths(af,an), col_types =at, na=character(), ... )
readr::problems(rsa_i) -> synthese_import
rsa_i <- rsa_i %>%
dplyr::mutate(DP = stringr::str_trim(DP),
DR = stringr::str_trim(DR),
ghm = paste0(RSACMD, RSATYPE, RSANUM, RSACOMPX),
anseqta = dplyr::if_else(MOISSOR < "03", as.character(annee - 1), as.character(annee)))
}
if (typi== 1){
deux<-Sys.time()
#cat(paste("MCO RSA Light",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
#cat("(Seule la partie fixe du RSA a été chargée)\n")
Fillers <- names(rsa_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rsa_i <- rsa_i[,!(names(rsa_i) %in% Fillers)] %>% dplyr::select(-ZA)
# Libelles
if (lib==T){
v <- libelles
v <- v[!is.na(v)]
rsa_i <- rsa_i %>% sjlabelled::set_label(c(v, 'Ghm', 'Année séq. de tarifs'))
}
if (tolower_names){
names(rsa_i) <- tolower(names(rsa_i))
}
rsa_1 <- list(rsa = rsa_i)
class(rsa_1) <- append(class(rsa_1),"RSA")
attr(rsa_1,"problems") <- synthese_import
return(rsa_1)
}
pmeasyr::formats %>% dplyr::filter(table == "rsa" & an == as.integer(annee)) -> rg
zac = rg$rg[rg$z == 'zac']
zd = rg$rg[rg$z == 'zd']
zum = rg$rg[rg$z == 'zum']
zal = rg$rg[rg$z == 'zal']
cd = rg$curseur[rg$z == 'zd']
cum = rg$curseur[rg$z == 'zum']
cal = rg$curseur[rg$z == 'zal']
fzad <- function(rsa){
if (as.integer(annee) > 2011){
return(rsa %>% dplyr::mutate(
TYPGLOB = ifelse(NBAUTPGV>0,stringr::str_sub(ZA,1,2*NBAUTPGV),""),
RDTH = ifelse(NB_RDTH>0,stringr::str_sub(ZA,2*NBAUTPGV+1,2*NBAUTPGV+7*NB_RDTH),""),
RUMS = ifelse(as.numeric(NBRUM)>0,stringr::str_sub(ZA,2*NBAUTPGV+7*NB_RDTH+1,2*NBAUTPGV+7*NB_RDTH+cum*NBRUM),""),
DAS = ifelse(NDAS>0,stringr::str_sub(ZA,2*NBAUTPGV+7*NB_RDTH+cum*NBRUM + 1,2*NBAUTPGV + 7*NB_RDTH + cum*NBRUM + cd*NDAS),""),
ACTES = ifelse(`NA`>0,stringr::str_sub(ZA,2*NBAUTPGV+7*NB_RDTH+cum*NBRUM + cd*NDAS + 1,2*NBAUTPGV + 7*NB_RDTH + cum*NBRUM + cd*NDAS + cal*`NA`),"")
))}
else if (as.integer(annee) == 2011){
return(rsa %>% dplyr::mutate(
RDTH = ifelse(NB_RDTH>0,stringr::str_sub(ZA,1,7*NB_RDTH),""),
RUMS = ifelse(as.numeric(NBRUM)>0,stringr::str_sub(ZA,7*NB_RDTH+1,7*NB_RDTH+cum*NBRUM),""),
DAS = ifelse(NDAS>0,stringr::str_sub(ZA,7*NB_RDTH+cum*NBRUM + 1,7*NB_RDTH + cum*NBRUM + cd*NDAS),""),
ACTES = ifelse(`NA`>0,stringr::str_sub(ZA,7*NB_RDTH+cum*NBRUM + cd*NDAS + 1,7*NB_RDTH + cum*NBRUM + cd*NDAS + cal*`NA`),"")))
}
}
if (typi == 2){
#cat('Import Light+ | Streaming des actes et das...\n')
rsa_i <- fzad(rsa_i)
rsa_i <- rsa_i %>%
dplyr::mutate(
actes = extz(ACTES,zac), # Stream des actes
das = extz(DAS,zd)) %>% # Stream des das
dplyr::select(-ZA,-ACTES,-RUMS,-DAS)
rsa_i <- rsa_i %>%
dplyr::mutate(das = stringr::str_replace_all(das, "\\s{1,},", ","))
Fillers <- names(rsa_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rsa_i <- rsa_i[,!(names(rsa_i) %in% Fillers)]
# Libelles
if (lib==T){
v <- libelles
if (annee==2011){
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs', "Supp. Radiothérapies", "Stream Actes", "Stream Das")
}
else {
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs', "Types Aut. à Portée Globale", "Supp. Radiothérapies", "Stream Actes", "Stream Das")
}
rsa_i <- rsa_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(rsa_i) <- tolower(names(rsa_i))
}
rsa_1 <- list(rsa = rsa_i)
class(rsa_1) <- append(class(rsa_1),"RSA")
deux<-Sys.time()
#cat(paste("MCO RSA Light+",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
attr(rsa_1,"problems") <- synthese_import
return(rsa_1)
}
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rsa_um", an == substr(annee,3,4))
debum <- fa[fa$nom == "TYPAUT1",]$position
finum <- fa[fa$nom == "TYPAUT1",]$fin
debdpdr <- fa[fa$nom == "DPUM",]$position
findpdr <- fa[fa$nom == "DRUM",]$fin
if (typi == 3){
#cat('Import Light++ | Streaming des actes, das, typaut UM et DP/DR des UM...\n')
rsa_i <- fzad(rsa_i)
rsa_i <- rsa_i %>%
dplyr::mutate(
actes = extz(ACTES,zac), # Stream des actes
lum = stringr::str_extract_all(RUMS,zum), # Liste des UM
um = unlist(lapply(lapply(lum, # Stream des types d'UM
function(x){substr(x,debum,finum)}),
function(y){toString(y)})),
dpdrum = unlist(lapply(lapply(lum, # Stream des dpdr d'UM
function(x){substr(x,debdpdr,findpdr)}),
function(y){toString(y)})),
das = extz(DAS,zd)) %>% # Stream des das
dplyr::select(-ZA,-RUMS,-ACTES,-DAS,-lum)
rsa_i <- rsa_i %>%
dplyr::mutate(das = stringr::str_replace_all(das, "\\s{1,},", ","),
dpdrum = stringr::str_replace_all(dpdrum, "\\s{1,},", ","))
deux<-Sys.time()
Fillers <- names(rsa_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rsa_i <- rsa_i[,!(names(rsa_i) %in% Fillers)]
if (lib==T){
v <- libelles
if (annee==2011) {
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs', "Supp. Radiothérapies", "Stream Actes","Parcours Typaut UM","Stream DP/DR des UM","Stream Das")
}
else{
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs',
"Types Aut. à Portée Globale", "Supp. Radiothérapies",
"Stream Actes","Parcours Typaut UM","Stream DP/DR des UM","Stream Das")
}
rsa_i <- rsa_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(rsa_i) <- tolower(names(rsa_i))
}
rsa_1 <- list(rsa = rsa_i)
class(rsa_1) <- append(class(rsa_1),"RSA")
#cat(paste("MCO RSA Light++",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
#cat("La table rsa est dans l'environnement de travail\n")
attr(rsa_1,"problems") <- synthese_import
return(rsa_1)
}
if (typi == 4){
#cat('Traitement | Parsing partie variable...\n')
rsa_i <- fzad(rsa_i)
rsa_i <- rsa_i %>%
dplyr::mutate(lactes = stringr::str_extract_all(ACTES,zal), # Liste des actes
lum = stringr::str_extract_all(RUMS,zum), # Liste des UM
ldas = stringr::str_extract_all(DAS,zd) ) %>% # Liste de das
dplyr::select(-ZA,-RUMS,-ACTES,-DAS)
#cat("Passages UM en ligne : ")
un_i<-Sys.time()
rsa_um <- purrr::flatten_chr(rsa_i$lum)
df <- rsa_i %>% dplyr::select(CLE_RSA,NBRUM)
df <- as.data.frame(lapply(df, rep, df$NBRUM), stringsAsFactors = F) %>% tibble::as_tibble()
if (as.integer(annee) <= 2012){
df <- df %>% dplyr::mutate(NSEQRUM = stringr::str_pad(dplyr::row_number(CLE_RSA), 2,"left","0"))}
rsa_um <- dplyr::bind_cols(df,data.frame(var = rsa_um, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rsa_um", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(rsa_um$var, i)))
names(temp) <- fa$nom[i]
rsa_um <- dplyr::bind_cols(rsa_um, temp)
}
rsa_um %>% dplyr::select(-var, -NBRUM) -> rsa_um
if (lib == T){
if (as.integer(annee) <= 2012){
rsa_um %>% sjlabelled::set_label(c('Clé RSA','N° Séquentiel du RUM', fa$libelle)) -> rsa_um}
else
rsa_um %>% sjlabelled::set_label(c('Clé RSA', fa$libelle)) -> rsa_um
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
# das
#cat("Das en ligne : ")
un_i<-Sys.time()
das <- purrr::flatten_chr(rsa_i$ldas) %>% stringr::str_trim()
df <- rsa_um %>% dplyr::select(CLE_RSA,NSEQRUM,NBDIAGAS)
df <- as.data.frame(lapply(df, rep, df$NBDIAGAS), stringsAsFactors = F) %>% tibble::as_tibble()
das <- dplyr::bind_cols(df,data.frame(DAS = das, stringsAsFactors = F) ) %>% tibble::as_tibble()
das <- das %>% dplyr::select(-NBDIAGAS)
if (lib == T){
das %>% sjlabelled::set_label(c('Clé RSA', 'N° séquentiel du RUM', 'Diagnostic associé')) -> das
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
# actes
#cat("Actes en ligne : ")
un_i<-Sys.time()
actes <- purrr::flatten_chr(rsa_i$lactes)
df <- rsa_um %>% dplyr::select(CLE_RSA,NSEQRUM,NBACTE)
df <- as.data.frame(lapply(df, rep, df$NBACTE), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(var = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rsa_actes", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(actes$var, i)))
names(temp) <- fa$nom[i]
actes <- dplyr::bind_cols(actes, temp)
}
actes %>% dplyr::select(-var, -NBACTE) -> actes
if (lib == T){
actes %>% sjlabelled::set_label(c('Clé RSA', 'N° séquentiel du RUM', fa$libelle)) -> actes
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
deux<-Sys.time()
Fillers <- names(rsa_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rsa_i <- rsa_i[,!(names(rsa_i) %in% Fillers)]
# Libelles
rsa_i <- rsa_i %>% dplyr::select(-lactes, - lum, - ldas)
if (lib==T){
v <- libelles
if (annee==2011){
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs', "Supp. Radiothérapies")
}
else {
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs', "Types Aut. à Portée Globale", "Supp. Radiothérapies")
}
rsa_i <- rsa_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(rsa_i) <- tolower(names(rsa_i))
names(actes) <- tolower(names(actes))
names(das) <- tolower(names(das))
names(rsa_um) <- tolower(names(rsa_um))
}
rsa_1 <- list(rsa = rsa_i,
actes = actes,
das = das,
rsa_um=rsa_um)
class(rsa_1) <- append(class(rsa_1),"RSA")
#cat(paste("MCO RSA Standard",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
attr(rsa_1,"problems") <- synthese_import
return(rsa_1)
}
if (typi == 5){
#cat('Import standard+\n')
#cat('Traitement | Parsing partie variable...\n')
rsa_i <- fzad(rsa_i)
rsa_i <- rsa_i %>%
dplyr::mutate(lactes = stringr::str_extract_all(ACTES,zal), # Liste des actes
actes = extz(ACTES,zac), # Stream des actes
lum = stringr::str_extract_all(RUMS,zum), # Liste des UM
ldas = stringr::str_extract_all(DAS,zd), # Liste de das
das = extz(DAS,zd)) %>% # Stream des das
dplyr::select(-ZA,-RUMS,-ACTES,-DAS)
rsa_i <- rsa_i %>%
dplyr::mutate(das = stringr::str_replace_all(das, "\\s{1,},", ","))
#cat("Passages UM en ligne : ")
un_i<-Sys.time()
rsa_um <- purrr::flatten_chr(rsa_i$lum)
df <- rsa_i %>% dplyr::select(CLE_RSA,NBRUM)
df <- as.data.frame(lapply(df, rep, df$NBRUM), stringsAsFactors = F) %>% tibble::as_tibble()
if (as.integer(annee) <= 2012){
df <- df %>% dplyr::mutate(NSEQRUM = stringr::str_pad(dplyr::row_number(CLE_RSA), 2,"left","0"))}
rsa_um <- dplyr::bind_cols(df,data.frame(var = rsa_um, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rsa_um", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(rsa_um$var, i)))
names(temp) <- fa$nom[i]
rsa_um <- dplyr::bind_cols(rsa_um, temp)
}
rsa_um %>% dplyr::select(-var, -NBRUM) -> rsa_um
if (lib == T){
if (as.integer(annee) <= 2012){
rsa_um %>% sjlabelled::set_label(c('Clé RSA','N° Séquentiel du RUM', fa$libelle)) -> rsa_um}
else
rsa_um %>% sjlabelled::set_label(c('Clé RSA', fa$libelle)) -> rsa_um
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
# das
#cat("Das en ligne : ")
un_i<-Sys.time()
das <- purrr::flatten_chr(rsa_i$ldas) %>% stringr::str_trim()
df <- rsa_um %>% dplyr::select(CLE_RSA,NSEQRUM,NBDIAGAS)
df <- as.data.frame(lapply(df, rep, df$NBDIAGAS), stringsAsFactors = F) %>% tibble::as_tibble()
das <- dplyr::bind_cols(df,data.frame(DAS = das, stringsAsFactors = F) ) %>% tibble::as_tibble()
das <- das %>% dplyr::select(-NBDIAGAS)
if (lib == T){
das %>% sjlabelled::set_label(c('Clé RSA', 'N° séquentiel du RUM', 'Diagnostic associé')) -> das
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
# actes
#cat("Actes en ligne : ")
un_i<-Sys.time()
actes <- purrr::flatten_chr(rsa_i$lactes)
df <- rsa_um %>% dplyr::select(CLE_RSA,NSEQRUM,NBACTE)
df <- as.data.frame(lapply(df, rep, df$NBACTE), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(var = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rsa_actes", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(actes$var, i)))
names(temp) <- fa$nom[i]
actes <- dplyr::bind_cols(actes, temp)
}
actes %>% dplyr::select(-var, -NBACTE) -> actes
if (lib == T){
actes %>% sjlabelled::set_label(c('Clé RSA', 'N° séquentiel du RUM', fa$libelle)) -> actes
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
deux<-Sys.time()
Fillers <- names(rsa_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rsa_i <- rsa_i[,!(names(rsa_i) %in% Fillers)]
# Libelles
deux<-Sys.time()
rsa_i <- rsa_i %>% dplyr::select(-lactes,-lum,-ldas)
Fillers <- names(rsa_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rsa_i <- rsa_i[,!(names(rsa_i) %in% Fillers)]
if (lib==T){
v <- libelles
if (annee==2011) {
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs', "Supp. Radiothérapies", "Stream Actes", "Stream Das")
}
else{
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs', "Types Aut. à Portée Globale", "Supp. Radiothérapies", "Stream Actes", "Stream Das")
}
rsa_i <- rsa_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(rsa_i) <- tolower(names(rsa_i))
names(actes) <- tolower(names(actes))
names(das) <- tolower(names(das))
names(rsa_um) <- tolower(names(rsa_um))
}
rsa_1 <- list(rsa = rsa_i , actes = actes, das = das, rsa_um=rsa_um)
class(rsa_1) <- append(class(rsa_1),"RSA")
#cat(paste("MCO RSA Standard+",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
#cat("Les tables rsa, acdi et rsa_um sont dans l'environnement de travail\n")
attr(rsa_1,"problems") <- synthese_import
return(rsa_1)
}
if (typi == 6){
#cat('Import standard++\n')
#cat('Traitement | Parsing partie variable...\n')
rsa_i <- fzad(rsa_i)
rsa_i <- rsa_i %>%
dplyr::mutate(lactes = stringr::str_extract_all(ACTES,zal), # Liste des actes
actes = extz(ACTES,zac), # Stream des actes
#na = stringr::str_count(ZA,zal), # Nombre d'actes trouvés #
lum = stringr::str_extract_all(RUMS,zum), # Liste des UM
#num = stringr::str_count(ZA,zum), # Nombre d'UM trouvés #
um = unlist(lapply(lapply(lum, # Stream des types d'UM
function(x){substr(x,debum,finum)}),
function(y){toString(y)})),
dpdrum = unlist(lapply(lapply(lum, # Stream des dpdr d'UM
function(x){substr(x,debdpdr,findpdr)}),
function(y){toString(y)})),
ldas = stringr::str_extract_all(DAS,zd), # Liste de das
das = extz(DAS,zd)) %>% # Stream des das
dplyr::select(-ZA,-RUMS,-ACTES,-DAS)
rsa_i <- rsa_i %>%
dplyr::mutate(das = stringr::str_replace_all(das, "\\s{1,},", ","),
dpdrum = stringr::str_replace_all(dpdrum, "\\s{1,},", ","))
#cat("Passages UM en ligne : ")
un_i<-Sys.time()
rsa_um <- purrr::flatten_chr(rsa_i$lum)
df <- rsa_i %>% dplyr::select(CLE_RSA,NBRUM)
df <- as.data.frame(lapply(df, rep, df$NBRUM), stringsAsFactors = F) %>% tibble::as_tibble()
if (as.integer(annee) <= 2012){
df <- df %>% dplyr::mutate(NSEQRUM = stringr::str_pad(dplyr::row_number(CLE_RSA), 2,"left","0"))}
rsa_um <- dplyr::bind_cols(df,data.frame(var = rsa_um, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rsa_um", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(rsa_um$var, i)))
names(temp) <- fa$nom[i]
rsa_um <- dplyr::bind_cols(rsa_um, temp)
}
rsa_um %>% dplyr::select(-var, -NBRUM) -> rsa_um
if (lib == T){
if (as.integer(annee) <= 2012){
rsa_um %>% sjlabelled::set_label(c('Clé RSA','N° Séquentiel du RUM', fa$libelle)) -> rsa_um}
else
rsa_um %>% sjlabelled::set_label(c('Clé RSA', fa$libelle)) -> rsa_um
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
# das
#cat("Das en ligne : ")
un_i<-Sys.time()
das <- purrr::flatten_chr(rsa_i$ldas) %>% stringr::str_trim()
df <- rsa_um %>% dplyr::select(CLE_RSA,NSEQRUM,NBDIAGAS)
df <- as.data.frame(lapply(df, rep, df$NBDIAGAS), stringsAsFactors = F) %>% tibble::as_tibble()
das <- dplyr::bind_cols(df,data.frame(DAS = das, stringsAsFactors = F) ) %>% tibble::as_tibble()
das <- das %>% dplyr::select(-NBDIAGAS)
if (lib == T){
das %>% sjlabelled::set_label(c('Clé RSA', 'N° séquentiel du RUM', 'Diagnostic associé')) -> das
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
# actes
#cat("Actes en ligne : ")
un_i<-Sys.time()
actes <- purrr::flatten_chr(rsa_i$lactes)
df <- rsa_um %>% dplyr::select(CLE_RSA,NSEQRUM,NBACTE)
df <- as.data.frame(lapply(df, rep, df$NBACTE), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(var = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rsa_actes", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(actes$var, i)))
names(temp) <- fa$nom[i]
actes <- dplyr::bind_cols(actes, temp)
}
actes %>% dplyr::select(-var, -NBACTE) -> actes
if (lib == T){
actes %>% sjlabelled::set_label(c('Clé RSA', 'N° séquentiel du RUM', fa$libelle)) -> actes
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
deux<-Sys.time()
rsa_i <- rsa_i %>% dplyr::select(-lactes,-lum,-ldas)
Fillers <- names(rsa_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rsa_i <- rsa_i[,!(names(rsa_i) %in% Fillers)]
if (lib==T){
v <- libelles
if (annee==2011) {
v <- c(v[!is.na(v)],"Ghm", "Année séq. de tarifs", "Supp. Radiothérapies",
"Stream Actes","Parcours Typaut UM",
"Stream DP/DR des UM","Stream Das")
}
else{
v <- c(v[!is.na(v)],"Ghm", "Année séq. de tarifs",
"Types Aut. à Portée Globale", "Supp. Radiothérapies",
"Stream Actes","Parcours Typaut UM","Stream DP/DR des UM","Stream Das")
}
rsa_i <- rsa_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(rsa_i) <- tolower(names(rsa_i))
names(actes) <- tolower(names(actes))
names(das) <- tolower(names(das))
names(rsa_um) <- tolower(names(rsa_um))
}
rsa_1 <- list(rsa = rsa_i , actes = actes, das = das, rsa_um = rsa_um)
class(rsa_1) <- append(class(rsa_1),"RSA")
#cat(paste("MCO RSA Standard++",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
#cat("Les tables rsa, acdi et rsa_um sont dans l'environnement de travail\n")
attr(rsa_1,"problems") <- synthese_import
return(rsa_1)
}
cat("Quel type d'import ?\n")
typo <- data.frame(Type=c(1,
2,
3,
4,
5,
6),
Import=c('Light : Partie fixe',
'Light+ : Partie fixe + stream en ligne (+) actes et das',
'Light++ : Partie fixe + stream en ligne (++) actes, das, typaut um et dpdr des um',
'Standard : Partie fixe + création des tables acdi et rsa_um',
'Standard+ : Partie fixe + création des tables acdi et rsa_um + stream (+)',
'Standard++ : Partie fixe + création des tables acdi et rsa_um + stream (++)'),
Temps=c('Très Rapide','Rapide','Long','Rapide', 'Long','Long'),
`Temps rapporté`=c('= 1','* 4 (~)','* 9 (~)','* 4 (~)','* 6 (~)', '* 10 (~)'))
cat(knitr::kable(typo),sep='\n')
n <- readline(prompt="Taper le type d'import voulu : ")
return(irsa(finess,annee,mois,path,lib,n, ...))
}
#' ~ TRA - Import du TRA
#'
#' Import du fichier TRA, 4 champs PMSI couverts.
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu (sortie de Genrsa) :
#' \emph{finess.annee.moisc.tra}
#'
#' \strong{750712184.2016.2.tra}
#'
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param champ Champ PMSI du TRA a integrer ("mco", "ssr", "had", "psy_rpsa", ", "psy_r3a"), par defaut "mco"
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premières lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame ou tibble) qui contient : - Clé RSA - NORSS - Numéro de ligne du fichier RSS d'origine (rss.ini) - NAS - Date d'entrée du séjour - GHM groupage du RSS (origine) - Date de sortie du séjour
#'
#' @examples
#' \dontrun{
#' itra('750712184',2015,12,'~/Documents/data/champ_pmsi') -> tra15
#' }
#'
#' @author G. Pressiat
#'
#' @usage itra(finess, annee, mois, path, lib = T, tolower_names = F, champ = "mco")
#' @seealso \code{\link{irum}}, \code{\link{irsa}}, \code{\link{ileg_mco}}, \code{\link{iano_mco}}, \code{\link{irha}}, \code{\link{irapss}}, \code{\link{irpsa}}, \code{\link{ir3a}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @export itra
#' @export
itra <- function(...){
UseMethod('itra')
}
#' @export
itra.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(itra.default, param2)
}
#' @export
itra.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(itra.default, param2)
}
#' @export
itra.default <- function(finess, annee, mois, path, lib = T, champ= "mco", tolower_names = F, ... ){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (champ == "mco" & paste0(annee, stringr::str_pad(mois, 2, 'left', '0')) >= '202303') {
# Druides
champ1 = champ
format <- pmeasyr::formats %>% dplyr::filter(champ == champ1, table == 'tra')
tra_i <- readr::read_delim(paste0(path,"/",finess,".",annee,".",mois,".tra.txt"), delim = ";",
col_names = c('CLE_RSA', 'NORSS', 'NAS', 'DTENT', 'DTSORT', 'GHM1', 'filler'),
col_types = readr::cols(.default = readr::col_character())) %>%
dplyr::mutate(NO_ligne_RSS = "") %>%
dplyr::select(format$nom)
tra_i <- tra_i %>%
dplyr::mutate(DTENT = lubridate::dmy(DTENT, quiet = TRUE),
DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
NOHOP = paste0("000",stringr::str_sub(NAS,1,2))) %>%
dplyr::mutate_if(is.character, stringr::str_trim)
if (tolower_names){
names(tra_i) <- tolower(names(tra_i))
}
if (lib == T){
v <- c(format$libelle, 'Établissement')
return(tra_i %>% sjlabelled::set_label(v))
} else {
return(tra_i)
}
} else if (!grepl("psy",champ)){
champ1 = champ
format <- pmeasyr::formats %>% dplyr::filter(champ == champ1, table == 'tra')
} else {
champ1 = champ
format <- pmeasyr::formats %>% dplyr::filter(champ == "psy", table == champ1)
}
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (champ=="mco"){
tra_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".tra.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(tra_i) -> synthese_import
tra_i <- tra_i %>%
dplyr::mutate(DTENT = lubridate::dmy(DTENT, quiet = TRUE),
DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
NOHOP = paste0("000",stringr::str_sub(NAS,1,2)))
}
if (champ=="had"){
tra_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".tra"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(tra_i) -> synthese_import
tra_i <- tra_i %>%
dplyr::mutate(DTENT = lubridate::dmy(DTENT, quiet = TRUE),
DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
NOHOP = paste0("000",stringr::str_sub(NAS,1,2)),
DTNAI = lubridate::dmy(DTNAI, quiet = TRUE),
DT_DEB_SEQ = lubridate::dmy(DT_DEB_SEQ, quiet = TRUE),
DT_FIN_SEQ = lubridate::dmy(DT_FIN_SEQ, quiet = TRUE),
DT_DEB_SS_SEQ = lubridate::dmy(DT_DEB_SS_SEQ, quiet = TRUE),
DT_FIN_SS_SEQ = lubridate::dmy(DT_FIN_SS_SEQ, quiet = TRUE))
}
if (champ=="ssr"){
tra_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".tra"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(tra_i) -> synthese_import
tra_i <- tra_i %>%
dplyr::mutate(NOHOP = paste0("000",stringr::str_sub(NAS,1,2)))
}
if (champ=="psy_rpsa"){
if (as.character(annee) < '2020'){
extens <- '.tra.txt'
} else {
extens <- '.tra'
}
tra_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois, extens),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(tra_i) -> synthese_import
tra_i <- tra_i %>%
dplyr::mutate(NOHOP = paste0("000",stringr::str_sub(NAS,1,2)),
DTENT = lubridate::dmy(DTENT),
DTSORT = lubridate::dmy(DTSORT),
DT_DEB_SEQ = lubridate::dmy(DT_DEB_SEQ, quiet = TRUE),
DT_FIN_SEQ = lubridate::dmy(DT_FIN_SEQ, quiet = TRUE))
}
if (champ=="psy_r3a"){
if (as.character(annee) < '2020'){
extens <- '.tra.raa.txt'
} else {
extens <- '.tra.raa'
}
tra_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois, extens),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(tra_i) -> synthese_import
tra_i <- tra_i %>%
dplyr::mutate(DTACTE = lubridate::dmy(DTACTE, quiet = TRUE),
DTACTE_2 = lubridate::dmy(DTACTE_2, quiet = TRUE))
}
if (lib==T & champ !="psy_r3a"){
if (tolower_names){
names(tra_i) <- tolower(names(tra_i))
}
v <- c(libelles, 'Établissement')
return(tra_i %>% sjlabelled::set_label(v))
}
if (lib==T & champ =="psy_r3a"){
if (tolower_names){
names(tra_i) <- tolower(names(tra_i))
}
v <- libelles
return(tra_i %>% sjlabelled::set_label(v))
}
if (tolower_names){
names(tra_i) <- tolower(names(tra_i))
}
attr(tra_i,"problems") <- synthese_import
return(tra_i)
}
#' ~ MCO - Import des Anohosp
#'
#' Import du fichier ANO In ou Out.
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu :
#' \emph{finess.annee.moisc.ano}
#' \emph{finess.annee.moisc.ano.txt}
#'
#' \strong{750712184.2016.2.ano}
#' \strong{750712184.2016.2.ano.txt}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des données sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typano Type de donnees In / Out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame ou tibble) qui contient les données Anohosp in / out
#'
#' @examples
#' \dontrun{
#' iano_mco('750712184',2015,12,'~/Documents/data/mco') -> ano_out15
#' iano_mco('750712184',2015,12,'~/Documents/data/mco', typano = "in") -> ano_in15
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irum}}, \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @export iano_mco
#' @usage iano_mco(finess, annee, mois, path, lib = T, tolower_names = F, typano = "out")
#' @export
iano_mco <- function( ...){
UseMethod('iano_mco')
}
#' @export
iano_mco.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iano_mco.default, param2)
}
#' @export
iano_mco.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iano_mco.default, param2)
}
#' @export
iano_mco.default <- function(finess, annee, mois, path, typano = c("out", "in"), lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
typano <- match.arg(typano)
if (!(typano %in% c('in', 'out'))){
stop('Paramètre typano incorrect')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (typano=="out"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa_ano', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (annee>=2013){
ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') +
(CRCDNAI=='0') + (CRCSEXE=='0')==9),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
MTRMBAMC = MTRMBAMC/100,
TAUXRM = TAUXRM /100,
MTMALPAR = MTMALPAR/100)
}
if (2011<annee & annee<2013){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') == 7),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
MTRMBAMC = MTRMBAMC/100,
TAUXRM = TAUXRM /100,
MTMALPAR = MTMALPAR/100)
}
if (annee == 2011){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') == 7),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMALPAR = MTMALPAR/100)
}
Fillers <- names(ano_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="Fil"]
ano_i <- ano_i[,!(names(ano_i) %in% Fillers)]
if (lib==T){
v <- c(libelles[!is.na(libelles)], "Chaînage Ok")
ano_i <- ano_i %>% sjlabelled::set_label(v)
}
}
if (typano=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rum_ano', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (2011<annee){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTHOSP = lubridate::dmy(DTHOSP, quiet = TRUE),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTRMAMC = MTRMAMC /100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
if (annee == 2011){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
Fillers <- names(ano_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
ano_i <- ano_i[,!(names(ano_i) %in% Fillers)]
if (lib==T){
v <- libelles[!is.na(libelles)]
ano_i <- ano_i %>% sjlabelled::set_label(v)
}
}
if (tolower_names){
names(ano_i) <- tolower(names(ano_i))
}
attr(ano_i,"problems") <- synthese_import
return(ano_i)
}
#' ~ MCO - Import des Med
#'
#' Import des fichiers MED In ou Out.
#'
#' Formats depuis 2011 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typmed Type de donnees In / Out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les médicaments In ou Out
#' (T2A, ATU et thrombo selon l'existence des fichiers : si le fichier n'existe pas, pas de donnée importée).
#' Pour discriminer le type de prestation, la colonne TYPEPREST donne l'information : T2A 06 - ATU 09 - THROMBO 10
#'
#' @examples
#' \dontrun{
#' imed_mco('750712184',2015,12,'~/Documents/data/mco') -> med_out15
#' imed_mco('750712184',2015,12,'~/Documents/data/mco', typmed = "in") -> med_in15
#' }
#'
#' @author G. Pressiat
#'
#' @usage imed_mco(finess, annee, mois, path, lib = T, tolower_names = F, typmed = c('out', 'in'))
#' @seealso \code{\link{irum}}, \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @export imed_mco
#' @export
imed_mco <- function(...){
UseMethod('imed_mco')
}
#' @export
imed_mco.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(imed_mco.default, param2)
}
#' @export
imed_mco.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(imed_mco.default, param2)
}
#' @export
imed_mco.default <- function(finess, annee, mois, path, typmed = c("out", "in"), lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
typmed <- match.arg(typmed)
if (!(typmed %in% c('in', 'out'))){
stop('Paramètre typmed incorrect')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (typmed=="out"){
# med_out
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa_med', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
med_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".med"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(med_i) -> synthese_import
med_i <- med_i %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000)
info = file.info(paste0(path,"/",finess,".",annee,".",mois,".medatu"))
if (info$size >0 & !is.na(info$size)){
med_i2<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".medatu"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
synthese_import <- dplyr::bind_rows(synthese_import, readr::problems(med_i2))
med_i2 <- med_i2 %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000)
med_i <- rbind(med_i,med_i2)
}
info = file.info(paste0(path,"/",finess,".",annee,".",mois,".medthrombo"))
if (info$size >0 & !is.na(info$size)){
med_i3<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".medthrombo"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
synthese_import <- dplyr::bind_rows(synthese_import, readr::problems(med_i3))
med_i3 <- med_i3 %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000)
med_i <- rbind(med_i,med_i3)
}
if (lib==T){
v <- libelles
med_i <- med_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(med_i) <- tolower(names(med_i))
}
attr(med_i,"problems") <- synthese_import
return(med_i)
}
if (typmed=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rum_med', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
info = file.info(paste0(path,"/",finess,".",annee,".",mois,".med.txt"))
if (info$size >0 & !is.na(info$size)){
med_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".med.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(med_i) -> synthese_import
med_i <- med_i %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000)
}
if (lib==T){
v <- libelles
v<- v[!is.na(v)]
med_i <- med_i %>% sjlabelled::set_label(v)
}
med_i %>% dplyr::mutate(DTDISP = lubridate::dmy(DTDISP, quiet = TRUE)) -> med_i
if (tolower_names){
names(med_i) <- tolower(names(med_i))
}
attr(med_i,"problems") <- synthese_import
return(med_i)
}
}
#' ~ MCO - Import des DMI
#'
#' Import des fichiers DMI In ou Out.
#'
#' Formats depuis 2011 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typdmi Type de donnees In / Out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les dispositifs médicaux implantables In ou Out (T2A, ATU et thrombo selon l'existence des fichiers :
#' si le fichier n'existe pas, pas de donnée importée). Pour discriminer le type de prestation, la colonne TYPEPREST donne l'information :
#' T2A 06 - ATU 09 - THROMBO 10
#'
#' @examples
#' \dontrun{
#' idmi_mco('750712184',2015,12,'~/Documents/data/mco') -> dmi_out15
#' idmi_mco('750712184',2015,12,'~/Documents/data/mco', typdmi = "in") -> dmi_in15
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irum}}, \code{\link{irsa}}
#' @export idmi_mco
#' @export
idmi_mco <- function(...){
UseMethod('idmi_mco')
}
#' @export
idmi_mco.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(idmi_mco.default, param2)
}
#' @export
idmi_mco.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(idmi_mco.default, param2)
}
#' @export
idmi_mco.default <- function(finess, annee, mois, path, typdmi = c("out", "in"), lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
typdmi <- match.arg(typdmi)
if (!(typdmi %in% c('in', 'out'))){
stop('Paramètre typdmi incorrect')
}
#op <- options(digits.secs = 6)
un<-Sys.time()
if (typdmi=="out"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa_dmi', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
dmi_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".dmip"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(dmi_i) -> synthese_import
dmi_i <- dmi_i %>%
dplyr::mutate(PRIX = PRIX /1000)
if (lib==T){
v <- libelles
dmi_i <- dmi_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(dmi_i) <- tolower(names(dmi_i))
}
attr(dmi_i,"problems") <- synthese_import
return(dmi_i)
}
if (typdmi=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rum_dmi', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
dmi_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".dmi.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(dmi_i) -> synthese_import
dmi_i <- dmi_i %>%
dplyr::mutate(PRIX = PRIX /1000,
DTPOSE = lubridate::dmy(DTPOSE, quiet = TRUE))
if (lib==T){
v <- libelles
v <- v[!is.na(v)]
dmi_i <- dmi_i %>% dplyr::select(-Fil1,-Fil2) %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(dmi_i) <- tolower(names(dmi_i))
}
attr(dmi_i,"problems") <- synthese_import
return(dmi_i)
}
}
#' ~ MCO - Import des IVG
#'
#' Import des fichiers IVG In ou Out.
#'
#' Formats depuis 2017 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typivg Type de donnees In / Out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les IVG In ou Out
#' (si le fichier n'existe pas, pas de donnée importée).
#' Le TYPEPREST est par defaut 53
#'
#' @examples
#' \dontrun{
#' iivg_mco('750712184', 2017, 12,'~/Documents/data/mco') -> ivg_out17
#' iivg_mco('750712184', 2017, 12,'~/Documents/data/mco', typivg = "in") -> ivg_in17
#' }
#'
#' @author G. Pressiat, N. Taright
#'
#' @usage iivg_mco(finess, annee, mois, path, lib = T, tolower_names = F, typivg = c('out', 'in'))
#' @seealso \code{\link{irum}}, \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @export iivg_mco
#' @export
iivg_mco <- function(...){
UseMethod('iivg_mco')
}
#' @export
iivg_mco.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iivg_mco.default, param2)
}
#' @export
iivg_mco.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iivg_mco.default, param2)
}
#' @export
iivg_mco.default <- function(finess, annee, mois, path, typivg = c("out", "in"), lib = T, tolower_names = F, ...){
if (annee<2017|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
typivg <- match.arg(typivg)
if (!(typivg %in% c('in', 'out'))){
stop('Paramètre typivg incorrect')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (typivg == "out"){
# ivg_out
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa_ivg', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
ivg_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ivg"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ivg_i) -> synthese_import
if (lib==T){
v <- libelles
ivg_i <- ivg_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(ivg_i) <- tolower(names(ivg_i))
}
attr(ivg_i,"problems") <- synthese_import
return(ivg_i)
}
if (typivg=="in"){
# ivg_in
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rum_ivg', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
# info = file.info(paste0(path,"/",finess,".",annee,".",mois,".ivg.txt"))
# if (info$size >0 & !is.na(info$size)){
ivg_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ivg.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ivg_i) -> synthese_import
# }
if (lib==T){
v <- libelles
v<- v[!is.na(v)]
ivg_i <- ivg_i %>% sjlabelled::set_label(v)
}
ivg_i %>%
dplyr::mutate(D8EEUE = lubridate::dmy(D8EEUE, quiet = TRUE),
D8SOUE = lubridate::dmy(D8SOUE, quiet = TRUE)) -> ivg_i
if (tolower_names){
names(ivg_i) <- tolower(names(ivg_i))
}
attr(ivg_i,"problems") <- synthese_import
return(ivg_i)
}
}
#' ~ MCO - Import des transports (TPT)
#'
#' Import des fichiers TPT In ou Out.
#'
#' Formats depuis 2021 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typtpt Type de donnees In / Out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les transports In ou Out
#' (si le fichier n'existe pas, pas de donnée importée).
#' Le TYPEPREST est par defaut 15
#'
#' @examples
#' \dontrun{
#' itpt_mco('750712184', 2021, 12,'~/Documents/data/mco') -> tpt_out15
#' itpt_mco('750712184', 2021, 12,'~/Documents/data/mco', typtpt = "in") -> tpt_in15
#' }
#'
#' @author G. Pressiat, N. Taright
#'
#' @usage itpt_mco(finess, annee, mois, path, lib = T, tolower_names = F, typtpt = c('out', 'in'))
#' @seealso \code{\link{irum}}, \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @export itpt_mco
#' @export
itpt_mco <- function(...){
UseMethod('itpt_mco')
}
#' @export
itpt_mco.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(itpt_mco.default, param2)
}
#' @export
itpt_mco.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(itpt_mco.default, param2)
}
#' @export
itpt_mco.default <- function(finess, annee, mois, path, typtpt = c("out", "in"), lib = T, tolower_names = F, ...){
if (annee < 2021 | annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
typtpt <- match.arg(typtpt)
if (!(typtpt %in% c('in', 'out'))){
stop('Paramètre typtpt incorrect')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (typtpt == "out"){
# TPT out
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa_tpt', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
tpt_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".transport"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(tpt_i) -> synthese_import
tpt_i <- tpt_i %>%
dplyr::mutate(DTALLER = lubridate::dmy(DTALLER, quiet = TRUE))
if (lib==T){
v <- libelles
tpt_i <- tpt_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(tpt_i) <- tolower(names(tpt_i))
}
attr(tpt_i,"problems") <- synthese_import
return(tpt_i)
}
if (typtpt=="in"){
# TPT in
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rum_tpt', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
tpt_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".transp.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(tpt_i) -> synthese_import
if (lib==T){
v <- libelles
# v<- v[!is.na(v)]
tpt_i <- tpt_i %>% sjlabelled::set_label(v)
}
tpt_i %>%
dplyr::mutate(DTALLER = lubridate::dmy(DTALLER, quiet = TRUE)) -> tpt_i
if (tolower_names){
names(tpt_i) <- tolower(names(tpt_i))
}
attr(tpt_i,"problems") <- synthese_import
return(tpt_i)
}
}
#' ~ MCO - Import des erreurs Leg
#'
#' Import de la liste d'erreurs de génération Genrsa
#'
#' Formats depuis 2011 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param reshape booleen TRUE/FALSE : la donnee doit-elle etre restructuree ? une ligne = une erreur, sinon, une ligne = un sejour. par defaut a F
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les erreurs Out.
#'
#' @examples
#' \dontrun{
#' ileg_mco('750712184',2015,12,'~/Documents/data/mco') -> leg15
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irum}}, \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @export ileg_mco
#' @usage ileg_mco(finess, annee, mois, path, reshape = F, tolower_names = F, ...)
#' @export
ileg_mco <- function(...){
UseMethod('ileg_mco')
}
#' @export
ileg_mco.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(ileg_mco.default, param2)
}
#' @export
ileg_mco.list <- function(l , ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(ileg_mco.default, param2)
}
#' @export
ileg_mco.default <- function(finess, annee, mois, path, reshape = F, tolower_names = F, ...){
leg_i <- readr::read_lines(paste0(path,"/",finess,".",annee,".",mois,".leg"), ...)
leg_i1 <- tibble::tibble(l = leg_i) %>%
tidyr::separate(l, c('FINESS', 'MOIS', 'ANNEE', 'CLE_RSA', 'NBERR', 'ERRS'), ";", extra = "merge")
if (reshape==FALSE){
leg_i1 <- leg_i1 %>%
dplyr::mutate(EG = stringr::str_replace_all(ERRS, ";", ", ")) %>%
dplyr::select(-ERRS)
if (tolower_names){
names(leg_i1) <- tolower(names(leg_i1))
}
return(leg_i1)
}
u <- stringr::str_split(leg_i1$ERRS, ";") %>% purrr::flatten_chr()
leg_i1 <- tibble::as_tibble(lapply(leg_i1, rep, leg_i1$NBERR), stringsAsFactors = F)
leg_i2 <- dplyr::bind_cols(leg_i1, data.frame(EG = as.character(u), stringsAsFactors = F))
leg_i2 <- leg_i2 %>%
dplyr::mutate(ERRS = stringr::str_replace_all(ERRS, ";", ", "))
if (tolower_names){
names(leg_i2) <- tolower(names(leg_i2))
}
return(leg_i2)
}
#' ~ TRA - Ajout du TRA aux donnees Out
#'
#' Ajout du TRA par dplyr::inner_join
#'
#'
#' @param table Table a laquelle rajouter le tra
#' @param tra tra a rajouter
#' @param sel Variable a garder du tra ; sel = 1 : numero de sejour, sel = 2 : toutes les variables
#' @param champ Champ PMSI : mco, had, ssr, psy : deux tra en psy : psy_rpsa, psy_r3a
#'
#' @return Une table contenant le inner_join entre table et tra
#'
#' @examples
#' \dontrun{
#' med <- imed_mco('750712184',2015,12,"~/Documents/data/mco","out")
#' tra <- itra('750712184',2015,12,"~/Documents/data/mco")
#' med <- inner_tra(med,tra)
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irum}}, \code{\link{irsa}}, \code{\link{imed_mco}}, \code{\link{irpsa}}, \code{\link{irha}}, \code{\link{irapss}}
#' @export
inner_tra <- function(table, tra, sel = 1, champ = "mco"){
#inner_tra <- function(table, tra ){
suppressMessages( dplyr::inner_join(table, tra) )
if (champ == "mco"){
if (sel==1){
return( suppressMessages( dplyr::inner_join(table, tra %>% dplyr::select(c(1:2,4,8)))))
}
if (sel==2){
return( suppressMessages( dplyr::inner_join(table, tra )))
}
}
if (champ == "had"){
if (sel==1){
return( suppressMessages( dplyr::inner_join(table, tra %>% dplyr::select(1:4))))
}
if (sel==2){
return( suppressMessages( dplyr::inner_join(table, tra)))
}
}
if (champ == "ssr"){
if (sel==1){
return(suppressMessages( dplyr::inner_join(table, tra %>% dplyr::select(c(1,3,4,5)))))
}
if (sel==2){
return(suppressMessages( dplyr::inner_join(table, tra)))
}
}
if (champ == "psy_rpsa"){
if (sel==1){
return(suppressMessages( dplyr::inner_join(table, tra %>% dplyr::select(c(3:5,10)))))
}
if (sel==2){
return(suppressMessages( dplyr::inner_join(table, tra)))
}
}
if (champ == "psy_r3a"){
if (sel==1){
return(suppressMessages( dplyr::inner_join(table, tra)))
}
if (sel==2){
return(suppressMessages( dplyr::inner_join(table, tra)))
}
}
if (!(sel %in% 1:2)){
print("Paramètre sel incorrect")
return(NULL)
}
if (!(champ %in% c('mco','had','ssr','psyrpsa','psyr3a'))){
print("Paramètre champ incorrect")
return(NULL)
}
}
#' ~ MCO - Import des DIAP
#'
#' Imports des fichiers DIAP In / Out
#'
#' Formats depuis 2011 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typdiap Type de donnees In / Out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les dialyses péritonéales In ou Out.
#'
#' @examples
#' \dontrun{
#' idiap <- idiap('750712184',2015,12,"~/Documents/data/mco")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irum}}, \code{\link{irsa}}
#' @usage idiap(finess, annee, mois, path,
#' typdiap = c("out", "in"),
#' lib = T, tolower_names = F, ...)
#' @export idiap
#' @export
idiap <- function(...){
UseMethod('idiap')
}
#' @export
idiap.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(idiap.default, param2)
}
#' @export
idiap.list <- function(l , ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(idiap.default, param2)
}
#' @export
idiap.default <- function(finess, annee, mois, path,
typdiap = c("out", "in"), lib = T,
tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
typdiap <- match.arg(typdiap)
if (!(typdiap %in% c('in', 'out'))){
stop('Paramètre typdiap incorrect')
}
#op <- options(digits.secs = 6)
un<-Sys.time()
if (typdiap=="out"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa_diap', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
diap_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".diap"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(diap_i) -> synthese_import
if (lib==T){
v <- libelles
diap_i <- diap_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(diap_i) <- tolower(names(diap_i))
}
attr(diap_i,"problems") <- synthese_import
return(diap_i)
}
if (typdiap=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'ffc_in', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
diap_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".diap.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(diap_i) -> synthese_import
diap_i <- diap_i %>%
dplyr::mutate(DTDEBUT = lubridate::dmy(DTDEBUT, quiet = TRUE))
if (lib==T){
v <- libelles
diap_i <- diap_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(diap_i) <- tolower(names(diap_i))
}
attr(diap_i,"problems") <- synthese_import
return(diap_i)
}
}
#' ~ MCO - Import des donnees UM du Out
#'
#' Imports du fichier IUM MCO
#'
#' Formats depuis 2011 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires à passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les informations structures du Out.
#'
#' @examples
#' \dontrun{
#' um <- iium('750712184',2015,12,"~/Documents/data/mco")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage iium(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export iium
#' @export
iium <- function(...){
UseMethod('iium')
}
#' @export
iium.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iium.default, param2)
}
#' @export
iium.list <- function(l , ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iium.default, param2)
}
#' @export
iium.default <- function(finess, annee, mois, path, lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'um', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
ium_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ium"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ium_i) -> synthese_import
ium_i <- ium_i %>%
dplyr::mutate(DTEAUT = lubridate::dmy(DTEAUT, quiet = TRUE))
if (lib==T){
v <- libelles
ium_i <- ium_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(ium_i) <- tolower(names(ium_i))
}
attr(ium_i,"problems") <- synthese_import
return(ium_i)
}
#' ~ MCO - Import des donnees correspondances d'UM du Out
#'
#' Imports du fichier IUM corresp MCO
#'
#' Formats depuis 2020 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2020)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires à passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les informations Um out/UM in.
#'
#' @examples
#' \dontrun{
#' um_corresp <- iium_corresp('750712184',2020,12,"~/Documents/data/mco")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage iium_corresp(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export iium_corresp
#' @export
iium_corresp <- function(...){
UseMethod('iium_corresp')
}
#' @export
iium_corresp.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iium_corresp.default, param2)
}
#' @export
iium_corresp.list <- function(l , ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iium_corresp.default, param2)
}
#' @export
iium_corresp.default <- function(finess, annee, mois, path, tolower_names = F, ...){
fp <- paste0(path,"/",finess,".",annee,".",mois,".ium.correspnumseq.txt")
umcorresp_i <- readr::read_delim(fp, col_names = c('NOSEQUM', 'CDURM'),
col_types = readr::cols(NOSEQUM = readr::col_character(),
CDURM = readr::col_character()), skip = 0L, delim = ";")
if (tolower_names){
names(umcorresp_i) <- tolower(names(umcorresp_i))
}
return(umcorresp_i)
}
#' ~ MCO - Import des PO
#'
#' Imports des fichiers PO In / Out
#'
#' Formats depuis 2011 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typpo Type de donnees In / Out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#' @return Une table (data.frame, tibble) contenant les prélèvements d'organes In ou Out.
#'
#' @examples
#' \dontrun{
#' po <- ipo('750712184',2015,12,"~/Documents/data/mco")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irum}}, \code{\link{irsa}}, utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage ipo(finess, annee, mois, path, typpo = c("out", "in"), lib = T, tolower_names = F, ...)
#' @export ipo
#' @export
ipo <- function( ...){
UseMethod('ipo')
}
#' @export
ipo.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(ipo.default, param2)
}
#' @export
ipo.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(ipo.default, param2)
}
#' @export
ipo.default <- function(finess, annee, mois, path, typpo = c("out", "in"), lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
typpo <- match.arg(typpo)
if (!(typpo %in% c('in', 'out'))){
stop('Paramètre typpo incorrect')
}
#op <- options(digits.secs = 6)
un<-Sys.time()
if (typpo=="out"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa_po', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
po_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".porg"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(po_i) -> synthese_import
if (lib==T){
v <- libelles
po_i <- po_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(po_i) <- tolower(names(po_i))
}
attr(po_i,"problems") <- synthese_import
return(po_i)
}
if (typpo=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'ffc_in', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
po_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".porg.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(po_i) -> synthese_import
po_i <- po_i %>%
dplyr::mutate(DTDEBUT = lubridate::dmy(DTDEBUT, quiet = TRUE))
if (lib==T){
v <- libelles
po_i <- po_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(po_i) <- tolower(names(po_i))
}
attr(po_i,"problems") <- synthese_import
return(po_i)
}
}
##############################################
####################### HAD ##################
##############################################
#' ~ HAD - Import des RAPSS
#'
#' Imports du fichier RAPSS
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu (sortie de Paprica) :
#' \emph{finess.annee.moisc.rapss}
#'
#' \strong{750712184.2016.2.rapss}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des données sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une classe S3 contenant les tables (data.frame, tibble ou tbl) importées (rapss, acdi, ght).
#'
#' @examples
#' \dontrun{
#' um <- iium('750712184',2015,12,"~/Documents/data/had")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{iano_had}}, \code{\link{ileg_had}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage irapss(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export irapss
#' @export
irapss <- function(...){
UseMethod('irapss')
}
#' @export
irapss.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(irapss.default, param2)
}
#' @export
irapss.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(irapss.default, param2)
}
#' @export
irapss.default <- function(finess, annee, mois, path, lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
# cat(paste("L'objet retourné prendra la forme d'une classe S3.
# $rapss pour accéder à la table RSA
# $acdi pour accéder à la table ACDI
# $ght pour accéder aux ght etb et paprica\n\n"))
if(annee >= 2020 & mois >= 3) {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss', an == "20_H33")
} else if(annee == 2021 & mois < 3) {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss', an == "20_H33")
} else {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss', an == substr(as.character(annee),3,4))
}
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
extz <- function(x,pat){unlist(lapply(stringr::str_extract_all(x,pat),toString) )}
rapss_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rapss"),
readr::fwf_widths(af,an), col_types = at , na=character(),...)
readr::problems(rapss_i) -> synthese_import
if (annee==2011){
zght <- ".{5}"
zd <- ".{1,6}"
zA <- ".{1,17}"
rapss_i <- rapss_i %>% dplyr::mutate(
# Diagnostics et actes
da = ifelse(NBDA>0,stringr::str_sub(Z,1,NBDA*6),""),
lda = stringr::str_extract_all(da,zd),
za = ifelse(NBZA>0,stringr::str_sub(Z,1+NBDA*6,NBDA*6+NBZA*17),""),
lactes = stringr::str_extract_all(za,zA),
# groupage Etablissement
NOVRPSS = stringr::str_sub(Z, 1+NBDA*6+NBZA*17, NBDA*6+NBZA*17+3),
ETB_VCLASS = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+3, NBDA*6+NBZA*17+3+2),
ETB_CDRETR = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+3+2, NBDA*6+NBZA*17+3+2+3),
ETB_GHPC = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+3+2+3, NBDA*6+NBZA*17+3+2+3+4),
ETB_NBGHT = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+3+2+3+4, NBDA*6+NBZA*17+3+2+3+4+1) %>% as.numeric(),
etb_ght = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+13,NBDA*6+NBZA*17+13+5*ETB_NBGHT),
letb_ght = stringr::str_extract_all(etb_ght,zght),
# groupage Paprica
PAPRICA_VCLASS = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+13+5*ETB_NBGHT,NBDA*6+NBZA*17+13+5*ETB_NBGHT+2),
PAPRICA_CDRETR = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2,NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3),
PAPRICA_GHPC = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3,NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3+4),
PAPRICA_NBGHT = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3+4,NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3+4+1) %>% as.numeric(),
pap_ght = stringr::str_sub(Z,1+NBDA*6+NBZA*17+13+5*ETB_NBGHT+10,NBDA*6+NBZA*17+13+5*ETB_NBGHT+10+PAPRICA_NBGHT*5),
lpap_ght = stringr::str_extract_all(pap_ght,zght)
)
}
if (2011< annee & annee<=2014){
zght <- ".{5}"
zd <- ".{1,6}"
zA <- ".{1,17}"
rapss_i <- rapss_i %>% dplyr::mutate(
# Diagnostics et actes
dmpp = ifelse(NBDIAGMPP>0,stringr::str_sub(Z,1,NBDIAGMPP*6),""),
ldmpp = stringr::str_extract_all(dmpp,zd),
dmpa = ifelse(NBDIAGMPA>0,stringr::str_sub(Z,1+NBDIAGMPP*6,NBDIAGMPP*6+NBDIAGMPA*6),""),
ldmpa = stringr::str_extract_all(dmpa,zd),
da = ifelse(NBDA>0,stringr::str_sub(Z,1+NBDIAGMPP*6+NBDIAGMPA*6,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6),""),
lda = stringr::str_extract_all(da,zd),
za = ifelse(NBZA>0,stringr::str_sub(Z,1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17),""),
lactes = stringr::str_extract_all(za,zA),
# groupage Etablissement
NOVRPSS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3),
ETB_VCLASS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3+2),
ETB_CDRETR = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3+2, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3+2+3),
ETB_GHPC = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3+2+3, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3+2+3+4),
ETB_NBGHT = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3+2+3+4, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3+2+3+4+1) %>% as.numeric(),
etb_ght = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT),
letb_ght = stringr::str_extract_all(etb_ght,zght),
# groupage Paprica
PAPRICA_VCLASS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2),
PAPRICA_CDRETR = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3),
PAPRICA_GHPC = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3+4),
PAPRICA_NBGHT = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3+4,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3+4+1) %>% as.numeric(),
pap_ght = stringr::str_sub(Z,1+ NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+10,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+10+PAPRICA_NBGHT*5),
lpap_ght = stringr::str_extract_all(pap_ght,zght)
)
}
if (annee>2014 & annee<2020){
zght <- ".{5}"
zd <- ".{1,6}"
zA <- ".{1,19}"
rapss_i <- rapss_i %>% dplyr::mutate(
DP = stringr::str_trim(DP),
# Diagnostics et actes
dmpp = ifelse(NBDIAGMPP>0,stringr::str_sub(Z,1,NBDIAGMPP*6),""),
ldmpp = stringr::str_extract_all(dmpp,zd),
dmpa = ifelse(NBDIAGMPA>0,stringr::str_sub(Z,1+NBDIAGMPP*6,NBDIAGMPP*6+NBDIAGMPA*6),""),
ldmpa = stringr::str_extract_all(dmpa,zd),
da = ifelse(NBDA>0,stringr::str_sub(Z,1+NBDIAGMPP*6+NBDIAGMPA*6,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6),""),
lda = stringr::str_extract_all(da,zd),
za = ifelse(NBZA>0,stringr::str_sub(Z,1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19),""),
lactes = stringr::str_extract_all(za,zA),
# groupage Etablissement
NOVRPSS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3),
ETB_VCLASS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3+2),
ETB_CDRETR = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3+2, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3+2+3),
ETB_GHPC = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3+2+3, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3+2+3+4),
ETB_NBGHT = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3+2+3+4, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3+2+3+4+1) %>% as.numeric(),
etb_ght = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT),
letb_ght = stringr::str_extract_all(etb_ght,zght),
# groupage Paprica
PAPRICA_VCLASS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+2),
PAPRICA_CDRETR = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+2,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+2+3),
PAPRICA_GHPC = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+2+3,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+2+3+4),
PAPRICA_NBGHT = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+2+3+4,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+2+3+4+1) %>% as.numeric(),
pap_ght = stringr::str_sub(Z,1+ NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+10,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+10+PAPRICA_NBGHT*5),
lpap_ght = stringr::str_extract_all(pap_ght,zght)
)
}
if (annee>=2020){
zght <- ".{5}"
zd <- ".{1,6}"
zA <- ".{1,20}"
rapss_i <- rapss_i %>% dplyr::mutate(
DP = stringr::str_trim(DP),
# Diagnostics et actes
dmpp = ifelse(NBDIAGMPP>0,stringr::str_sub(Z,1,NBDIAGMPP*6),""),
ldmpp = stringr::str_extract_all(dmpp,zd),
dmpa = ifelse(NBDIAGMPA>0,stringr::str_sub(Z,1+NBDIAGMPP*6,NBDIAGMPP*6+NBDIAGMPA*6),""),
ldmpa = stringr::str_extract_all(dmpa,zd),
da = ifelse(NBDA>0,stringr::str_sub(Z,1+NBDIAGMPP*6+NBDIAGMPA*6,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6),""),
lda = stringr::str_extract_all(da,zd),
za = ifelse(NBZA>0,stringr::str_sub(Z,1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20),""),
lactes = stringr::str_extract_all(za,zA),
# groupage Etablissement
NOVRPSS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3),
ETB_VCLASS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3+2),
ETB_CDRETR = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3+2, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3+2+3),
ETB_GHPC = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3+2+3, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3+2+3+4),
ETB_NBGHT = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3+2+3+4, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3+2+3+4+1) %>% as.numeric(),
etb_ght = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT),
letb_ght = stringr::str_extract_all(etb_ght,zght),
# groupage Paprica
PAPRICA_VCLASS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+2),
PAPRICA_CDRETR = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+2,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+2+3),
PAPRICA_GHPC = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+2+3,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+2+3+4),
PAPRICA_NBGHT = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+2+3+4,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+2+3+4+1) %>% as.numeric(),
pap_ght = stringr::str_sub(Z,1+ NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+10,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+10+PAPRICA_NBGHT*5),
lpap_ght = stringr::str_extract_all(pap_ght,zght)
)
}
if (annee>2011){
actes <- purrr::flatten_chr(rapss_i$lactes)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,NBZA)
df <- as.data.frame(lapply(df, rep, df$NBZA), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(ZACTES = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
if (annee>=2020) {
actes <- dplyr::mutate(actes, CODE = 'A') %>% dplyr::select(-NBZA) %>% dplyr::mutate(
DELAI = stringr::str_sub(ZACTES, 1, 5) %>% as.numeric(),
CDCCAM = stringr::str_sub(ZACTES, 6,12),
PHASE = stringr::str_sub(ZACTES,15,15),
ACT = stringr::str_sub(ZACTES,16,16),
EXTDOC = stringr::str_sub(ZACTES,17,17),
NBEXEC = stringr::str_sub(ZACTES,18,19),
INDVAL = stringr::str_sub(ZACTES,20,20))
} else {
actes <- dplyr::mutate(actes, CODE = 'A') %>% dplyr::select(-NBZA) %>% dplyr::mutate(
DELAI = stringr::str_sub(ZACTES, 1, 4) %>% as.numeric(),
CDCCAM = stringr::str_sub(ZACTES, 5,11),
PHASE = stringr::str_sub(ZACTES,14,14),
ACT = stringr::str_sub(ZACTES,15,15),
EXTDOC = stringr::str_sub(ZACTES,16,16),
NBEXEC = stringr::str_sub(ZACTES,17,18),
INDVAL = stringr::str_sub(ZACTES,19,19))
}
da <- purrr::flatten_chr(rapss_i$lda)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = stringr::str_trim(da), stringsAsFactors = F) ) %>% tibble::as_tibble()
da <- dplyr::mutate(da, CODE = 'DA') %>% dplyr::select(-NBDA)
dmpp <- purrr::flatten_chr(rapss_i$ldmpp)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,NBDIAGMPP)
df <- as.data.frame(lapply(df, rep, df$NBDIAGMPP), stringsAsFactors = F) %>% tibble::as_tibble()
dmpp <- dplyr::bind_cols(df,data.frame(DMPP = stringr::str_trim(dmpp), stringsAsFactors = F) ) %>% tibble::as_tibble()
dmpp <- dplyr::mutate(dmpp, CODE = 'DMPP') %>% dplyr::select(-NBDIAGMPP)
dmpa <- purrr::flatten_chr(rapss_i$ldmpa)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,NBDIAGMPA)
df <- as.data.frame(lapply(df, rep, df$NBDIAGMPA), stringsAsFactors = F) %>% tibble::as_tibble()
dmpa <- dplyr::bind_cols(df,data.frame(DMPA = stringr::str_trim(dmpa), stringsAsFactors = F) ) %>% tibble::as_tibble()
dmpa <- dplyr::mutate(dmpa, CODE = 'DMPA') %>% dplyr::select(-NBDIAGMPA)
acdi <- dplyr::bind_rows(actes,da,dmpp,dmpa) %>% dplyr::select(-ZACTES)
rapss_i <- rapss_i %>% dplyr::select(-c(FILLER,Z,da,za,dmpp,dmpa,lda,ldmpp,ldmpa,lactes))
}
if (annee==2011){
actes <- purrr::flatten_chr(rapss_i$lactes)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,NBZA)
df <- as.data.frame(lapply(df, rep, df$NBZA), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(ZACTES = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
actes <- dplyr::mutate(actes, CODE = 'A') %>% dplyr::select(-NBZA) %>% dplyr::mutate(
DELAI = stringr::str_sub(ZACTES, 1, 4) %>% as.numeric(),
CDCCAM = stringr::str_sub(ZACTES, 5,11),
PHASE = stringr::str_sub(ZACTES,14,14),
ACT = stringr::str_sub(ZACTES,15,15),
EXTDOC = stringr::str_sub(ZACTES,16,16),
NBEXEC = stringr::str_sub(ZACTES,17,18),
INDVAL = stringr::str_sub(ZACTES,19,19))
da <- purrr::flatten_chr(rapss_i$lda)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = stringr::str_trim(da), stringsAsFactors = F) ) %>% tibble::as_tibble()
da <- dplyr::mutate(da, CODE = 'DA') %>% dplyr::select(-NBDA)
acdi <- dplyr::bind_rows(actes,da) %>% dplyr::select(-ZACTES)
rapss_i <- rapss_i %>% dplyr::select(-c(Z,da,za,lda,lactes))
}
etb_ght <- purrr::flatten_chr(rapss_i$letb_ght)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,NOVRPSS, VCLASS = ETB_VCLASS, CDRETR = ETB_CDRETR,
GHPC = ETB_GHPC, NBGHT = ETB_NBGHT)
df <- as.data.frame(lapply(df, rep, df$NBGHT), stringsAsFactors = F) %>% tibble::as_tibble()
etb_ght <- dplyr::bind_cols(df,data.frame(etb_ght, stringsAsFactors = F) ) %>% tibble::as_tibble() %>%
dplyr::mutate(TYPGHT='ETAB',
NUMGHT = stringr::str_sub(etb_ght,1,2),
JOURSGHT = stringr::str_sub(etb_ght,3,5) %>% as.numeric() ) %>%
dplyr::select(-etb_ght)
pap_ght <- purrr::flatten_chr(rapss_i$lpap_ght)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,VCLASS=PAPRICA_VCLASS, CDRETR = PAPRICA_CDRETR, GHPC = PAPRICA_GHPC,
NBGHT = PAPRICA_NBGHT )
df <- as.data.frame(lapply(df, rep, df$NBGHT), stringsAsFactors = F) %>% tibble::as_tibble()
pap_ght <- dplyr::bind_cols(df,data.frame(pap_ght, stringsAsFactors = F) ) %>% tibble::as_tibble() %>%
dplyr::mutate(TYPGHT='PAPRICA',
NUMGHT = stringr::str_sub(pap_ght,1,2),
JOURSGHT = stringr::str_sub(pap_ght,3,5) %>% as.numeric() ) %>%
dplyr::select(-pap_ght)
ght <- dplyr::bind_rows(etb_ght,pap_ght)
rapss_i <- rapss_i %>% dplyr::select(-c(lpap_ght,letb_ght))
rapss_i <- rapss_i %>% dplyr::select(- dplyr::starts_with("PAP"),- dplyr::starts_with("ETB"),-NOVRPSS)
acdi[is.na(acdi) & is.character(acdi)] <- ""
rapss_i[is.na(rapss_i) & is.character(rapss_i)] <- ""
ght[is.na(ght) & is.character(ght)] <- ""
if (lib==T){
ght <- ght %>% sjlabelled::set_label(c('N° du séjour HAD', 'N° de la séquence', 'N° de la sous-séquence',
'N° de version du RPSS','Version de classification',
'Codes retours', 'Groupe homogène de prise en charge',
'Nombre de GHT','Type de GHT', 'N° du GHT', 'Nombre de jours du GHT'))
if (annee==2011){
acdi <- acdi %>% sjlabelled::set_label(c('N° du séjour HAD', 'N° de la séquence', 'N° de la sous-séquence',
'Type de code (A : Acte, DA : Diagnostic Associé)',
"Délai depuis la date d'entrée","Code CCAM","Phase", "Activité", "Extension documentaire",
"Nombre d'exécécutions", "Indic Validité de l'acte","Diagnostic Associé"))
}else{
acdi <- acdi %>% sjlabelled::set_label(c('N° du séjour HAD', 'N° de la séquence', 'N° de la sous-séquence',
'Type de code (A : Acte, DA : Diagnostic Associé, DMPP : Diagnostic Mode principal, DMPA : Diagnostic Mode associé)',
"Délai depuis la date d'entrée","Code CCAM","Phase", "Activité", "Extension documentaire",
"Nombre d'exécécutions", "Indic Validité de l'acte","Diagnostic Associé", "Diagnostic MPP",
"Diagnostic MPA"))
}
}
Fillers <- names(rapss_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rapss_i <- rapss_i[,!(names(rapss_i) %in% Fillers)]
if (lib==T){
rapss_i <- rapss_i %>% sjlabelled::set_label(libelles[!is.na(libelles)])
}
if (tolower_names){
names(rapss_i) <- tolower(names(rapss_i))
names(acdi) <- tolower(names(acdi))
names(ght) <- tolower(names(ght))
}
rapss_1 <- list(rapss = rapss_i, acdi = acdi, ght = ght)
attr(rapss_1, "problems") <- synthese_import
return(rapss_1)
}
#' ~ HAD - Import des Anohosp
#'
#' Imports du fichier Ano
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu (sortie de Paprica) :
#' \emph{finess.annee.moisc.ano}
#'
#' \strong{750712184.2016.2.ano}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typano Type de donnees in / out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les données Anohosp HAD du Out.
#'
#' @examples
#' \dontrun{
#' anoh <- iano_had('750712184',2015,12,"~/Documents/data/had")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irapss}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage iano_had(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export iano_had
#' @export
iano_had <- function(finess, annee, mois, path, typano = c('out', 'in'), lib = T, tolower_names = F, ...){
UseMethod('iano_had')
}
#' @export
iano_had.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iano_had.default, param2)
}
#' @export
iano_had.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iano_had.default, param2)
}
#' @export
iano_had.default <- function(finess, annee,mois, path, lib = T, typano = c('out', 'in'), tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
typano <- match.arg(typano)
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (typano=="out"){
if(annee == 2022 & mois >= 3) {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss_ano', an == "22_H35")
} else if(annee == 2022 & mois < 3) {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss_ano', an == substr(as.character(annee),3,4))
} else if(annee == 2020 & mois >= 3) {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss_ano', an == "20_H33")
} else if(annee == 2021 & mois < 3) {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss_ano', an == "20_H33")
} else {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss_ano', an == substr(as.character(annee),3,4))
}
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (annee<=2012){
ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSOR = lubridate::dmy(DTSOR, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') ==7),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100)
}
if (annee>2012){
ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSOR = lubridate::dmy(DTSOR, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') +
(CRCDNAI=='0') + (CRCSEXE=='0')==9),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
MTRMBAMC = MTRMBAMC/100,
TAUXRM = TAUXRM /100)
}
if (lib==T){
ano_i <- ano_i %>% sjlabelled::set_label(c(libelles,'Chaînage Ok'))
ano_i <- ano_i %>% dplyr::select(-dplyr::starts_with("Fill"))
}
}
if (typano=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss_ano', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (2011<annee){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTHOSP = lubridate::dmy(DTHOSP, quiet = TRUE),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTRMAMC = MTRMAMC /100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
if (annee == 2011){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
Fillers <- names(ano_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
ano_i <- ano_i[,!(names(ano_i) %in% Fillers)]
if (lib==T){
v <- libelles[!is.na(libelles)]
ano_i <- ano_i %>% sjlabelled::set_label(v)
}
}
if (tolower_names){
names(ano_i) <- tolower(names(ano_i))
}
attr(ano_i,"problems") <- synthese_import
return(ano_i)
}
#' ~ HAD - Import des Med
#'
#' Imports du fichier Med Out
#'
#' Formats depuis 2011 pris en charge
#'
#' import des med, medatu et mchl si le fichier existe
#'
#' Structure du nom du fichier attendu (sortie de Paprica) :
#' \emph{finess.annee.moisc.med}
#'
#' \strong{750712184.2016.2.med}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les données médicaments HAD du Out.
#'
#' @examples
#' \dontrun{
#' medh <- imed_had('750712184',2015,12,"~/Documents/data/had")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irapss}}
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage imed_had(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export imed_had
#' @export
imed_had <- function(...){
UseMethod('imed_had')
}
#' @export
imed_had.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(imed_had.default, param2)
}
#' @export
imed_had.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(imed_had.default, param2)
}
#' @export
imed_had.default <- function(finess, annee, mois, path, lib=T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss_med', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
med_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".med"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(med_i) -> synthese_import
med_i <- med_i %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000) %>% sjlabelled::set_label(libelles)
info = file.info(paste0(path,"/",finess,".",annee,".",mois,".medatu"))
if (info$size >0 & !is.na(info$size)){
med_i2<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".medatu"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
synthese_import <- dplyr::bind_rows(synthese_import, readr::problems(med_i2))
med_i2 <- med_i2 %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000) %>% sjlabelled::set_label(libelles)
med_i <- rbind(med_i,med_i2)
}
info = file.info(paste0(path,"/",finess,".",annee,".",mois,".mchl"))
if (info$size >0 & !is.na(info$size)){
med_i3<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".mchl"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
synthese_import <- dplyr::bind_rows(synthese_import, readr::problems(med_i3))
med_i3 <- med_i3 %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000) %>% sjlabelled::set_label(libelles)
med_i <- rbind(med_i, med_i3)
}
if (tolower_names){
names(med_i) <- tolower(names(med_i))
}
attr(med_i,"problems") <- synthese_import
return(med_i)
}
#' ~ HAD - Import des erreurs Leg
#'
#' Import de la liste d'erreurs de génération Paprica
#'
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param reshape booleen TRUE/FALSE : la donnee doit-elle etre restructuree ? une ligne = une erreur, sinon, une ligne = un sejour. par defaut a F
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#'
#' @return Une table (data.frame, tibble) contenant les erreurs Out.
#'
#' @examples
#' \dontrun{
#' ileg_had('750712184',2015,12,'~/Documents/data/had') -> leg15
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irapss}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage ileg_had(finess, annee, mois, path, reshape = F, tolower_names = F, ...)
#' @export ileg_had
#' @export
ileg_had <- function(...){
UseMethod('ileg_had')
}
#' @export
ileg_had.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(ileg_had.default, param2)
}
#' @export
ileg_had.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(ileg_had.default, param2)
}
#' @export
ileg_had.default <- function(finess, annee, mois, path, reshape = F, tolower_names = F, ...){
leg_i <- readr::read_lines(paste0(path,"/",finess,".",annee,".",mois,".leg"))
leg_i1 <- tibble::tibble(l = leg_i) %>%
tidyr::separate(l, c('FINESS', 'MOIS', 'ANNEE', 'NOSEQSEJ',
'NOSEQ', 'NOSOUSSEQ', 'NBERR', 'ERRS'), ";", extra = "merge")
if (reshape==FALSE){
leg_i1 <- leg_i1 %>%
dplyr::mutate(EG = stringr::str_replace_all(ERRS, ";", ", ")) %>%
dplyr::select(-ERRS)
if (tolower_names){
names(leg_i1) <- tolower(names(leg_i1))
}
return(leg_i1)
}
u <- stringr::str_split(leg_i1$ERRS, ";") %>% purrr::flatten_chr()
leg_i1 <- tibble::as_tibble(lapply(leg_i1, rep, leg_i1$NBERR), stringsAsFactors = F)
leg_i2 <- dplyr::bind_cols(leg_i1, data.frame(EG = as.character(u), stringsAsFactors = F))
leg_i2 <- leg_i2 %>%
dplyr::mutate(ERRS = stringr::str_replace_all(ERRS, ";", ", "))
if (tolower_names){
names(leg_i2) <- tolower(names(leg_i2))
}
return(leg_i2)
}
##############################################
####################### SSR ##################
##############################################
#' ~ SSR - Import des RHA
#'
#' Import des RHA
#'
#' Formats depuis 2011 pris en charge
#'
#' @param finess Finess du fichier Out de GENRHA a integrer
#' @param annee Annee de la periode (du fichier Out)
#' @param mois Mois de la periode (du fichier Out)
#' @param path Chemin d'acces au fichier .rha
#' @param lib Attribution de libelles aux colonnes
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max=10e3} pour lire les 10000 premieres lignes
#'
#' @examples
#' \dontrun{
#' irha('750712184',2015,12,'pathpath/') -> rha15
#' }
#' @author G. Pressiat
#' @seealso \code{\link{iano_ssr}}, \code{\link{ileg_ssr}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage irha(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export irha
#' @export
irha <- function(...){
UseMethod('irha')
}
#' @export
irha.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(irha.default, param2)
}
#' @export
irha.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(irha.default, param2)
}
#' @export
irha.default <- function(finess, annee, mois, path, lib=T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
#op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'ssr', table == 'rha', an == substr(as.character(annee),3,4))
format$longueur[nrow(format)] <- NA
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
suppressWarnings(rha_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rha"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...))
readr::problems(rha_i) -> synthese_import
rha_i <- rha_i %>%
dplyr::mutate(FPPC = stringr::str_trim(FPPC),
MMP = stringr::str_trim(MMP),
AE = stringr::str_trim(AE))
# if (annee > 2016){
# rha_i <- rha_i %>% dplyr::mutate(RR = as.numeric(RR) / 100)
# }
#
if (annee > 2019){
fzacte <- function(ccam){
dplyr::mutate(ccam,
DELAI = stringr::str_sub(ccam,1,5),
CDCCAM = stringr::str_sub(ccam,6,12),
DESCRI = stringr::str_sub(ccam,13,14) %>% stringr::str_trim(),
PHASE = stringr::str_sub(ccam,15,15),
ACT = stringr::str_sub(ccam,16,16),
EXTDOC = stringr::str_sub(ccam,17,17),
NBEXEC = stringr::str_sub(ccam,18,19),
INDVAL = stringr::str_sub(ccam,20,20)
) %>% dplyr::select(-ccam)
}
fzsarr <- function(csarr){
dplyr::mutate(csarr,
CSARR = stringr::str_sub(csarr,1,7),
CDAPP = stringr::str_sub(csarr,8,10),
CDMOD = stringr::str_sub(csarr,11,12),
CDPAT1 = stringr::str_sub(csarr,13,14),
CDPAT2 = stringr::str_sub(csarr,15,16),
CDINTER = stringr::str_sub(csarr,17,18),
NBPATIND = stringr::str_sub(csarr,19,19),
NBEXEC = stringr::str_sub(csarr,20,21),
INDVAL = stringr::str_sub(csarr,22,22),
DELAI = stringr::str_sub(csarr,23,27),
NBPATREEL = stringr::str_sub(csarr,28,29),
NBINT = stringr::str_sub(csarr,30,31),
EXTDOCcsarr = stringr::str_sub(csarr,32,33)
) %>% dplyr::select(-csarr)
}
zad <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,ZAD, NBDA, NBCSARR, NBCCAM) %>%
dplyr::mutate(
da = ifelse(NBDA>0,stringr::str_sub(ZAD,1,6*NBDA),""),
lda = stringr::str_extract_all(da,".{1,6}"),
csarr = ifelse(NBCSARR>0,stringr::str_sub(ZAD,6*NBDA+1,6*NBDA + 33*NBCSARR),""),
lcsarr = stringr::str_extract_all(csarr, ".{1,33}"),
ccam = ifelse(NBCCAM>0,stringr::str_sub(ZAD,6*NBDA+1+33*NBCSARR,6*NBDA + 33*NBCSARR + 20*NBCCAM),""),
lccam = stringr::str_extract_all(ccam, ".{1,20}")
)
da <- purrr::flatten_chr(zad$lda)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = da, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='DA') %>% dplyr::select(-NBDA) %>%
dplyr::select(NOSEQSEJ, NOSEQRHS, CODE, DA) %>% dplyr::mutate(DA = stringr::str_trim(DA))
csarr <- purrr::flatten_chr(zad$lcsarr)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCSARR)
df <- as.data.frame(lapply(df, rep, df$NBCSARR), stringsAsFactors = F) %>% tibble::as_tibble()
csarr <- dplyr::bind_cols(df,data.frame(csarr = csarr, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CSARR') %>% dplyr::select(-NBCSARR)
ccam <- purrr::flatten_chr(zad$lccam)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCCAM)
df <- as.data.frame(lapply(df, rep, df$NBCCAM), stringsAsFactors = F) %>% tibble::as_tibble()
ccam <- dplyr::bind_cols(df,data.frame(ccam = ccam, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CCAM') %>% dplyr::select(-NBCCAM)
acdi <-dplyr::bind_rows(da, fzsarr(csarr), fzacte(ccam))
if (lib == T){
labelacdi <- c('N° Séquentiel du séjour', 'N° Séquentiel du RHS', "Type de code (DA / CSARR / CCAM)","Diagnostic associé",
"Code CSARR", "Code supplémentaire appareillage", "Code modulateur de lieu", "Code modulateur patient n°1",
"Code modulateur patient n°2", "Code de l'intervenant", "Nb de patients en acte individuel",
"Nb de réalisations","Acte compatible avec la semaine", "Délai depuis la date d'entrée dans l'UM",
"Nb réel de patients", "Nb d'intervenants","Extension documentaire CSARR", "Code CCAM", "Partie descriptive","Phase CCAM",
"Activité CCAM", "Extension documentaire CCAM")
acdi <- acdi %>% sjlabelled::set_label(labelacdi)
}
}
if (annee > 2014 & annee < 2020){
fzacte <- function(ccam){
dplyr::mutate(ccam,
DELAI = stringr::str_sub(ccam,1,4),
CDCCAM = stringr::str_sub(ccam,5,11),
DESCRI = stringr::str_sub(ccam, 12,13) %>% stringr::str_trim(),
PHASE = stringr::str_sub(ccam,14,14),
ACT = stringr::str_sub(ccam,15,15),
EXTDOC = stringr::str_sub(ccam,16,16),
NBEXEC = stringr::str_sub(ccam,17,18),
INDVAL = stringr::str_sub(ccam,19,19)
) %>% dplyr::select(-ccam)
}
fzsarr <- function(csarr){
dplyr::mutate(csarr,
CSARR = stringr::str_sub(csarr,1,7),
CDAPP = stringr::str_sub(csarr,8,10),
CDMOD = stringr::str_sub(csarr,11,12),
CDPAT1 = stringr::str_sub(csarr,13,14),
CDPAT2 = stringr::str_sub(csarr,15,16),
CDINTER = stringr::str_sub(csarr,17,18),
NBPATIND = stringr::str_sub(csarr,19,19),
NBEXEC = stringr::str_sub(csarr,20,21),
INDVAL = stringr::str_sub(csarr,22,22),
DELAI = stringr::str_sub(csarr,23,26),
NBPATREEL = stringr::str_sub(csarr,27,28),
NBINT = stringr::str_sub(csarr,29,30),
EXTDOCcsarr = stringr::str_sub(csarr,31,32)
) %>% dplyr::select(-csarr)
}
zad <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,ZAD, NBDA, NBCSARR, NBCCAM) %>%
dplyr::mutate(
da = ifelse(NBDA>0,stringr::str_sub(ZAD,1,6*NBDA),""),
lda = stringr::str_extract_all(da,".{1,6}"),
csarr = ifelse(NBCSARR>0,stringr::str_sub(ZAD,6*NBDA+1,6*NBDA + 32*NBCSARR),""),
lcsarr = stringr::str_extract_all(csarr, ".{1,32}"),
ccam = ifelse(NBCCAM>0,stringr::str_sub(ZAD,6*NBDA+1+32*NBCSARR,6*NBDA + 32*NBCSARR + 19*NBCCAM),""),
lccam = stringr::str_extract_all(ccam, ".{1,19}")
)
da <- purrr::flatten_chr(zad$lda)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = da, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='DA') %>% dplyr::select(-NBDA) %>%
dplyr::select(NOSEQSEJ, NOSEQRHS, CODE, DA) %>% dplyr::mutate(DA = stringr::str_trim(DA))
csarr <- purrr::flatten_chr(zad$lcsarr)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCSARR)
df <- as.data.frame(lapply(df, rep, df$NBCSARR), stringsAsFactors = F) %>% tibble::as_tibble()
csarr <- dplyr::bind_cols(df,data.frame(csarr = csarr, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CSARR') %>% dplyr::select(-NBCSARR)
ccam <- purrr::flatten_chr(zad$lccam)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCCAM)
df <- as.data.frame(lapply(df, rep, df$NBCCAM), stringsAsFactors = F) %>% tibble::as_tibble()
ccam <- dplyr::bind_cols(df,data.frame(ccam = ccam, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CCAM') %>% dplyr::select(-NBCCAM)
acdi <-dplyr::bind_rows(da, fzsarr(csarr), fzacte(ccam))
if (lib == T){
labelacdi <- c('N° Séquentiel du séjour', 'N° Séquentiel du RHS', "Type de code (DA / CSARR / CCAM)","Diagnostic associé",
"Code CSARR", "Code supplémentaire appareillage", "Code modulateur de lieu", "Code modulateur patient n°1",
"Code modulateur patient n°2", "Code de l'intervenant", "Nb de patients en acte individuel",
"Nb de réalisations","Acte compatible avec la semaine", "Délai depuis la date d'entrée dans l'UM",
"Nb réel de patients", "Nb d'intervenants","Extension documentaire CSARR", "Code CCAM", "Partie descriptive","Phase CCAM",
"Activité CCAM", "Extension documentaire CCAM")
acdi <- acdi %>% sjlabelled::set_label(labelacdi)
}
}
if (annee == 2014){
fzacte <- function(ccam){
dplyr::mutate(ccam,
DELAI = stringr::str_sub(ccam,1 , 4),
CDCCAM = stringr::str_sub(ccam,5 ,11),
PHASE = stringr::str_sub(ccam,12,12),
ACT = stringr::str_sub(ccam,13,13),
EXTDOC = stringr::str_sub(ccam,14,14),
NBEXEC = stringr::str_sub(ccam,15,16),
INDVAL = stringr::str_sub(ccam,17,17)
) %>% dplyr::select(-ccam)
}
fzsarr <- function(csarr){
dplyr::mutate(csarr,
CSARR = stringr::str_sub(csarr,1,7),
CDAPP = stringr::str_sub(csarr,8,10),
CDMOD = stringr::str_sub(csarr,11,12),
CDPAT1 = stringr::str_sub(csarr,13,14),
CDPAT2 = stringr::str_sub(csarr,15,16),
CDINTER = stringr::str_sub(csarr,17,18),
NBPATIND = stringr::str_sub(csarr,19,19),
NBEXEC = stringr::str_sub(csarr,20,21),
INDVAL = stringr::str_sub(csarr,22,22),
DELAI = stringr::str_sub(csarr,23,26),
NBPATREEL = stringr::str_sub(csarr,27,28),
NBINT = stringr::str_sub(csarr,29,30),
EXTDOCcsarr = stringr::str_sub(csarr,31,32)
) %>% dplyr::select(-csarr)
}
zad <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,ZAD, NBDA, NBCSARR, NBCCAM) %>%
dplyr::mutate(
da = ifelse(NBDA>0,stringr::str_sub(ZAD,1,6*NBDA),""),
lda = stringr::str_extract_all(da,".{1,6}"),
csarr = ifelse(NBCSARR>0,stringr::str_sub(ZAD,6*NBDA+1,6*NBDA + 32*NBCSARR),""),
lcsarr = stringr::str_extract_all(csarr, ".{1,32}"),
ccam = ifelse(NBCCAM>0,stringr::str_sub(ZAD,6*NBDA+1+32*NBCSARR,6*NBDA + 32*NBCSARR + 17*NBCCAM),""),
lccam = stringr::str_extract_all(ccam, ".{1,17}")
)
da <- purrr::flatten_chr(zad$lda)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = da, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='DA') %>% dplyr::select(-NBDA) %>%
dplyr::select(NOSEQSEJ, NOSEQRHS, CODE, DA) %>% dplyr::mutate(DA = stringr::str_trim(DA))
csarr <- purrr::flatten_chr(zad$lcsarr)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCSARR)
df <- as.data.frame(lapply(df, rep, df$NBCSARR), stringsAsFactors = F) %>% tibble::as_tibble()
csarr <- dplyr::bind_cols(df,data.frame(csarr = csarr, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CSARR') %>% dplyr::select(-NBCSARR)
ccam <- purrr::flatten_chr(zad$lccam)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCCAM)
df <- as.data.frame(lapply(df, rep, df$NBCCAM), stringsAsFactors = F) %>% tibble::as_tibble()
ccam <- dplyr::bind_cols(df,data.frame(ccam = ccam, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CCAM') %>% dplyr::select(-NBCCAM)
acdi <-dplyr::bind_rows(da, fzsarr(csarr), fzacte(ccam))
if (lib == T){
labelacdi <- c('N° Séquentiel du séjour', 'N° Séquentiel du RHS', "Type de code (DA / CSARR / CCAM)","Diagnostic associé",
"Code CSARR", "Code supplémentaire appareillage", "Code modulateur de lieu", "Code modulateur patient n°1",
"Code modulateur patient n°2", "Code de l'intervenant", "Nb de patients en acte individuel",
"Nb de réalisations","Acte compatible avec la semaine", "Délai depuis la date d'entrée dans l'UM",
"Nb réel de patients", "Nb d'intervenants","Extension documentaire CSARR", "Code CCAM", "Phase CCAM",
"Activité CCAM", "Extension documentaire CCAM")
acdi <- acdi %>% sjlabelled::set_label(labelacdi)
}
}
if (annee == 2013){
fzacte <- function(ccam){
dplyr::mutate(ccam,
DELAI = stringr::str_sub(ccam,1 , 4),
CDCCAM = stringr::str_sub(ccam,5 ,11),
PHASE = stringr::str_sub(ccam,12,12),
ACT = stringr::str_sub(ccam,13,13),
EXTDOC = stringr::str_sub(ccam,14,14),
NBEXEC = stringr::str_sub(ccam,15,16),
INDVAL = stringr::str_sub(ccam,17,17)
) %>% dplyr::select(-ccam)
}
fzsarr <- function(csarr){
dplyr::mutate(csarr,
CSARR = stringr::str_sub(csarr,1,7),
CDARR = ifelse(nchar(stringr::str_trim(CSARR)) == 4, CSARR, ""),
CSARR = ifelse(nchar(stringr::str_trim(CSARR)) == 7, CSARR, ""),
CODE = ifelse(nchar(stringr::str_trim(CSARR)) == 7, "CSARR", "CDARR"),
CDAPP = stringr::str_sub(csarr,8,10),
CDMOD = stringr::str_sub(csarr,11,12),
CDPAT1 = stringr::str_sub(csarr,13,14),
CDPAT2 = stringr::str_sub(csarr,15,16),
CDINTER = stringr::str_sub(csarr,17,18),
NBPATIND = stringr::str_sub(csarr,19,19),
NBEXEC = stringr::str_sub(csarr,20,21),
INDVAL = stringr::str_sub(csarr,22,22),
DELAI = stringr::str_sub(csarr,23,26)) %>%
dplyr::select(-csarr)
}
zad <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,ZAD, NBDA, NBCSARR, NBCCAM) %>%
dplyr::mutate(
da = ifelse(NBDA>0,stringr::str_sub(ZAD,1,6*NBDA),""),
lda = stringr::str_extract_all(da,".{1,6}"),
csarr = ifelse(NBCSARR>0,stringr::str_sub(ZAD,6*NBDA+1,6*NBDA + 26*NBCSARR),""),
lcsarr = stringr::str_extract_all(csarr, ".{1,26}"),
ccam = ifelse(NBCCAM>0,stringr::str_sub(ZAD,6*NBDA+1+26*NBCSARR,6*NBDA + 26*NBCSARR + 17*NBCCAM),""),
lccam = stringr::str_extract_all(ccam, ".{1,17}")
)
da <- purrr::flatten_chr(zad$lda)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = da, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='DA')%>% dplyr::select(-NBDA) %>%
dplyr::select(NOSEQSEJ, NOSEQRHS, CODE, DA) %>% dplyr::mutate(DA = stringr::str_trim(DA))
csarr <- purrr::flatten_chr(zad$lcsarr)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCSARR)
df <- as.data.frame(lapply(df, rep, df$NBCSARR), stringsAsFactors = F) %>% tibble::as_tibble()
csarr <- dplyr::bind_cols(df,data.frame(csarr = csarr, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBCSARR)
ccam <- purrr::flatten_chr(zad$lccam)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCCAM)
df <- as.data.frame(lapply(df, rep, df$NBCCAM), stringsAsFactors = F) %>% tibble::as_tibble()
ccam <- dplyr::bind_cols(df,data.frame(ccam = ccam, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CCAM') %>% dplyr::select(-NBCCAM)
acdi <-dplyr::bind_rows(da, fzsarr(csarr), fzacte(ccam))
if (lib == T){
labelacdi <- c('N° Séquentiel du séjour', 'N° Séquentiel du RHS', "Type de code (DA / CSARR / CDARR / CCAM)","Diagnostic associé",
"Code CSARR","Code CDARR", "Code supplémentaire appareillage", "Code modulateur de lieu", "Code modulateur patient n°1",
"Code modulateur patient n°2", "Code de l'intervenant", "Nb de patients en acte individuel",
"Nb de réalisations","Acte compatible avec la semaine", "Délai depuis la date d'entrée dans l'UM",
"Code CCAM", "Phase CCAM", "Activité CCAM", "Extension documentaire CCAM")
acdi <- acdi %>% sjlabelled::set_label(labelacdi)
}
}
if (annee == 2012){
fzacte <- function(ccam){
dplyr::mutate(ccam,
DELAI = stringr::str_sub(ccam,1 , 4),
CDCCAM = stringr::str_sub(ccam,5 ,11),
PHASE = stringr::str_sub(ccam,12,12),
ACT = stringr::str_sub(ccam,13,13),
EXTDOC = stringr::str_sub(ccam,14,14),
NBEXEC = stringr::str_sub(ccam,15,16),
INDVAL = stringr::str_sub(ccam,17,17)
) %>% dplyr::select(-ccam)
}
fzsarr <- function(csarr){
dplyr::mutate(csarr,
CSARR = stringr::str_sub(csarr,1,7),
CDARR = ifelse(nchar(stringr::str_trim(CSARR)) == 4, CSARR, ""),
CSARR = ifelse(nchar(stringr::str_trim(CSARR)) == 7, CSARR, ""),
CODE = ifelse(nchar(stringr::str_trim(CSARR)) == 7, "CSARR", "CDARR"),
CDAPP = stringr::str_sub(csarr,8,10),
CDMOD = stringr::str_sub(csarr,11,12),
CDPAT1 = stringr::str_sub(csarr,13,14),
CDPAT2 = stringr::str_sub(csarr,15,16),
CDINTER = stringr::str_sub(csarr,17,18),
NBPATIND = stringr::str_sub(csarr,19,19),
NBEXEC = stringr::str_sub(csarr,20,21),
INDVAL = stringr::str_sub(csarr,22,22),
DELAI = stringr::str_sub(csarr,23,26)) %>%
dplyr::select(-csarr)
}
zad <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,ZAD, NBDA, NBCDARR, NBCCAM) %>%
dplyr::mutate(
da = ifelse(NBDA>0,stringr::str_sub(ZAD,1,6*NBDA),""),
lda = stringr::str_extract_all(da,".{1,6}"),
csarr = ifelse(NBCDARR>0,stringr::str_sub(ZAD,6*NBDA+1,6*NBDA + 26*NBCDARR),""),
lcsarr = stringr::str_extract_all(csarr, ".{1,26}"),
ccam = ifelse(NBCCAM>0,stringr::str_sub(ZAD,6*NBDA+1+26*NBCDARR,6*NBDA + 26*NBCDARR + 17*NBCCAM),""),
lccam = stringr::str_extract_all(ccam, ".{1,17}")
)
da <- purrr::flatten_chr(zad$lda)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = da, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='DA') %>% dplyr::select(-NBDA) %>%
dplyr::select(NOSEQSEJ, NOSEQRHS, CODE, DA) %>% dplyr::mutate(DA = stringr::str_trim(DA))
csarr <- purrr::flatten_chr(zad$lcsarr)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCDARR)
df <- as.data.frame(lapply(df, rep, df$NBCDARR), stringsAsFactors = F) %>% tibble::as_tibble()
csarr <- dplyr::bind_cols(df,data.frame(csarr = csarr, stringsAsFactors = F) )%>% tibble::as_tibble() %>% dplyr::select(-NBCDARR)
ccam <- purrr::flatten_chr(zad$lccam)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCCAM)
df <- as.data.frame(lapply(df, rep, df$NBCCAM), stringsAsFactors = F) %>% tibble::as_tibble()
ccam <- dplyr::bind_cols(df,data.frame(ccam = ccam, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CCAM') %>% dplyr::select(-NBCCAM)
acdi <- dplyr::bind_rows(da, fzsarr(csarr), fzacte(ccam))
if (lib == T){
labelacdi <- c('N° Séquentiel du séjour', 'N° Séquentiel du RHS', "Type de code (DA / CSARR / CDARR / CCAM)","Diagnostic associé",
"Code CSARR","Code CDARR", "Code supplémentaire appareillage", "Code modulateur de lieu", "Code modulateur patient n°1",
"Code modulateur patient n°2", "Code de l'intervenant", "Nb de patients en acte individuel",
"Nb de réalisations","Acte compatible avec la semaine", "Délai depuis la date d'entrée dans l'UM",
"Code CCAM", "Phase CCAM", "Activité CCAM", "Extension documentaire CCAM")
acdi <- acdi %>% sjlabelled::set_label(labelacdi)
}
}
if (annee == 2011){
fzacte <- function(ccam){
dplyr::mutate(ccam,
DELAI = stringr::str_sub(ccam,1 , 4),
CDCCAM = stringr::str_sub(ccam,5 ,11),
PHASE = stringr::str_sub(ccam,12,12),
ACT = stringr::str_sub(ccam,13,13),
EXTDOC = stringr::str_sub(ccam,14,14),
NBEXEC = stringr::str_sub(ccam,15,16),
INDVAL = stringr::str_sub(ccam,17,17)
) %>% dplyr::select(-ccam)
}
fzdarr <- function(cdarr){
dplyr::mutate(cdarr,
CDINTER = stringr::str_sub(cdarr,1,2),
CDARR = stringr::str_sub(cdarr,3,6),
CODE = "CDARR",
NBEXEC = stringr::str_sub(cdarr,7,8),
INDVAL = stringr::str_sub(cdarr,9,9)) %>%
dplyr::select(-cdarr)
}
zad <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,ZAD, NBDA, NBCDARR, NBCCAM) %>%
dplyr::mutate(
da = ifelse(NBDA>0,stringr::str_sub(ZAD,1,6*NBDA),""),
lda = stringr::str_extract_all(da,".{1,6}"),
cdarr = ifelse(NBCDARR>0,stringr::str_sub(ZAD,6*NBDA+1,6*NBDA + 9*NBCDARR),""),
lcdarr = stringr::str_extract_all(cdarr, ".{1,9}"),
ccam = ifelse(NBCCAM>0,stringr::str_sub(ZAD,6*NBDA+1+9*NBCDARR, 6*NBDA + 9*NBCDARR + 17*NBCCAM),""),
lccam = stringr::str_extract_all(ccam, ".{1,17}")
)
da <- purrr::flatten_chr(zad$lda)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = da, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='DA') %>% dplyr::select(-NBDA) %>%
dplyr::select(NOSEQSEJ, NOSEQRHS, CODE, DA) %>% dplyr::mutate(DA = stringr::str_trim(DA))
cdarr <- purrr::flatten_chr(zad$lcdarr)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCDARR)
df <- as.data.frame(lapply(df, rep, df$NBCDARR), stringsAsFactors = F) %>% tibble::as_tibble()
cdarr <- dplyr::bind_cols(df,data.frame(cdarr = cdarr, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CDARR') %>% dplyr::select(-NBCDARR)
ccam <- purrr::flatten_chr(zad$lccam)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCCAM)
df <- as.data.frame(lapply(df, rep, df$NBCCAM), stringsAsFactors = F) %>% tibble::as_tibble()
ccam <- dplyr::bind_cols(df,data.frame(ccam = ccam, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CCAM') %>% dplyr::select(-NBCCAM)
acdi <-dplyr::bind_rows(da, fzdarr(cdarr), fzacte(ccam))
if (lib == T){
labelacdi <- c('N° Séquentiel du séjour', 'N° Séquentiel du RHS', "Type de code (DA / CDARR / CCAM)","Diagnostic associé",
"Code de l'intervenant", "Code CDARR", "Nb de réalisations","Acte compatible avec la semaine",
"Délai depuis la date d'entrée dans l'UM",
"Code CCAM", "Phase CCAM", "Activité CCAM", "Extension documentaire CCAM")
acdi <- acdi %>% sjlabelled::set_label(labelacdi)
}
}
acdi[is.na(acdi)] <- ""
suppressWarnings(acdi$NBEXEC <- acdi$NBEXEC %>% as.numeric())
suppressWarnings(acdi$DELAI <- acdi$DELAI %>% as.numeric())
suppressWarnings(if (annee>2014){acdi$NBPATREEL <- acdi$NBPATREEL %>% as.numeric()})
Fillers <- names(rha_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="Fil"]
rha_i <- rha_i[,!(names(rha_i) %in% Fillers)]
rha_i <- rha_i %>% dplyr::select(-ZAD)
if (lib == T){
rha_i <- rha_i %>% sjlabelled::set_label(libelles[!is.na(libelles)])
}
if (tolower_names){
names(rha_i) <- tolower(names(rha_i))
names(acdi) <- tolower(names(acdi))
}
rha_1 = list(rha = rha_i, acdi = acdi)
attr(rha_1,"problems") <- synthese_import
deux <- Sys.time()
#cat("Données RHA importées en : ", deux-un, " secondes\n")
return(rha_1)
}
#' ~ SSR - Import des Anohosp
#'
#' Import du fichier Ano
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu (sortie de Genrha) :
#' \emph{finess.annee.moisc.ano}
#'
#' \strong{750712184.2016.2.ano}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typano Type de donnees in / out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... paramètres supplementaires à passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip =...}
#'
#' @return Une table (data.frame, tibble) contenant les données Anohosp SSR du Out.
#'
#' @examples
#' \dontrun{
#' anoh <- iano_ssr('750712184',2015,12,"~/Documents/data/ssr")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irha}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#'
#' @usage iano_ssr(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export iano_ssr
#' @export
iano_ssr <- function(...){
UseMethod('iano_ssr')
}
#' @export
iano_ssr.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iano_ssr.default, param2)
}
#' @export
iano_ssr.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iano_ssr.default, param2)
}
#' @export
iano_ssr.default <- function(finess, annee, mois, path, lib = T, typano = c('out', 'in'), tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
typano <- match.arg(typano)
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (typano=="out"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'ssr', table == 'rha_ano', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
if (annee>2012){
ano_i <- ano_i %>%
dplyr::mutate(DTSOR = lubridate::dmy(DTSOR, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') +
(CRCDNAI=='0') + (CRCSEXE=='0')==9),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
MTRMBAMC = MTRMBAMC/100,
TAUXRM = TAUXRM /100)
}
if (annee<2013){
ano_i <- ano_i %>%
dplyr::mutate(DTSOR = lubridate::dmy(DTSOR, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') == 7),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100)
}
if (lib == T){
ano_i <- ano_i %>% sjlabelled::set_label(c(libelles,'Chaînage Ok'))
ano_i <- ano_i %>% dplyr::select(-dplyr::starts_with("FIL"))
}
}
if (typano=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'ssr', table == 'rhs_ano', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (2011<annee){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".anoh.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTHOSP = lubridate::dmy(DTHOSP, quiet = TRUE),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTRMAMC = MTRMAMC /100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
if (annee == 2011){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".anoh.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
Fillers <- names(ano_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
ano_i <- ano_i[,!(names(ano_i) %in% Fillers)]
if (lib==T){
v <- libelles[!is.na(libelles)]
ano_i <- ano_i %>% sjlabelled::set_label(v)
}
}
if (tolower_names){
names(ano_i) <- tolower(names(ano_i))
}
attr(ano_i,"problems") <- synthese_import
return(ano_i)
}
#' ~ SSR - Import des SSRHA
#'
#' Import du fichier SHA
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu (sortie de Genrha) :
#' \emph{finess.annee.moisc.sha}
#'
#' \strong{750712184.2016.2.sha}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles a la table : T
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les données SHA, et a partir de 2017 une liste de deux tables (sha et gme)
#'
#' @examples
#' \dontrun{
#' sha <- issrha('750712184',2015,12,"~/Documents/data/ssr")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irha}}, \code{\link{ileg_ssr}}, \code{\link{iano_ssr}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage issrha(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export issrha
#' @export
issrha <- function(...){
UseMethod('issrha')
}
#' @export
issrha.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(issrha.default, param2)
}
#' @export
issrha.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(issrha.default, param2)
}
#' @export
issrha.default <- function(finess, annee,mois, path, lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'ssr', table == 'ssrha', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
ssrha_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".sha"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ssrha_i) -> synthese_import
if (lib == T){
ssrha_i <- ssrha_i %>%
sjlabelled::set_label(libelles)
}
if (annee > 2021){
zac <- ssrha_i %>% dplyr::select(NBZGP, ZGP)
fixe <- ssrha_i %>% dplyr::select(NOFINESS, NOSEQSEJ, NBZGP)
zac1 <- purrr::flatten_chr(stringr::str_extract_all(zac$ZGP, '.{1,14}'))
fixe <- as.data.frame(lapply(fixe, rep, fixe$NBZGP), stringsAsFactors = F)
gp <- data.frame(zac1 = as.character(zac1), stringsAsFactors = F)
gp <- dplyr::mutate(gp,
GME = stringr::str_sub(zac1, 1, 7),
GMT = stringr::str_sub(zac1, 8, 11),
NJ = stringr::str_sub(zac1, 12, 14) %>% as.integer()) %>%
dplyr::select(-zac1)
if (lib == T){
gp <- sjlabelled::set_label(gp, c("GME", "GMT", "Nombre de jours de présence"))
}
gp <- dplyr::as_tibble(dplyr::bind_cols(fixe, gp))
if (tolower_names){
names(ssrha_i) <- tolower(names(ssrha_i))
names(gp) <- tolower(names(gp))
}
ssrha_1 <- list(ssrha = ssrha_i, gme = gp)
attr(ssrha_1,"problems") <- synthese_import
return(ssrha_1)
}
if (annee > 2016){
zac <- ssrha_i %>% dplyr::select(NBZGP, ZGP)
fixe <- ssrha_i %>% dplyr::select(NOFINESS, NOSEQSEJ, NBZGP)
zac1 <- purrr::flatten_chr(stringr::str_extract_all(zac$ZGP, '.{1,13}'))
fixe <- as.data.frame(lapply(fixe, rep, fixe$NBZGP), stringsAsFactors = F)
gp <- data.frame(zac1 = as.character(zac1), stringsAsFactors = F)
gp <- dplyr::mutate(gp,
GME = stringr::str_sub(zac1, 1, 6),
GMT = stringr::str_sub(zac1, 7, 10),
NJ = stringr::str_sub(zac1, 11, 13) %>% as.integer()) %>%
dplyr::select(-zac1)
if (lib == T){
gp <- sjlabelled::set_label(gp, c("GME", "GMT", "Nombre de jours de présence"))
}
gp <- dplyr::as_tibble(dplyr::bind_cols(fixe, gp))
if (tolower_names){
names(ssrha_i) <- tolower(names(ssrha_i))
names(gp) <- tolower(names(gp))
}
ssrha_1 <- list(ssrha = ssrha_i, gme = gp)
attr(ssrha_1,"problems") <- synthese_import
return(ssrha_1)
}
if (tolower_names){
names(ssrha_i) <- tolower(names(ssrha_i))
}
attr(ssrha_i,"problems") <- synthese_import
return(ssrha_i)
}
#' ~ SSR - Import des erreurs Leg
#'
#' Import de la liste d'erreurs de génération Genrha
#'
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param reshape booleen TRUE/FALSE : la donnee doit-elle etre restructuree ? une ligne = une erreur, sinon, une ligne = un sejour. par defaut a F
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#'
#' @return Une table (data.frame, tibble) contenant les erreurs Out.
#'
#' @examples
#' \dontrun{
#' ileg_had('750712184',2015,12,'~/Documents/data/ssr') -> leg15
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irha}}, \code{\link{issrha}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage ileg_ssr(finess, annee, mois, path, reshape = F, tolower_names = F, ...)
#' @export ileg_ssr
#' @export
ileg_ssr <- function(...){
UseMethod('ileg_ssr')
}
#' @export
ileg_ssr.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(ileg_ssr.default, param2)
}
#' @export
ileg_ssr.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(ileg_ssr.default, param2)
}
#' @export
ileg_ssr.default <- function(finess, annee, mois, path, reshape = F, tolower_names = F, ...){
leg_i <- readr::read_lines(paste0(path,"/",finess,".",annee,".",mois,".leg"))
leg_i1 <- tibble::tibble(l = leg_i) %>%
tidyr::separate(l, c('FINESS', 'MOIS', 'ANNEE', 'NOSEQSEJ',
'NOSEQRHS', 'NBERR', 'ERRS'), ";", extra = "merge")
if (reshape==FALSE){
leg_i1 <- leg_i1 %>%
dplyr::mutate(EG = stringr::str_replace_all(ERRS, ";", ", ")) %>%
dplyr::select(-ERRS)
if (tolower_names){
names(leg_i1) <- tolower(names(leg_i1))
}
return(leg_i1)
}
u <- stringr::str_split(leg_i1$ERRS, ";") %>% purrr::flatten_chr()
leg_i1 <- tibble::as_tibble(lapply(leg_i1, rep, leg_i1$NBERR), stringsAsFactors = F)
leg_i2 <- dplyr::bind_cols(leg_i1, data.frame(EG = as.character(u), stringsAsFactors = F))
leg_i2 <- leg_i2 %>%
dplyr::mutate(ERRS = stringr::str_replace_all(ERRS, ";", ", "))
if (tolower_names){
names(leg_i2) <- tolower(names(leg_i2))
}
return(leg_i2)
}
#' ~ SSR - Import des Med
#'
#' Imports du fichier Med Out
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu (sortie de Genrha) :
#' \emph{finess.annee.moisc.med}
#'
#' \strong{750712184.2017.2.med}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les données médicaments SSR du Out.
#'
#' @examples
#' \dontrun{
#' meds <- imed_ssr('750712184',2015,12,"~/Documents/data/ssr")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irapss}}
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage imed_ssr(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export imed_ssr
#' @export
imed_ssr <- function(...){
UseMethod('imed_ssr')
}
#' @export
imed_ssr.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(imed_ssr.default, param2)
}
#' @export
imed_ssr.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(imed_ssr.default, param2)
}
#' @export
imed_ssr.default <- function(finess, annee, mois, path, lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'ssr', table == 'rha_med', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
info = file.info(paste0(path,"/",finess,".",annee,".",mois,".med"))
if (info$size >0 & !is.na(info$size)){
med_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".med"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...) %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000) %>% sjlabelled::set_label(libelles)
}
else {
med_i <- tibble::as_tibble(data.frame())
}
info = file.info(paste0(path,"/",finess,".",annee,".",mois,".medatu"))
if (info$size >0 & !is.na(info$size)){
med_i2<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".medatu"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...) %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000) %>% sjlabelled::set_label(libelles)
med_i <- rbind(med_i,med_i2)
}
Fillers <- names(med_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="Fil"]
med_i <- med_i[,!(names(med_i) %in% Fillers)]
if (tolower_names){
names(med_i) <- tolower(names(med_i))
}
return(med_i)
}
#' ~ SSR - Import des donnees UM du Out
#'
#' Imports du fichier IUM SSR
#'
#' Formats depuis 2013 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires à passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les informations structures du Out.
#'
#' @examples
#' \dontrun{
#' um <- iium_ssr('750712184',2015,12,"~/Documents/data/ssr")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage iium_ssr(finess, annee, mois, path, lib = T, ...)
#' @export iium_ssr
#' @export
iium_ssr <- function(...){
UseMethod('iium_ssr')
}
#' @export
iium_ssr.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iium_ssr.default, param2)
}
#' @export
iium_ssr.list <- function(l , ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iium_ssr.default, param2)
}
#' @export
iium_ssr.default <- function(finess, annee, mois, path, lib = T, tolower_names = F, ...){
if (annee<2013|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'ssr', table == 'rha_um', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
ium_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ium"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ium_i) -> synthese_import
if (lib==T){
v <- libelles
ium_i <- ium_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(ium_i) <- tolower(names(ium_i))
}
attr(ium_i,"problems") <- synthese_import
return(ium_i)
}
##############################################
####################### PSY ##################
##############################################
#' ~ PSY - Import des RPSA
#'
#' Import du fichier RPSA
#'
#' Formats depuis 2012 pris en charge
#' Structure du nom du fichier attendu (sortie de Pivoine) :
#' \emph{finess.annee.moisc.rpsa}
#'
#' \strong{750712184.2016.2.rpsa}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les données RPSA.
#'
#' @examples
#' \dontrun{
#' rpsa <- irpsa('750712184',2015,12,"~/Documents/data/psy")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{ir3a}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage irpsa(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export irpsa
#' @export
irpsa <- function(...){
UseMethod('irpsa')
}
#' @export
irpsa.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(irpsa.default, param2)
}
#' @export
irpsa.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(irpsa.default, param2)
}
#' @export
irpsa.default <- function(finess, annee, mois, path, lib = T, tolower_names = F, ...){
if (annee<2012|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'psy', table == 'rpsa', an == substr(as.character(annee),3,4))
format$longueur[nrow(format)] <- NA
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
extz <- function(x,pat){unlist(lapply(stringr::str_extract_all(x,pat),toString) )}
suppressWarnings(rpsa_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rpsa"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...))
readr::problems(rpsa_i) -> synthese_import
rpsa_i <- rpsa_i %>%
dplyr::mutate(DP = stringr::str_trim(DP))
if (annee < 2017){
zad <- rpsa_i %>% dplyr::select(NOSEQSEJ, NOSEQ,NBDA,ZAD) %>% dplyr::mutate(da = ifelse(NBDA>0,ZAD,""),
lda = stringr::str_extract_all(da, '.{1,6}'))
da <- purrr::flatten_chr(zad$lda) %>% stringr::str_trim()
df <- zad %>% dplyr::select(NOSEQSEJ, NOSEQ,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = stringr::str_trim(da), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDA)
rpsa_i$ZAD[is.na(rpsa_i$ZAD)] <- ""
rpsa_i <- rpsa_i %>% dplyr::mutate(das = extz(ZAD, ".{1,6}")) %>% dplyr::select(-ZAD)
if (lib == T){
rpsa_i <- rpsa_i %>% sjlabelled::set_label(c(libelles[-length(libelles)], "Stream DA ou facteurs associés"))
da <- da %>% sjlabelled::set_label(c('N° séquentiel de séjour','N° séquentiel de séquence au sein du séjour',
'Diagnostics et facteurs associés'))
}
if (tolower_names){
names(rpsa_i) <- tolower(names(rpsa_i))
names(da) <- tolower(names(da))
}
rpsa_1 = list(rpsa = rpsa_i, das = da)
}
if (annee > 2016 & annee < 2020){
rpsa_i <- rpsa_i %>%
dplyr::mutate(da = ifelse(NBDA>0,stringr::str_sub(ZAD,1, NBDA*6),""),
lda = stringr::str_extract_all(da, '.{1,6}'),
actes = ifelse(NBZA>0,stringr::str_sub(ZAD,NBDA*6+1,1+ NBDA*6 + NBZA*17),""),
lactes = stringr::str_extract_all(actes, '.{1,17}'))
zad <- rpsa_i
da <- purrr::flatten_chr(zad$lda) %>% stringr::str_trim()
df <- zad %>% dplyr::select(NOSEQSEJ, NOSEQ,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = stringr::str_trim(da), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDA)
actes <- purrr::flatten_chr(zad$lactes)
df <- zad %>% dplyr::select(NOSEQSEJ, NOSEQ,NBZA)
df <- as.data.frame(lapply(df, rep, df$NBZA), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(ACTES = actes, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBZA)
fzacte <- function(actes){
dplyr::mutate(actes,
DELAI = stringr::str_sub(ACTES,1,3) %>% as.integer(),
CDCCAM = stringr::str_sub(ACTES,4,10),
DESCRI = stringr::str_sub(ACTES,11,12) %>% stringr::str_trim(),
PHASE = stringr::str_sub(ACTES,13,13),
ACT = stringr::str_sub(ACTES,14,14),
EXTDOC = stringr::str_sub(ACTES,15,15),
NBEXEC = stringr::str_sub(ACTES,16,17) %>% as.integer()
) %>% dplyr::select(-ACTES)
}
fzacte(actes) -> actes
rpsa_i$ZAD[is.na(rpsa_i$ZAD)] <- ""
rpsa_i <- rpsa_i %>% dplyr::mutate(das = extz(da, ".{1,6}"),
actes = extz(actes, "[A-Z]{4}[0-9]{3}")) %>% dplyr::select(-ZAD, -da, -lactes, -lda)
libelles[is.na(libelles)] <- ""
if (lib == T){
rpsa_i <- rpsa_i %>% sjlabelled::set_label(c(libelles[-length(libelles)], "Stream actes","Stream DA ou facteurs associés"))
da <- da %>% sjlabelled::set_label(c('N° séquentiel de séjour','N° séquentiel de séquence au sein du séjour',
'Diagnostics et facteurs associés'))
actes <- actes %>% sjlabelled::set_label(c('N° séquentiel de séjour','N° séquentiel de séquence au sein du séjour',
"Délai depuis la date d'entrée", "Code CCAM",
"Extension PMSI", "Code de la phase", "Code de l'activité", "Extension documentaire", "Nombre de réalisations"))
}
if (tolower_names){
names(rpsa_i) <- tolower(names(rpsa_i))
names(da) <- tolower(names(da))
names(actes) <- tolower(names(actes))
}
rpsa_1 = list(rpsa = rpsa_i, das = da, actes = actes)
}
if (annee > 2019){
rpsa_i <- rpsa_i %>%
dplyr::mutate(da = ifelse(NBDA>0,stringr::str_sub(ZAD,1, NBDA*6),""),
lda = stringr::str_extract_all(da, '.{1,6}'),
actes = ifelse(NBZA>0,stringr::str_sub(ZAD,NBDA*6+1,1+ NBDA*6 + NBZA*19),""),
lactes = stringr::str_extract_all(actes, '.{1,19}'))
zad <- rpsa_i
da <- purrr::flatten_chr(zad$lda) %>% stringr::str_trim()
df <- zad %>% dplyr::select(NOSEQSEJ, NOSEQ,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = stringr::str_trim(da), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDA)
actes <- purrr::flatten_chr(zad$lactes)
df <- zad %>% dplyr::select(NOSEQSEJ, NOSEQ,NBZA)
df <- as.data.frame(lapply(df, rep, df$NBZA), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(ACTES = actes, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBZA)
fzacte <- function(actes){
dplyr::mutate(actes,
DELAI = stringr::str_sub(ACTES,1,5) %>% as.integer(),
CDCCAM = stringr::str_sub(ACTES,6,12),
DESCRI = stringr::str_sub(ACTES,13,14) %>% stringr::str_trim(),
PHASE = stringr::str_sub(ACTES,15,15),
ACT = stringr::str_sub(ACTES,16,16),
EXTDOC = stringr::str_sub(ACTES,17,18),
NBEXEC = stringr::str_sub(ACTES,19,19) %>% as.integer()
) %>% dplyr::select(-ACTES)
}
fzacte(actes) -> actes
rpsa_i$ZAD[is.na(rpsa_i$ZAD)] <- ""
rpsa_i <- rpsa_i %>% dplyr::mutate(das = extz(da, ".{1,6}"),
actes = extz(actes, "[A-Z]{4}[0-9]{3}")) %>% dplyr::select(-ZAD, -da, -lactes, -lda)
libelles[is.na(libelles)] <- ""
if (lib == T){
rpsa_i <- rpsa_i %>% sjlabelled::set_label(c(libelles[-length(libelles)], "Stream actes","Stream DA ou facteurs associés"))
da <- da %>% sjlabelled::set_label(c('N° séquentiel de séjour','N° séquentiel de séquence au sein du séjour',
'Diagnostics et facteurs associés'))
actes <- actes %>% sjlabelled::set_label(c('N° séquentiel de séjour','N° séquentiel de séquence au sein du séjour',
"Délai depuis la date d'entrée", "Code CCAM",
"Extension PMSI", "Code de la phase", "Code de l'activité", "Extension documentaire", "Nombre de réalisations"))
}
if (tolower_names){
names(rpsa_i) <- tolower(names(rpsa_i))
names(da) <- tolower(names(da))
names(actes) <- tolower(names(actes))
}
rpsa_1 = list(rpsa = rpsa_i, das = da, actes = actes)
}
attr(rpsa_1,"problems") <- synthese_import
return(rpsa_1)
}
#' ~ PSY - Import des R3A
#'
#' Import du fichier R3A
#'
#' Formats depuis 2012 pris en charge
#' Structure du nom du fichier attendu (sortie de Pivoine) :
#' \emph{finess.annee.moisc.r3a}
#'
#' \strong{750712184.2016.3.r3a}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des données (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les données R3A.
#'
#' @examples
#' \dontrun{
#' r3a <- ir3a('750712184',2015,12,"~/Documents/data/psy")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irpsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage ir3a(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export ir3a
#' @export
ir3a <- function(...){
UseMethod('ir3a')
}
#' @export
ir3a.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(ir3a.default, param2)
}
#' @export
ir3a.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(ir3a.default, param2)
}
#' @export
ir3a.default <- function(finess, annee, mois, path, lib = T, tolower_names = F, ...){
if (annee<2012|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'psy', table == 'r3a', an == substr(as.character(annee),3,4))
format$longueur[nrow(format)] <- NA
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
extz <- function(x,pat){unlist(lapply(stringr::str_extract_all(x,pat),toString) )}
suppressWarnings(r3a_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".r3a"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...))
readr::problems(r3a_i) -> synthese_import
r3a_i <- r3a_i %>%
dplyr::mutate(DP = stringr::str_trim(DP))
zad <- r3a_i %>% dplyr::select(NOSEQSEJ,NOORDR,NBDA,ZAD) %>% dplyr::mutate(da = ifelse(NBDA>0,ZAD,""),
lda = stringr::str_extract_all(da, '.{1,6}'))
da <- purrr::flatten_chr(zad$lda)
df <- zad %>% dplyr::select(NOSEQSEJ,NOORDR,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = stringr::str_trim(da), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDA)
r3a_i$ZAD[is.na(r3a_i$ZAD)] <- ""
r3a_i <- r3a_i %>% dplyr::mutate(das = extz(ZAD, ".{1,6}")) %>% dplyr::select(-ZAD)
if (lib == T){
r3a_i <- r3a_i %>% sjlabelled::set_label(c(libelles[-length(libelles)], "Stream DA ou facteurs associés"))
da <- da %>% sjlabelled::set_label(c('N° séquentiel de séjour',"N° d'ordre", 'Diagnostics et facteurs associés'))
}
if (tolower_names){
names(r3a_i) <- tolower(names(r3a_i))
names(da) <- tolower(names(da))
}
r3a_1 = list(r3a = r3a_i, das = da)
attr(r3a_1,"problems") <- synthese_import
return(r3a_1)
}
#' ~ PSY - Import des Anohosp
#'
#' Import du fichier Ano
#'
#' Formats depuis 2012 pris en charge
#' Structure du nom du fichier attendu (sortie de Genrha) :
#' \emph{finess.annee.moisc.ano}
#'
#' \strong{750712184.2016.2.ano}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typano Type de donnees in / out
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les données Anohosp SSR du Out.
#'
#' @examples
#' \dontrun{
#' anoh <- iano_psy('750712184',2015,12,"~/Documents/data/psy")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irpsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage iano_psy(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export iano_psy
#' @export
iano_psy <- function(...){
UseMethod('iano_psy')
}
#' @export
iano_psy.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iano_psy.default, param2)
}
#' @export
iano_psy.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iano_psy.default, param2)
}
#' @export
iano_psy.default <- function(finess, annee, mois, path, typano = c('out', 'in'), lib=T, tolower_names = F, ...){
if (annee<2012|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
typano <- match.arg(typano)
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (typano=="out"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'psy', table == 'rpsa_ano', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
extz <- function(x,pat){unlist(lapply(stringr::str_extract_all(x,pat),toString) )}
if (annee<=2012){
ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSOR = lubridate::dmy(DTSOR, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') ==7),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTRMBAMC = MTRMBAMC/100)
}
if (annee>2012){
ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSOR = lubridate::dmy(DTSOR, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') +
(CRCDNAI=='0') + (CRCSEXE=='0')==9),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
MTRMBAMC = MTRMBAMC/100,
TAUXRM = TAUXRM /100)
}
if (lib == T){
ano_i <- ano_i %>% sjlabelled::set_label(c(libelles,'Chaînage Ok'))
ano_i <- ano_i %>% dplyr::select(-dplyr::starts_with("Fill"))
}
}
if (typano=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'psy', table == 'rps_ano', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (2011<annee){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".anohosp.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTHOSP = lubridate::dmy(DTHOSP, quiet = TRUE),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTRMAMC = MTRMAMC /100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
if (annee == 2011){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".anohosp.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
Fillers <- names(ano_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
ano_i <- ano_i[,!(names(ano_i) %in% Fillers)]
if (lib==T){
v <- libelles[!is.na(libelles)]
ano_i <- ano_i %>% sjlabelled::set_label(v)
}
}
if (tolower_names){
names(ano_i) <- tolower(names(ano_i))
}
attr(ano_i,"problems") <- synthese_import
return(ano_i)
}
##############################################
####################### DICO #################
##############################################
#' ~ Dico - Dictionnaire des tables
#'
#' Obtenir le dictionnaire d'une table
#'
#'
#' @param table Table dont on veut le dictionnaire de variables
#'
#' @examples
#' \dontrun{
#' # N'importer qu'une ligne du fichier :
#' irsa('750712184', 2016, 8, '~/path/path', typi= 1, n_max = 1) -> import
#' dico(import$rsa)
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irsa}}, \code{\link{irum}}
#' @export
dico <- function(table){
tibble::tibble(
nom = names(table),
label = sjlabelled::get_label(table),
type = sapply(table, class)
) %>% sjlabelled::set_label(c("Nom de la variable","Libellé, de la variable", "Type"))
}
##############################################
####################### Tidy #################
##############################################
#' ~ Tidy - Tidy Diagnostics
#'
#' Restructurer les diagnostics
#'
#' On obtient une table contenant tous les diagnostics par séjour, sur le principe suivant :
#' Une variable numérique indique la position des diagnostics
#' - pour les rsa : 1 : DP du rsa, 2 : DR du rsa, 3 : DPUM, 4 : DRUM, 5 : DAS
#' - pour les rum : 1 : DP du rum, 2 : DR du rum, 3 : DAS, 4 : DAD
#' - pour les rha : 1 : MMP du rha, 2 : FPPC du rha, 3 : AE, 4 : DA
#'
#' @param d Objet S3 resultat de l'import pmeasyr (irsa, irum, irha)
#' @param include booleen : defaut a T; T : restructure l'objet S3 (agglomere dp, dr, das et dad, par exemple)
#'
#' @examples
#' \dontrun{
#' # avec include = T
#' irum('750712184', 2016, 8, '~/path/path', typi = 3) -> d1
#' tdiag(d1) -> d1
#' d1$diags
#' d1$actes
#' d1$dad
#' irsa('750712184', 2016, 8, '~/path/path', typi = 4) -> d1
#' tdiag(d1, include = F) -> alldiag
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irsa}}, \code{\link{irum}}, \code{\link{irha}}
#' @export
tdiag <- function (d, include = T){
if (names(d)[1] == "rsa") {
if ('DP' %in% names(d$rsa)){
temp <- d$rsa %>% dplyr::select(CLE_RSA, NSEQRUM = NOSEQRUM, DP, DR) %>%
sjlabelled::set_label(rep("", 4))
e <- temp %>% tidyr::gather(position, diag, -CLE_RSA, - NSEQRUM,
na.rm = T)
f <- e %>% dplyr::filter(diag != "")
g <- d$das %>% dplyr::select(CLE_RSA,NSEQRUM,diag = DAS) %>% dplyr::mutate(position = "DAS")
h <- dplyr::bind_rows(f, g)
temp <- d$rsa_um %>% dplyr::select(CLE_RSA, NSEQRUM, DPUM, DRUM) %>%
sjlabelled::set_label(rep("", 4))
e <- temp %>% tidyr::gather(position, diag, -CLE_RSA, - NSEQRUM,
na.rm = T)
f <- e %>% dplyr::filter(diag != "")
h <- dplyr::bind_rows(h, f) %>% dplyr::mutate(position = as.numeric(as.character(forcats::fct_recode(position,`1` = "DP", `2` = "DR", `3` = "DPUM", `4` = "DRUM",
`5` = "DAS"))))
# h <- sjlabelled::remove_all_labels(h)
if (!is.null(sjlabelled::get_label(d$rsa$NOFINESS))){
h <- h %>% sjlabelled::set_label(c("Clé rsa", "N° du RUM","1:DP, 2:DR, 3:DPUM, 4:DRUM, 5:DAS",
"Diagnostic"))
}
if (include == F) {
return(h %>% dplyr::as_tibble())
}
else {
return(list(rsa = d$rsa %>% dplyr::as_tibble(),
rsa_um = d$rsa_um %>% dplyr::as_tibble(),
actes = d$actes %>% dplyr::as_tibble(),
diags = h %>% dplyr::as_tibble()))
}
}
else if ('dp' %in% names(d$rsa)){
temp <- d$rsa %>% dplyr::select(cle_rsa, nseqrum = noseqrum, dp, dr) %>%
sjlabelled::set_label(rep("", 4))
e <- temp %>% tidyr::gather(position, diag, -cle_rsa, - nseqrum,
na.rm = T)
f <- e %>% dplyr::filter(diag != "")
g <- d$das %>% dplyr::select(cle_rsa,nseqrum,diag = das) %>% dplyr::mutate(position = "das")
h <- dplyr::bind_rows(f, g)
temp <- d$rsa_um %>% dplyr::select(cle_rsa, nseqrum, dpum, drum) %>%
sjlabelled::set_label(rep("", 4))
e <- temp %>% tidyr::gather(position, diag, -cle_rsa, - nseqrum,
na.rm = T)
f <- e %>% dplyr::filter(diag != "")
h <- dplyr::bind_rows(h, f) %>% dplyr::mutate(position = as.numeric(as.character(forcats::fct_recode(position,`1` = "dp", `2` = "dr", `3` = "dpum", `4` = "drum",
`5` = "das"))))
# h <- sjlabelled::remove_all_labels(h)
if (!is.null(sjlabelled::get_label(d$rsa$nofiness))){
h <- h %>% sjlabelled::set_label(c("Clé rsa", "N° du RUM","1:DP, 2:DR, 3:DPUM, 4:DRUM, 5:DAS",
"Diagnostic"))
}
if (include == F) {
return(h %>% dplyr::as_tibble())
}
else {
return(list(rsa = d$rsa %>% dplyr::as_tibble(),
rsa_um = d$rsa_um %>% dplyr::as_tibble(),
actes = d$actes %>% dplyr::as_tibble(),
diags = h %>% dplyr::as_tibble()))
}
}
}
if (names(d)[1] == "rum") {
if ("DP" %in% names(d$rum)){
temp <- d$rum %>% dplyr::select(NAS,NORUM, DP, DR) %>% sjlabelled::set_label(rep("",4))
e <- temp %>% tidyr::gather(position, diag, -NAS,- NORUM, na.rm = T)
f <- e %>% dplyr::filter(diag != "")
g <- d$das %>% dplyr::rename(diag = DAS) %>% dplyr::mutate(position = "DAS")
g2 <- d$dad %>% dplyr::rename(diag = DAD) %>% dplyr::mutate(position = "DAD")
h <- dplyr::bind_rows(list(f, g, g2)) %>%
dplyr::mutate(position = as.numeric(as.character(forcats::fct_recode(position,`1` = "DP", `2` = "DR", `3` = "DAS", `4`="DAD"))))
h <- sjlabelled::remove_all_labels(h)
if (!is.null(sjlabelled::get_label(d$rum$NOFINESS))){
h <- h %>% sjlabelled::set_label(c("N° administratif du séjour", "N° du RUM",
"1:DP, 2:DR, 3:DAS, 4:DAD", "Diagnostic"))
}
if (include == F) {
return(h %>% dplyr::as_tibble())
}
else {
return(list(rum = d$rum %>% dplyr::as_tibble(),
actes = d$actes %>% dplyr::as_tibble(),
diags = h %>% dplyr::as_tibble()))
}
}
else if ("dp" %in% names(d$rum)){
temp <- d$rum %>% dplyr::select(nas, norum, dp, dr) %>% sjlabelled::set_label(rep("",4))
e <- temp %>% tidyr::gather(position, diag, -nas,- norum, na.rm = T)
f <- e %>% dplyr::filter(diag != "")
g <- d$das %>% dplyr::rename(diag = das) %>% dplyr::mutate(position = "das")
g2 <- d$dad %>% dplyr::rename(diag = dad) %>% dplyr::mutate(position = "dad")
h <- dplyr::bind_rows(list(f, g, g2)) %>%
dplyr::mutate(position = as.numeric(as.character(forcats::fct_recode(position,`1` = "dp", `2` = "dr", `3` = "das", `4`="dad"))))
h <- sjlabelled::remove_all_labels(h)
if (!is.null(sjlabelled::get_label(d$rum$nofiness))){
h <- h %>% sjlabelled::set_label(c("N° administratif du séjour", "N° du RUM",
"1:DP, 2:DR, 3:DAS, 4:DAD", "Diagnostic"))}
if (include == F) {
return(h %>% dplyr::as_tibble())
}
else {
return(list(rum = d$rum %>% dplyr::as_tibble(),
actes = d$actes %>% dplyr::as_tibble(),
diags = h %>% dplyr::as_tibble()))
}
}
}
if (names(d)[1] == "rha") {
if ("MMP" %in% names(d$rha)){
temp <- d$rha %>% dplyr::select(NOSEQSEJ, NOSEQRHS, MMP, FPPC, AE) %>%
sjlabelled::set_label(rep("", 5))
e <- temp %>% tidyr::gather(position, diag, -NOSEQSEJ, - NOSEQRHS,
na.rm = T)
f <- e %>% dplyr::filter(diag != "")
g <- d$acdi %>% dplyr::filter(CODE == 'DA') %>% dplyr::select(NOSEQSEJ,NOSEQRHS,diag = DA) %>% dplyr::mutate(position = "DA")
h <- dplyr::bind_rows(f, g)
h <- dplyr::bind_rows(h, f) %>% dplyr::mutate(position = as.numeric(as.character(forcats::fct_recode(position,`1` = "MMP", `2` = "FPPC", `3` = "AE", `4` = "DA"))))
h <- h %>% sjlabelled::set_label(c("N° séquentiel du séjour", "N° séquentiel du RHS","1:MMP, 2:FPPC, 3:AE, 4:DA",
"Diagnostic"))
if (include == F) {
return(h %>% dplyr::as_tibble())
}
else {
return(list(rha = d$rha %>% dplyr::as_tibble(),
acdi = d$acdi %>% dplyr::as_tibble(),
diags = h %>% dplyr::as_tibble()))
}
}
else if ("mmp" %in% names(d$rha)){
temp <- d$rha %>% dplyr::select(noseqsej, noseqrhs, mmp, fppc, ae) %>%
sjlabelled::set_label(rep("", 5))
e <- temp %>% tidyr::gather(position, diag, -noseqsej, - noseqrhs,
na.rm = T)
f <- e %>% dplyr::filter(diag != "")
g <- d$acdi %>% dplyr::filter(code == 'DA') %>% dplyr::select(noseqsej,noseqrhs,diag = da) %>% dplyr::mutate(position = "da")
h <- dplyr::bind_rows(f, g)
h <- dplyr::bind_rows(h, f) %>% dplyr::mutate(position = as.numeric(as.character(forcats::fct_recode(position,`1` = "mmp", `2` = "fppc", `3` = "ae", `4` = "da"))))
h <- h %>% sjlabelled::set_label(c("N° séquentiel du séjour", "N° séquentiel du RHS","1:MMP, 2:FPPC, 3:AE, 4:DA",
"Diagnostic"))
if (include == F) {
return(h %>% dplyr::as_tibble())
}
else {
return(list(rha = d$rha %>% dplyr::as_tibble(),
acdi = d$acdi %>% dplyr::as_tibble(),
diags = h %>% dplyr::as_tibble()))
}
}
}
}
##############################################
####################### RSF ##################
##############################################
#' ~ RSF - Import des Rafael
#'
#' Import des Rafael et des Rafael reprises
#'
#' Formats depuis 2012 pour les rsfa
#' Formats depuis 2014 pour les rsfa-maj (reprise 2013)
#'
#' @return Une classe S3 contenant les tables (data.frame, tibble ou tbl) importées (rafaels)
#'
#' @examples
#' \dontrun{
#' irafael('750712184',2015,12,'~/Documents/data/rsf') -> rsfa15
#' irafael('750712184',2015,12,'~/Documents/data/rsf', lister = 'C', lamda = T) -> rsfa14_lamda
#' }
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par défaut a TRUE ; necessite le package \code{sjlabelled}
#' @param stat avec stat = T, un tableau synthetise le nombre de lignes par type de rafael
#' @param lister Liste des types d'enregistrements a importer
#' @param lamda a TRUE, importe les fichiers \code{rsfa-maj} de reprise de l'annee passee
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... Autres parametres a specifier \code{n_max = 1e3}, ...
#' @author G. Pressiat
#'
#' @seealso \code{\link{iano_rafael}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage irafael(finess, annee, mois, path, lib = T, tolower_names = F,
#' stat = T, lister = c("A", "B",
#' "C", "H", "L", "M", "P"), lamda = F, ...)
#' @export irafael
#' @export
irafael <- function(...){
UseMethod('irafael')
}
#' @export
irafael.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(irafael.default, param2)
}
#' @export
irafael.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(irafael.default, param2)
}
#' @export
irafael.default <- function(finess, annee, mois, path, lib = T, stat = T,
lister = c('A', 'B', 'C', 'H', 'L', 'M', 'P'),
lamda = F, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (lamda == F){
# cat(paste("Import des RSFA / Rafael", annee, paste0("M",mois),"\n"))
# cat(paste("L'objet retourné prendra la forme d'une classe S3.
# $A pour les Rafael A, et B, C, ...\n"))
formats <- pmeasyr::formats %>% dplyr::filter(champ == "rsf", table == "rafael", an == substr(annee,3,4))
r <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rsfa"),
readr::fwf_widths(NA, 'lon'),
col_types = readr::cols('c'), ...)
readr::problems(r) -> synthese_import
typi_r <- 9
if (annee > 2016 & annee < 2020){typi_r <- 11}
# if (annee > 2019){typi_r <- 9}
}
if (lamda == T){
# cat(paste("Import des rsfa-maj", annee, paste0("M",mois),"\n"))
# cat(paste("L'objet retourné prendra la forme d'une classe S3.
# $A pour les Rafael A, et B, C, ...\n"))
#
formats <- pmeasyr::formats %>% dplyr::filter(champ == "rsf", table == "rafael-maj", an == substr(annee,3,4))
r <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rsfa-maj"),
readr::fwf_widths(NA, 'lon'),
col_types = readr::cols('c'), ...)
readr::problems(r) -> synthese_import
typi_r <- 27
if (annee > 2017){typi_r <- 29}
}
former <- function(cla, col1){
switch(cla,
'c' = col1,
'trim' = col1 %>% stringr::str_trim(),
'i' = col1 %>% as.integer(),
'n' = (col1 %>% as.numeric() )/100)
}
cutt <- function(typs, lib){
fa <- formats %>% dplyr::filter(Typer == typs)
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
r %>% dplyr::filter(substr(lon,typi_r,typi_r) == typs) -> one
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$cla[i], u(one$lon, i)))
names(temp) <- fa$nom[i]
one <- dplyr::bind_cols(one, temp)
}
one %>% dplyr::select(-lon) -> one
if (lib == T){
one %>% sjlabelled::set_label(fa$libelle) -> one
}
return(one)
}
if ('A' %in% lister){rafael_A <- suppressWarnings(cutt('A', lib))}else{rafael_A <- data.frame()}
r %>% dplyr::filter(substr(lon,typi_r,typi_r) != 'A') -> r
if ('B' %in% lister){rafael_B <- suppressWarnings(cutt('B', lib))}else{rafael_B <- data.frame()}
r %>% dplyr::filter(substr(lon,typi_r,typi_r) != 'B') -> r
if ('C' %in% lister){rafael_C <- suppressWarnings(cutt('C', lib))}else{rafael_C <- data.frame()}
r %>% dplyr::filter(substr(lon,typi_r,typi_r) != 'C') -> r
if ('M' %in% lister){rafael_M <- suppressWarnings(cutt('M', lib))}else{rafael_M <- data.frame()}
r %>% dplyr::filter(substr(lon,typi_r,typi_r) != 'M') -> r
if ('L' %in% lister){rafael_L <- suppressWarnings(cutt('L', lib))}else{rafael_L <- data.frame()}
r %>% dplyr::filter(substr(lon,typi_r,typi_r) != 'L') -> r
if ('P' %in% lister){rafael_P <- suppressWarnings(cutt('P', lib))}else{rafael_P <- data.frame()}
r %>% dplyr::filter(substr(lon,typi_r,typi_r) != 'P') -> r
if ('H' %in% lister){rafael_H <- suppressWarnings(cutt('H', lib))}else{rafael_H <- data.frame()}
rm(r)
deux<-Sys.time()
#at(paste("Rafaels",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
if (stat == T){
print(
knitr::kable(tibble::tibble(Rafael = c('A', 'B', 'C', 'H', 'L', 'M', 'P'),
Lignes = c(nrow(rafael_A),
nrow(rafael_B),
nrow(rafael_C),
nrow(rafael_H),
nrow(rafael_L),
nrow(rafael_M),
nrow(rafael_P)))))
}
if (tolower_names){
names(rafael_A) <- tolower(names(rafael_A))
names(rafael_B) <- tolower(names(rafael_B))
names(rafael_C) <- tolower(names(rafael_C))
names(rafael_H) <- tolower(names(rafael_H))
names(rafael_L) <- tolower(names(rafael_L))
names(rafael_M) <- tolower(names(rafael_M))
names(rafael_P) <- tolower(names(rafael_P))
}
r_ii <- list("A" = rafael_A,
"B" = rafael_B,
"C" = rafael_C,
"H" = rafael_H,
"L" = rafael_L,
"M" = rafael_M,
"P" = rafael_P)
attr(r_ii,"problems") <- synthese_import
return(r_ii)
}
#' ~ RSF - Import des Anohosp RSFA
#'
#' Import du fichier ANO-ACE RSF Out ou le ano-ace-maj (reprise)
#'
#' Formats depuis 2012 pris en charge pour les ano-ace
#' Formats depuis 2014 pris en charge pour les ano-ace-maj (reprise 2013)
#'
#' Structure du nom du fichier attendu :
#' \emph{finess.annee.moisc.ano}
#'
#' \strong{750712184.2016.2.ano}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lamda a TRUE, importe le fichier ano-ace-maj
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame ou tibble) qui contient les données Anohosp in / out
#'
#' @examples
#' \dontrun{
#' iano_rafael('750712184', 2015, 12,'~/Documents/data/rsf') -> ano_out15
#' iano_rafael('750712184', 2015, 12,'~/Documents/data/rsf', lamda = T) -> lamda_maj_ano_out14
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irafael}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage iano_rafael(finess, annee, mois, path, lib = T, lamda = F, tolower_names = F, ...)
#' @export iano_rafael
#' @export
iano_rafael <- function(...){
UseMethod('iano_rafael')
}
#' @export
iano_rafael.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iano_rafael.default, param2)
}
#' @export
iano_rafael.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iano_rafael.default, param2)
}
#' @export
iano_rafael.default <- function(finess, annee, mois, path, lib = T, lamda = F, tolower_names = F, ...){
if (annee<2012|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
if (lamda == F){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'rsf', table == 'rafael_ano', an == substr(as.character(annee),3,4))
}
if (lamda == T){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'rsf', table == 'rafael_ano-maj', an == substr(as.character(annee),3,4))
}
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (lamda == F){ ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano-ace"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRNOSEC=='0')+(CRDNAIS=='0')+ (CRSEXE=='0') + (CRNAS=='0') +
(CRDENTR=='0') ==5)) %>% sjlabelled::set_label(c(libelles, 'Chaînage Ok'))
}
if (lamda == T){ ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano-ace-maj"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRNOSEC=='0')+(CRDNAIS=='0')+ (CRSEXE=='0') + (CRNAS=='0') +
(CRDENTR=='0') ==5)) %>% sjlabelled::set_label(c(libelles, 'Chaînage Ok'))
}
if (tolower_names){
names(ano_i) <- tolower(names(ano_i))
}
attr(ano_i,"problems") <- synthese_import
return(ano_i)
}
#' Table des formats
#'
#' @name formats
#' @docType data
#' @author G. Pressiat
#' @keywords data
NULL
#' ~ par - Noyau de parametres
#'
#' Définir un noyau de paramètres
#'
#' Voir exemple
#'
#' @exportClass pm_param
#' @author G. Pressiat
#'
#' @examples
#' \dontrun{
#' library(magrittr)
#'
#' p <- noyau_pmeasyr(
#' finess = '750712184',
#' annee = 2016,
#' mois = 12,
#' path = '~/Documents/data/mco',
#' progress = F
#' )
#'
#' p %>% adezip(type = "out", liste = "")
#'
#' p %>% irsa() -> rsa
#' p %>% iano_mco() -> ano
#' p %>% ipo() -> po
#'
#' p %>% adezip(type = "in", liste = "")
#'
#' p %>% irum() -> rum
#'
#' # Modifier le type d'import :
#' irsa(p, typi = 6) -> rsa
#'
#' # Pour visualiser p :
#' p
#' print(p)
#' }
#' @seealso \code{\link{noyau_skeleton}}
#' @export
noyau_pmeasyr <- function(...){
params <- list(...)
#attr(params, "class") <- "list"
attr(params, "class") <- "pm_param"
#class(params) <- append(class(params),"pm_param")
return(params)
}
#' @rdname noyau_pmeasyr
#' @export
print.pm_param <- function(x, ...){
i <- unlist(x) %>%
t() %>%
as.data.frame(stringsAsFactors=F) %>%
tidyr::gather("parametre", "valeur")
a <- as.character(knitr::kable(i))
a <- paste0('', a)
a <- c('*** Noyau de param pmeasyr ***\n', a)
cat(a, sep="\n")
}
#' ~ par - Noyau de parametres
#'
#' Générer un squelette de noyau de paramètres
#'
#' Voir exemple
#'
#' @author G. Pressiat
#'
#' @examples
#' \dontrun{
#'
#' noyau_skeleton()
#' ## résultat :
#' ## noyau_pmeasyr(
#' ## finess = '.........',
#' ## annee = ....,
#' ## mois = ..,
#' ## path = ''
#' ## ) -> p
#'
#' noyau_skeleton("alpha_bravo", T)
#'
#' ## noyau_pmeasyr(
#' ## finess = '.........',
#' ## annee = ....,
#' ## mois = ..,
#' ## path = ''
#' ## ) -> alpha_bravo
#' ##
#' ## # adezip(alpha_bravo, type = 'out')
#' ## # adezip(alpha_bravo, type = 'in')
#'
#' }
#'
#' @seealso \code{\link{noyau_pmeasyr}}
#' @export
noyau_skeleton <- function(nom = "p", zip = F){
cat(paste0("\nnoyau_pmeasyr(
finess = \'.........\',
annee = ....,
mois = ..,
path = \'\'
) -> ", nom, "\n\n"))
if (zip){
cat(paste0("# adezip(", nom, ", type = \'out\')\n# adezip(", nom, ", type = \'in\')"))
}
}
##############################################
####################### LABELS ###############
##############################################
#' ~ Labels pour le PMSI
#'
#' Attribuer des libelles aux colonnes PMSI
#'
#' @param col Colonne à laquelle attribuer le libellé
#' @param Mode_entree '6' : 'Mutation'
#' @param Mode_sortie '9' : 'Décès'
#' @param Provenance '1' : 'MCO'
#' @param Destination '6' : 'HAD'
#' @param Sexe '2' : 'Femme'
#'
#' @return Un vecteur caractère ou facteur
#'
#' @examples
#' \dontrun{
#' labeleasier(rsa$rsa$SEXE, Sexe = T, F)
#' labeleasier(rsa$rsa$DEST, Destination = T, F)
#' }
#'
#' @author G. Pressiat
#'
#'
#' @import forcats
#' @export
labeleasier <- function(col,
Mode_entree = F,
Mode_sortie = F,
Provenance = F,
Destination = F,
Sexe = F,
facteur = F){
choix = c(Mode_entree,
Mode_sortie,
Provenance,
Destination,
Sexe)
noms <- c('Mode_entree',
'Mode_sortie',
'Provenance',
'Destination',
'Sexe')
if (sum( choix) != 1){
stop("Un et un seul format doit être spécifié par TRUE en paramètre")}
quoi <- noms[which(choix==T)]
r <- suppressWarnings(switch(quoi,
"Mode_entree" = forcats::fct_recode(col,
"PIE" = "0",
"Mutation" = "6",
"Transfert" = "7",
"Domicile" = "8",
"Inconnu" = ''),
"Mode_sortie" = forcats::fct_recode(col,
"Mutation" = "6",
"Transfert" = "7",
"Domicile" = "8",
"Décès" = "9",
"Inconnu" = ''),
"Provenance" = forcats::fct_recode(col,
"MCO" = "1",
"SSR" = "2",
"SLD" = "3",
"PSY" = "4",
"SAU" = "5",
"HAD" = "6",
"ESMS" = "7",
"SIAD" = "8",
"Inconnu" = ''
),
"Destination" = forcats::fct_recode(col,
"MCO" = "1",
"SSR" = "2",
"SLD" = "3",
"PSY" = "4",
"SAU" = "5",
"HAD" = "6",
"ESMS" = "7",
"SIAD" = "8",
"Inconnu" = ''
),
"Sexe" = forcats::fct_recode(col,
"Homme" = "1",
"Femme" = "2",
"Inconnu" = "9",
"Inconnu" = '0',
"Inconnu" = ''
)))
if (facteur == T){return(r)}else{return(as.character(r))}
}
##############################################
####################### DB ###################
##############################################
`%+%` <- function(x,y){paste0(x,y)}
#' ~ db - Copier les rsa dans une db
#'
#' Copier les rsa, les passages um, les actes et les diagnostics des rsa, et ano dans une db
#'
#' Les tables sont importées dans R puis copiées dans la db.
#' La table diag est créée, les variables ghm, année séquentielle des tarifs
#' et un champ caractère diagnostics sont ajoutés à la table rsa.
#' Le tra est ajouté aux tables.
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param p le noyau pmeasyr
#' @param remove a TRUE, les tables precedentes rsa de l'annee sont effacees avant
#' @param zip a TRUE les fichiers des archives sont dezippes et effaces apres integration dans la db
#' @param indexes index a ajouter a la table dans la base (voir \code{\link[dplyr]{copy_to}})
#' @return nothing
#' @export
#'
#' @usage db_mco_out(con, p, remove = T, zip = T, indexes = list(), ...)
#' @examples
#' \dontrun{
#' purrr::quietly(db_mco_out)(con, p) -> statuts ; gc(); #ok
#' purrr::quietly(db_mco_out)(con, p, annee = 2017, mois = 7) -> statuts ; gc(); #..
#' }
db_mco_out <- function (con, p, remove = T, zip = T, indexes = list(), ...){
p <- utils::modifyList(p, list(...))
an <- substr(as.character(p$annee), 3, 4)
if (remove == T) {
#u <- DBI::dbListTables(con)
u <- dplyr::src_tbls(con)
lr <- u[grepl("_rsa_", u) & grepl(an, u)]
lapply(lr, function(x) {
DBI::dbRemoveTable(con$con, x)
})
}
if (zip == T) {
adezip(p, type = "out", liste = c("rsa", "ano", "tra"))
}
rsa <- pmeasyr::irsa(p, typi = 6) %>% pmeasyr::tdiag()
rsa_ano <- pmeasyr::iano_mco(p)
tra <- pmeasyr::itra(p)
rsa$rsa <- pmeasyr::inner_tra(rsa$rsa, tra) %>% mutate(diags = paste0(dpdrum,
das, sep = " "))
rsa$actes <- pmeasyr::inner_tra(rsa$actes, tra)
rsa$diags <- pmeasyr::inner_tra(rsa$diags, tra)
rsa$rsa_um <- pmeasyr::inner_tra(rsa$rsa_um, tra)
rsa_ano <- pmeasyr::inner_tra(rsa_ano, tra)
purrr::flatten_int(purrr::map(indexes, length)) -> t_1
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsa$rsa))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsa$rsa), "mco_" %+% an %+% "_rsa_rsa", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsa$actes))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsa$actes), "mco_" %+% an %+% "_rsa_actes", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsa$diags))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsa$diags), "mco_" %+% an %+% "_rsa_diags", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsa$rsa_um))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsa$rsa_um), "mco_" %+% an %+% "_rsa_um", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsa_ano))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsa_ano), "mco_" %+% an %+% "_rsa_ano", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
if (zip == T) {
pmeasyr::adelete(p)
}
}
#' ~ db - Copier les rha dans une db
#'
#' Copier les rha, les actes, les diagnostics des rha, ssrha et ano dans une db
#'
#' Les tables sont importées dans R puis copiées dans la db.
#' Le tra est ajouté aux tables.
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param p le noyau pmeasyr
#' @param remove a TRUE, les tables precedentes rha de l'annee sont effacees avant
#' @param zip a TRUE les fichiers des archives sont dezippes et effaces apres integration dans la db
#' @param indexes index a ajouter a la table dans la base (voir \code{\link[dplyr]{copy_to}})
#' @return nothing
#' @export
#'
#' @usage db_ssr_out(con, p, remove = T, zip = T, indexes = list(), ...)
#' @examples
#' \dontrun{
#' purrr::quietly(db_ssr_out)(con, p) -> statuts ; gc(); #ok
#' purrr::quietly(db_ssr_out)(con, p, annee = 2017, mois = 7) -> statuts ; gc(); #..
#' }
db_ssr_out <- function (con, p, remove = T, zip = T, indexes = list(), ...){
p <- utils::modifyList(p, list(...))
an <- substr(as.character(p$annee), 3, 4)
if (remove == T) {
#u <- DBI::dbListTables(con)
u <- dplyr::src_tbls(con)
lr <- u[grepl("ssr", u) & grepl(an, u)]
lapply(lr, function(x) {
DBI::dbRemoveTable(con$con, x)
})
}
if (zip == T) {
pmeasyr::adezip(p, type = "out", liste = c("rha", "ano",
"sha", "tra"))
}
rha <- pmeasyr::irha(p)
ssrha <- pmeasyr::issrha(p)
rha_ano <- pmeasyr::iano_ssr(p)
tra <- pmeasyr::itra(p, champ = "ssr")
rha$rha <- pmeasyr::inner_tra(rha$rha, tra, champ = "ssr")
rha$acdi <- pmeasyr::inner_tra(rha$acdi, tra, champ = "ssr")
if (p$annee > 2016) {
ssrha$ssrha <- pmeasyr::inner_tra(ssrha$ssrha, tra, champ = "ssr")
ssrha$gme <- pmeasyr::inner_tra(ssrha$gme, tra, champ = "ssr")
}
else {
ssrha <- pmeasyr::inner_tra(ssrha, tra, champ = "ssr")
}
rha_ano <- pmeasyr::inner_tra(rha_ano, tra, champ = "ssr")
purrr::flatten_int(purrr::map(indexes, length)) -> t_1
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rha$rha))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rha$rha), "ssr_" %+% an %+% "_rha_rha", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rha$acdi))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rha$acdi), "ssr_" %+% an %+% "_rha_acdi", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rha_ano))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rha_ano), "ssr_" %+% an %+% "_rha_ano", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
if (p$annee > 2016) {
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(ssrha$ssrha))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(ssrha$ssrha), "ssr_" %+% an %+% "_rha_ssrha", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(ssrha$gme))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(ssrha$gme), "ssr_" %+% an %+% "_rha_gme", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
}
else {
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(ssrha))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(ssrha), "ssr_" %+% an %+% "_rha_ssrha", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
}
if (zip == T) {
pmeasyr::adelete(p)
}
}
#' ~ db - Copier les rapss dans une db
#'
#' Copier les rapss, les actes, les diagnostics et la table ano des rapss dans une db
#'
#' Les tables sont importées dans R puis copiées dans la db.
#' Le tra est ajouté aux tables.
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param p le noyau pmeasyr
#' @param remove a TRUE, les tables precedentes rapss de l'annee sont effacees avant
#' @param zip a TRUE les fichiers des archives sont dezippes et effaces apres integration dans la db
#' @param indexes index a ajouter a la table dans la base (voir \code{\link[dplyr]{copy_to}})
#' @return nothing
#' @export
#'
#' @usage db_had_out(con, p, remove = T, zip = T, indexes = list(), ...)
#' @examples
#' \dontrun{
#' purrr::quietly(db_had_out)(con, p) -> statuts ; gc(); #ok
#' purrr::quietly(db_had_out)(con, p, annee = 2017, mois = 7) -> statuts ; gc(); #..
#' }
db_had_out <- function (con, p, remove = T, zip = T, indexes = list(), ...){
p <- utils::modifyList(p, list(...))
an <- substr(as.character(p$annee), 3, 4)
if (remove == T) {
#u <- DBI::dbListTables(con)
u <- dplyr::src_tbls(con)
lr <- u[grepl("_rapss_", u) & grepl(an, u)]
lapply(lr, function(x) {
DBI::dbRemoveTable(con$con, x)
})
}
if (zip == T) {
pmeasyr::adezip(p, type = "out", liste = c("rapss", "ano",
"tra"))
}
rapss <- pmeasyr::irapss(p)
rapss_ano <- pmeasyr::iano_had(p)
tra <- pmeasyr::itra(p, champ = "had")
rapss$rapss <- pmeasyr::inner_tra(rapss$rapss, tra, champ = "had")
rapss$acdi <- pmeasyr::inner_tra(rapss$acdi, tra, champ = "had")
rapss_ano <- pmeasyr::inner_tra(rapss_ano, tra, champ = "had")
purrr::flatten_int(purrr::map(indexes, length)) -> t_1
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rapss$rapss))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rapss$rapss), "had_" %+% an %+% "_rapss_rapss", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rapss$acdi))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rapss$acdi), "had_" %+% an %+% "_rapss_acdi", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rapss_ano))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rapss_ano), "had_" %+% an %+% "_rapss_ano", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
if (zip == T) {
pmeasyr::adelete(p)
}
}
#' ~ db - Copier les rpsa dans une db
#'
#' Copier les rpsa, les actes, les diagnostics et la table ano des rpsa dans une db
#'
#' Les tables sont importées dans R puis copiées dans la db.
#' Le tra est ajouté aux tables.
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param p le noyau pmeasyr
#' @param remove a TRUE, les tables precedentes rpsa de l'annee sont effacees avant
#' @param zip a TRUE les fichiers des archives sont dezippes et effaces apres integration dans la db
#' @param indexes index a ajouter a la table dans la base (voir \code{\link[dplyr]{copy_to}})
#' @return nothing
#' @export
#'
#' @usage db_psy_out(con, p, remove = T, zip = T, indexes = list(), ...)
#' @examples
#' \dontrun{
#' purrr::quietly(db_psy_out)(con, p) -> statuts ; gc(); #ok
#' purrr::quietly(db_psy_out)(con, p, annee = 2017, mois = 6) -> statuts ; gc(); #..
#' }
db_psy_out <- function (con, p, remove = T, zip = T, indexes = list(), ...){
p <- utils::modifyList(p, list(...))
an <- substr(as.character(p$annee), 3, 4)
if (remove == T) {
#u <- DBI::dbListTables(con)
u <- dplyr::src_tbls(con)
lr <- u[grepl("psy", u) & grepl(an, u)]
lapply(lr, function(x) {
DBI::dbRemoveTable(con$con, x)
})
}
if (zip == T) {
pmeasyr::adezip(p, type = "out", liste = c("rpsa", "ano",
"tra", "tra.raa", "r3a"))
}
rpsa <- pmeasyr::irpsa(p)
rpsa_ano <- pmeasyr::iano_psy(p)
r3a <- pmeasyr::ir3a(p)
tra_rpsa <- pmeasyr::itra(p, champ = "psy_rpsa")
tra_r3a <- pmeasyr::itra(p, champ = "psy_r3a")
rpsa$rpsa <- pmeasyr::inner_tra(rpsa$rpsa, tra_rpsa, champ = "psy_rpsa")
rpsa$das <- pmeasyr::inner_tra(rpsa$das, tra_rpsa, champ = "psy_rpsa")
if (p$annee > 2016) {
rpsa$actes <- pmeasyr::inner_tra(rpsa$actes, tra_rpsa)
}
rpsa_ano <- pmeasyr::inner_tra(rpsa_ano, tra_rpsa, champ = "psy_rpsa")
r3a$r3a <- pmeasyr::inner_tra(r3a$r3a, tra_r3a, champ = "psy_r3a")
r3a$da <- pmeasyr::inner_tra(r3a$da, tra_r3a, champ = "psy_r3a")
purrr::flatten_int(purrr::map(indexes, length)) -> t_1
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rpsa$rpsa))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rpsa$rpsa), "psy_" %+% an %+% "_rpsa_rpsa", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rpsa$das))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rpsa$das), "psy_" %+% an %+% "_rpsa_das", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
if (p$annee > 2016) {
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rpsa$actes))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rpsa$actes), "psy_" %+% an %+% "_rpsa_actes", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
}
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rpsa_ano))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rpsa_ano), "psy_" %+% an %+% "_rpsa_ano", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(r3a$r3a))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(r3a$r3a), "psy_" %+% an %+% "_r3a_r3a", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(r3a$das))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(r3a$das), "psy_" %+% an %+% "_r3a_das", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
if (zip == T) {
pmeasyr::adelete(p)
}
}
#' ~ db - Copier les rum dans une db
#'
#' Copier les rum, les actes et les diagnostics des rums dans une db
#'
#' Les tables sont importées dans R puis copiées dans la db
#' La table diag est créée et la durée des rum est calculée (DUREESEJPART)
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param p le noyau pmeasyr
#' @param remove a TRUE, les tables precedentes rum de l'annee sont effacees avant
#' @param zip a TRUE les fichiers des archives sont dezippes et effaces apres integration dans la db
#' @param indexes index a ajouter a la table dans la base (voir \code{\link[dplyr]{copy_to}})
#' @return nothing
#' @export
#'
#' @usage db_mco_in(con, p, remove = T, zip = T, indexes = list(), ...)
#' @examples
#' \dontrun{
#' purrr::quietly(db_mco_in)(con, p) -> statuts ; gc(); #ok
#' purrr::quietly(db_mco_in)(con, p, annee = 2015) -> statuts ; gc(); #..
#' }
db_mco_in <- function (con, p, remove = T, zip = T, indexes = list(), ...) {
p <- utils::modifyList(p, list(...))
an <- substr(as.character(p$annee), 3, 4)
if (remove == T) {
#u <- DBI::dbListTables(con)
u <- dplyr::src_tbls(con)
lr <- u[grepl("_rum_", u) & grepl(an, u)]
lapply(lr, function(x) {
dbRemoveTable(con$con, x)
})
}
if (zip == T) {
pmeasyr::adezip(p, type = "in", liste = "rss")
}
rum <- pmeasyr::irum(p, typi = 4) %>% pmeasyr::tdiag()
purrr::flatten_int(purrr::map(indexes, length)) -> t_1
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rum$rum))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rum$rum), "mco_" %+% an %+% "_rum_rum", temporary = FALSE, overwrite = TRUE, indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rum$diags))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rum$diags), "mco_" %+% an %+% "_rum_diags", temporary = FALSE, overwrite = TRUE, indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rum$actes))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rum$actes), "mco_" %+% an %+% "_rum_actes", temporary = FALSE, overwrite = TRUE, indexes = indexes[t_1 == t_2])
if (zip == T) {
pmeasyr::adelete(p)
}
}
#' ~ db - Copier les rsf dans une db
#'
#' Copier tous les rsf (lettre par lettre, A, B, C, ...), les ano-ace dans une db
#'
#' Les tables sont importées dans R puis copiées dans la db
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param p le noyau pmeasyr
#' @param remove a TRUE, les tables precedentes rafael de l'annee sont effacees avant
#' @param zip a TRUE les fichiers des archives sont dezippes et effaces apres integration dans la db
#' @param indexes index a ajouter a la table dans la base (voir \code{\link[dplyr]{copy_to}})
#' @return nothing
#'
#' @import DBI
#' @export
#'
#' @usage db_rsf_out(con, p, remove = T, zip = T, indexes = list(), ...)
#' @examples
#' \dontrun{
#' purrr::quietly(db_rsf_out)(con, p) -> statuts ; gc(); #ok
#' purrr::quietly(db_rsf_out)(con, p, annee = 2014) -> statuts ; gc(); #ok
#' }
db_rsf_out <- function (con, p, remove = T, zip = T, indexes = list(), ...){
p <- utils::modifyList(p, list(...))
an <- substr(as.character(p$annee), 3, 4)
if (remove == T) {
u <- dplyr::src_tbls(con)
lr <- u[grepl("_rafael_", u) & grepl(an, u)]
lapply(lr, function(x) {
DBI::dbRemoveTable(con$con, x)
})
}
if (zip == T) {
pmeasyr::adezip(p, type = "out", liste = c("rsfa", "ano-ace"))
}
rsf <- pmeasyr::irafael(p)
rsf_ano <- pmeasyr::iano_rafael(p)
purrr::flatten_int(purrr::map(indexes, length)) -> t_1
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf$A))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf$A), "rsf_" %+% an %+% "_rafael_a", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf$B))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf$B), "rsf_" %+% an %+% "_rafael_b", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf$C))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf$C), "rsf_" %+% an %+% "_rafael_c", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf$H))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf$H), "rsf_" %+% an %+% "_rafael_h", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf$L))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf$L), "rsf_" %+% an %+% "_rafael_l", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf$M))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf$M), "rsf_" %+% an %+% "_rafael_m", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf$P))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf$P), "rsf_" %+% an %+% "_rafael_p", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf_ano))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf_ano), "rsf_" %+% an %+% "_rafael_ano", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
if (zip == T) {
pmeasyr::adelete(p)
}
}
#' ~ db - Lister les tables d'une db en tableau
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param nb le nombre de lignes du tableau
#'
#' @return nothing
#' @export
#'
#' @usage db_liste_tables(con, nb = 15)
#' @examples
#' \dontrun{
#' db_liste_tables(con)
#' }
#' @export
db_liste_tables <- function(con, nb = 15){
DBI::dbListTables(con) -> liste
suppressWarnings(matrix(c(sort(liste), rep('',nb - length(liste) %% nb)),
nrow = nb)) %>% tibble::as_tibble() %>%
knitr::kable(col.names = paste0(nb %+% ' tables, n°',
1:(floor((length(liste)/ nb) )+1)))
}
#' ~ db - remote access aux tables mco
#'
#' @param con Connexion à la base de données
#' @param an Année pmsi (ex: 16)
#' @param table Table à requêter
#' @return remote table
#'
#' @usage tbl_mco(con, an, table)
#' @examples
#' \dontrun{
#' tbl_mco(con, 16, 'rsa_rsa')
#' }
#' @export
tbl_mco <- function(con, an, table){
dplyr::tbl(con, 'mco_' %+% an %+% '_' %+% table)
}
#' ~ db - remote access aux tables rsf
#'
#' @param con Connexion à la base de données
#' @param an Année pmsi (ex: 16)
#' @param table Table à requêter
#' @return remote table
#'
#' @usage tbl_rsf(con, an, table)
#' @examples
#' \dontrun{
#' tbl_rsf(con, 16, 'rsf_rafael_ano')
#' }
#' @export
tbl_rsf <- function(con, an, table){
dplyr::tbl(con, 'rsf_' %+% an %+% '_' %+% table)
}
#' ~ db - remote access aux tables ssr
#'
#' @param con Connexion à la base de données
#' @param an Année pmsi (ex: 16)
#' @param table Table à requêter
#' @return remote table
#'
#' @usage tbl_ssr(con, an, table)
#' @examples
#' \dontrun{
#' tbl_ssr(con, 16, 'rha_rha')
#' }
#' @export
tbl_ssr <- function(con, an, table){
dplyr::tbl(con, 'ssr_' %+% an %+% '_' %+% table)
}
#' ~ db - remote access aux tables had
#'
#' @param con Connexion à la base de données
#' @param an Année pmsi (ex: 16)
#' @param table Table à requêter
#' @return remote table
#' @return tibble
#'
#' @usage tbl_had(con, an, table)
#' @examples
#' \dontrun{
#' tbl_had(con, 16, 'rapss_rapss')
#' }
#' @export
tbl_had <- function(con, an, table){
dplyr::tbl(con, 'had_' %+% an %+% '_' %+% table)
}
#' ~ db - remote access aux tables psy
#'
#' @param con Connexion à la base de données
#' @param an Année pmsi (ex: 16)
#' @param table Table à requêter
#' @return remote table
#' @return tibble
#'
#' @usage tbl_psy(con, an, table)
#' @examples
#' \dontrun{
#' tbl_psy(con, 16, 'rpsa_rpsa')
#' }
#' @export
tbl_psy <- function(con, an, table){
dplyr::tbl(con, 'psy_' %+% an %+% '_' %+% table)
}
#' ~ db - Copier un tibble dans une db
#'
#' Copier une table R dans une db
#'
#' La tables déjà importée dans R est copiée dans la db
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param an l'annee pmsi
#' @param table La table R (tibble) a copier dans la db
#' @param prefix prefixe de la table dans la db (ex : mco, rsf, ssr, ...)
#' @param suffix suffixe de la table dans la db (ex : rum_rum, rha_actes, rapss_rapss, ...)
#' @param indexes index a ajouter a la table dans la base (voir \code{\link[dplyr]{copy_to}})
#'
#' @return nothing
#'
#'
#' @usage db_generique(con, an, table, prefix, suffix, indexes = list(), remove = T)
#' @examples
#' \dontrun{
#' purrr::quietly(db_generique)(con, 16, ma_table, 'had', 'rapss_ano') -> statuts ; gc(); #
#' # Result in db : had_16_rapss_ano
#' }
#' @export
db_generique <- function(con, an, table, prefix, suffix, indexes = list(), remove = T){
nom <- prefix %+% "_" %+% an %+% "_" %+% suffix
if (remove == T){
#DBI::dbListTables(con) -> u
dplyr::src_tbls(con) -> u
if (length(u[u == nom])>0){
DBI::dbRemoveTable(con$con, nom)}
}
purrr::flatten_int(purrr::map(indexes, length)) -> t_1
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(table))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(table), nom, temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
}
##############################################
################## REQUETES ##################
##############################################
#' ~ req : mise en forme d'une liste de codes
#'
#'
#' @examples
#' \dontrun{
#' li <- c('QEFA003', 'QEFA005', 'QEFA010', 'QEFA013', 'QEFA015', 'QEFA019', 'QEFA020')
#'
#' enrobeur(li, robe="", interstice="|") %>% cat()
#'
#' enrobeur(li, robe="\'", interstice=",") %>% cat()
#'
#' enrobeur(li, robe="\'%", interstice="\n", symetrique = T) %>% cat()
#' }
#'
#' @author G. Pressiat
#' voir \url{https://guillaumepressiat.shinyapps.io/transcodeur/} pour son utilisation interactive hors AP-HP
#' @export
enrobeur <- function(a, robe = "\'", colonne = F, interstice = ", ", symetrique = F){
strReverse <- function(x) sapply(lapply(strsplit(x, NULL), rev), paste,
collapse="")
b <- paste0(robe,a,ifelse(symetrique == F,robe, strReverse(robe)))
if (colonne == F){
return(paste0(b, collapse = interstice))
}
else { return(b)}
}
#' ~ req : requeter les rsa avec une liste
#'
#'
#' @examples
#' \dontrun{
#' liste = list(actes = c('EBLA003', 'EQLF002'))
#' requete(rsa, liste)
#'
#' liste = list(actes = c('EBLA003', 'EQLF002'), dureemax = 0)
#' requete(rsa, liste)
#' }
#'
#' @return un tibble contenant les rsa respectant la requete : les rsa qui ont un acte de la liste, un diag, une duree correspondante, etc.
#'
#' @author G. Pressiat
#' @importFrom dplyr mutate inner_join select filter_ distinct tibble tibble data_frame
#' @importFrom purrr flatten_chr
#' @importFrom sqldf sqldf
#' @export
requete <- function (tables, elements, vars = NULL) {
chaine = list()
if (length(elements[["ghm"]]) > 0) {
chaine$ghm <- paste0("grepl('", enrobeur(elements$ghm,
robe = "", colonne = F, interstice = "|"), "', ghm) ")
}
if (length(elements[["ghm_exclus"]]) > 0) {
chaine$ghm_exclus <- paste0("!grepl('", enrobeur(elements$ghm_exclus,
robe = "", colonne = F, interstice = "|"), "', ghm) ")
}
if (length(elements[["diags_exclus"]]) > 0) {
chaine$diags_exclus = paste0("!grepl('", enrobeur(elements$diags_exclus,
robe = "", colonne = F, interstice = "|"), "', diags) ")
}
if (length(elements[["agemin"]]) > 0) {
chaine$agemin = paste0("agean >= ", elements$agemin)
}
if (length(elements[["agemax"]]) > 0) {
chaine$agemax = paste0("agean <= ", elements$agemax)
}
if ((length(elements[["agejrmin"]]) > 0) & ((length(elements[["agemmax"]]) >
0) | (length(elements[["agemin"]]) > 0))) {
chaine$agejrmin = paste0("agean >= ", elements$agejrmin/365.25)
}
if ((length(elements[["agejrmax"]]) > 0) & ((length(elements[["agemmax"]]) >
0) | (length(elements[["agemin"]]) > 0))) {
chaine$agejrmax = paste0("agean <= ", elements$agejrmax/365.25)
}
if (length(elements[["agejrmin"]]) > 0 & (length(elements[["agemmax"]]) ==
0) & (length(elements[["agemin"]]) == 0)) {
chaine$agejrmin = paste0("!is.na(agejr) & agejr >= ",
elements$agejrmin)
}
if (length(elements[["agejrmax"]]) > 0 & (length(elements[["agemmax"]]) ==
0) & (length(elements[["agemin"]]) == 0)) {
chaine$agejrmin = paste0("!is.na(agejr) & agejr <= ",
elements$agejrmax)
}
if (length(elements[["dureemax"]]) > 0) {
chaine$dureemax = paste0("duree <= ", elements$dureemax)
}
if (length(elements[["dureemin"]]) > 0) {
chaine$dureemin <- paste0("duree >= ", elements$dureemin)
}
if (length(elements[["poidsmin"]]) > 0) {
chaine$poidsmin <- paste0("poids >= ", elements$poidsmin)
}
if (length(elements[["poidsmax"]]) > 0) {
chaine$podsmax <- paste0("poids <= ", elements$poidsmax)
}
if (length(elements[["autres"]]) > 0) {
if (!identical(chaine, character())) {
chaine$autres <- paste0(elements$autres)
}
else {
chaine <- paste0(elements$autres)
}
}
if (length(chaine) == 0) {
chaine = list("TRUE")
}
chaine <- rlang::parse_exprs(paste0(purrr::flatten_chr(chaine),
collapse = " & ")) # Again, note the plural s
rsa_filtre <- tables$rsa %>% dplyr::filter(!!!chaine) %>%
dplyr::select(cle_rsa)
# rsa_filtre <- tables$rsa %>% filter_(paste0(purrr::flatten_chr(chaine),
# collapse = " & ")) %>% select(cle_rsa)
if (length(elements[["diags"]]) > 0) {
if (elements[["positions_diags"]][1] == "toutes") {
d <- tables$diags
s <- paste0("select distinct cle_rsa from d where ",
paste0("diag like '", elements$diags, "%'",
collapse = " or "))
diags <- sqldf::sqldf(s) %>% tibble::as_tibble()
}
else if (elements[["positions_diags"]][1] == "dp") {
d <- tables$rsa
s <- paste0("select cle_rsa from d where (",
paste0("dp like '", elements$diags, "%'",
collapse = " or "), ")")
diags <- sqldf::sqldf(s) %>% tibble::as_tibble() %>%
dplyr::select(cle_rsa)
}
else {
d <- tables$diags
s <- paste0("select distinct cle_rsa from d where position in (",
paste0(elements$positions_diags, collapse = ", "),
") and ( ", paste0("diag like '", elements$diags,
"%'", collapse = " or "), " )")
diags <- sqldf::sqldf(s) %>% tibble::as_tibble()
}}
else {
diags = dplyr::tibble()
}
if (length(elements[["actes"]]) > 0) {
liste_actes = tibble::tibble(cdccam = elements$actes) %>%
tibble::as_tibble()
if (length(elements[["activite_actes"]]) > 0) {
actes = dplyr::inner_join(tables$actes %>% filter(act %in%
elements[["activite_actes"]]), liste_actes,
by = c(cdccam = "cdccam")) %>% dplyr::distinct(cle_rsa)
}
else {
actes = dplyr::inner_join(tables$actes, liste_actes,
by = c(cdccam = "cdccam")) %>% dplyr::distinct(cle_rsa)
}
}
else {
actes = dplyr::tibble()
}
resultat <- tables$rsa %>% dplyr::inner_join(rsa_filtre,
by = "cle_rsa")
if (length(elements[["actes"]]) > 0) {
resultat <- resultat %>% dplyr::inner_join(actes, by = "cle_rsa")
}
if (length(elements[["diags"]]) > 0) {
resultat <- resultat %>% dplyr::inner_join(diags, by = "cle_rsa")
}
resultat
if (is.null(vars)) {
return(dplyr::distinct(resultat, cle_rsa))
}
else {
return(resultat %>% dplyr::select(cle_rsa, vars))
}
}
#' ~ req : requeter les rsa dans une db avec une liste
#'
#' @examples
#' \dontrun{
#' liste = list(actes = c('EBLA003', 'EQLF002'))
#' requete_db(con, an, liste)
#'
#' liste = list(actes = c('EBLA003', 'EQLF002'), dureemax = 0)
#' requete_db(con, 16, liste)
#' }
#'
#' @return un tibble contenant les rsa respectant la requete : les rsa qui ont un acte de la liste, un diag, une duree correspondante, etc.
#'
#' @author G. Pressiat
#' @importFrom dplyr mutate inner_join select filter_ distinct tibble tibble data_frame
#' @export
requete_db <- function (con, an, elements, vars = NULL)
{
chaine = list()
if (length(elements[["ghm"]]) > 0) {
chaine$ghm <- paste0("(", paste0("ghm %like% '", elements$ghm,
"%'", collapse = " | "), ")")
}
if (length(elements[["ghm_exclus"]]) > 0) {
chaine$ghm_exclus <- paste0("(", paste0("!(ghm %like% '",
elements$ghm_exclus, "%')", collapse = " & "), ")")
}
if (length(elements[["agemin"]]) > 0) {
chaine$agemin = paste0("agean >= ", elements$agemin)
}
if (length(elements[["agemax"]]) > 0) {
chaine$agemax = paste0("agean <= ", elements$agemax)
}
if ((length(elements[["agejrmin"]]) > 0) & ((length(elements[["agemmax"]]) >
0) | (length(elements[["agemin"]]) > 0))) {
chaine$agejrmin = paste0("agean >= ", elements$agejrmin/365.25)
}
if ((length(elements[["agejrmax"]]) > 0) & ((length(elements[["agemmax"]]) >
0) | (length(elements[["agemin"]]) > 0))) {
chaine$agejrmax = paste0("agean <= ", elements$agejrmax/365.25)
}
if (length(elements[["agejrmin"]]) > 0 & (length(elements[["agemmax"]]) ==
0) & (length(elements[["agemin"]]) == 0)) {
chaine$agejrmin = paste0("!is.na(agejr) & agejr >= ",
elements$agejrmin)
}
if (length(elements[["agejrmax"]]) > 0 & (length(elements[["agemmax"]]) ==
0) & (length(elements[["agemin"]]) == 0)) {
chaine$agejrmin = paste0("!is.na(agejr) & agejr <= ",
elements$agejrmax)
}
if (length(elements[["dureemax"]]) > 0) {
chaine$dureemax = paste0("duree <= ", elements$dureemax)
}
if (length(elements[["dureemin"]]) > 0) {
chaine$dureemin <- paste0("duree >= ", elements$dureemin)
}
if (length(elements[["poidsmin"]]) > 0) {
chaine$poidsmin <- paste0("poids >= ", elements$poidsmin)
}
if (length(elements[["poidsmax"]]) > 0) {
chaine$podsmax <- paste0("poids <= ", elements$poidsmax)
}
if (length(elements[["autres"]]) > 0) {
if (!identical(chaine, character())) {
chaine$autres <- paste0(elements$autres)
}
else {
chaine <- paste0(elements$autres)
}
}
if (length(chaine) == 0) {
chaine = list("TRUE")
}
chaine <- rlang::parse_exprs(paste0(purrr::flatten_chr(chaine),
collapse = " & "))
rsa_filtre <- tbl_mco(con, an, "rsa_rsa") %>% dplyr::filter(!!!chaine) %>% dplyr::select(cle_rsa)
if (length(elements[["diags"]]) > 0) {
if (elements[["positions_diags"]][1] == "toutes"){
chaine_d <- paste0("(", paste0("diag %like% '",elements$diags, "%'", collapse = " | "), ' )')
} else
if (elements[["positions_diags"]][1] == "dp"){
chaine_d <- paste0("position == '1' & ( ", paste0("diag %like% '",elements$diags, "%'", collapse = " | "), ' )')
} else {
chaine_d <- paste0("position %in% c(", paste0(elements$positions_diags,
collapse = ", "), ") & (", paste0("diag %like% '",
elements$diags, "%'", collapse = " | "), ' )')
}
chaine_d <- rlang::parse_exprs(chaine_d)
diags_filtre <- tbl_mco(con, an, "rsa_diags") %>%
dplyr::filter(!!!chaine_d) %>% dplyr::distinct(cle_rsa)
}
else {
diags_filtre <- NULL
}
if (length(elements[["diags_exclus"]]) > 0) {
chaine_d <- paste0('( ', paste0("diag %like% '", elements$diags_exclus, "%'", collapse = " | "), ' )')
chaine_d <- rlang::parse_exprs(chaine_d)
antidiags_filtre <- tbl_mco(con, an, "rsa_diags") %>%
dplyr::filter(!!!chaine_d) %>% dplyr::distinct(cle_rsa)
}
else {
antidiags_filtre <- NULL
}
if (length(elements[["actes"]]) > 0) {
if (length(elements[["activite_actes"]]) > 0){
liste_actes = dplyr::data_frame(cdccam = elements$actes) %>%
dplyr::tibble() %>% dplyr::copy_to(con, ., "acc",
overwrite = T)
actes_filtre = dplyr::inner_join(tbl_mco(con, an, "rsa_actes") %>% filter(act %in% elements[['activite_actes']]),
dplyr::tbl(con, "acc"), by = c(cdccam = "cdccam")) %>%
dplyr::distinct(cle_rsa)
} else {
liste_actes = dplyr::data_frame(cdccam = elements$actes) %>%
dplyr::tibble() %>% dplyr::copy_to(con, ., "acc",
overwrite = T)
actes_filtre = dplyr::inner_join(tbl_mco(con, an, "rsa_actes"),
dplyr::tbl(con, "acc"), by = c(cdccam = "cdccam")) %>%
dplyr::distinct(cle_rsa)
}
}
else {
actes_filtre = NULL
}
resultat <- rsa_filtre
if (length(elements[["diags"]]) > 0) {
resultat <- resultat %>% dplyr::inner_join(diags_filtre,
by = "cle_rsa")
}
if (length(elements[["diags_exclus"]]) > 0) {
resultat <- resultat %>% dplyr::anti_join(antidiags_filtre,
by = "cle_rsa")
}
if (length(elements[["actes"]]) > 0) {
resultat <- resultat %>% dplyr::inner_join(actes_filtre,
by = "cle_rsa")
}
if (is.null(vars)) {
return(resultat %>% dplyr::collect())
}
else {
return(resultat %>% dplyr::inner_join(tbl_mco(con,
an, "rsa_rsa") %>% dplyr::select(cle_rsa, vars),
by = "cle_rsa") %>% dplyr::collect())
}
}
#' ~ req : lancer une ou plusieurs requetes dans une db avec une ou des listes
#'
#'
#' @examples
#' \dontrun{
#' get_all_listes('Recours Exceptionnel') -> listes_re
#' lancer_requete_db(con, an, listes_re)
#'
#' get_liste('chir_bariatrique_total') -> liste_bari
#' lancer_requete_db(con, an, liste_bari)
#' }
#'
#' @return un tibble concatenant les resultats de toutes les requetes : les rsa qui ont un acte de la liste, un diag, une duree correspondante, etc.
#' @author G. Pressiat
#' @importFrom dplyr mutate bind_rows
#' @export
lancer_requete_db <- function(con, an, elements, vars = NULL){
if (length(elements$nom) == 1){
cat(elements$nom, "\n")
return(elements %>%
requete_db(con, an, ., vars) %>%
dplyr::mutate(Requete = elements$nom,
Thematique = elements$thematique))}
else {
return(dplyr::bind_rows(lapply(elements,
function(elements1){
cat(elements1$nom, "\n")
elements1 %>%
requete_db(con, an, ., vars) %>%
dplyr::mutate(Requete = elements1$nom,
Thematique = elements1$thematique)})))}
}
#' ~ req : lancer une ou plusieurs requetes avec une ou des listes
#'
#'
#' @examples
#' \dontrun{
#' prepare_rsa(rsa) -> rsa
#' get_all_listes('Recours Exceptionnel') -> listes_re
#' lancer_requete(rsa, listes_re)
#'
#' get_liste('chir_bariatrique_total') -> liste_bari
#' lancer_requete(rsa, liste_bari)
#' }
#'
#' @return un tibble concatenant les resultats de toutes les requetes : les rsa qui ont un acte de la liste, un diag, une duree correspondante, etc.
#' @author G. Pressiat
#' @importFrom dplyr mutate bind_rows
#' @export
lancer_requete <- function(tables, elements, vars = NULL){
if (length(elements$nom) == 1){
cat(elements$nom, "\n")
return(elements %>%
requete(tables, ., vars) %>%
dplyr::mutate(Requete = elements$nom,
Thematique = elements$thematique))}
else {
return(dplyr::bind_rows(lapply(elements,
function(elements1){
cat(elements1$nom, "\n")
elements1 %>%
requete(tables, ., vars) %>%
dplyr::mutate(Requete = elements1$nom,
Thematique = elements1$thematique)})))}
}
#' ~ req : preparer les rsa pour la requete
#'
#' On selectionne certaines variables et on en cree d'autres utiles lors de l'execution de la requete
#'
#' @examples
#' \dontrun{
#' tab <- irsa(typi = 6)
#' prepare_rsa(tab)
#' }
#'
#' @return un objet de classe rsa de pmeasyr
#' @author G. Pressiat
#' @importFrom dplyr select mutate
#' @importFrom tidyr unite
#' @export
prepare_rsa <- function(rsa){
rsa$rsa <- rsa$rsa %>%
# tidyr::unite(ghm, RSACMD, RSATYPE, RSANUM, RSACOMPX, sep = "") %>%
#dplyr::select(NOFINESS, CLE_RSA, NOSEQRUM, MOISSOR, ghm, DP, DR, ECHPMSI, PROV, DEST, SCHPMSI, AGEAN,POIDS, AGEJR, dpdrum, DUREE, das, actes, um) %>%
dplyr::mutate(diags = paste(dpdrum, das),
agean = dplyr::if_else(is.na(agean), as.numeric(agejr)/365.25, as.numeric(agean))) %>%
dplyr::mutate(rsatype = substr(ghm, 3,3))
rsa <- tdiag(rsa)
# sjlabelled::remove_all_labels(rsa$rsa) -> rsa$rsa
# sjlabelled::remove_all_labels(rsa$actes) -> rsa$actes
# sjlabelled::remove_all_labels(rsa$diags) -> rsa$diags
# sjlabelled::remove_all_labels(rsa$rsa_um) -> rsa$rsa_um
return(rsa)
}
#' ~ req : collecter les rsa présents dans une db
#'
#' On selectionne certaines variables et on en cree d'autres utiles lors de l'execution de la requete
#'
#' @param con Connexion à la base de données
#' @param an année des rsa (ex: 17)
#' @param n Nombre de lignes à importer (équivalent `head`)
#' @examples
#' \dontrun{
#' rsa <- collect_rsa_from_db(con, 16, n = 1e5)
#' }
#'
#' @return un liste rsa similaire à un import de pmeasyr
#' @author G. Pressiat
#' @export
collect_rsa_from_db <- function(con, an, n = Inf){
rsa <- list()
to_up <- function(table){
names(table) <- toupper(names(table))
table
}
# %>% to_up() %>% rename(ghm = GHM,
# dpdrum = DPDRUM,
# das = DAS,
# actes = ACTES, um = UM)
tbl_mco(con, an, 'rsa_rsa') %>% dplyr::collect(n = n) -> rsa$rsa
tbl_mco(con, an, 'rsa_actes') %>% dplyr::collect(n = n) -> rsa$actes
tbl_mco(con, an, 'rsa_diags') %>% dplyr::filter(position == 5) %>% dplyr::collect(n = n) %>% dplyr::rename(DAS = DIAG) -> rsa$das
tbl_mco(con, an, 'rsa_um') %>% dplyr::collect(n = n) -> rsa$rsa_um
rsa
}
#' ~ req : creer un json pour partager une liste
#'
#' On selectionne certaines variables et on en cree d'autres utiles lors de l'execution de la requete
#'
#' @param requete `list` qui contient la requête
#' @param chemin Nom du fichier json qui sera créé
#' @examples
#' \dontrun{
#' liste = list(nom_abrege = "pac",
#' thematique = "test",
#' actes = c('EBLA003', 'EQLF002'),
#' dureemax = 0,
#' auteur = "John Doe",
#' date_saisie = "1960-01-01")
#' creer_json(liste, paste0('~/Documents/listes/', liste$nom_abrege, '.json'))
#' }
#'
#' @return un objet de classe rsa de pmeasyr
#' @author G. Pressiat
#' @importFrom jsonlite write_json
#' @export
creer_json <- function(requete, chemin){
jsonlite::write_json(requete, chemin, method='C', pretty = T)
}
IM-APHP/pmeasyr documentation built on April 22, 2024, 6:38 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions creer_json collect_rsa_from_db prepare_rsa lancer_requete lancer_requete_db enrobeur db_generique tbl_psy tbl_had tbl_ssr tbl_rsf tbl_mco db_liste_tables `%+%` labeleasier noyau_skeleton print.pm_param noyau_pmeasyr iano_rafael.default iano_rafael.list iano_rafael.pm_param iano_rafael irafael.default irafael.list irafael.pm_param irafael dico iano_psy.default iano_psy.list iano_psy.pm_param iano_psy ir3a.default ir3a.list ir3a.pm_param ir3a irpsa.default irpsa.list irpsa.pm_param irpsa iium_ssr.default iium_ssr.list iium_ssr.pm_param iium_ssr imed_ssr.default imed_ssr.list imed_ssr.pm_param imed_ssr ileg_ssr.default ileg_ssr.list ileg_ssr.pm_param ileg_ssr issrha.default issrha.list issrha.pm_param issrha iano_ssr.default iano_ssr.list iano_ssr.pm_param iano_ssr irha.default irha.list irha.pm_param irha ileg_had.default ileg_had.list ileg_had.pm_param ileg_had imed_had.default imed_had.list imed_had.pm_param imed_had iano_had.default iano_had.list iano_had.pm_param iano_had irapss.default irapss.list irapss.pm_param irapss ipo.default ipo.list ipo.pm_param ipo iium_corresp.default iium_corresp.list iium_corresp.pm_param iium_corresp iium.default iium.list iium.pm_param iium idiap.default idiap.list idiap.pm_param idiap inner_tra ileg_mco.default ileg_mco.list ileg_mco.pm_param ileg_mco itpt_mco.default itpt_mco.list itpt_mco.pm_param itpt_mco iivg_mco.default iivg_mco.list iivg_mco.pm_param iivg_mco idmi_mco.default idmi_mco.list idmi_mco.pm_param idmi_mco imed_mco.default imed_mco.list imed_mco.pm_param imed_mco iano_mco.default iano_mco.list iano_mco.pm_param iano_mco itra.default itra.list itra.pm_param itra irsa.default irsa.list irsa.pm_param irsa irum.default irum.list irum.pm_param irum
Documented in collect_rsa_from_db creer_json db_generique db_liste_tables dico enrobeur iano_had iano_mco iano_psy iano_rafael iano_ssr idiap idmi_mco iium iium_corresp iium_ssr iivg_mco ileg_had ileg_mco ileg_ssr imed_had imed_mco imed_ssr inner_tra ipo ir3a irafael irapss irha irpsa irsa irum issrha itpt_mco itra labeleasier lancer_requete lancer_requete_db noyau_pmeasyr noyau_skeleton prepare_rsa print.pm_param tbl_had tbl_mco tbl_psy tbl_rsf tbl_ssr
##############################################
####################### MCO ##################
##############################################
#' ~ MCO - Import des RUM
#'
#' Import des RUM. 4 types d'imports possibles.
#'
#' Formats depuis 2011 pris en charge
#'
#' Structure du nom du fichier attendu (entrée pour Genrsa) :
#' \emph{finess.annee.moisc.rum}
#'
#' \strong{750712184.2016.2.rum}
#'
#' Types d'imports :
#' \tabular{ll}{
#' 1 XLight : \tab partie fixe\cr
#' 2 Light : \tab partie fixe + streaming des actes, dad et das\cr
#' 3 Standard : \tab partie fixe + table acdi\cr
#' 4 Standard+ : \tab Import standard (3) + stream\cr
#' }
#'
#' \strong{Principe du streaming :}
#' Mise en chaîne de caractères de la succession d'actes CCAM au cours du RUM, par exemple, pour un RUM :
#' \samp{"ACQK001, LFQK002, MCQK001, NAQK015, PAQK002, PAQK900, YYYY600, ZZQP004"}
#'
#' La recherche d'un (ou d'une liste d') acte(s) sur un RUM est largement accélérée, comparée à une requête sur la large table acdi par une requête du type :
#'
#' \code{grepl("ZZQP004",rum$actes)} # toutes les lignes de RUM avec au moins un ZZQP004
#' \code{grepl("ZZQP004|EBLA003",rum$actes)} # toutes les lignes de RUM avec au moins un ZZQP004 ou un EBLA003
#'
#' @param finess Finess du In a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param typi Type d'import, par defaut a 3, a 0 : propose a l'utilisateur de choisir au lancement
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une classe S3 contenant les tables (data.frame, tibble) importées (rum, actes, das et dad si import 3 et 4)
#'
#' @examples
#' \dontrun{
#' irum('750712184',2015,12,'~/Documents/data/mco', typi = 1) -> rum15
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irsa}}, \code{\link{ileg_mco}}, \code{\link{iano_mco}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @importFrom utils View data unzip modifyList
#' @importFrom magrittr '%>%'
#' @export irum
#' @usage irum(finess, annee, mois, path, lib = T, typi = 3, tolower_names = F, ...)
#' @export
irum <- function(finess, annee, mois, path, lib = T, typi = 3, tolower_names = F, ...){
UseMethod("irum")
}
#' @export
irum.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(irum.default, param2)
}
#' @export
irum.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(irum.default, param2)
}
#' @export
irum.default <- function(finess, annee, mois, path, lib = T, typi = 3, tolower_names = F, ...){
if (annee < 2011 | annee > 2024){
stop("Année PMSI non prise en charge\n")
}
if (mois < 1 | mois > 12){
stop("Mois incorrect\n")
}
if (!(typi %in% 0:4)){
stop("Type d'import incorrect : 0 ou 1, 2, 3 et 4\n")
}
# op <- options(digits.secs = 6)
un<-Sys.time()
# Import de la table
# cat(paste("Import des RUM",annee,paste0("M",mois),"\n"))
# cat(paste("L'objet retourné prendra la forme d'une classe S3.
# $rum pour accéder à la table RUM
# $das pour accéder à la table DAS
# $dad pour accéder à la table DAD
# $actes pour accéder à la table ACTES\n\n"))
extz <- function(x,pat){unlist(lapply(stringr::str_extract_all(x,pat),toString) )}
format <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rum", an == substr(annee,3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
pmeasyr::formats %>% dplyr::filter(table == "rum", substr(an,1,4) == as.character(annee)) -> rg
# regexpr et curseurs par version
if (length(unique(rg$an)) == 1) {
situation_al = 1
zac <- rg$rg[rg$z == "zac"]
zd <- rg$rg[rg$z == "zd"]
zal <- rg$rg[rg$z == "zal"]
zdad <- rg$rg[rg$z == "zdad"]
curs_al <- rg$curseur[rg$z == "zal"]
curs_d <- rg$curseur[rg$z == "zd"]
curs_dad <- rg$curseur[rg$z == "zdad"]
} else {
levan <- sort(unique(rg$an))
vers <- substr(sort(unique(rg$an)),6,9)
# Regpexpr
# Curseurs
zac <- unique(rg$rg[rg$z == "zac"])
if (length(unique(rg$rg[rg$z == "zd"])) > 1){
zd1 <- rg$rg[rg$z == "zd" & rg$an == levan[1]]
zd2 <- rg$rg[rg$z == "zd" & rg$an == levan[2]]
curs_d1 <- rg$curseur[rg$z == "zd" & rg$an == levan[1]]
curs_d2 <- rg$curseur[rg$z == "zd" & rg$an == levan[2]]
situation_d = 2
} else {
situation_d = 1
zd <- unique(rg$rg[rg$z == "zd"])
curs_d <- unique(rg$curseur[rg$z == "zd"])
}
if (length(unique(rg$rg[rg$z == "zdad"])) > 1){
zdad1 <- rg$rg[rg$z == "zdad" & rg$an == levan[1]]
zdad2 <- rg$rg[rg$z == "zdad" & rg$an == levan[2]]
curs_dad1 <- rg$rg[rg$z == "zdad" & rg$an == levan[1]]
curs_dad2 <- rg$rg[rg$z == "zdad" & rg$an == levan[2]]
situation_dad = 2
} else {
situation_dad = 1
zdad <- unique(rg$rg[rg$z == "zdad"])
curs_dad <- unique(rg$curseur[rg$z == "zdad"])
}
if (length(unique(rg$rg[rg$z == "zal"])) > 1){
zal1 <- rg$rg[rg$z == "zal" & rg$an == levan[1]]
zal2 <- rg$rg[rg$z == "zal" & rg$an == levan[2]]
curs_al1 <- rg$curseur[rg$z == "zal" & rg$an == levan[1]]
curs_al2 <- rg$curseur[rg$z == "zal" & rg$an == levan[2]]
situation_al = 2
} else {
situation_al = 1
zal <- unique(rg$rg[rg$z == "zal"])
curs_al <- unique(rg$curseur[rg$z == "zal"])
}
}
zad <- function(rum_i){
if (situation_al == 1){
rum_i %>% dplyr::mutate(
ac = ifelse(NBACTE>0,stringr::str_sub(ZAD,curs_d*NBDAS+curs_dad*NBDAD+1,curs_d*NBDAS+curs_dad*NBDAD+curs_al*NBACTE),""),
lactes = stringr::str_extract_all(ac,zal),
actes = extz(ac,zac),
das_ = ifelse(NBDAS>0,stringr::str_sub(ZAD,1,curs_d*NBDAS),""),
ldas= stringr::str_extract_all(das_,zd),
das = extz(das_,zd),
dad_ = ifelse(NBDAD>0,stringr::str_sub(ZAD,curs_d*NBDAS+1,curs_d*NBDAD+curs_dad*NBDAS),""),
ldad = stringr::str_extract_all(dad_,zdad),
dad = extz(dad_,zdad)
) %>% dplyr::select(-ac,-das_,-dad_)
} else {
rum_i %>% dplyr::mutate(
ac = ifelse(NBACTE>0,dplyr::if_else(NOVERG == vers[1],
stringr::str_sub(ZAD,curs_d*NBDAS+curs_dad*NBDAD+1,
curs_d*NBDAS+curs_dad*NBDAD+curs_al1*NBACTE),
stringr::str_sub(ZAD,curs_d*NBDAS+curs_dad*NBDAD+1,
curs_d*NBDAS+curs_dad*NBDAD+curs_al2*NBACTE)), ""),
lactes = dplyr::if_else(NOVERG == vers[1], stringr::str_extract_all(ac,zal1),stringr::str_extract_all(ac,zal2)),
actes = extz(ac,zac),
das_ = dplyr::if_else(NBDAS>0,stringr::str_sub(ZAD,1,curs_d*NBDAS),""),
ldas= stringr::str_extract_all(das_,zd),
das = extz(das_,zd),
dad_ = dplyr::if_else(NBDAD>0,stringr::str_sub(ZAD,curs_d*NBDAS+1,curs_dad*NBDAD+curs_d*NBDAS),""),
ldad = stringr::str_extract_all(dad_,zdad),
dad = extz(dad_,zdad)
) %>% dplyr::select(-ac,-das_,-dad_)
}
}
zad3 <- function(rum_i){
if (situation_al == 1){
rum_i %>% dplyr::mutate(
ac = ifelse(NBACTE>0,stringr::str_sub(ZAD,curs_d*NBDAS+curs_dad*NBDAD+1,
curs_d*NBDAS+curs_dad*NBDAD+curs_al*NBACTE),""),
lactes = stringr::str_extract_all(ac,zal),
das_ = ifelse(NBDAS>0,stringr::str_sub(ZAD,1,curs_d*NBDAS),""),
ldas= stringr::str_extract_all(das_,zd),
dad_ = ifelse(NBDAD>0,stringr::str_sub(ZAD,8*NBDAS+1,8*NBDAD+8*NBDAS),""),
ldad = stringr::str_extract_all(dad_,zdad)
) %>% dplyr::select(-ac,-das_,-dad_)
} else {
rum_i %>% dplyr::mutate(
ac = ifelse(NBACTE>0 & NOVERG == vers[1],
stringr::str_sub(ZAD,curs_d*NBDAS+curs_dad*NBDAD+1,
curs_d*NBDAS+curs_dad*NBDAD+curs_al1*NBACTE),
ifelse(NBACTE>0 & NOVERG == vers[2],
stringr::str_sub(ZAD,curs_d*NBDAS+curs_dad*NBDAD+1,
curs_d*NBDAS+curs_dad*NBDAD+curs_al2*NBACTE), "")),
lactes = dplyr::if_else(NOVERG == vers[1], stringr::str_extract_all(ac,zal1),stringr::str_extract_all(ac,zal2)),
das_ = dplyr::if_else(NBDAS>0,stringr::str_sub(ZAD,1,curs_d*NBDAS),""),
ldas= stringr::str_extract_all(das_,zd),
dad_ = dplyr::if_else(NBDAD>0,stringr::str_sub(ZAD,curs_d*NBDAS+1,curs_dad*NBDAD+curs_d*NBDAS),""),
ldad = stringr::str_extract_all(dad_,zdad)
) %>% dplyr::select(-ac,-das_,-dad_)
}
}
if (annee==2011){
i <- function(annee,mois){
rum_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rss.ini.txt"),
readr::fwf_widths(c(2,6,1,3,NA),c("NOCLAS","CDGHM","Fil1","NOVERG","RUM")),
col_types = readr::cols('c','c','c','c','c'), trim_ws = FALSE,
na=character(), ...) %>%
dplyr::mutate(
CDERG = stringr::str_sub(RUM,1,3),
NOFINESS = stringr::str_sub(RUM,4,12),
NOVERS = stringr::str_sub(RUM,13,15),
NORSS = stringr::str_sub(RUM,16,35),
NAS = stringr::str_sub(RUM,36,55),
NORUM = stringr::str_sub(RUM,56,65),
DTNAIS = stringr::str_sub(RUM,66,73),
SXPMSI = stringr::str_sub(RUM,74,74),
CDURM = stringr::str_sub(RUM,75,78),
KYTYPAUTLIT = stringr::str_sub(RUM,79,80),
D8EEUE = stringr::str_sub(RUM,81,88),
MDEEUE = stringr::str_sub(RUM,89,89),
TYTRPR = stringr::str_sub(RUM,90,90),
D8SOUE = stringr::str_sub(RUM,91,98),
MDSOUE = stringr::str_sub(RUM,99,99),
TYTRDS = stringr::str_sub(RUM,100,100),
CDRESI = stringr::str_sub(RUM,101,105),
PDNAIS = stringr::str_sub(RUM,106,109) %>% as.numeric(),
AGEGEST = stringr::str_sub(RUM,110,111) %>% as.integer(),
DDR2 = ifelse(NOVERG=='115', "" , stringr::str_sub(RUM,112,119)),
NBSEAN = ifelse(NOVERG=='115', stringr::str_sub(RUM,112,113) , stringr::str_sub(RUM,120,121)) %>% as.integer(),
NBDAS = ifelse(NOVERG=='115', stringr::str_sub(RUM,114,115) , stringr::str_sub(RUM,122,123)) %>% as.integer(),
NBDAD = ifelse(NOVERG=='115', stringr::str_sub(RUM,116,117) , stringr::str_sub(RUM,124,125)) %>% as.integer(),
NBACTE = ifelse(NOVERG=='115', stringr::str_sub(RUM,118,120) , stringr::str_sub(RUM,126,128)) %>% as.integer(),
DP = ifelse(NOVERG=='115', stringr::str_sub(RUM,121,128) , stringr::str_sub(RUM,129,137)),
DR = ifelse(NOVERG=='115', stringr::str_sub(RUM,129,136) , stringr::str_sub(RUM,138,146)),
IGS = ifelse(NOVERG=='115', stringr::str_sub(RUM,137,138) , stringr::str_sub(RUM,147,149)),
CONFCDRSS = ifelse(NOVERG=='115', stringr::str_sub(RUM,139,140) , stringr::str_sub(RUM,150,150)),
RDT_TYPMACH = ifelse(NOVERG=='115', stringr::str_sub(RUM,141,141) , stringr::str_sub(RUM,151,151)),
RDT_TYPDOSIM = ifelse(NOVERG=='115', stringr::str_sub(RUM,142,142) , stringr::str_sub(RUM,152,152)),
NBFAISC = ifelse(NOVERG=='115', stringr::str_sub(RUM,143,143) , stringr::str_sub(RUM,153,153)) %>% as.integer(),
ZAD = ifelse(NOVERG=='115', stringr::str_sub(RUM,154,stringr::str_length(RUM)) , stringr::str_sub(RUM,181,stringr::str_length(RUM)))
) %>% dplyr::select(-RUM)
}
}
if (annee>=2012){
i <- function(annee,mois){
suppressWarnings(readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rss.ini.txt"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...))}
}
former <- function(cla, col1){
switch(cla,
'trim' = col1 %>% stringr::str_trim(),
'c' = col1,
'i' = col1 %>% as.integer(),
'n2' = (col1 %>% as.numeric() )/100,
'n3' = (col1 %>% as.numeric() )/1000,
'dmy' = lubridate::dmy(col1, quiet = TRUE))
}
if (typi !=0){
#cat("Lecture du fichier / parsing fixe...\n")
rum_i <- i(annee,mois) %>% dplyr::mutate(
DTNAIS=lubridate::dmy(DTNAIS, quiet = TRUE),
D8EEUE=lubridate::dmy(D8EEUE, quiet = TRUE),
D8SOUE=lubridate::dmy(D8SOUE, quiet = TRUE),
DP = stringr::str_trim(DP),
DR = stringr::str_trim(DR)) %>%
dplyr::mutate(DUREESEJPART = as.integer(difftime(D8SOUE, D8EEUE, units= c("days"))))
readr::problems(rum_i) -> synthese_import
}
if (typi== 1){
Fillers <- names(rum_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="Fil"]
rum_i <- rum_i[,!(names(rum_i) %in% Fillers)] %>% dplyr::select(-ZAD)
# Libelles
if (lib==T){
v <- libelles
v <- v[!is.na(v)]
rum_i <- rum_i %>% sjlabelled::set_label(c(v, "Durée rum"))
}
if (tolower_names){
names(rum_i) <- tolower(names(rum_i))
}
rum_1 <- list(rum = rum_i)
class(rum_1) <- append(class(rum_1),"RUM")
deux<-Sys.time()
#cat(paste("MCO RUM XLight",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
#cat("(Seule la partie fixe du RUM a été chargée)\n")
return(rum_1)
}
if (typi== 2){
#cat("Traitement | Parsing variable...\n")
rum_i <- zad(rum_i) %>% dplyr::select(-lactes,-ldas,-ldad,-ZAD )
rum_i <- rum_i %>%
dplyr::mutate(das = stringr::str_replace_all(das, "\\s{1,},", ","),
dad = stringr::str_replace_all(dad, "\\s{1,},", ","))
Fillers <- names(rum_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="Fil"]
rum_i <- rum_i[,!(names(rum_i) %in% Fillers)]
if (lib==T){
v <- libelles
v <- c(v[!is.na(v)], "Durée rum", "Stream Actes","Stream Das", "Stream Dad")
rum_i <- rum_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(rum_i) <- tolower(names(rum_i))
}
rum_1 <- list(rum = rum_i)
class(rum_1) <- append(class(rum_1),"RUM")
deux<-Sys.time()
#cat(paste("MCO RUM Light",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
return(rum_1)
}
if (typi== 3){
#cat("Traitement | Parsing variable...\n")
rum_i <- zad3(rum_i)
if (situation_al == 1){
#cat("Actes en ligne : ")
un_i<-Sys.time()
actes <- purrr::flatten_chr(rum_i$lactes)
df <- rum_i %>% dplyr::select(NAS, NORUM, NBACTE)
df <- as.data.frame(lapply(df, rep, df$NBACTE), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(var = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rum_actes", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(actes$var, i)))
names(temp) <- fa$nom[i]
actes <- dplyr::bind_cols(actes, temp)
}
actes %>% dplyr::select(-var, - NBACTE) -> actes
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
} else {
#cat("Actes en ligne : ")
un_i<-Sys.time()
actes <- purrr::flatten_chr(rum_i$lactes)
df <- rum_i %>% dplyr::select(NAS, NORUM, NOVERG, NBACTE)
df <- as.data.frame(lapply(df, rep, df$NBACTE), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(var = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa1 <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rum_actes",
an == paste0(substr(annee,3,4), '_',vers[1]))
deb1 <- fa1$position
fin1 <- fa1$fin
fa2 <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rum_actes",
an == paste0(substr(annee,3,4), '_',vers[2]))
deb2 <- fa2$position
fin2 <- fa2$fin
u <- function( i, actes){
as.vector(as.matrix(actes %>%
dplyr::mutate(temp = dplyr::if_else(NOVERG == vers[1], stringr::str_sub(var, deb1[i], fin1[i]),
stringr::str_sub(var, deb2[i], fin2[i]))) %>%
dplyr::select(temp)))}
for (i in 1:length(deb1)){
temp <- dplyr::as_tibble(former(fa1$type[i], u(i, actes)))
names(temp) <- fa1$nom[i]
actes <- dplyr::bind_cols(actes, temp)
}
actes %>% dplyr::select(-var, - NBACTE, - NOVERG) -> actes
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
fa <- fa2
}
#cat("Das en ligne : ")
un_i<-Sys.time()
das <- purrr::flatten_chr(rum_i$ldas) %>% stringr::str_trim()
df <- rum_i %>% dplyr::select(NAS,NORUM,NBDAS)
df <- as.data.frame(lapply(df, rep, df$NBDAS), stringsAsFactors = F) %>% tibble::as_tibble()
das <- dplyr::bind_cols(df,data.frame(DAS = stringr::str_trim(das), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDAS)
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
#cat("Dad en ligne : ")
un_i<-Sys.time()
dad <- purrr::flatten_chr(rum_i$ldad)
df <- rum_i %>% dplyr::select(NAS,NORUM,NBDAD)
df <- as.data.frame(lapply(df, rep, df$NBDAD), stringsAsFactors = F) %>% tibble::as_tibble()
dad <- dplyr::bind_cols(df,data.frame(DAD = stringr::str_trim(dad), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDAD)
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
if (lib == T){
actes %>% sjlabelled::set_label(c('N° administratif du séjour','N° du RUM', fa$libelle)) -> actes
das %>% sjlabelled::set_label(c('N° administratif du séjour','N° du RUM', 'Diagnostic associé')) -> das
dad %>% sjlabelled::set_label(c('N° administratif du séjour','N° du RUM', 'Donnée à visée documentaire')) -> dad
}
Fillers <- names(rum_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="Fil"]
rum_i <- rum_i[,!(names(rum_i) %in% Fillers)] %>% dplyr::select(-ZAD, -ldad, -lactes, -ldas)
# Libelles
if (lib==T){
v <- libelles
v <- v[!is.na(v)]
rum_i <- rum_i %>% sjlabelled::set_label(c(v, "Durée rum"))
}
if (tolower_names){
names(rum_i) <- tolower(names(rum_i))
names(actes) <- tolower(names(actes))
names(das) <- tolower(names(das))
names(dad) <- tolower(names(dad))
}
rum_1 <- list(rum = rum_i, actes = actes, das = das, dad = dad)
class(rum_1) <- append(class(rum_1),"RUM")
deux<-Sys.time()
#cat(paste("MCO RUM Standard",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
return(rum_1)
}
if (typi== 4){
#cat("Traitement | Parsing variable...\n")
rum_i <- zad(rum_i)
if (situation_al == 1){
#cat("Actes en ligne : ")
un_i<-Sys.time()
actes <- purrr::flatten_chr(rum_i$lactes)
df <- rum_i %>% dplyr::select(NAS, NORUM, NBACTE)
df <- as.data.frame(lapply(df, rep, df$NBACTE), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(var = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rum_actes", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(actes$var, i)))
names(temp) <- fa$nom[i]
actes <- dplyr::bind_cols(actes, temp)
}
actes %>% dplyr::select(-var, - NBACTE) -> actes
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
} else {
#cat("Actes en ligne : ")
un_i<-Sys.time()
actes <- purrr::flatten_chr(rum_i$lactes)
df <- rum_i %>% dplyr::select(NAS, NORUM, NOVERG, NBACTE)
df <- as.data.frame(lapply(df, rep, df$NBACTE), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(var = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa1 <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rum_actes",
an == paste0(substr(annee,3,4), '_',vers[1]))
deb1 <- fa1$position
fin1 <- fa1$fin
fa2 <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rum_actes",
an == paste0(substr(annee,3,4), '_',vers[2]))
deb2 <- fa2$position
fin2 <- fa2$fin
u <- function( i, actes){
as.vector(as.matrix(actes %>%
dplyr::mutate(temp = dplyr::if_else(NOVERG == vers[1], stringr::str_sub(var, deb1[i], fin1[i]),
stringr::str_sub(var, deb2[i], fin2[i]))) %>%
dplyr::select(temp)))}
for (i in 1:length(deb1)){
temp <- dplyr::as_tibble(former(fa1$type[i], u(i, actes)))
names(temp) <- fa1$nom[i]
actes <- dplyr::bind_cols(actes, temp)
}
actes %>% dplyr::select(-var, -NBACTE, - NOVERG) -> actes
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
fa <- fa2
}
#cat("Das en ligne : ")
un_i<-Sys.time()
das <- purrr::flatten_chr(rum_i$ldas) %>% stringr::str_trim()
df <- rum_i %>% dplyr::select(NAS,NORUM,NBDAS)
df <- as.data.frame(lapply(df, rep, df$NBDAS), stringsAsFactors = F) %>% tibble::as_tibble()
das <- dplyr::bind_cols(df,data.frame(DAS = stringr::str_trim(das), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDAS)
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
#cat("Dad en ligne : ")
un_i<-Sys.time()
dad <- purrr::flatten_chr(rum_i$ldad)
df <- rum_i %>% dplyr::select(NAS,NORUM,NBDAD)
df <- as.data.frame(lapply(df, rep, df$NBDAD), stringsAsFactors = F) %>% tibble::as_tibble()
dad <- dplyr::bind_cols(df,data.frame(DAD = stringr::str_trim(dad), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDAD)
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
if (lib == T){
actes %>% sjlabelled::set_label(c('N° administratif du séjour','N° du RUM', fa$libelle)) -> actes
das %>% sjlabelled::set_label(c('N° administratif du séjour','N° du RUM', 'Diagnostic associé')) -> das
dad %>% sjlabelled::set_label(c('N° administratif du séjour','N° du RUM', 'Donnée à visée documentaire')) -> dad
}
rum_i <- rum_i %>% dplyr::select(-lactes,-ldas,-ldad,-ZAD ) %>%
dplyr::mutate(das = stringr::str_replace_all(das, "\\s{1,},", ","),
dad = stringr::str_replace_all(dad, "\\s{1,},", ","))
Fillers <- names(rum_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="Fil"]
rum_i <- rum_i[,!(names(rum_i) %in% Fillers)]
# Libelles
if (lib==T){
v <- libelles
v <- c(v[!is.na(v)], "Durée rum", "Stream Actes","Stream Das", "Stream Dad")
rum_i <- rum_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(rum_i) <- tolower(names(rum_i))
names(actes) <- tolower(names(actes))
names(das) <- tolower(names(das))
names(dad) <- tolower(names(dad))
}
rum_1 <- list(rum = rum_i, actes = actes, das = das, dad = dad)
class(rum_1) <- append(class(rum_1),"RUM")
deux<-Sys.time()
attr(rum_i,"problems") <- synthese_import
#cat(paste("MCO RUM Standard+",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
return(rum_1)
}
cat("Quel type d'import ?\n")
typo <- data.frame(Type=c(1,
2,
3,
4),
Import=c('XLight : Partie fixe',
'Light : Partie fixe + stream en ligne des actes, das et dad',
'Standard : Partie fixe + table acdi',
'Standard+ : Partie fixe + stream + table acdi '),
Temps=c('Très Rapide','Rapide','Rapide','Long'),
`Temps rapporté`=c('= 1','* 5 (~)','* 4 (~)','* 7 (~)'))
cat(knitr::kable(typo), sep = "\n")
n <- readline(prompt="Taper le type d'import voulu : ")
return(irum(finess,annee,mois,path,lib,n, ...))
}
#' ~ MCO - Import des RSA
#'
#' Import des RSA. 6 types d'imports possibles.
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu (sortie de Genrsa) :
#' \emph{finess.annee.moisc.rsa}
#'
#' \strong{750712184.2016.2.rsa}
#'
#' Types d'imports :
#' \tabular{ll}{
#' 1 Light : \tab partie fixe (très rapide)\cr
#' 2 Light+ : \tab Partie fixe + stream en ligne (+) actes et das\cr
#' 3 Light++ : \tab Partie fixe + stream en ligne (++) actes, das, typaut um et dpdr des um\cr
#' 4 Standard : \tab Partie fixe + création des tables acdi et rsa_um\cr
#' 5 Standard+ : \tab Partie fixe + création des tables acdi et rsa_um + stream (+)\cr
#' 6 Standard++ : \tab Partie fixe + création des tables acdi et rsa_um + stream (++)\cr
#' }
#'
#'
#' \strong{Principe du streaming :}
#' Mise en chaîne de caractères de la succession d'actes CCAM au cours du RUM, par exemple, pour un RUM :
#' \samp{"ACQK001, LFQK002, MCQK001, NAQK015, PAQK002, PAQK900, YYYY600, ZZQP004"}
#'
#' La recherche d'un (ou d'une liste d') acte(s) sur un RUM est largement accélérée, comparée à une requête sur la large table acdi par une requête du type :
#'
#' \code{grepl("ZZQP004",rsa$actes)} # toutes les lignes de RSA avec au moins un ZZQP004
#'
#' \code{e66 <- grepl('E66',das)|grepl('E66',dpdrum)} # toutes les lignes de RSA avec un diagnostic E66
#'
#' Cela permet de n'utiliser que la seule table rsa avec stream et d'avoir les infos sur les séjours directement :
#' nb séjours, journées, entrée / sortie (...) plutôt que d'avoir à utiliser et croiser les tables acdi, rsa_um avec rsa.
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param typi Type d'import, par defaut a 4, a 0 : propose a l'utilisateur de choisir au lancement
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une classe S3 contenant les tables (data.frame, tibble ou tbl) importées (rsa, rsa_um, actes et das si import > 3)
#'
#' @examples
#' \dontrun{
#' irsa('750712184',2015,12,'~/Documents/data/mco') -> rsa15
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irum}}, \code{\link{ileg_mco}}, \code{\link{iano_mco}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage irsa(finess, annee, mois, path, lib = T, typi = 4, tolower_names = F, ...)
#' @export irsa
#' @export
irsa <- function(finess, annee, mois, path, lib = T, typi = 4, tolower_names = F, ...){
UseMethod('irsa')
}
#' @export
irsa.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(irsa.default, param2)
}
#' @export
irsa.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(irsa.default, param2)
}
#' @export
irsa.default <- function(finess, annee, mois, path, lib = T, typi = 4, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
if (!(typi %in% 0:6)){
stop("Type d'import incorrect : 0 ou 1, 2, 3, 4, 5 et 6\n")
}
#op <- options(digits.secs = 6)
un<-Sys.time()
# cat(paste("L'objet retourné prendra la forme d'une classe S3.
# $rsa pour accéder à la table RSA
# $rsa_um pour accéder à la table RSA_UM
# $das pour accéder à la table des DAS
# $actes pour accéder à la table des ACTES\n\n"))
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
extz <- function(x,pat){unlist(lapply(stringr::str_extract_all(x,pat),toString) )}
former <- function(cla, col1){
switch(cla,
'trim' = col1 %>% stringr::str_trim(),
'c' = col1,
'i' = col1 %>% as.integer(),
'n2' = (col1 %>% as.numeric() )/100,
'n3' = (col1 %>% as.numeric() )/1000,
'dmy' = lubridate::dmy(col1, quiet = TRUE))
}
if (typi !=0){
#cat('Lecture du fichier | Parsing partie fixe...\n')
rsa_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rsa"),
readr::fwf_widths(af,an), col_types =at, na=character(), ... )
readr::problems(rsa_i) -> synthese_import
rsa_i <- rsa_i %>%
dplyr::mutate(DP = stringr::str_trim(DP),
DR = stringr::str_trim(DR),
ghm = paste0(RSACMD, RSATYPE, RSANUM, RSACOMPX),
anseqta = dplyr::if_else(MOISSOR < "03", as.character(annee - 1), as.character(annee)))
}
if (typi== 1){
deux<-Sys.time()
#cat(paste("MCO RSA Light",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
#cat("(Seule la partie fixe du RSA a été chargée)\n")
Fillers <- names(rsa_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rsa_i <- rsa_i[,!(names(rsa_i) %in% Fillers)] %>% dplyr::select(-ZA)
# Libelles
if (lib==T){
v <- libelles
v <- v[!is.na(v)]
rsa_i <- rsa_i %>% sjlabelled::set_label(c(v, 'Ghm', 'Année séq. de tarifs'))
}
if (tolower_names){
names(rsa_i) <- tolower(names(rsa_i))
}
rsa_1 <- list(rsa = rsa_i)
class(rsa_1) <- append(class(rsa_1),"RSA")
attr(rsa_1,"problems") <- synthese_import
return(rsa_1)
}
pmeasyr::formats %>% dplyr::filter(table == "rsa" & an == as.integer(annee)) -> rg
zac = rg$rg[rg$z == 'zac']
zd = rg$rg[rg$z == 'zd']
zum = rg$rg[rg$z == 'zum']
zal = rg$rg[rg$z == 'zal']
cd = rg$curseur[rg$z == 'zd']
cum = rg$curseur[rg$z == 'zum']
cal = rg$curseur[rg$z == 'zal']
fzad <- function(rsa){
if (as.integer(annee) > 2011){
return(rsa %>% dplyr::mutate(
TYPGLOB = ifelse(NBAUTPGV>0,stringr::str_sub(ZA,1,2*NBAUTPGV),""),
RDTH = ifelse(NB_RDTH>0,stringr::str_sub(ZA,2*NBAUTPGV+1,2*NBAUTPGV+7*NB_RDTH),""),
RUMS = ifelse(as.numeric(NBRUM)>0,stringr::str_sub(ZA,2*NBAUTPGV+7*NB_RDTH+1,2*NBAUTPGV+7*NB_RDTH+cum*NBRUM),""),
DAS = ifelse(NDAS>0,stringr::str_sub(ZA,2*NBAUTPGV+7*NB_RDTH+cum*NBRUM + 1,2*NBAUTPGV + 7*NB_RDTH + cum*NBRUM + cd*NDAS),""),
ACTES = ifelse(`NA`>0,stringr::str_sub(ZA,2*NBAUTPGV+7*NB_RDTH+cum*NBRUM + cd*NDAS + 1,2*NBAUTPGV + 7*NB_RDTH + cum*NBRUM + cd*NDAS + cal*`NA`),"")
))}
else if (as.integer(annee) == 2011){
return(rsa %>% dplyr::mutate(
RDTH = ifelse(NB_RDTH>0,stringr::str_sub(ZA,1,7*NB_RDTH),""),
RUMS = ifelse(as.numeric(NBRUM)>0,stringr::str_sub(ZA,7*NB_RDTH+1,7*NB_RDTH+cum*NBRUM),""),
DAS = ifelse(NDAS>0,stringr::str_sub(ZA,7*NB_RDTH+cum*NBRUM + 1,7*NB_RDTH + cum*NBRUM + cd*NDAS),""),
ACTES = ifelse(`NA`>0,stringr::str_sub(ZA,7*NB_RDTH+cum*NBRUM + cd*NDAS + 1,7*NB_RDTH + cum*NBRUM + cd*NDAS + cal*`NA`),"")))
}
}
if (typi == 2){
#cat('Import Light+ | Streaming des actes et das...\n')
rsa_i <- fzad(rsa_i)
rsa_i <- rsa_i %>%
dplyr::mutate(
actes = extz(ACTES,zac), # Stream des actes
das = extz(DAS,zd)) %>% # Stream des das
dplyr::select(-ZA,-ACTES,-RUMS,-DAS)
rsa_i <- rsa_i %>%
dplyr::mutate(das = stringr::str_replace_all(das, "\\s{1,},", ","))
Fillers <- names(rsa_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rsa_i <- rsa_i[,!(names(rsa_i) %in% Fillers)]
# Libelles
if (lib==T){
v <- libelles
if (annee==2011){
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs', "Supp. Radiothérapies", "Stream Actes", "Stream Das")
}
else {
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs', "Types Aut. à Portée Globale", "Supp. Radiothérapies", "Stream Actes", "Stream Das")
}
rsa_i <- rsa_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(rsa_i) <- tolower(names(rsa_i))
}
rsa_1 <- list(rsa = rsa_i)
class(rsa_1) <- append(class(rsa_1),"RSA")
deux<-Sys.time()
#cat(paste("MCO RSA Light+",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
attr(rsa_1,"problems") <- synthese_import
return(rsa_1)
}
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rsa_um", an == substr(annee,3,4))
debum <- fa[fa$nom == "TYPAUT1",]$position
finum <- fa[fa$nom == "TYPAUT1",]$fin
debdpdr <- fa[fa$nom == "DPUM",]$position
findpdr <- fa[fa$nom == "DRUM",]$fin
if (typi == 3){
#cat('Import Light++ | Streaming des actes, das, typaut UM et DP/DR des UM...\n')
rsa_i <- fzad(rsa_i)
rsa_i <- rsa_i %>%
dplyr::mutate(
actes = extz(ACTES,zac), # Stream des actes
lum = stringr::str_extract_all(RUMS,zum), # Liste des UM
um = unlist(lapply(lapply(lum, # Stream des types d'UM
function(x){substr(x,debum,finum)}),
function(y){toString(y)})),
dpdrum = unlist(lapply(lapply(lum, # Stream des dpdr d'UM
function(x){substr(x,debdpdr,findpdr)}),
function(y){toString(y)})),
das = extz(DAS,zd)) %>% # Stream des das
dplyr::select(-ZA,-RUMS,-ACTES,-DAS,-lum)
rsa_i <- rsa_i %>%
dplyr::mutate(das = stringr::str_replace_all(das, "\\s{1,},", ","),
dpdrum = stringr::str_replace_all(dpdrum, "\\s{1,},", ","))
deux<-Sys.time()
Fillers <- names(rsa_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rsa_i <- rsa_i[,!(names(rsa_i) %in% Fillers)]
if (lib==T){
v <- libelles
if (annee==2011) {
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs', "Supp. Radiothérapies", "Stream Actes","Parcours Typaut UM","Stream DP/DR des UM","Stream Das")
}
else{
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs',
"Types Aut. à Portée Globale", "Supp. Radiothérapies",
"Stream Actes","Parcours Typaut UM","Stream DP/DR des UM","Stream Das")
}
rsa_i <- rsa_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(rsa_i) <- tolower(names(rsa_i))
}
rsa_1 <- list(rsa = rsa_i)
class(rsa_1) <- append(class(rsa_1),"RSA")
#cat(paste("MCO RSA Light++",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
#cat("La table rsa est dans l'environnement de travail\n")
attr(rsa_1,"problems") <- synthese_import
return(rsa_1)
}
if (typi == 4){
#cat('Traitement | Parsing partie variable...\n')
rsa_i <- fzad(rsa_i)
rsa_i <- rsa_i %>%
dplyr::mutate(lactes = stringr::str_extract_all(ACTES,zal), # Liste des actes
lum = stringr::str_extract_all(RUMS,zum), # Liste des UM
ldas = stringr::str_extract_all(DAS,zd) ) %>% # Liste de das
dplyr::select(-ZA,-RUMS,-ACTES,-DAS)
#cat("Passages UM en ligne : ")
un_i<-Sys.time()
rsa_um <- purrr::flatten_chr(rsa_i$lum)
df <- rsa_i %>% dplyr::select(CLE_RSA,NBRUM)
df <- as.data.frame(lapply(df, rep, df$NBRUM), stringsAsFactors = F) %>% tibble::as_tibble()
if (as.integer(annee) <= 2012){
df <- df %>% dplyr::mutate(NSEQRUM = stringr::str_pad(dplyr::row_number(CLE_RSA), 2,"left","0"))}
rsa_um <- dplyr::bind_cols(df,data.frame(var = rsa_um, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rsa_um", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(rsa_um$var, i)))
names(temp) <- fa$nom[i]
rsa_um <- dplyr::bind_cols(rsa_um, temp)
}
rsa_um %>% dplyr::select(-var, -NBRUM) -> rsa_um
if (lib == T){
if (as.integer(annee) <= 2012){
rsa_um %>% sjlabelled::set_label(c('Clé RSA','N° Séquentiel du RUM', fa$libelle)) -> rsa_um}
else
rsa_um %>% sjlabelled::set_label(c('Clé RSA', fa$libelle)) -> rsa_um
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
# das
#cat("Das en ligne : ")
un_i<-Sys.time()
das <- purrr::flatten_chr(rsa_i$ldas) %>% stringr::str_trim()
df <- rsa_um %>% dplyr::select(CLE_RSA,NSEQRUM,NBDIAGAS)
df <- as.data.frame(lapply(df, rep, df$NBDIAGAS), stringsAsFactors = F) %>% tibble::as_tibble()
das <- dplyr::bind_cols(df,data.frame(DAS = das, stringsAsFactors = F) ) %>% tibble::as_tibble()
das <- das %>% dplyr::select(-NBDIAGAS)
if (lib == T){
das %>% sjlabelled::set_label(c('Clé RSA', 'N° séquentiel du RUM', 'Diagnostic associé')) -> das
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
# actes
#cat("Actes en ligne : ")
un_i<-Sys.time()
actes <- purrr::flatten_chr(rsa_i$lactes)
df <- rsa_um %>% dplyr::select(CLE_RSA,NSEQRUM,NBACTE)
df <- as.data.frame(lapply(df, rep, df$NBACTE), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(var = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rsa_actes", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(actes$var, i)))
names(temp) <- fa$nom[i]
actes <- dplyr::bind_cols(actes, temp)
}
actes %>% dplyr::select(-var, -NBACTE) -> actes
if (lib == T){
actes %>% sjlabelled::set_label(c('Clé RSA', 'N° séquentiel du RUM', fa$libelle)) -> actes
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
deux<-Sys.time()
Fillers <- names(rsa_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rsa_i <- rsa_i[,!(names(rsa_i) %in% Fillers)]
# Libelles
rsa_i <- rsa_i %>% dplyr::select(-lactes, - lum, - ldas)
if (lib==T){
v <- libelles
if (annee==2011){
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs', "Supp. Radiothérapies")
}
else {
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs', "Types Aut. à Portée Globale", "Supp. Radiothérapies")
}
rsa_i <- rsa_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(rsa_i) <- tolower(names(rsa_i))
names(actes) <- tolower(names(actes))
names(das) <- tolower(names(das))
names(rsa_um) <- tolower(names(rsa_um))
}
rsa_1 <- list(rsa = rsa_i,
actes = actes,
das = das,
rsa_um=rsa_um)
class(rsa_1) <- append(class(rsa_1),"RSA")
#cat(paste("MCO RSA Standard",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
attr(rsa_1,"problems") <- synthese_import
return(rsa_1)
}
if (typi == 5){
#cat('Import standard+\n')
#cat('Traitement | Parsing partie variable...\n')
rsa_i <- fzad(rsa_i)
rsa_i <- rsa_i %>%
dplyr::mutate(lactes = stringr::str_extract_all(ACTES,zal), # Liste des actes
actes = extz(ACTES,zac), # Stream des actes
lum = stringr::str_extract_all(RUMS,zum), # Liste des UM
ldas = stringr::str_extract_all(DAS,zd), # Liste de das
das = extz(DAS,zd)) %>% # Stream des das
dplyr::select(-ZA,-RUMS,-ACTES,-DAS)
rsa_i <- rsa_i %>%
dplyr::mutate(das = stringr::str_replace_all(das, "\\s{1,},", ","))
#cat("Passages UM en ligne : ")
un_i<-Sys.time()
rsa_um <- purrr::flatten_chr(rsa_i$lum)
df <- rsa_i %>% dplyr::select(CLE_RSA,NBRUM)
df <- as.data.frame(lapply(df, rep, df$NBRUM), stringsAsFactors = F) %>% tibble::as_tibble()
if (as.integer(annee) <= 2012){
df <- df %>% dplyr::mutate(NSEQRUM = stringr::str_pad(dplyr::row_number(CLE_RSA), 2,"left","0"))}
rsa_um <- dplyr::bind_cols(df,data.frame(var = rsa_um, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rsa_um", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(rsa_um$var, i)))
names(temp) <- fa$nom[i]
rsa_um <- dplyr::bind_cols(rsa_um, temp)
}
rsa_um %>% dplyr::select(-var, -NBRUM) -> rsa_um
if (lib == T){
if (as.integer(annee) <= 2012){
rsa_um %>% sjlabelled::set_label(c('Clé RSA','N° Séquentiel du RUM', fa$libelle)) -> rsa_um}
else
rsa_um %>% sjlabelled::set_label(c('Clé RSA', fa$libelle)) -> rsa_um
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
# das
#cat("Das en ligne : ")
un_i<-Sys.time()
das <- purrr::flatten_chr(rsa_i$ldas) %>% stringr::str_trim()
df <- rsa_um %>% dplyr::select(CLE_RSA,NSEQRUM,NBDIAGAS)
df <- as.data.frame(lapply(df, rep, df$NBDIAGAS), stringsAsFactors = F) %>% tibble::as_tibble()
das <- dplyr::bind_cols(df,data.frame(DAS = das, stringsAsFactors = F) ) %>% tibble::as_tibble()
das <- das %>% dplyr::select(-NBDIAGAS)
if (lib == T){
das %>% sjlabelled::set_label(c('Clé RSA', 'N° séquentiel du RUM', 'Diagnostic associé')) -> das
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
# actes
#cat("Actes en ligne : ")
un_i<-Sys.time()
actes <- purrr::flatten_chr(rsa_i$lactes)
df <- rsa_um %>% dplyr::select(CLE_RSA,NSEQRUM,NBACTE)
df <- as.data.frame(lapply(df, rep, df$NBACTE), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(var = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rsa_actes", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(actes$var, i)))
names(temp) <- fa$nom[i]
actes <- dplyr::bind_cols(actes, temp)
}
actes %>% dplyr::select(-var, -NBACTE) -> actes
if (lib == T){
actes %>% sjlabelled::set_label(c('Clé RSA', 'N° séquentiel du RUM', fa$libelle)) -> actes
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
deux<-Sys.time()
Fillers <- names(rsa_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rsa_i <- rsa_i[,!(names(rsa_i) %in% Fillers)]
# Libelles
deux<-Sys.time()
rsa_i <- rsa_i %>% dplyr::select(-lactes,-lum,-ldas)
Fillers <- names(rsa_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rsa_i <- rsa_i[,!(names(rsa_i) %in% Fillers)]
if (lib==T){
v <- libelles
if (annee==2011) {
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs', "Supp. Radiothérapies", "Stream Actes", "Stream Das")
}
else{
v <- c(v[!is.na(v)], 'Ghm', 'Année séq. de tarifs', "Types Aut. à Portée Globale", "Supp. Radiothérapies", "Stream Actes", "Stream Das")
}
rsa_i <- rsa_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(rsa_i) <- tolower(names(rsa_i))
names(actes) <- tolower(names(actes))
names(das) <- tolower(names(das))
names(rsa_um) <- tolower(names(rsa_um))
}
rsa_1 <- list(rsa = rsa_i , actes = actes, das = das, rsa_um=rsa_um)
class(rsa_1) <- append(class(rsa_1),"RSA")
#cat(paste("MCO RSA Standard+",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
#cat("Les tables rsa, acdi et rsa_um sont dans l'environnement de travail\n")
attr(rsa_1,"problems") <- synthese_import
return(rsa_1)
}
if (typi == 6){
#cat('Import standard++\n')
#cat('Traitement | Parsing partie variable...\n')
rsa_i <- fzad(rsa_i)
rsa_i <- rsa_i %>%
dplyr::mutate(lactes = stringr::str_extract_all(ACTES,zal), # Liste des actes
actes = extz(ACTES,zac), # Stream des actes
#na = stringr::str_count(ZA,zal), # Nombre d'actes trouvés #
lum = stringr::str_extract_all(RUMS,zum), # Liste des UM
#num = stringr::str_count(ZA,zum), # Nombre d'UM trouvés #
um = unlist(lapply(lapply(lum, # Stream des types d'UM
function(x){substr(x,debum,finum)}),
function(y){toString(y)})),
dpdrum = unlist(lapply(lapply(lum, # Stream des dpdr d'UM
function(x){substr(x,debdpdr,findpdr)}),
function(y){toString(y)})),
ldas = stringr::str_extract_all(DAS,zd), # Liste de das
das = extz(DAS,zd)) %>% # Stream des das
dplyr::select(-ZA,-RUMS,-ACTES,-DAS)
rsa_i <- rsa_i %>%
dplyr::mutate(das = stringr::str_replace_all(das, "\\s{1,},", ","),
dpdrum = stringr::str_replace_all(dpdrum, "\\s{1,},", ","))
#cat("Passages UM en ligne : ")
un_i<-Sys.time()
rsa_um <- purrr::flatten_chr(rsa_i$lum)
df <- rsa_i %>% dplyr::select(CLE_RSA,NBRUM)
df <- as.data.frame(lapply(df, rep, df$NBRUM), stringsAsFactors = F) %>% tibble::as_tibble()
if (as.integer(annee) <= 2012){
df <- df %>% dplyr::mutate(NSEQRUM = stringr::str_pad(dplyr::row_number(CLE_RSA), 2,"left","0"))}
rsa_um <- dplyr::bind_cols(df,data.frame(var = rsa_um, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rsa_um", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(rsa_um$var, i)))
names(temp) <- fa$nom[i]
rsa_um <- dplyr::bind_cols(rsa_um, temp)
}
rsa_um %>% dplyr::select(-var, -NBRUM) -> rsa_um
if (lib == T){
if (as.integer(annee) <= 2012){
rsa_um %>% sjlabelled::set_label(c('Clé RSA','N° Séquentiel du RUM', fa$libelle)) -> rsa_um}
else
rsa_um %>% sjlabelled::set_label(c('Clé RSA', fa$libelle)) -> rsa_um
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
# das
#cat("Das en ligne : ")
un_i<-Sys.time()
das <- purrr::flatten_chr(rsa_i$ldas) %>% stringr::str_trim()
df <- rsa_um %>% dplyr::select(CLE_RSA,NSEQRUM,NBDIAGAS)
df <- as.data.frame(lapply(df, rep, df$NBDIAGAS), stringsAsFactors = F) %>% tibble::as_tibble()
das <- dplyr::bind_cols(df,data.frame(DAS = das, stringsAsFactors = F) ) %>% tibble::as_tibble()
das <- das %>% dplyr::select(-NBDIAGAS)
if (lib == T){
das %>% sjlabelled::set_label(c('Clé RSA', 'N° séquentiel du RUM', 'Diagnostic associé')) -> das
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
# actes
#cat("Actes en ligne : ")
un_i<-Sys.time()
actes <- purrr::flatten_chr(rsa_i$lactes)
df <- rsa_um %>% dplyr::select(CLE_RSA,NSEQRUM,NBACTE)
df <- as.data.frame(lapply(df, rep, df$NBACTE), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(var = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
fa <- pmeasyr::formats %>% dplyr::filter(champ == "mco", table == "rsa_actes", an == substr(annee,3,4))
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$type[i], u(actes$var, i)))
names(temp) <- fa$nom[i]
actes <- dplyr::bind_cols(actes, temp)
}
actes %>% dplyr::select(-var, -NBACTE) -> actes
if (lib == T){
actes %>% sjlabelled::set_label(c('Clé RSA', 'N° séquentiel du RUM', fa$libelle)) -> actes
}
deux_i<-Sys.time()
#cat(round(difftime(deux_i,un_i, units="secs"),0), "secondes\n")
deux<-Sys.time()
rsa_i <- rsa_i %>% dplyr::select(-lactes,-lum,-ldas)
Fillers <- names(rsa_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rsa_i <- rsa_i[,!(names(rsa_i) %in% Fillers)]
if (lib==T){
v <- libelles
if (annee==2011) {
v <- c(v[!is.na(v)],"Ghm", "Année séq. de tarifs", "Supp. Radiothérapies",
"Stream Actes","Parcours Typaut UM",
"Stream DP/DR des UM","Stream Das")
}
else{
v <- c(v[!is.na(v)],"Ghm", "Année séq. de tarifs",
"Types Aut. à Portée Globale", "Supp. Radiothérapies",
"Stream Actes","Parcours Typaut UM","Stream DP/DR des UM","Stream Das")
}
rsa_i <- rsa_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(rsa_i) <- tolower(names(rsa_i))
names(actes) <- tolower(names(actes))
names(das) <- tolower(names(das))
names(rsa_um) <- tolower(names(rsa_um))
}
rsa_1 <- list(rsa = rsa_i , actes = actes, das = das, rsa_um = rsa_um)
class(rsa_1) <- append(class(rsa_1),"RSA")
#cat(paste("MCO RSA Standard++",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
#cat("Les tables rsa, acdi et rsa_um sont dans l'environnement de travail\n")
attr(rsa_1,"problems") <- synthese_import
return(rsa_1)
}
cat("Quel type d'import ?\n")
typo <- data.frame(Type=c(1,
2,
3,
4,
5,
6),
Import=c('Light : Partie fixe',
'Light+ : Partie fixe + stream en ligne (+) actes et das',
'Light++ : Partie fixe + stream en ligne (++) actes, das, typaut um et dpdr des um',
'Standard : Partie fixe + création des tables acdi et rsa_um',
'Standard+ : Partie fixe + création des tables acdi et rsa_um + stream (+)',
'Standard++ : Partie fixe + création des tables acdi et rsa_um + stream (++)'),
Temps=c('Très Rapide','Rapide','Long','Rapide', 'Long','Long'),
`Temps rapporté`=c('= 1','* 4 (~)','* 9 (~)','* 4 (~)','* 6 (~)', '* 10 (~)'))
cat(knitr::kable(typo),sep='\n')
n <- readline(prompt="Taper le type d'import voulu : ")
return(irsa(finess,annee,mois,path,lib,n, ...))
}
#' ~ TRA - Import du TRA
#'
#' Import du fichier TRA, 4 champs PMSI couverts.
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu (sortie de Genrsa) :
#' \emph{finess.annee.moisc.tra}
#'
#' \strong{750712184.2016.2.tra}
#'
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param champ Champ PMSI du TRA a integrer ("mco", "ssr", "had", "psy_rpsa", ", "psy_r3a"), par defaut "mco"
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premières lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame ou tibble) qui contient : - Clé RSA - NORSS - Numéro de ligne du fichier RSS d'origine (rss.ini) - NAS - Date d'entrée du séjour - GHM groupage du RSS (origine) - Date de sortie du séjour
#'
#' @examples
#' \dontrun{
#' itra('750712184',2015,12,'~/Documents/data/champ_pmsi') -> tra15
#' }
#'
#' @author G. Pressiat
#'
#' @usage itra(finess, annee, mois, path, lib = T, tolower_names = F, champ = "mco")
#' @seealso \code{\link{irum}}, \code{\link{irsa}}, \code{\link{ileg_mco}}, \code{\link{iano_mco}}, \code{\link{irha}}, \code{\link{irapss}}, \code{\link{irpsa}}, \code{\link{ir3a}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @export itra
#' @export
itra <- function(...){
UseMethod('itra')
}
#' @export
itra.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(itra.default, param2)
}
#' @export
itra.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(itra.default, param2)
}
#' @export
itra.default <- function(finess, annee, mois, path, lib = T, champ= "mco", tolower_names = F, ... ){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (champ == "mco" & paste0(annee, stringr::str_pad(mois, 2, 'left', '0')) >= '202303') {
# Druides
champ1 = champ
format <- pmeasyr::formats %>% dplyr::filter(champ == champ1, table == 'tra')
tra_i <- readr::read_delim(paste0(path,"/",finess,".",annee,".",mois,".tra.txt"), delim = ";",
col_names = c('CLE_RSA', 'NORSS', 'NAS', 'DTENT', 'DTSORT', 'GHM1', 'filler'),
col_types = readr::cols(.default = readr::col_character())) %>%
dplyr::mutate(NO_ligne_RSS = "") %>%
dplyr::select(format$nom)
tra_i <- tra_i %>%
dplyr::mutate(DTENT = lubridate::dmy(DTENT, quiet = TRUE),
DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
NOHOP = paste0("000",stringr::str_sub(NAS,1,2))) %>%
dplyr::mutate_if(is.character, stringr::str_trim)
if (tolower_names){
names(tra_i) <- tolower(names(tra_i))
}
if (lib == T){
v <- c(format$libelle, 'Établissement')
return(tra_i %>% sjlabelled::set_label(v))
} else {
return(tra_i)
}
} else if (!grepl("psy",champ)){
champ1 = champ
format <- pmeasyr::formats %>% dplyr::filter(champ == champ1, table == 'tra')
} else {
champ1 = champ
format <- pmeasyr::formats %>% dplyr::filter(champ == "psy", table == champ1)
}
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (champ=="mco"){
tra_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".tra.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(tra_i) -> synthese_import
tra_i <- tra_i %>%
dplyr::mutate(DTENT = lubridate::dmy(DTENT, quiet = TRUE),
DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
NOHOP = paste0("000",stringr::str_sub(NAS,1,2)))
}
if (champ=="had"){
tra_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".tra"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(tra_i) -> synthese_import
tra_i <- tra_i %>%
dplyr::mutate(DTENT = lubridate::dmy(DTENT, quiet = TRUE),
DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
NOHOP = paste0("000",stringr::str_sub(NAS,1,2)),
DTNAI = lubridate::dmy(DTNAI, quiet = TRUE),
DT_DEB_SEQ = lubridate::dmy(DT_DEB_SEQ, quiet = TRUE),
DT_FIN_SEQ = lubridate::dmy(DT_FIN_SEQ, quiet = TRUE),
DT_DEB_SS_SEQ = lubridate::dmy(DT_DEB_SS_SEQ, quiet = TRUE),
DT_FIN_SS_SEQ = lubridate::dmy(DT_FIN_SS_SEQ, quiet = TRUE))
}
if (champ=="ssr"){
tra_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".tra"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(tra_i) -> synthese_import
tra_i <- tra_i %>%
dplyr::mutate(NOHOP = paste0("000",stringr::str_sub(NAS,1,2)))
}
if (champ=="psy_rpsa"){
if (as.character(annee) < '2020'){
extens <- '.tra.txt'
} else {
extens <- '.tra'
}
tra_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois, extens),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(tra_i) -> synthese_import
tra_i <- tra_i %>%
dplyr::mutate(NOHOP = paste0("000",stringr::str_sub(NAS,1,2)),
DTENT = lubridate::dmy(DTENT),
DTSORT = lubridate::dmy(DTSORT),
DT_DEB_SEQ = lubridate::dmy(DT_DEB_SEQ, quiet = TRUE),
DT_FIN_SEQ = lubridate::dmy(DT_FIN_SEQ, quiet = TRUE))
}
if (champ=="psy_r3a"){
if (as.character(annee) < '2020'){
extens <- '.tra.raa.txt'
} else {
extens <- '.tra.raa'
}
tra_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois, extens),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(tra_i) -> synthese_import
tra_i <- tra_i %>%
dplyr::mutate(DTACTE = lubridate::dmy(DTACTE, quiet = TRUE),
DTACTE_2 = lubridate::dmy(DTACTE_2, quiet = TRUE))
}
if (lib==T & champ !="psy_r3a"){
if (tolower_names){
names(tra_i) <- tolower(names(tra_i))
}
v <- c(libelles, 'Établissement')
return(tra_i %>% sjlabelled::set_label(v))
}
if (lib==T & champ =="psy_r3a"){
if (tolower_names){
names(tra_i) <- tolower(names(tra_i))
}
v <- libelles
return(tra_i %>% sjlabelled::set_label(v))
}
if (tolower_names){
names(tra_i) <- tolower(names(tra_i))
}
attr(tra_i,"problems") <- synthese_import
return(tra_i)
}
#' ~ MCO - Import des Anohosp
#'
#' Import du fichier ANO In ou Out.
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu :
#' \emph{finess.annee.moisc.ano}
#' \emph{finess.annee.moisc.ano.txt}
#'
#' \strong{750712184.2016.2.ano}
#' \strong{750712184.2016.2.ano.txt}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des données sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typano Type de donnees In / Out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame ou tibble) qui contient les données Anohosp in / out
#'
#' @examples
#' \dontrun{
#' iano_mco('750712184',2015,12,'~/Documents/data/mco') -> ano_out15
#' iano_mco('750712184',2015,12,'~/Documents/data/mco', typano = "in") -> ano_in15
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irum}}, \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @export iano_mco
#' @usage iano_mco(finess, annee, mois, path, lib = T, tolower_names = F, typano = "out")
#' @export
iano_mco <- function( ...){
UseMethod('iano_mco')
}
#' @export
iano_mco.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iano_mco.default, param2)
}
#' @export
iano_mco.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iano_mco.default, param2)
}
#' @export
iano_mco.default <- function(finess, annee, mois, path, typano = c("out", "in"), lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
typano <- match.arg(typano)
if (!(typano %in% c('in', 'out'))){
stop('Paramètre typano incorrect')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (typano=="out"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa_ano', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (annee>=2013){
ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') +
(CRCDNAI=='0') + (CRCSEXE=='0')==9),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
MTRMBAMC = MTRMBAMC/100,
TAUXRM = TAUXRM /100,
MTMALPAR = MTMALPAR/100)
}
if (2011<annee & annee<2013){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') == 7),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
MTRMBAMC = MTRMBAMC/100,
TAUXRM = TAUXRM /100,
MTMALPAR = MTMALPAR/100)
}
if (annee == 2011){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') == 7),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMALPAR = MTMALPAR/100)
}
Fillers <- names(ano_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="Fil"]
ano_i <- ano_i[,!(names(ano_i) %in% Fillers)]
if (lib==T){
v <- c(libelles[!is.na(libelles)], "Chaînage Ok")
ano_i <- ano_i %>% sjlabelled::set_label(v)
}
}
if (typano=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rum_ano', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (2011<annee){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTHOSP = lubridate::dmy(DTHOSP, quiet = TRUE),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTRMAMC = MTRMAMC /100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
if (annee == 2011){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
Fillers <- names(ano_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
ano_i <- ano_i[,!(names(ano_i) %in% Fillers)]
if (lib==T){
v <- libelles[!is.na(libelles)]
ano_i <- ano_i %>% sjlabelled::set_label(v)
}
}
if (tolower_names){
names(ano_i) <- tolower(names(ano_i))
}
attr(ano_i,"problems") <- synthese_import
return(ano_i)
}
#' ~ MCO - Import des Med
#'
#' Import des fichiers MED In ou Out.
#'
#' Formats depuis 2011 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typmed Type de donnees In / Out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les médicaments In ou Out
#' (T2A, ATU et thrombo selon l'existence des fichiers : si le fichier n'existe pas, pas de donnée importée).
#' Pour discriminer le type de prestation, la colonne TYPEPREST donne l'information : T2A 06 - ATU 09 - THROMBO 10
#'
#' @examples
#' \dontrun{
#' imed_mco('750712184',2015,12,'~/Documents/data/mco') -> med_out15
#' imed_mco('750712184',2015,12,'~/Documents/data/mco', typmed = "in") -> med_in15
#' }
#'
#' @author G. Pressiat
#'
#' @usage imed_mco(finess, annee, mois, path, lib = T, tolower_names = F, typmed = c('out', 'in'))
#' @seealso \code{\link{irum}}, \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @export imed_mco
#' @export
imed_mco <- function(...){
UseMethod('imed_mco')
}
#' @export
imed_mco.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(imed_mco.default, param2)
}
#' @export
imed_mco.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(imed_mco.default, param2)
}
#' @export
imed_mco.default <- function(finess, annee, mois, path, typmed = c("out", "in"), lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
typmed <- match.arg(typmed)
if (!(typmed %in% c('in', 'out'))){
stop('Paramètre typmed incorrect')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (typmed=="out"){
# med_out
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa_med', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
med_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".med"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(med_i) -> synthese_import
med_i <- med_i %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000)
info = file.info(paste0(path,"/",finess,".",annee,".",mois,".medatu"))
if (info$size >0 & !is.na(info$size)){
med_i2<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".medatu"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
synthese_import <- dplyr::bind_rows(synthese_import, readr::problems(med_i2))
med_i2 <- med_i2 %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000)
med_i <- rbind(med_i,med_i2)
}
info = file.info(paste0(path,"/",finess,".",annee,".",mois,".medthrombo"))
if (info$size >0 & !is.na(info$size)){
med_i3<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".medthrombo"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
synthese_import <- dplyr::bind_rows(synthese_import, readr::problems(med_i3))
med_i3 <- med_i3 %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000)
med_i <- rbind(med_i,med_i3)
}
if (lib==T){
v <- libelles
med_i <- med_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(med_i) <- tolower(names(med_i))
}
attr(med_i,"problems") <- synthese_import
return(med_i)
}
if (typmed=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rum_med', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
info = file.info(paste0(path,"/",finess,".",annee,".",mois,".med.txt"))
if (info$size >0 & !is.na(info$size)){
med_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".med.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(med_i) -> synthese_import
med_i <- med_i %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000)
}
if (lib==T){
v <- libelles
v<- v[!is.na(v)]
med_i <- med_i %>% sjlabelled::set_label(v)
}
med_i %>% dplyr::mutate(DTDISP = lubridate::dmy(DTDISP, quiet = TRUE)) -> med_i
if (tolower_names){
names(med_i) <- tolower(names(med_i))
}
attr(med_i,"problems") <- synthese_import
return(med_i)
}
}
#' ~ MCO - Import des DMI
#'
#' Import des fichiers DMI In ou Out.
#'
#' Formats depuis 2011 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typdmi Type de donnees In / Out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les dispositifs médicaux implantables In ou Out (T2A, ATU et thrombo selon l'existence des fichiers :
#' si le fichier n'existe pas, pas de donnée importée). Pour discriminer le type de prestation, la colonne TYPEPREST donne l'information :
#' T2A 06 - ATU 09 - THROMBO 10
#'
#' @examples
#' \dontrun{
#' idmi_mco('750712184',2015,12,'~/Documents/data/mco') -> dmi_out15
#' idmi_mco('750712184',2015,12,'~/Documents/data/mco', typdmi = "in") -> dmi_in15
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irum}}, \code{\link{irsa}}
#' @export idmi_mco
#' @export
idmi_mco <- function(...){
UseMethod('idmi_mco')
}
#' @export
idmi_mco.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(idmi_mco.default, param2)
}
#' @export
idmi_mco.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(idmi_mco.default, param2)
}
#' @export
idmi_mco.default <- function(finess, annee, mois, path, typdmi = c("out", "in"), lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
typdmi <- match.arg(typdmi)
if (!(typdmi %in% c('in', 'out'))){
stop('Paramètre typdmi incorrect')
}
#op <- options(digits.secs = 6)
un<-Sys.time()
if (typdmi=="out"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa_dmi', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
dmi_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".dmip"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(dmi_i) -> synthese_import
dmi_i <- dmi_i %>%
dplyr::mutate(PRIX = PRIX /1000)
if (lib==T){
v <- libelles
dmi_i <- dmi_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(dmi_i) <- tolower(names(dmi_i))
}
attr(dmi_i,"problems") <- synthese_import
return(dmi_i)
}
if (typdmi=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rum_dmi', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
dmi_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".dmi.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(dmi_i) -> synthese_import
dmi_i <- dmi_i %>%
dplyr::mutate(PRIX = PRIX /1000,
DTPOSE = lubridate::dmy(DTPOSE, quiet = TRUE))
if (lib==T){
v <- libelles
v <- v[!is.na(v)]
dmi_i <- dmi_i %>% dplyr::select(-Fil1,-Fil2) %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(dmi_i) <- tolower(names(dmi_i))
}
attr(dmi_i,"problems") <- synthese_import
return(dmi_i)
}
}
#' ~ MCO - Import des IVG
#'
#' Import des fichiers IVG In ou Out.
#'
#' Formats depuis 2017 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typivg Type de donnees In / Out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les IVG In ou Out
#' (si le fichier n'existe pas, pas de donnée importée).
#' Le TYPEPREST est par defaut 53
#'
#' @examples
#' \dontrun{
#' iivg_mco('750712184', 2017, 12,'~/Documents/data/mco') -> ivg_out17
#' iivg_mco('750712184', 2017, 12,'~/Documents/data/mco', typivg = "in") -> ivg_in17
#' }
#'
#' @author G. Pressiat, N. Taright
#'
#' @usage iivg_mco(finess, annee, mois, path, lib = T, tolower_names = F, typivg = c('out', 'in'))
#' @seealso \code{\link{irum}}, \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @export iivg_mco
#' @export
iivg_mco <- function(...){
UseMethod('iivg_mco')
}
#' @export
iivg_mco.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iivg_mco.default, param2)
}
#' @export
iivg_mco.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iivg_mco.default, param2)
}
#' @export
iivg_mco.default <- function(finess, annee, mois, path, typivg = c("out", "in"), lib = T, tolower_names = F, ...){
if (annee<2017|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
typivg <- match.arg(typivg)
if (!(typivg %in% c('in', 'out'))){
stop('Paramètre typivg incorrect')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (typivg == "out"){
# ivg_out
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa_ivg', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
ivg_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ivg"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ivg_i) -> synthese_import
if (lib==T){
v <- libelles
ivg_i <- ivg_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(ivg_i) <- tolower(names(ivg_i))
}
attr(ivg_i,"problems") <- synthese_import
return(ivg_i)
}
if (typivg=="in"){
# ivg_in
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rum_ivg', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
# info = file.info(paste0(path,"/",finess,".",annee,".",mois,".ivg.txt"))
# if (info$size >0 & !is.na(info$size)){
ivg_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ivg.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ivg_i) -> synthese_import
# }
if (lib==T){
v <- libelles
v<- v[!is.na(v)]
ivg_i <- ivg_i %>% sjlabelled::set_label(v)
}
ivg_i %>%
dplyr::mutate(D8EEUE = lubridate::dmy(D8EEUE, quiet = TRUE),
D8SOUE = lubridate::dmy(D8SOUE, quiet = TRUE)) -> ivg_i
if (tolower_names){
names(ivg_i) <- tolower(names(ivg_i))
}
attr(ivg_i,"problems") <- synthese_import
return(ivg_i)
}
}
#' ~ MCO - Import des transports (TPT)
#'
#' Import des fichiers TPT In ou Out.
#'
#' Formats depuis 2021 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typtpt Type de donnees In / Out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les transports In ou Out
#' (si le fichier n'existe pas, pas de donnée importée).
#' Le TYPEPREST est par defaut 15
#'
#' @examples
#' \dontrun{
#' itpt_mco('750712184', 2021, 12,'~/Documents/data/mco') -> tpt_out15
#' itpt_mco('750712184', 2021, 12,'~/Documents/data/mco', typtpt = "in") -> tpt_in15
#' }
#'
#' @author G. Pressiat, N. Taright
#'
#' @usage itpt_mco(finess, annee, mois, path, lib = T, tolower_names = F, typtpt = c('out', 'in'))
#' @seealso \code{\link{irum}}, \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @export itpt_mco
#' @export
itpt_mco <- function(...){
UseMethod('itpt_mco')
}
#' @export
itpt_mco.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(itpt_mco.default, param2)
}
#' @export
itpt_mco.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(itpt_mco.default, param2)
}
#' @export
itpt_mco.default <- function(finess, annee, mois, path, typtpt = c("out", "in"), lib = T, tolower_names = F, ...){
if (annee < 2021 | annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
typtpt <- match.arg(typtpt)
if (!(typtpt %in% c('in', 'out'))){
stop('Paramètre typtpt incorrect')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (typtpt == "out"){
# TPT out
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa_tpt', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
tpt_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".transport"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(tpt_i) -> synthese_import
tpt_i <- tpt_i %>%
dplyr::mutate(DTALLER = lubridate::dmy(DTALLER, quiet = TRUE))
if (lib==T){
v <- libelles
tpt_i <- tpt_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(tpt_i) <- tolower(names(tpt_i))
}
attr(tpt_i,"problems") <- synthese_import
return(tpt_i)
}
if (typtpt=="in"){
# TPT in
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rum_tpt', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
tpt_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".transp.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(tpt_i) -> synthese_import
if (lib==T){
v <- libelles
# v<- v[!is.na(v)]
tpt_i <- tpt_i %>% sjlabelled::set_label(v)
}
tpt_i %>%
dplyr::mutate(DTALLER = lubridate::dmy(DTALLER, quiet = TRUE)) -> tpt_i
if (tolower_names){
names(tpt_i) <- tolower(names(tpt_i))
}
attr(tpt_i,"problems") <- synthese_import
return(tpt_i)
}
}
#' ~ MCO - Import des erreurs Leg
#'
#' Import de la liste d'erreurs de génération Genrsa
#'
#' Formats depuis 2011 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param reshape booleen TRUE/FALSE : la donnee doit-elle etre restructuree ? une ligne = une erreur, sinon, une ligne = un sejour. par defaut a F
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les erreurs Out.
#'
#' @examples
#' \dontrun{
#' ileg_mco('750712184',2015,12,'~/Documents/data/mco') -> leg15
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irum}}, \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @export ileg_mco
#' @usage ileg_mco(finess, annee, mois, path, reshape = F, tolower_names = F, ...)
#' @export
ileg_mco <- function(...){
UseMethod('ileg_mco')
}
#' @export
ileg_mco.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(ileg_mco.default, param2)
}
#' @export
ileg_mco.list <- function(l , ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(ileg_mco.default, param2)
}
#' @export
ileg_mco.default <- function(finess, annee, mois, path, reshape = F, tolower_names = F, ...){
leg_i <- readr::read_lines(paste0(path,"/",finess,".",annee,".",mois,".leg"), ...)
leg_i1 <- tibble::tibble(l = leg_i) %>%
tidyr::separate(l, c('FINESS', 'MOIS', 'ANNEE', 'CLE_RSA', 'NBERR', 'ERRS'), ";", extra = "merge")
if (reshape==FALSE){
leg_i1 <- leg_i1 %>%
dplyr::mutate(EG = stringr::str_replace_all(ERRS, ";", ", ")) %>%
dplyr::select(-ERRS)
if (tolower_names){
names(leg_i1) <- tolower(names(leg_i1))
}
return(leg_i1)
}
u <- stringr::str_split(leg_i1$ERRS, ";") %>% purrr::flatten_chr()
leg_i1 <- tibble::as_tibble(lapply(leg_i1, rep, leg_i1$NBERR), stringsAsFactors = F)
leg_i2 <- dplyr::bind_cols(leg_i1, data.frame(EG = as.character(u), stringsAsFactors = F))
leg_i2 <- leg_i2 %>%
dplyr::mutate(ERRS = stringr::str_replace_all(ERRS, ";", ", "))
if (tolower_names){
names(leg_i2) <- tolower(names(leg_i2))
}
return(leg_i2)
}
#' ~ TRA - Ajout du TRA aux donnees Out
#'
#' Ajout du TRA par dplyr::inner_join
#'
#'
#' @param table Table a laquelle rajouter le tra
#' @param tra tra a rajouter
#' @param sel Variable a garder du tra ; sel = 1 : numero de sejour, sel = 2 : toutes les variables
#' @param champ Champ PMSI : mco, had, ssr, psy : deux tra en psy : psy_rpsa, psy_r3a
#'
#' @return Une table contenant le inner_join entre table et tra
#'
#' @examples
#' \dontrun{
#' med <- imed_mco('750712184',2015,12,"~/Documents/data/mco","out")
#' tra <- itra('750712184',2015,12,"~/Documents/data/mco")
#' med <- inner_tra(med,tra)
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irum}}, \code{\link{irsa}}, \code{\link{imed_mco}}, \code{\link{irpsa}}, \code{\link{irha}}, \code{\link{irapss}}
#' @export
inner_tra <- function(table, tra, sel = 1, champ = "mco"){
#inner_tra <- function(table, tra ){
suppressMessages( dplyr::inner_join(table, tra) )
if (champ == "mco"){
if (sel==1){
return( suppressMessages( dplyr::inner_join(table, tra %>% dplyr::select(c(1:2,4,8)))))
}
if (sel==2){
return( suppressMessages( dplyr::inner_join(table, tra )))
}
}
if (champ == "had"){
if (sel==1){
return( suppressMessages( dplyr::inner_join(table, tra %>% dplyr::select(1:4))))
}
if (sel==2){
return( suppressMessages( dplyr::inner_join(table, tra)))
}
}
if (champ == "ssr"){
if (sel==1){
return(suppressMessages( dplyr::inner_join(table, tra %>% dplyr::select(c(1,3,4,5)))))
}
if (sel==2){
return(suppressMessages( dplyr::inner_join(table, tra)))
}
}
if (champ == "psy_rpsa"){
if (sel==1){
return(suppressMessages( dplyr::inner_join(table, tra %>% dplyr::select(c(3:5,10)))))
}
if (sel==2){
return(suppressMessages( dplyr::inner_join(table, tra)))
}
}
if (champ == "psy_r3a"){
if (sel==1){
return(suppressMessages( dplyr::inner_join(table, tra)))
}
if (sel==2){
return(suppressMessages( dplyr::inner_join(table, tra)))
}
}
if (!(sel %in% 1:2)){
print("Paramètre sel incorrect")
return(NULL)
}
if (!(champ %in% c('mco','had','ssr','psyrpsa','psyr3a'))){
print("Paramètre champ incorrect")
return(NULL)
}
}
#' ~ MCO - Import des DIAP
#'
#' Imports des fichiers DIAP In / Out
#'
#' Formats depuis 2011 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typdiap Type de donnees In / Out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les dialyses péritonéales In ou Out.
#'
#' @examples
#' \dontrun{
#' idiap <- idiap('750712184',2015,12,"~/Documents/data/mco")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irum}}, \code{\link{irsa}}
#' @usage idiap(finess, annee, mois, path,
#' typdiap = c("out", "in"),
#' lib = T, tolower_names = F, ...)
#' @export idiap
#' @export
idiap <- function(...){
UseMethod('idiap')
}
#' @export
idiap.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(idiap.default, param2)
}
#' @export
idiap.list <- function(l , ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(idiap.default, param2)
}
#' @export
idiap.default <- function(finess, annee, mois, path,
typdiap = c("out", "in"), lib = T,
tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
typdiap <- match.arg(typdiap)
if (!(typdiap %in% c('in', 'out'))){
stop('Paramètre typdiap incorrect')
}
#op <- options(digits.secs = 6)
un<-Sys.time()
if (typdiap=="out"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa_diap', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
diap_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".diap"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(diap_i) -> synthese_import
if (lib==T){
v <- libelles
diap_i <- diap_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(diap_i) <- tolower(names(diap_i))
}
attr(diap_i,"problems") <- synthese_import
return(diap_i)
}
if (typdiap=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'ffc_in', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
diap_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".diap.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(diap_i) -> synthese_import
diap_i <- diap_i %>%
dplyr::mutate(DTDEBUT = lubridate::dmy(DTDEBUT, quiet = TRUE))
if (lib==T){
v <- libelles
diap_i <- diap_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(diap_i) <- tolower(names(diap_i))
}
attr(diap_i,"problems") <- synthese_import
return(diap_i)
}
}
#' ~ MCO - Import des donnees UM du Out
#'
#' Imports du fichier IUM MCO
#'
#' Formats depuis 2011 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires à passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les informations structures du Out.
#'
#' @examples
#' \dontrun{
#' um <- iium('750712184',2015,12,"~/Documents/data/mco")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage iium(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export iium
#' @export
iium <- function(...){
UseMethod('iium')
}
#' @export
iium.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iium.default, param2)
}
#' @export
iium.list <- function(l , ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iium.default, param2)
}
#' @export
iium.default <- function(finess, annee, mois, path, lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'um', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
ium_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ium"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ium_i) -> synthese_import
ium_i <- ium_i %>%
dplyr::mutate(DTEAUT = lubridate::dmy(DTEAUT, quiet = TRUE))
if (lib==T){
v <- libelles
ium_i <- ium_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(ium_i) <- tolower(names(ium_i))
}
attr(ium_i,"problems") <- synthese_import
return(ium_i)
}
#' ~ MCO - Import des donnees correspondances d'UM du Out
#'
#' Imports du fichier IUM corresp MCO
#'
#' Formats depuis 2020 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2020)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires à passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les informations Um out/UM in.
#'
#' @examples
#' \dontrun{
#' um_corresp <- iium_corresp('750712184',2020,12,"~/Documents/data/mco")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage iium_corresp(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export iium_corresp
#' @export
iium_corresp <- function(...){
UseMethod('iium_corresp')
}
#' @export
iium_corresp.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iium_corresp.default, param2)
}
#' @export
iium_corresp.list <- function(l , ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iium_corresp.default, param2)
}
#' @export
iium_corresp.default <- function(finess, annee, mois, path, tolower_names = F, ...){
fp <- paste0(path,"/",finess,".",annee,".",mois,".ium.correspnumseq.txt")
umcorresp_i <- readr::read_delim(fp, col_names = c('NOSEQUM', 'CDURM'),
col_types = readr::cols(NOSEQUM = readr::col_character(),
CDURM = readr::col_character()), skip = 0L, delim = ";")
if (tolower_names){
names(umcorresp_i) <- tolower(names(umcorresp_i))
}
return(umcorresp_i)
}
#' ~ MCO - Import des PO
#'
#' Imports des fichiers PO In / Out
#'
#' Formats depuis 2011 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typpo Type de donnees In / Out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#' @return Une table (data.frame, tibble) contenant les prélèvements d'organes In ou Out.
#'
#' @examples
#' \dontrun{
#' po <- ipo('750712184',2015,12,"~/Documents/data/mco")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irum}}, \code{\link{irsa}}, utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage ipo(finess, annee, mois, path, typpo = c("out", "in"), lib = T, tolower_names = F, ...)
#' @export ipo
#' @export
ipo <- function( ...){
UseMethod('ipo')
}
#' @export
ipo.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(ipo.default, param2)
}
#' @export
ipo.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(ipo.default, param2)
}
#' @export
ipo.default <- function(finess, annee, mois, path, typpo = c("out", "in"), lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
typpo <- match.arg(typpo)
if (!(typpo %in% c('in', 'out'))){
stop('Paramètre typpo incorrect')
}
#op <- options(digits.secs = 6)
un<-Sys.time()
if (typpo=="out"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'rsa_po', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
po_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".porg"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(po_i) -> synthese_import
if (lib==T){
v <- libelles
po_i <- po_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(po_i) <- tolower(names(po_i))
}
attr(po_i,"problems") <- synthese_import
return(po_i)
}
if (typpo=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'mco', table == 'ffc_in', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
po_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".porg.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(po_i) -> synthese_import
po_i <- po_i %>%
dplyr::mutate(DTDEBUT = lubridate::dmy(DTDEBUT, quiet = TRUE))
if (lib==T){
v <- libelles
po_i <- po_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(po_i) <- tolower(names(po_i))
}
attr(po_i,"problems") <- synthese_import
return(po_i)
}
}
##############################################
####################### HAD ##################
##############################################
#' ~ HAD - Import des RAPSS
#'
#' Imports du fichier RAPSS
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu (sortie de Paprica) :
#' \emph{finess.annee.moisc.rapss}
#'
#' \strong{750712184.2016.2.rapss}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des données sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une classe S3 contenant les tables (data.frame, tibble ou tbl) importées (rapss, acdi, ght).
#'
#' @examples
#' \dontrun{
#' um <- iium('750712184',2015,12,"~/Documents/data/had")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{iano_had}}, \code{\link{ileg_had}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage irapss(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export irapss
#' @export
irapss <- function(...){
UseMethod('irapss')
}
#' @export
irapss.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(irapss.default, param2)
}
#' @export
irapss.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(irapss.default, param2)
}
#' @export
irapss.default <- function(finess, annee, mois, path, lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
# cat(paste("L'objet retourné prendra la forme d'une classe S3.
# $rapss pour accéder à la table RSA
# $acdi pour accéder à la table ACDI
# $ght pour accéder aux ght etb et paprica\n\n"))
if(annee >= 2020 & mois >= 3) {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss', an == "20_H33")
} else if(annee == 2021 & mois < 3) {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss', an == "20_H33")
} else {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss', an == substr(as.character(annee),3,4))
}
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
extz <- function(x,pat){unlist(lapply(stringr::str_extract_all(x,pat),toString) )}
rapss_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rapss"),
readr::fwf_widths(af,an), col_types = at , na=character(),...)
readr::problems(rapss_i) -> synthese_import
if (annee==2011){
zght <- ".{5}"
zd <- ".{1,6}"
zA <- ".{1,17}"
rapss_i <- rapss_i %>% dplyr::mutate(
# Diagnostics et actes
da = ifelse(NBDA>0,stringr::str_sub(Z,1,NBDA*6),""),
lda = stringr::str_extract_all(da,zd),
za = ifelse(NBZA>0,stringr::str_sub(Z,1+NBDA*6,NBDA*6+NBZA*17),""),
lactes = stringr::str_extract_all(za,zA),
# groupage Etablissement
NOVRPSS = stringr::str_sub(Z, 1+NBDA*6+NBZA*17, NBDA*6+NBZA*17+3),
ETB_VCLASS = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+3, NBDA*6+NBZA*17+3+2),
ETB_CDRETR = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+3+2, NBDA*6+NBZA*17+3+2+3),
ETB_GHPC = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+3+2+3, NBDA*6+NBZA*17+3+2+3+4),
ETB_NBGHT = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+3+2+3+4, NBDA*6+NBZA*17+3+2+3+4+1) %>% as.numeric(),
etb_ght = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+13,NBDA*6+NBZA*17+13+5*ETB_NBGHT),
letb_ght = stringr::str_extract_all(etb_ght,zght),
# groupage Paprica
PAPRICA_VCLASS = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+13+5*ETB_NBGHT,NBDA*6+NBZA*17+13+5*ETB_NBGHT+2),
PAPRICA_CDRETR = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2,NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3),
PAPRICA_GHPC = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3,NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3+4),
PAPRICA_NBGHT = stringr::str_sub(Z, 1+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3+4,NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3+4+1) %>% as.numeric(),
pap_ght = stringr::str_sub(Z,1+NBDA*6+NBZA*17+13+5*ETB_NBGHT+10,NBDA*6+NBZA*17+13+5*ETB_NBGHT+10+PAPRICA_NBGHT*5),
lpap_ght = stringr::str_extract_all(pap_ght,zght)
)
}
if (2011< annee & annee<=2014){
zght <- ".{5}"
zd <- ".{1,6}"
zA <- ".{1,17}"
rapss_i <- rapss_i %>% dplyr::mutate(
# Diagnostics et actes
dmpp = ifelse(NBDIAGMPP>0,stringr::str_sub(Z,1,NBDIAGMPP*6),""),
ldmpp = stringr::str_extract_all(dmpp,zd),
dmpa = ifelse(NBDIAGMPA>0,stringr::str_sub(Z,1+NBDIAGMPP*6,NBDIAGMPP*6+NBDIAGMPA*6),""),
ldmpa = stringr::str_extract_all(dmpa,zd),
da = ifelse(NBDA>0,stringr::str_sub(Z,1+NBDIAGMPP*6+NBDIAGMPA*6,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6),""),
lda = stringr::str_extract_all(da,zd),
za = ifelse(NBZA>0,stringr::str_sub(Z,1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17),""),
lactes = stringr::str_extract_all(za,zA),
# groupage Etablissement
NOVRPSS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3),
ETB_VCLASS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3+2),
ETB_CDRETR = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3+2, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3+2+3),
ETB_GHPC = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3+2+3, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3+2+3+4),
ETB_NBGHT = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3+2+3+4, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+3+2+3+4+1) %>% as.numeric(),
etb_ght = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT),
letb_ght = stringr::str_extract_all(etb_ght,zght),
# groupage Paprica
PAPRICA_VCLASS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2),
PAPRICA_CDRETR = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3),
PAPRICA_GHPC = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3+4),
PAPRICA_NBGHT = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3+4,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+2+3+4+1) %>% as.numeric(),
pap_ght = stringr::str_sub(Z,1+ NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+10,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*17+13+5*ETB_NBGHT+10+PAPRICA_NBGHT*5),
lpap_ght = stringr::str_extract_all(pap_ght,zght)
)
}
if (annee>2014 & annee<2020){
zght <- ".{5}"
zd <- ".{1,6}"
zA <- ".{1,19}"
rapss_i <- rapss_i %>% dplyr::mutate(
DP = stringr::str_trim(DP),
# Diagnostics et actes
dmpp = ifelse(NBDIAGMPP>0,stringr::str_sub(Z,1,NBDIAGMPP*6),""),
ldmpp = stringr::str_extract_all(dmpp,zd),
dmpa = ifelse(NBDIAGMPA>0,stringr::str_sub(Z,1+NBDIAGMPP*6,NBDIAGMPP*6+NBDIAGMPA*6),""),
ldmpa = stringr::str_extract_all(dmpa,zd),
da = ifelse(NBDA>0,stringr::str_sub(Z,1+NBDIAGMPP*6+NBDIAGMPA*6,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6),""),
lda = stringr::str_extract_all(da,zd),
za = ifelse(NBZA>0,stringr::str_sub(Z,1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19),""),
lactes = stringr::str_extract_all(za,zA),
# groupage Etablissement
NOVRPSS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3),
ETB_VCLASS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3+2),
ETB_CDRETR = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3+2, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3+2+3),
ETB_GHPC = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3+2+3, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3+2+3+4),
ETB_NBGHT = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3+2+3+4, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+3+2+3+4+1) %>% as.numeric(),
etb_ght = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT),
letb_ght = stringr::str_extract_all(etb_ght,zght),
# groupage Paprica
PAPRICA_VCLASS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+2),
PAPRICA_CDRETR = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+2,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+2+3),
PAPRICA_GHPC = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+2+3,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+2+3+4),
PAPRICA_NBGHT = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+2+3+4,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+2+3+4+1) %>% as.numeric(),
pap_ght = stringr::str_sub(Z,1+ NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+10,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*19+13+5*ETB_NBGHT+10+PAPRICA_NBGHT*5),
lpap_ght = stringr::str_extract_all(pap_ght,zght)
)
}
if (annee>=2020){
zght <- ".{5}"
zd <- ".{1,6}"
zA <- ".{1,20}"
rapss_i <- rapss_i %>% dplyr::mutate(
DP = stringr::str_trim(DP),
# Diagnostics et actes
dmpp = ifelse(NBDIAGMPP>0,stringr::str_sub(Z,1,NBDIAGMPP*6),""),
ldmpp = stringr::str_extract_all(dmpp,zd),
dmpa = ifelse(NBDIAGMPA>0,stringr::str_sub(Z,1+NBDIAGMPP*6,NBDIAGMPP*6+NBDIAGMPA*6),""),
ldmpa = stringr::str_extract_all(dmpa,zd),
da = ifelse(NBDA>0,stringr::str_sub(Z,1+NBDIAGMPP*6+NBDIAGMPA*6,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6),""),
lda = stringr::str_extract_all(da,zd),
za = ifelse(NBZA>0,stringr::str_sub(Z,1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20),""),
lactes = stringr::str_extract_all(za,zA),
# groupage Etablissement
NOVRPSS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3),
ETB_VCLASS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3+2),
ETB_CDRETR = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3+2, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3+2+3),
ETB_GHPC = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3+2+3, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3+2+3+4),
ETB_NBGHT = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3+2+3+4, NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+3+2+3+4+1) %>% as.numeric(),
etb_ght = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT),
letb_ght = stringr::str_extract_all(etb_ght,zght),
# groupage Paprica
PAPRICA_VCLASS = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+2),
PAPRICA_CDRETR = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+2,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+2+3),
PAPRICA_GHPC = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+2+3,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+2+3+4),
PAPRICA_NBGHT = stringr::str_sub(Z, 1+NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+2+3+4,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+2+3+4+1) %>% as.numeric(),
pap_ght = stringr::str_sub(Z,1+ NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+10,NBDIAGMPP*6+NBDIAGMPA*6+NBDA*6+NBZA*20+13+5*ETB_NBGHT+10+PAPRICA_NBGHT*5),
lpap_ght = stringr::str_extract_all(pap_ght,zght)
)
}
if (annee>2011){
actes <- purrr::flatten_chr(rapss_i$lactes)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,NBZA)
df <- as.data.frame(lapply(df, rep, df$NBZA), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(ZACTES = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
if (annee>=2020) {
actes <- dplyr::mutate(actes, CODE = 'A') %>% dplyr::select(-NBZA) %>% dplyr::mutate(
DELAI = stringr::str_sub(ZACTES, 1, 5) %>% as.numeric(),
CDCCAM = stringr::str_sub(ZACTES, 6,12),
PHASE = stringr::str_sub(ZACTES,15,15),
ACT = stringr::str_sub(ZACTES,16,16),
EXTDOC = stringr::str_sub(ZACTES,17,17),
NBEXEC = stringr::str_sub(ZACTES,18,19),
INDVAL = stringr::str_sub(ZACTES,20,20))
} else {
actes <- dplyr::mutate(actes, CODE = 'A') %>% dplyr::select(-NBZA) %>% dplyr::mutate(
DELAI = stringr::str_sub(ZACTES, 1, 4) %>% as.numeric(),
CDCCAM = stringr::str_sub(ZACTES, 5,11),
PHASE = stringr::str_sub(ZACTES,14,14),
ACT = stringr::str_sub(ZACTES,15,15),
EXTDOC = stringr::str_sub(ZACTES,16,16),
NBEXEC = stringr::str_sub(ZACTES,17,18),
INDVAL = stringr::str_sub(ZACTES,19,19))
}
da <- purrr::flatten_chr(rapss_i$lda)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = stringr::str_trim(da), stringsAsFactors = F) ) %>% tibble::as_tibble()
da <- dplyr::mutate(da, CODE = 'DA') %>% dplyr::select(-NBDA)
dmpp <- purrr::flatten_chr(rapss_i$ldmpp)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,NBDIAGMPP)
df <- as.data.frame(lapply(df, rep, df$NBDIAGMPP), stringsAsFactors = F) %>% tibble::as_tibble()
dmpp <- dplyr::bind_cols(df,data.frame(DMPP = stringr::str_trim(dmpp), stringsAsFactors = F) ) %>% tibble::as_tibble()
dmpp <- dplyr::mutate(dmpp, CODE = 'DMPP') %>% dplyr::select(-NBDIAGMPP)
dmpa <- purrr::flatten_chr(rapss_i$ldmpa)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,NBDIAGMPA)
df <- as.data.frame(lapply(df, rep, df$NBDIAGMPA), stringsAsFactors = F) %>% tibble::as_tibble()
dmpa <- dplyr::bind_cols(df,data.frame(DMPA = stringr::str_trim(dmpa), stringsAsFactors = F) ) %>% tibble::as_tibble()
dmpa <- dplyr::mutate(dmpa, CODE = 'DMPA') %>% dplyr::select(-NBDIAGMPA)
acdi <- dplyr::bind_rows(actes,da,dmpp,dmpa) %>% dplyr::select(-ZACTES)
rapss_i <- rapss_i %>% dplyr::select(-c(FILLER,Z,da,za,dmpp,dmpa,lda,ldmpp,ldmpa,lactes))
}
if (annee==2011){
actes <- purrr::flatten_chr(rapss_i$lactes)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,NBZA)
df <- as.data.frame(lapply(df, rep, df$NBZA), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(ZACTES = actes, stringsAsFactors = F) ) %>% tibble::as_tibble()
actes <- dplyr::mutate(actes, CODE = 'A') %>% dplyr::select(-NBZA) %>% dplyr::mutate(
DELAI = stringr::str_sub(ZACTES, 1, 4) %>% as.numeric(),
CDCCAM = stringr::str_sub(ZACTES, 5,11),
PHASE = stringr::str_sub(ZACTES,14,14),
ACT = stringr::str_sub(ZACTES,15,15),
EXTDOC = stringr::str_sub(ZACTES,16,16),
NBEXEC = stringr::str_sub(ZACTES,17,18),
INDVAL = stringr::str_sub(ZACTES,19,19))
da <- purrr::flatten_chr(rapss_i$lda)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = stringr::str_trim(da), stringsAsFactors = F) ) %>% tibble::as_tibble()
da <- dplyr::mutate(da, CODE = 'DA') %>% dplyr::select(-NBDA)
acdi <- dplyr::bind_rows(actes,da) %>% dplyr::select(-ZACTES)
rapss_i <- rapss_i %>% dplyr::select(-c(Z,da,za,lda,lactes))
}
etb_ght <- purrr::flatten_chr(rapss_i$letb_ght)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,NOVRPSS, VCLASS = ETB_VCLASS, CDRETR = ETB_CDRETR,
GHPC = ETB_GHPC, NBGHT = ETB_NBGHT)
df <- as.data.frame(lapply(df, rep, df$NBGHT), stringsAsFactors = F) %>% tibble::as_tibble()
etb_ght <- dplyr::bind_cols(df,data.frame(etb_ght, stringsAsFactors = F) ) %>% tibble::as_tibble() %>%
dplyr::mutate(TYPGHT='ETAB',
NUMGHT = stringr::str_sub(etb_ght,1,2),
JOURSGHT = stringr::str_sub(etb_ght,3,5) %>% as.numeric() ) %>%
dplyr::select(-etb_ght)
pap_ght <- purrr::flatten_chr(rapss_i$lpap_ght)
df <- rapss_i %>% dplyr::select(NOSEQSEJ,NOSEQ,NOSOUSSEQ,VCLASS=PAPRICA_VCLASS, CDRETR = PAPRICA_CDRETR, GHPC = PAPRICA_GHPC,
NBGHT = PAPRICA_NBGHT )
df <- as.data.frame(lapply(df, rep, df$NBGHT), stringsAsFactors = F) %>% tibble::as_tibble()
pap_ght <- dplyr::bind_cols(df,data.frame(pap_ght, stringsAsFactors = F) ) %>% tibble::as_tibble() %>%
dplyr::mutate(TYPGHT='PAPRICA',
NUMGHT = stringr::str_sub(pap_ght,1,2),
JOURSGHT = stringr::str_sub(pap_ght,3,5) %>% as.numeric() ) %>%
dplyr::select(-pap_ght)
ght <- dplyr::bind_rows(etb_ght,pap_ght)
rapss_i <- rapss_i %>% dplyr::select(-c(lpap_ght,letb_ght))
rapss_i <- rapss_i %>% dplyr::select(- dplyr::starts_with("PAP"),- dplyr::starts_with("ETB"),-NOVRPSS)
acdi[is.na(acdi) & is.character(acdi)] <- ""
rapss_i[is.na(rapss_i) & is.character(rapss_i)] <- ""
ght[is.na(ght) & is.character(ght)] <- ""
if (lib==T){
ght <- ght %>% sjlabelled::set_label(c('N° du séjour HAD', 'N° de la séquence', 'N° de la sous-séquence',
'N° de version du RPSS','Version de classification',
'Codes retours', 'Groupe homogène de prise en charge',
'Nombre de GHT','Type de GHT', 'N° du GHT', 'Nombre de jours du GHT'))
if (annee==2011){
acdi <- acdi %>% sjlabelled::set_label(c('N° du séjour HAD', 'N° de la séquence', 'N° de la sous-séquence',
'Type de code (A : Acte, DA : Diagnostic Associé)',
"Délai depuis la date d'entrée","Code CCAM","Phase", "Activité", "Extension documentaire",
"Nombre d'exécécutions", "Indic Validité de l'acte","Diagnostic Associé"))
}else{
acdi <- acdi %>% sjlabelled::set_label(c('N° du séjour HAD', 'N° de la séquence', 'N° de la sous-séquence',
'Type de code (A : Acte, DA : Diagnostic Associé, DMPP : Diagnostic Mode principal, DMPA : Diagnostic Mode associé)',
"Délai depuis la date d'entrée","Code CCAM","Phase", "Activité", "Extension documentaire",
"Nombre d'exécécutions", "Indic Validité de l'acte","Diagnostic Associé", "Diagnostic MPP",
"Diagnostic MPA"))
}
}
Fillers <- names(rapss_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
rapss_i <- rapss_i[,!(names(rapss_i) %in% Fillers)]
if (lib==T){
rapss_i <- rapss_i %>% sjlabelled::set_label(libelles[!is.na(libelles)])
}
if (tolower_names){
names(rapss_i) <- tolower(names(rapss_i))
names(acdi) <- tolower(names(acdi))
names(ght) <- tolower(names(ght))
}
rapss_1 <- list(rapss = rapss_i, acdi = acdi, ght = ght)
attr(rapss_1, "problems") <- synthese_import
return(rapss_1)
}
#' ~ HAD - Import des Anohosp
#'
#' Imports du fichier Ano
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu (sortie de Paprica) :
#' \emph{finess.annee.moisc.ano}
#'
#' \strong{750712184.2016.2.ano}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typano Type de donnees in / out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les données Anohosp HAD du Out.
#'
#' @examples
#' \dontrun{
#' anoh <- iano_had('750712184',2015,12,"~/Documents/data/had")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irapss}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage iano_had(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export iano_had
#' @export
iano_had <- function(finess, annee, mois, path, typano = c('out', 'in'), lib = T, tolower_names = F, ...){
UseMethod('iano_had')
}
#' @export
iano_had.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iano_had.default, param2)
}
#' @export
iano_had.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iano_had.default, param2)
}
#' @export
iano_had.default <- function(finess, annee,mois, path, lib = T, typano = c('out', 'in'), tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
typano <- match.arg(typano)
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (typano=="out"){
if(annee == 2022 & mois >= 3) {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss_ano', an == "22_H35")
} else if(annee == 2022 & mois < 3) {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss_ano', an == substr(as.character(annee),3,4))
} else if(annee == 2020 & mois >= 3) {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss_ano', an == "20_H33")
} else if(annee == 2021 & mois < 3) {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss_ano', an == "20_H33")
} else {
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss_ano', an == substr(as.character(annee),3,4))
}
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (annee<=2012){
ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSOR = lubridate::dmy(DTSOR, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') ==7),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100)
}
if (annee>2012){
ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSOR = lubridate::dmy(DTSOR, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') +
(CRCDNAI=='0') + (CRCSEXE=='0')==9),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
MTRMBAMC = MTRMBAMC/100,
TAUXRM = TAUXRM /100)
}
if (lib==T){
ano_i <- ano_i %>% sjlabelled::set_label(c(libelles,'Chaînage Ok'))
ano_i <- ano_i %>% dplyr::select(-dplyr::starts_with("Fill"))
}
}
if (typano=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss_ano', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (2011<annee){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTHOSP = lubridate::dmy(DTHOSP, quiet = TRUE),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTRMAMC = MTRMAMC /100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
if (annee == 2011){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
Fillers <- names(ano_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
ano_i <- ano_i[,!(names(ano_i) %in% Fillers)]
if (lib==T){
v <- libelles[!is.na(libelles)]
ano_i <- ano_i %>% sjlabelled::set_label(v)
}
}
if (tolower_names){
names(ano_i) <- tolower(names(ano_i))
}
attr(ano_i,"problems") <- synthese_import
return(ano_i)
}
#' ~ HAD - Import des Med
#'
#' Imports du fichier Med Out
#'
#' Formats depuis 2011 pris en charge
#'
#' import des med, medatu et mchl si le fichier existe
#'
#' Structure du nom du fichier attendu (sortie de Paprica) :
#' \emph{finess.annee.moisc.med}
#'
#' \strong{750712184.2016.2.med}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les données médicaments HAD du Out.
#'
#' @examples
#' \dontrun{
#' medh <- imed_had('750712184',2015,12,"~/Documents/data/had")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irapss}}
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage imed_had(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export imed_had
#' @export
imed_had <- function(...){
UseMethod('imed_had')
}
#' @export
imed_had.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(imed_had.default, param2)
}
#' @export
imed_had.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(imed_had.default, param2)
}
#' @export
imed_had.default <- function(finess, annee, mois, path, lib=T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'had', table == 'rapss_med', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
med_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".med"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(med_i) -> synthese_import
med_i <- med_i %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000) %>% sjlabelled::set_label(libelles)
info = file.info(paste0(path,"/",finess,".",annee,".",mois,".medatu"))
if (info$size >0 & !is.na(info$size)){
med_i2<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".medatu"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
synthese_import <- dplyr::bind_rows(synthese_import, readr::problems(med_i2))
med_i2 <- med_i2 %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000) %>% sjlabelled::set_label(libelles)
med_i <- rbind(med_i,med_i2)
}
info = file.info(paste0(path,"/",finess,".",annee,".",mois,".mchl"))
if (info$size >0 & !is.na(info$size)){
med_i3<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".mchl"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
synthese_import <- dplyr::bind_rows(synthese_import, readr::problems(med_i3))
med_i3 <- med_i3 %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000) %>% sjlabelled::set_label(libelles)
med_i <- rbind(med_i, med_i3)
}
if (tolower_names){
names(med_i) <- tolower(names(med_i))
}
attr(med_i,"problems") <- synthese_import
return(med_i)
}
#' ~ HAD - Import des erreurs Leg
#'
#' Import de la liste d'erreurs de génération Paprica
#'
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param reshape booleen TRUE/FALSE : la donnee doit-elle etre restructuree ? une ligne = une erreur, sinon, une ligne = un sejour. par defaut a F
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#'
#' @return Une table (data.frame, tibble) contenant les erreurs Out.
#'
#' @examples
#' \dontrun{
#' ileg_had('750712184',2015,12,'~/Documents/data/had') -> leg15
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irapss}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage ileg_had(finess, annee, mois, path, reshape = F, tolower_names = F, ...)
#' @export ileg_had
#' @export
ileg_had <- function(...){
UseMethod('ileg_had')
}
#' @export
ileg_had.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(ileg_had.default, param2)
}
#' @export
ileg_had.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(ileg_had.default, param2)
}
#' @export
ileg_had.default <- function(finess, annee, mois, path, reshape = F, tolower_names = F, ...){
leg_i <- readr::read_lines(paste0(path,"/",finess,".",annee,".",mois,".leg"))
leg_i1 <- tibble::tibble(l = leg_i) %>%
tidyr::separate(l, c('FINESS', 'MOIS', 'ANNEE', 'NOSEQSEJ',
'NOSEQ', 'NOSOUSSEQ', 'NBERR', 'ERRS'), ";", extra = "merge")
if (reshape==FALSE){
leg_i1 <- leg_i1 %>%
dplyr::mutate(EG = stringr::str_replace_all(ERRS, ";", ", ")) %>%
dplyr::select(-ERRS)
if (tolower_names){
names(leg_i1) <- tolower(names(leg_i1))
}
return(leg_i1)
}
u <- stringr::str_split(leg_i1$ERRS, ";") %>% purrr::flatten_chr()
leg_i1 <- tibble::as_tibble(lapply(leg_i1, rep, leg_i1$NBERR), stringsAsFactors = F)
leg_i2 <- dplyr::bind_cols(leg_i1, data.frame(EG = as.character(u), stringsAsFactors = F))
leg_i2 <- leg_i2 %>%
dplyr::mutate(ERRS = stringr::str_replace_all(ERRS, ";", ", "))
if (tolower_names){
names(leg_i2) <- tolower(names(leg_i2))
}
return(leg_i2)
}
##############################################
####################### SSR ##################
##############################################
#' ~ SSR - Import des RHA
#'
#' Import des RHA
#'
#' Formats depuis 2011 pris en charge
#'
#' @param finess Finess du fichier Out de GENRHA a integrer
#' @param annee Annee de la periode (du fichier Out)
#' @param mois Mois de la periode (du fichier Out)
#' @param path Chemin d'acces au fichier .rha
#' @param lib Attribution de libelles aux colonnes
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max=10e3} pour lire les 10000 premieres lignes
#'
#' @examples
#' \dontrun{
#' irha('750712184',2015,12,'pathpath/') -> rha15
#' }
#' @author G. Pressiat
#' @seealso \code{\link{iano_ssr}}, \code{\link{ileg_ssr}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage irha(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export irha
#' @export
irha <- function(...){
UseMethod('irha')
}
#' @export
irha.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(irha.default, param2)
}
#' @export
irha.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(irha.default, param2)
}
#' @export
irha.default <- function(finess, annee, mois, path, lib=T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
#op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'ssr', table == 'rha', an == substr(as.character(annee),3,4))
format$longueur[nrow(format)] <- NA
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
suppressWarnings(rha_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rha"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...))
readr::problems(rha_i) -> synthese_import
rha_i <- rha_i %>%
dplyr::mutate(FPPC = stringr::str_trim(FPPC),
MMP = stringr::str_trim(MMP),
AE = stringr::str_trim(AE))
# if (annee > 2016){
# rha_i <- rha_i %>% dplyr::mutate(RR = as.numeric(RR) / 100)
# }
#
if (annee > 2019){
fzacte <- function(ccam){
dplyr::mutate(ccam,
DELAI = stringr::str_sub(ccam,1,5),
CDCCAM = stringr::str_sub(ccam,6,12),
DESCRI = stringr::str_sub(ccam,13,14) %>% stringr::str_trim(),
PHASE = stringr::str_sub(ccam,15,15),
ACT = stringr::str_sub(ccam,16,16),
EXTDOC = stringr::str_sub(ccam,17,17),
NBEXEC = stringr::str_sub(ccam,18,19),
INDVAL = stringr::str_sub(ccam,20,20)
) %>% dplyr::select(-ccam)
}
fzsarr <- function(csarr){
dplyr::mutate(csarr,
CSARR = stringr::str_sub(csarr,1,7),
CDAPP = stringr::str_sub(csarr,8,10),
CDMOD = stringr::str_sub(csarr,11,12),
CDPAT1 = stringr::str_sub(csarr,13,14),
CDPAT2 = stringr::str_sub(csarr,15,16),
CDINTER = stringr::str_sub(csarr,17,18),
NBPATIND = stringr::str_sub(csarr,19,19),
NBEXEC = stringr::str_sub(csarr,20,21),
INDVAL = stringr::str_sub(csarr,22,22),
DELAI = stringr::str_sub(csarr,23,27),
NBPATREEL = stringr::str_sub(csarr,28,29),
NBINT = stringr::str_sub(csarr,30,31),
EXTDOCcsarr = stringr::str_sub(csarr,32,33)
) %>% dplyr::select(-csarr)
}
zad <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,ZAD, NBDA, NBCSARR, NBCCAM) %>%
dplyr::mutate(
da = ifelse(NBDA>0,stringr::str_sub(ZAD,1,6*NBDA),""),
lda = stringr::str_extract_all(da,".{1,6}"),
csarr = ifelse(NBCSARR>0,stringr::str_sub(ZAD,6*NBDA+1,6*NBDA + 33*NBCSARR),""),
lcsarr = stringr::str_extract_all(csarr, ".{1,33}"),
ccam = ifelse(NBCCAM>0,stringr::str_sub(ZAD,6*NBDA+1+33*NBCSARR,6*NBDA + 33*NBCSARR + 20*NBCCAM),""),
lccam = stringr::str_extract_all(ccam, ".{1,20}")
)
da <- purrr::flatten_chr(zad$lda)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = da, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='DA') %>% dplyr::select(-NBDA) %>%
dplyr::select(NOSEQSEJ, NOSEQRHS, CODE, DA) %>% dplyr::mutate(DA = stringr::str_trim(DA))
csarr <- purrr::flatten_chr(zad$lcsarr)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCSARR)
df <- as.data.frame(lapply(df, rep, df$NBCSARR), stringsAsFactors = F) %>% tibble::as_tibble()
csarr <- dplyr::bind_cols(df,data.frame(csarr = csarr, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CSARR') %>% dplyr::select(-NBCSARR)
ccam <- purrr::flatten_chr(zad$lccam)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCCAM)
df <- as.data.frame(lapply(df, rep, df$NBCCAM), stringsAsFactors = F) %>% tibble::as_tibble()
ccam <- dplyr::bind_cols(df,data.frame(ccam = ccam, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CCAM') %>% dplyr::select(-NBCCAM)
acdi <-dplyr::bind_rows(da, fzsarr(csarr), fzacte(ccam))
if (lib == T){
labelacdi <- c('N° Séquentiel du séjour', 'N° Séquentiel du RHS', "Type de code (DA / CSARR / CCAM)","Diagnostic associé",
"Code CSARR", "Code supplémentaire appareillage", "Code modulateur de lieu", "Code modulateur patient n°1",
"Code modulateur patient n°2", "Code de l'intervenant", "Nb de patients en acte individuel",
"Nb de réalisations","Acte compatible avec la semaine", "Délai depuis la date d'entrée dans l'UM",
"Nb réel de patients", "Nb d'intervenants","Extension documentaire CSARR", "Code CCAM", "Partie descriptive","Phase CCAM",
"Activité CCAM", "Extension documentaire CCAM")
acdi <- acdi %>% sjlabelled::set_label(labelacdi)
}
}
if (annee > 2014 & annee < 2020){
fzacte <- function(ccam){
dplyr::mutate(ccam,
DELAI = stringr::str_sub(ccam,1,4),
CDCCAM = stringr::str_sub(ccam,5,11),
DESCRI = stringr::str_sub(ccam, 12,13) %>% stringr::str_trim(),
PHASE = stringr::str_sub(ccam,14,14),
ACT = stringr::str_sub(ccam,15,15),
EXTDOC = stringr::str_sub(ccam,16,16),
NBEXEC = stringr::str_sub(ccam,17,18),
INDVAL = stringr::str_sub(ccam,19,19)
) %>% dplyr::select(-ccam)
}
fzsarr <- function(csarr){
dplyr::mutate(csarr,
CSARR = stringr::str_sub(csarr,1,7),
CDAPP = stringr::str_sub(csarr,8,10),
CDMOD = stringr::str_sub(csarr,11,12),
CDPAT1 = stringr::str_sub(csarr,13,14),
CDPAT2 = stringr::str_sub(csarr,15,16),
CDINTER = stringr::str_sub(csarr,17,18),
NBPATIND = stringr::str_sub(csarr,19,19),
NBEXEC = stringr::str_sub(csarr,20,21),
INDVAL = stringr::str_sub(csarr,22,22),
DELAI = stringr::str_sub(csarr,23,26),
NBPATREEL = stringr::str_sub(csarr,27,28),
NBINT = stringr::str_sub(csarr,29,30),
EXTDOCcsarr = stringr::str_sub(csarr,31,32)
) %>% dplyr::select(-csarr)
}
zad <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,ZAD, NBDA, NBCSARR, NBCCAM) %>%
dplyr::mutate(
da = ifelse(NBDA>0,stringr::str_sub(ZAD,1,6*NBDA),""),
lda = stringr::str_extract_all(da,".{1,6}"),
csarr = ifelse(NBCSARR>0,stringr::str_sub(ZAD,6*NBDA+1,6*NBDA + 32*NBCSARR),""),
lcsarr = stringr::str_extract_all(csarr, ".{1,32}"),
ccam = ifelse(NBCCAM>0,stringr::str_sub(ZAD,6*NBDA+1+32*NBCSARR,6*NBDA + 32*NBCSARR + 19*NBCCAM),""),
lccam = stringr::str_extract_all(ccam, ".{1,19}")
)
da <- purrr::flatten_chr(zad$lda)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = da, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='DA') %>% dplyr::select(-NBDA) %>%
dplyr::select(NOSEQSEJ, NOSEQRHS, CODE, DA) %>% dplyr::mutate(DA = stringr::str_trim(DA))
csarr <- purrr::flatten_chr(zad$lcsarr)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCSARR)
df <- as.data.frame(lapply(df, rep, df$NBCSARR), stringsAsFactors = F) %>% tibble::as_tibble()
csarr <- dplyr::bind_cols(df,data.frame(csarr = csarr, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CSARR') %>% dplyr::select(-NBCSARR)
ccam <- purrr::flatten_chr(zad$lccam)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCCAM)
df <- as.data.frame(lapply(df, rep, df$NBCCAM), stringsAsFactors = F) %>% tibble::as_tibble()
ccam <- dplyr::bind_cols(df,data.frame(ccam = ccam, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CCAM') %>% dplyr::select(-NBCCAM)
acdi <-dplyr::bind_rows(da, fzsarr(csarr), fzacte(ccam))
if (lib == T){
labelacdi <- c('N° Séquentiel du séjour', 'N° Séquentiel du RHS', "Type de code (DA / CSARR / CCAM)","Diagnostic associé",
"Code CSARR", "Code supplémentaire appareillage", "Code modulateur de lieu", "Code modulateur patient n°1",
"Code modulateur patient n°2", "Code de l'intervenant", "Nb de patients en acte individuel",
"Nb de réalisations","Acte compatible avec la semaine", "Délai depuis la date d'entrée dans l'UM",
"Nb réel de patients", "Nb d'intervenants","Extension documentaire CSARR", "Code CCAM", "Partie descriptive","Phase CCAM",
"Activité CCAM", "Extension documentaire CCAM")
acdi <- acdi %>% sjlabelled::set_label(labelacdi)
}
}
if (annee == 2014){
fzacte <- function(ccam){
dplyr::mutate(ccam,
DELAI = stringr::str_sub(ccam,1 , 4),
CDCCAM = stringr::str_sub(ccam,5 ,11),
PHASE = stringr::str_sub(ccam,12,12),
ACT = stringr::str_sub(ccam,13,13),
EXTDOC = stringr::str_sub(ccam,14,14),
NBEXEC = stringr::str_sub(ccam,15,16),
INDVAL = stringr::str_sub(ccam,17,17)
) %>% dplyr::select(-ccam)
}
fzsarr <- function(csarr){
dplyr::mutate(csarr,
CSARR = stringr::str_sub(csarr,1,7),
CDAPP = stringr::str_sub(csarr,8,10),
CDMOD = stringr::str_sub(csarr,11,12),
CDPAT1 = stringr::str_sub(csarr,13,14),
CDPAT2 = stringr::str_sub(csarr,15,16),
CDINTER = stringr::str_sub(csarr,17,18),
NBPATIND = stringr::str_sub(csarr,19,19),
NBEXEC = stringr::str_sub(csarr,20,21),
INDVAL = stringr::str_sub(csarr,22,22),
DELAI = stringr::str_sub(csarr,23,26),
NBPATREEL = stringr::str_sub(csarr,27,28),
NBINT = stringr::str_sub(csarr,29,30),
EXTDOCcsarr = stringr::str_sub(csarr,31,32)
) %>% dplyr::select(-csarr)
}
zad <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,ZAD, NBDA, NBCSARR, NBCCAM) %>%
dplyr::mutate(
da = ifelse(NBDA>0,stringr::str_sub(ZAD,1,6*NBDA),""),
lda = stringr::str_extract_all(da,".{1,6}"),
csarr = ifelse(NBCSARR>0,stringr::str_sub(ZAD,6*NBDA+1,6*NBDA + 32*NBCSARR),""),
lcsarr = stringr::str_extract_all(csarr, ".{1,32}"),
ccam = ifelse(NBCCAM>0,stringr::str_sub(ZAD,6*NBDA+1+32*NBCSARR,6*NBDA + 32*NBCSARR + 17*NBCCAM),""),
lccam = stringr::str_extract_all(ccam, ".{1,17}")
)
da <- purrr::flatten_chr(zad$lda)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = da, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='DA') %>% dplyr::select(-NBDA) %>%
dplyr::select(NOSEQSEJ, NOSEQRHS, CODE, DA) %>% dplyr::mutate(DA = stringr::str_trim(DA))
csarr <- purrr::flatten_chr(zad$lcsarr)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCSARR)
df <- as.data.frame(lapply(df, rep, df$NBCSARR), stringsAsFactors = F) %>% tibble::as_tibble()
csarr <- dplyr::bind_cols(df,data.frame(csarr = csarr, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CSARR') %>% dplyr::select(-NBCSARR)
ccam <- purrr::flatten_chr(zad$lccam)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCCAM)
df <- as.data.frame(lapply(df, rep, df$NBCCAM), stringsAsFactors = F) %>% tibble::as_tibble()
ccam <- dplyr::bind_cols(df,data.frame(ccam = ccam, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CCAM') %>% dplyr::select(-NBCCAM)
acdi <-dplyr::bind_rows(da, fzsarr(csarr), fzacte(ccam))
if (lib == T){
labelacdi <- c('N° Séquentiel du séjour', 'N° Séquentiel du RHS', "Type de code (DA / CSARR / CCAM)","Diagnostic associé",
"Code CSARR", "Code supplémentaire appareillage", "Code modulateur de lieu", "Code modulateur patient n°1",
"Code modulateur patient n°2", "Code de l'intervenant", "Nb de patients en acte individuel",
"Nb de réalisations","Acte compatible avec la semaine", "Délai depuis la date d'entrée dans l'UM",
"Nb réel de patients", "Nb d'intervenants","Extension documentaire CSARR", "Code CCAM", "Phase CCAM",
"Activité CCAM", "Extension documentaire CCAM")
acdi <- acdi %>% sjlabelled::set_label(labelacdi)
}
}
if (annee == 2013){
fzacte <- function(ccam){
dplyr::mutate(ccam,
DELAI = stringr::str_sub(ccam,1 , 4),
CDCCAM = stringr::str_sub(ccam,5 ,11),
PHASE = stringr::str_sub(ccam,12,12),
ACT = stringr::str_sub(ccam,13,13),
EXTDOC = stringr::str_sub(ccam,14,14),
NBEXEC = stringr::str_sub(ccam,15,16),
INDVAL = stringr::str_sub(ccam,17,17)
) %>% dplyr::select(-ccam)
}
fzsarr <- function(csarr){
dplyr::mutate(csarr,
CSARR = stringr::str_sub(csarr,1,7),
CDARR = ifelse(nchar(stringr::str_trim(CSARR)) == 4, CSARR, ""),
CSARR = ifelse(nchar(stringr::str_trim(CSARR)) == 7, CSARR, ""),
CODE = ifelse(nchar(stringr::str_trim(CSARR)) == 7, "CSARR", "CDARR"),
CDAPP = stringr::str_sub(csarr,8,10),
CDMOD = stringr::str_sub(csarr,11,12),
CDPAT1 = stringr::str_sub(csarr,13,14),
CDPAT2 = stringr::str_sub(csarr,15,16),
CDINTER = stringr::str_sub(csarr,17,18),
NBPATIND = stringr::str_sub(csarr,19,19),
NBEXEC = stringr::str_sub(csarr,20,21),
INDVAL = stringr::str_sub(csarr,22,22),
DELAI = stringr::str_sub(csarr,23,26)) %>%
dplyr::select(-csarr)
}
zad <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,ZAD, NBDA, NBCSARR, NBCCAM) %>%
dplyr::mutate(
da = ifelse(NBDA>0,stringr::str_sub(ZAD,1,6*NBDA),""),
lda = stringr::str_extract_all(da,".{1,6}"),
csarr = ifelse(NBCSARR>0,stringr::str_sub(ZAD,6*NBDA+1,6*NBDA + 26*NBCSARR),""),
lcsarr = stringr::str_extract_all(csarr, ".{1,26}"),
ccam = ifelse(NBCCAM>0,stringr::str_sub(ZAD,6*NBDA+1+26*NBCSARR,6*NBDA + 26*NBCSARR + 17*NBCCAM),""),
lccam = stringr::str_extract_all(ccam, ".{1,17}")
)
da <- purrr::flatten_chr(zad$lda)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = da, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='DA')%>% dplyr::select(-NBDA) %>%
dplyr::select(NOSEQSEJ, NOSEQRHS, CODE, DA) %>% dplyr::mutate(DA = stringr::str_trim(DA))
csarr <- purrr::flatten_chr(zad$lcsarr)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCSARR)
df <- as.data.frame(lapply(df, rep, df$NBCSARR), stringsAsFactors = F) %>% tibble::as_tibble()
csarr <- dplyr::bind_cols(df,data.frame(csarr = csarr, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBCSARR)
ccam <- purrr::flatten_chr(zad$lccam)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCCAM)
df <- as.data.frame(lapply(df, rep, df$NBCCAM), stringsAsFactors = F) %>% tibble::as_tibble()
ccam <- dplyr::bind_cols(df,data.frame(ccam = ccam, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CCAM') %>% dplyr::select(-NBCCAM)
acdi <-dplyr::bind_rows(da, fzsarr(csarr), fzacte(ccam))
if (lib == T){
labelacdi <- c('N° Séquentiel du séjour', 'N° Séquentiel du RHS', "Type de code (DA / CSARR / CDARR / CCAM)","Diagnostic associé",
"Code CSARR","Code CDARR", "Code supplémentaire appareillage", "Code modulateur de lieu", "Code modulateur patient n°1",
"Code modulateur patient n°2", "Code de l'intervenant", "Nb de patients en acte individuel",
"Nb de réalisations","Acte compatible avec la semaine", "Délai depuis la date d'entrée dans l'UM",
"Code CCAM", "Phase CCAM", "Activité CCAM", "Extension documentaire CCAM")
acdi <- acdi %>% sjlabelled::set_label(labelacdi)
}
}
if (annee == 2012){
fzacte <- function(ccam){
dplyr::mutate(ccam,
DELAI = stringr::str_sub(ccam,1 , 4),
CDCCAM = stringr::str_sub(ccam,5 ,11),
PHASE = stringr::str_sub(ccam,12,12),
ACT = stringr::str_sub(ccam,13,13),
EXTDOC = stringr::str_sub(ccam,14,14),
NBEXEC = stringr::str_sub(ccam,15,16),
INDVAL = stringr::str_sub(ccam,17,17)
) %>% dplyr::select(-ccam)
}
fzsarr <- function(csarr){
dplyr::mutate(csarr,
CSARR = stringr::str_sub(csarr,1,7),
CDARR = ifelse(nchar(stringr::str_trim(CSARR)) == 4, CSARR, ""),
CSARR = ifelse(nchar(stringr::str_trim(CSARR)) == 7, CSARR, ""),
CODE = ifelse(nchar(stringr::str_trim(CSARR)) == 7, "CSARR", "CDARR"),
CDAPP = stringr::str_sub(csarr,8,10),
CDMOD = stringr::str_sub(csarr,11,12),
CDPAT1 = stringr::str_sub(csarr,13,14),
CDPAT2 = stringr::str_sub(csarr,15,16),
CDINTER = stringr::str_sub(csarr,17,18),
NBPATIND = stringr::str_sub(csarr,19,19),
NBEXEC = stringr::str_sub(csarr,20,21),
INDVAL = stringr::str_sub(csarr,22,22),
DELAI = stringr::str_sub(csarr,23,26)) %>%
dplyr::select(-csarr)
}
zad <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,ZAD, NBDA, NBCDARR, NBCCAM) %>%
dplyr::mutate(
da = ifelse(NBDA>0,stringr::str_sub(ZAD,1,6*NBDA),""),
lda = stringr::str_extract_all(da,".{1,6}"),
csarr = ifelse(NBCDARR>0,stringr::str_sub(ZAD,6*NBDA+1,6*NBDA + 26*NBCDARR),""),
lcsarr = stringr::str_extract_all(csarr, ".{1,26}"),
ccam = ifelse(NBCCAM>0,stringr::str_sub(ZAD,6*NBDA+1+26*NBCDARR,6*NBDA + 26*NBCDARR + 17*NBCCAM),""),
lccam = stringr::str_extract_all(ccam, ".{1,17}")
)
da <- purrr::flatten_chr(zad$lda)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = da, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='DA') %>% dplyr::select(-NBDA) %>%
dplyr::select(NOSEQSEJ, NOSEQRHS, CODE, DA) %>% dplyr::mutate(DA = stringr::str_trim(DA))
csarr <- purrr::flatten_chr(zad$lcsarr)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCDARR)
df <- as.data.frame(lapply(df, rep, df$NBCDARR), stringsAsFactors = F) %>% tibble::as_tibble()
csarr <- dplyr::bind_cols(df,data.frame(csarr = csarr, stringsAsFactors = F) )%>% tibble::as_tibble() %>% dplyr::select(-NBCDARR)
ccam <- purrr::flatten_chr(zad$lccam)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCCAM)
df <- as.data.frame(lapply(df, rep, df$NBCCAM), stringsAsFactors = F) %>% tibble::as_tibble()
ccam <- dplyr::bind_cols(df,data.frame(ccam = ccam, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CCAM') %>% dplyr::select(-NBCCAM)
acdi <- dplyr::bind_rows(da, fzsarr(csarr), fzacte(ccam))
if (lib == T){
labelacdi <- c('N° Séquentiel du séjour', 'N° Séquentiel du RHS', "Type de code (DA / CSARR / CDARR / CCAM)","Diagnostic associé",
"Code CSARR","Code CDARR", "Code supplémentaire appareillage", "Code modulateur de lieu", "Code modulateur patient n°1",
"Code modulateur patient n°2", "Code de l'intervenant", "Nb de patients en acte individuel",
"Nb de réalisations","Acte compatible avec la semaine", "Délai depuis la date d'entrée dans l'UM",
"Code CCAM", "Phase CCAM", "Activité CCAM", "Extension documentaire CCAM")
acdi <- acdi %>% sjlabelled::set_label(labelacdi)
}
}
if (annee == 2011){
fzacte <- function(ccam){
dplyr::mutate(ccam,
DELAI = stringr::str_sub(ccam,1 , 4),
CDCCAM = stringr::str_sub(ccam,5 ,11),
PHASE = stringr::str_sub(ccam,12,12),
ACT = stringr::str_sub(ccam,13,13),
EXTDOC = stringr::str_sub(ccam,14,14),
NBEXEC = stringr::str_sub(ccam,15,16),
INDVAL = stringr::str_sub(ccam,17,17)
) %>% dplyr::select(-ccam)
}
fzdarr <- function(cdarr){
dplyr::mutate(cdarr,
CDINTER = stringr::str_sub(cdarr,1,2),
CDARR = stringr::str_sub(cdarr,3,6),
CODE = "CDARR",
NBEXEC = stringr::str_sub(cdarr,7,8),
INDVAL = stringr::str_sub(cdarr,9,9)) %>%
dplyr::select(-cdarr)
}
zad <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,ZAD, NBDA, NBCDARR, NBCCAM) %>%
dplyr::mutate(
da = ifelse(NBDA>0,stringr::str_sub(ZAD,1,6*NBDA),""),
lda = stringr::str_extract_all(da,".{1,6}"),
cdarr = ifelse(NBCDARR>0,stringr::str_sub(ZAD,6*NBDA+1,6*NBDA + 9*NBCDARR),""),
lcdarr = stringr::str_extract_all(cdarr, ".{1,9}"),
ccam = ifelse(NBCCAM>0,stringr::str_sub(ZAD,6*NBDA+1+9*NBCDARR, 6*NBDA + 9*NBCDARR + 17*NBCCAM),""),
lccam = stringr::str_extract_all(ccam, ".{1,17}")
)
da <- purrr::flatten_chr(zad$lda)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = da, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='DA') %>% dplyr::select(-NBDA) %>%
dplyr::select(NOSEQSEJ, NOSEQRHS, CODE, DA) %>% dplyr::mutate(DA = stringr::str_trim(DA))
cdarr <- purrr::flatten_chr(zad$lcdarr)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCDARR)
df <- as.data.frame(lapply(df, rep, df$NBCDARR), stringsAsFactors = F) %>% tibble::as_tibble()
cdarr <- dplyr::bind_cols(df,data.frame(cdarr = cdarr, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CDARR') %>% dplyr::select(-NBCDARR)
ccam <- purrr::flatten_chr(zad$lccam)
df <- rha_i %>% dplyr::select(NOSEQSEJ,NOSEQRHS,NBCCAM)
df <- as.data.frame(lapply(df, rep, df$NBCCAM), stringsAsFactors = F) %>% tibble::as_tibble()
ccam <- dplyr::bind_cols(df,data.frame(ccam = ccam, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::mutate(CODE='CCAM') %>% dplyr::select(-NBCCAM)
acdi <-dplyr::bind_rows(da, fzdarr(cdarr), fzacte(ccam))
if (lib == T){
labelacdi <- c('N° Séquentiel du séjour', 'N° Séquentiel du RHS', "Type de code (DA / CDARR / CCAM)","Diagnostic associé",
"Code de l'intervenant", "Code CDARR", "Nb de réalisations","Acte compatible avec la semaine",
"Délai depuis la date d'entrée dans l'UM",
"Code CCAM", "Phase CCAM", "Activité CCAM", "Extension documentaire CCAM")
acdi <- acdi %>% sjlabelled::set_label(labelacdi)
}
}
acdi[is.na(acdi)] <- ""
suppressWarnings(acdi$NBEXEC <- acdi$NBEXEC %>% as.numeric())
suppressWarnings(acdi$DELAI <- acdi$DELAI %>% as.numeric())
suppressWarnings(if (annee>2014){acdi$NBPATREEL <- acdi$NBPATREEL %>% as.numeric()})
Fillers <- names(rha_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="Fil"]
rha_i <- rha_i[,!(names(rha_i) %in% Fillers)]
rha_i <- rha_i %>% dplyr::select(-ZAD)
if (lib == T){
rha_i <- rha_i %>% sjlabelled::set_label(libelles[!is.na(libelles)])
}
if (tolower_names){
names(rha_i) <- tolower(names(rha_i))
names(acdi) <- tolower(names(acdi))
}
rha_1 = list(rha = rha_i, acdi = acdi)
attr(rha_1,"problems") <- synthese_import
deux <- Sys.time()
#cat("Données RHA importées en : ", deux-un, " secondes\n")
return(rha_1)
}
#' ~ SSR - Import des Anohosp
#'
#' Import du fichier Ano
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu (sortie de Genrha) :
#' \emph{finess.annee.moisc.ano}
#'
#' \strong{750712184.2016.2.ano}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typano Type de donnees in / out
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... paramètres supplementaires à passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip =...}
#'
#' @return Une table (data.frame, tibble) contenant les données Anohosp SSR du Out.
#'
#' @examples
#' \dontrun{
#' anoh <- iano_ssr('750712184',2015,12,"~/Documents/data/ssr")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irha}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#'
#' @usage iano_ssr(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export iano_ssr
#' @export
iano_ssr <- function(...){
UseMethod('iano_ssr')
}
#' @export
iano_ssr.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iano_ssr.default, param2)
}
#' @export
iano_ssr.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iano_ssr.default, param2)
}
#' @export
iano_ssr.default <- function(finess, annee, mois, path, lib = T, typano = c('out', 'in'), tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
typano <- match.arg(typano)
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (typano=="out"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'ssr', table == 'rha_ano', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
if (annee>2012){
ano_i <- ano_i %>%
dplyr::mutate(DTSOR = lubridate::dmy(DTSOR, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') +
(CRCDNAI=='0') + (CRCSEXE=='0')==9),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
MTRMBAMC = MTRMBAMC/100,
TAUXRM = TAUXRM /100)
}
if (annee<2013){
ano_i <- ano_i %>%
dplyr::mutate(DTSOR = lubridate::dmy(DTSOR, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') == 7),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100)
}
if (lib == T){
ano_i <- ano_i %>% sjlabelled::set_label(c(libelles,'Chaînage Ok'))
ano_i <- ano_i %>% dplyr::select(-dplyr::starts_with("FIL"))
}
}
if (typano=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'ssr', table == 'rhs_ano', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (2011<annee){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".anoh.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTHOSP = lubridate::dmy(DTHOSP, quiet = TRUE),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTRMAMC = MTRMAMC /100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
if (annee == 2011){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".anoh.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
Fillers <- names(ano_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
ano_i <- ano_i[,!(names(ano_i) %in% Fillers)]
if (lib==T){
v <- libelles[!is.na(libelles)]
ano_i <- ano_i %>% sjlabelled::set_label(v)
}
}
if (tolower_names){
names(ano_i) <- tolower(names(ano_i))
}
attr(ano_i,"problems") <- synthese_import
return(ano_i)
}
#' ~ SSR - Import des SSRHA
#'
#' Import du fichier SHA
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu (sortie de Genrha) :
#' \emph{finess.annee.moisc.sha}
#'
#' \strong{750712184.2016.2.sha}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles a la table : T
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les données SHA, et a partir de 2017 une liste de deux tables (sha et gme)
#'
#' @examples
#' \dontrun{
#' sha <- issrha('750712184',2015,12,"~/Documents/data/ssr")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irha}}, \code{\link{ileg_ssr}}, \code{\link{iano_ssr}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage issrha(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export issrha
#' @export
issrha <- function(...){
UseMethod('issrha')
}
#' @export
issrha.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(issrha.default, param2)
}
#' @export
issrha.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(issrha.default, param2)
}
#' @export
issrha.default <- function(finess, annee,mois, path, lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'ssr', table == 'ssrha', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
ssrha_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".sha"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ssrha_i) -> synthese_import
if (lib == T){
ssrha_i <- ssrha_i %>%
sjlabelled::set_label(libelles)
}
if (annee > 2021){
zac <- ssrha_i %>% dplyr::select(NBZGP, ZGP)
fixe <- ssrha_i %>% dplyr::select(NOFINESS, NOSEQSEJ, NBZGP)
zac1 <- purrr::flatten_chr(stringr::str_extract_all(zac$ZGP, '.{1,14}'))
fixe <- as.data.frame(lapply(fixe, rep, fixe$NBZGP), stringsAsFactors = F)
gp <- data.frame(zac1 = as.character(zac1), stringsAsFactors = F)
gp <- dplyr::mutate(gp,
GME = stringr::str_sub(zac1, 1, 7),
GMT = stringr::str_sub(zac1, 8, 11),
NJ = stringr::str_sub(zac1, 12, 14) %>% as.integer()) %>%
dplyr::select(-zac1)
if (lib == T){
gp <- sjlabelled::set_label(gp, c("GME", "GMT", "Nombre de jours de présence"))
}
gp <- dplyr::as_tibble(dplyr::bind_cols(fixe, gp))
if (tolower_names){
names(ssrha_i) <- tolower(names(ssrha_i))
names(gp) <- tolower(names(gp))
}
ssrha_1 <- list(ssrha = ssrha_i, gme = gp)
attr(ssrha_1,"problems") <- synthese_import
return(ssrha_1)
}
if (annee > 2016){
zac <- ssrha_i %>% dplyr::select(NBZGP, ZGP)
fixe <- ssrha_i %>% dplyr::select(NOFINESS, NOSEQSEJ, NBZGP)
zac1 <- purrr::flatten_chr(stringr::str_extract_all(zac$ZGP, '.{1,13}'))
fixe <- as.data.frame(lapply(fixe, rep, fixe$NBZGP), stringsAsFactors = F)
gp <- data.frame(zac1 = as.character(zac1), stringsAsFactors = F)
gp <- dplyr::mutate(gp,
GME = stringr::str_sub(zac1, 1, 6),
GMT = stringr::str_sub(zac1, 7, 10),
NJ = stringr::str_sub(zac1, 11, 13) %>% as.integer()) %>%
dplyr::select(-zac1)
if (lib == T){
gp <- sjlabelled::set_label(gp, c("GME", "GMT", "Nombre de jours de présence"))
}
gp <- dplyr::as_tibble(dplyr::bind_cols(fixe, gp))
if (tolower_names){
names(ssrha_i) <- tolower(names(ssrha_i))
names(gp) <- tolower(names(gp))
}
ssrha_1 <- list(ssrha = ssrha_i, gme = gp)
attr(ssrha_1,"problems") <- synthese_import
return(ssrha_1)
}
if (tolower_names){
names(ssrha_i) <- tolower(names(ssrha_i))
}
attr(ssrha_i,"problems") <- synthese_import
return(ssrha_i)
}
#' ~ SSR - Import des erreurs Leg
#'
#' Import de la liste d'erreurs de génération Genrha
#'
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param reshape booleen TRUE/FALSE : la donnee doit-elle etre restructuree ? une ligne = une erreur, sinon, une ligne = un sejour. par defaut a F
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#'
#' @return Une table (data.frame, tibble) contenant les erreurs Out.
#'
#' @examples
#' \dontrun{
#' ileg_had('750712184',2015,12,'~/Documents/data/ssr') -> leg15
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irha}}, \code{\link{issrha}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage ileg_ssr(finess, annee, mois, path, reshape = F, tolower_names = F, ...)
#' @export ileg_ssr
#' @export
ileg_ssr <- function(...){
UseMethod('ileg_ssr')
}
#' @export
ileg_ssr.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(ileg_ssr.default, param2)
}
#' @export
ileg_ssr.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(ileg_ssr.default, param2)
}
#' @export
ileg_ssr.default <- function(finess, annee, mois, path, reshape = F, tolower_names = F, ...){
leg_i <- readr::read_lines(paste0(path,"/",finess,".",annee,".",mois,".leg"))
leg_i1 <- tibble::tibble(l = leg_i) %>%
tidyr::separate(l, c('FINESS', 'MOIS', 'ANNEE', 'NOSEQSEJ',
'NOSEQRHS', 'NBERR', 'ERRS'), ";", extra = "merge")
if (reshape==FALSE){
leg_i1 <- leg_i1 %>%
dplyr::mutate(EG = stringr::str_replace_all(ERRS, ";", ", ")) %>%
dplyr::select(-ERRS)
if (tolower_names){
names(leg_i1) <- tolower(names(leg_i1))
}
return(leg_i1)
}
u <- stringr::str_split(leg_i1$ERRS, ";") %>% purrr::flatten_chr()
leg_i1 <- tibble::as_tibble(lapply(leg_i1, rep, leg_i1$NBERR), stringsAsFactors = F)
leg_i2 <- dplyr::bind_cols(leg_i1, data.frame(EG = as.character(u), stringsAsFactors = F))
leg_i2 <- leg_i2 %>%
dplyr::mutate(ERRS = stringr::str_replace_all(ERRS, ";", ", "))
if (tolower_names){
names(leg_i2) <- tolower(names(leg_i2))
}
return(leg_i2)
}
#' ~ SSR - Import des Med
#'
#' Imports du fichier Med Out
#'
#' Formats depuis 2011 pris en charge
#' Structure du nom du fichier attendu (sortie de Genrha) :
#' \emph{finess.annee.moisc.med}
#'
#' \strong{750712184.2017.2.med}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les données médicaments SSR du Out.
#'
#' @examples
#' \dontrun{
#' meds <- imed_ssr('750712184',2015,12,"~/Documents/data/ssr")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irapss}}
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage imed_ssr(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export imed_ssr
#' @export
imed_ssr <- function(...){
UseMethod('imed_ssr')
}
#' @export
imed_ssr.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(imed_ssr.default, param2)
}
#' @export
imed_ssr.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(imed_ssr.default, param2)
}
#' @export
imed_ssr.default <- function(finess, annee, mois, path, lib = T, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'ssr', table == 'rha_med', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
info = file.info(paste0(path,"/",finess,".",annee,".",mois,".med"))
if (info$size >0 & !is.na(info$size)){
med_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".med"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...) %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000) %>% sjlabelled::set_label(libelles)
}
else {
med_i <- tibble::as_tibble(data.frame())
}
info = file.info(paste0(path,"/",finess,".",annee,".",mois,".medatu"))
if (info$size >0 & !is.na(info$size)){
med_i2<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".medatu"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...) %>%
dplyr::mutate(NBADM = NBADM/1000,
PRIX = PRIX /1000) %>% sjlabelled::set_label(libelles)
med_i <- rbind(med_i,med_i2)
}
Fillers <- names(med_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="Fil"]
med_i <- med_i[,!(names(med_i) %in% Fillers)]
if (tolower_names){
names(med_i) <- tolower(names(med_i))
}
return(med_i)
}
#' ~ SSR - Import des donnees UM du Out
#'
#' Imports du fichier IUM SSR
#'
#' Formats depuis 2013 pris en charge
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires à passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les informations structures du Out.
#'
#' @examples
#' \dontrun{
#' um <- iium_ssr('750712184',2015,12,"~/Documents/data/ssr")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage iium_ssr(finess, annee, mois, path, lib = T, ...)
#' @export iium_ssr
#' @export
iium_ssr <- function(...){
UseMethod('iium_ssr')
}
#' @export
iium_ssr.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iium_ssr.default, param2)
}
#' @export
iium_ssr.list <- function(l , ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iium_ssr.default, param2)
}
#' @export
iium_ssr.default <- function(finess, annee, mois, path, lib = T, tolower_names = F, ...){
if (annee<2013|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'ssr', table == 'rha_um', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
ium_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ium"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ium_i) -> synthese_import
if (lib==T){
v <- libelles
ium_i <- ium_i %>% sjlabelled::set_label(v)
}
if (tolower_names){
names(ium_i) <- tolower(names(ium_i))
}
attr(ium_i,"problems") <- synthese_import
return(ium_i)
}
##############################################
####################### PSY ##################
##############################################
#' ~ PSY - Import des RPSA
#'
#' Import du fichier RPSA
#'
#' Formats depuis 2012 pris en charge
#' Structure du nom du fichier attendu (sortie de Pivoine) :
#' \emph{finess.annee.moisc.rpsa}
#'
#' \strong{750712184.2016.2.rpsa}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les données RPSA.
#'
#' @examples
#' \dontrun{
#' rpsa <- irpsa('750712184',2015,12,"~/Documents/data/psy")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{ir3a}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage irpsa(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export irpsa
#' @export
irpsa <- function(...){
UseMethod('irpsa')
}
#' @export
irpsa.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(irpsa.default, param2)
}
#' @export
irpsa.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(irpsa.default, param2)
}
#' @export
irpsa.default <- function(finess, annee, mois, path, lib = T, tolower_names = F, ...){
if (annee<2012|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'psy', table == 'rpsa', an == substr(as.character(annee),3,4))
format$longueur[nrow(format)] <- NA
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
extz <- function(x,pat){unlist(lapply(stringr::str_extract_all(x,pat),toString) )}
suppressWarnings(rpsa_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rpsa"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...))
readr::problems(rpsa_i) -> synthese_import
rpsa_i <- rpsa_i %>%
dplyr::mutate(DP = stringr::str_trim(DP))
if (annee < 2017){
zad <- rpsa_i %>% dplyr::select(NOSEQSEJ, NOSEQ,NBDA,ZAD) %>% dplyr::mutate(da = ifelse(NBDA>0,ZAD,""),
lda = stringr::str_extract_all(da, '.{1,6}'))
da <- purrr::flatten_chr(zad$lda) %>% stringr::str_trim()
df <- zad %>% dplyr::select(NOSEQSEJ, NOSEQ,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = stringr::str_trim(da), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDA)
rpsa_i$ZAD[is.na(rpsa_i$ZAD)] <- ""
rpsa_i <- rpsa_i %>% dplyr::mutate(das = extz(ZAD, ".{1,6}")) %>% dplyr::select(-ZAD)
if (lib == T){
rpsa_i <- rpsa_i %>% sjlabelled::set_label(c(libelles[-length(libelles)], "Stream DA ou facteurs associés"))
da <- da %>% sjlabelled::set_label(c('N° séquentiel de séjour','N° séquentiel de séquence au sein du séjour',
'Diagnostics et facteurs associés'))
}
if (tolower_names){
names(rpsa_i) <- tolower(names(rpsa_i))
names(da) <- tolower(names(da))
}
rpsa_1 = list(rpsa = rpsa_i, das = da)
}
if (annee > 2016 & annee < 2020){
rpsa_i <- rpsa_i %>%
dplyr::mutate(da = ifelse(NBDA>0,stringr::str_sub(ZAD,1, NBDA*6),""),
lda = stringr::str_extract_all(da, '.{1,6}'),
actes = ifelse(NBZA>0,stringr::str_sub(ZAD,NBDA*6+1,1+ NBDA*6 + NBZA*17),""),
lactes = stringr::str_extract_all(actes, '.{1,17}'))
zad <- rpsa_i
da <- purrr::flatten_chr(zad$lda) %>% stringr::str_trim()
df <- zad %>% dplyr::select(NOSEQSEJ, NOSEQ,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = stringr::str_trim(da), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDA)
actes <- purrr::flatten_chr(zad$lactes)
df <- zad %>% dplyr::select(NOSEQSEJ, NOSEQ,NBZA)
df <- as.data.frame(lapply(df, rep, df$NBZA), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(ACTES = actes, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBZA)
fzacte <- function(actes){
dplyr::mutate(actes,
DELAI = stringr::str_sub(ACTES,1,3) %>% as.integer(),
CDCCAM = stringr::str_sub(ACTES,4,10),
DESCRI = stringr::str_sub(ACTES,11,12) %>% stringr::str_trim(),
PHASE = stringr::str_sub(ACTES,13,13),
ACT = stringr::str_sub(ACTES,14,14),
EXTDOC = stringr::str_sub(ACTES,15,15),
NBEXEC = stringr::str_sub(ACTES,16,17) %>% as.integer()
) %>% dplyr::select(-ACTES)
}
fzacte(actes) -> actes
rpsa_i$ZAD[is.na(rpsa_i$ZAD)] <- ""
rpsa_i <- rpsa_i %>% dplyr::mutate(das = extz(da, ".{1,6}"),
actes = extz(actes, "[A-Z]{4}[0-9]{3}")) %>% dplyr::select(-ZAD, -da, -lactes, -lda)
libelles[is.na(libelles)] <- ""
if (lib == T){
rpsa_i <- rpsa_i %>% sjlabelled::set_label(c(libelles[-length(libelles)], "Stream actes","Stream DA ou facteurs associés"))
da <- da %>% sjlabelled::set_label(c('N° séquentiel de séjour','N° séquentiel de séquence au sein du séjour',
'Diagnostics et facteurs associés'))
actes <- actes %>% sjlabelled::set_label(c('N° séquentiel de séjour','N° séquentiel de séquence au sein du séjour',
"Délai depuis la date d'entrée", "Code CCAM",
"Extension PMSI", "Code de la phase", "Code de l'activité", "Extension documentaire", "Nombre de réalisations"))
}
if (tolower_names){
names(rpsa_i) <- tolower(names(rpsa_i))
names(da) <- tolower(names(da))
names(actes) <- tolower(names(actes))
}
rpsa_1 = list(rpsa = rpsa_i, das = da, actes = actes)
}
if (annee > 2019){
rpsa_i <- rpsa_i %>%
dplyr::mutate(da = ifelse(NBDA>0,stringr::str_sub(ZAD,1, NBDA*6),""),
lda = stringr::str_extract_all(da, '.{1,6}'),
actes = ifelse(NBZA>0,stringr::str_sub(ZAD,NBDA*6+1,1+ NBDA*6 + NBZA*19),""),
lactes = stringr::str_extract_all(actes, '.{1,19}'))
zad <- rpsa_i
da <- purrr::flatten_chr(zad$lda) %>% stringr::str_trim()
df <- zad %>% dplyr::select(NOSEQSEJ, NOSEQ,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = stringr::str_trim(da), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDA)
actes <- purrr::flatten_chr(zad$lactes)
df <- zad %>% dplyr::select(NOSEQSEJ, NOSEQ,NBZA)
df <- as.data.frame(lapply(df, rep, df$NBZA), stringsAsFactors = F) %>% tibble::as_tibble()
actes <- dplyr::bind_cols(df,data.frame(ACTES = actes, stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBZA)
fzacte <- function(actes){
dplyr::mutate(actes,
DELAI = stringr::str_sub(ACTES,1,5) %>% as.integer(),
CDCCAM = stringr::str_sub(ACTES,6,12),
DESCRI = stringr::str_sub(ACTES,13,14) %>% stringr::str_trim(),
PHASE = stringr::str_sub(ACTES,15,15),
ACT = stringr::str_sub(ACTES,16,16),
EXTDOC = stringr::str_sub(ACTES,17,18),
NBEXEC = stringr::str_sub(ACTES,19,19) %>% as.integer()
) %>% dplyr::select(-ACTES)
}
fzacte(actes) -> actes
rpsa_i$ZAD[is.na(rpsa_i$ZAD)] <- ""
rpsa_i <- rpsa_i %>% dplyr::mutate(das = extz(da, ".{1,6}"),
actes = extz(actes, "[A-Z]{4}[0-9]{3}")) %>% dplyr::select(-ZAD, -da, -lactes, -lda)
libelles[is.na(libelles)] <- ""
if (lib == T){
rpsa_i <- rpsa_i %>% sjlabelled::set_label(c(libelles[-length(libelles)], "Stream actes","Stream DA ou facteurs associés"))
da <- da %>% sjlabelled::set_label(c('N° séquentiel de séjour','N° séquentiel de séquence au sein du séjour',
'Diagnostics et facteurs associés'))
actes <- actes %>% sjlabelled::set_label(c('N° séquentiel de séjour','N° séquentiel de séquence au sein du séjour',
"Délai depuis la date d'entrée", "Code CCAM",
"Extension PMSI", "Code de la phase", "Code de l'activité", "Extension documentaire", "Nombre de réalisations"))
}
if (tolower_names){
names(rpsa_i) <- tolower(names(rpsa_i))
names(da) <- tolower(names(da))
names(actes) <- tolower(names(actes))
}
rpsa_1 = list(rpsa = rpsa_i, das = da, actes = actes)
}
attr(rpsa_1,"problems") <- synthese_import
return(rpsa_1)
}
#' ~ PSY - Import des R3A
#'
#' Import du fichier R3A
#'
#' Formats depuis 2012 pris en charge
#' Structure du nom du fichier attendu (sortie de Pivoine) :
#' \emph{finess.annee.moisc.r3a}
#'
#' \strong{750712184.2016.3.r3a}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des données (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les données R3A.
#'
#' @examples
#' \dontrun{
#' r3a <- ir3a('750712184',2015,12,"~/Documents/data/psy")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irpsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage ir3a(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export ir3a
#' @export
ir3a <- function(...){
UseMethod('ir3a')
}
#' @export
ir3a.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(ir3a.default, param2)
}
#' @export
ir3a.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(ir3a.default, param2)
}
#' @export
ir3a.default <- function(finess, annee, mois, path, lib = T, tolower_names = F, ...){
if (annee<2012|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
format <- pmeasyr::formats %>% dplyr::filter(champ == 'psy', table == 'r3a', an == substr(as.character(annee),3,4))
format$longueur[nrow(format)] <- NA
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
extz <- function(x,pat){unlist(lapply(stringr::str_extract_all(x,pat),toString) )}
suppressWarnings(r3a_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".r3a"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...))
readr::problems(r3a_i) -> synthese_import
r3a_i <- r3a_i %>%
dplyr::mutate(DP = stringr::str_trim(DP))
zad <- r3a_i %>% dplyr::select(NOSEQSEJ,NOORDR,NBDA,ZAD) %>% dplyr::mutate(da = ifelse(NBDA>0,ZAD,""),
lda = stringr::str_extract_all(da, '.{1,6}'))
da <- purrr::flatten_chr(zad$lda)
df <- zad %>% dplyr::select(NOSEQSEJ,NOORDR,NBDA)
df <- as.data.frame(lapply(df, rep, df$NBDA), stringsAsFactors = F) %>% tibble::as_tibble()
da <- dplyr::bind_cols(df,data.frame(DA = stringr::str_trim(da), stringsAsFactors = F) ) %>% tibble::as_tibble() %>% dplyr::select(-NBDA)
r3a_i$ZAD[is.na(r3a_i$ZAD)] <- ""
r3a_i <- r3a_i %>% dplyr::mutate(das = extz(ZAD, ".{1,6}")) %>% dplyr::select(-ZAD)
if (lib == T){
r3a_i <- r3a_i %>% sjlabelled::set_label(c(libelles[-length(libelles)], "Stream DA ou facteurs associés"))
da <- da %>% sjlabelled::set_label(c('N° séquentiel de séjour',"N° d'ordre", 'Diagnostics et facteurs associés'))
}
if (tolower_names){
names(r3a_i) <- tolower(names(r3a_i))
names(da) <- tolower(names(da))
}
r3a_1 = list(r3a = r3a_i, das = da)
attr(r3a_1,"problems") <- synthese_import
return(r3a_1)
}
#' ~ PSY - Import des Anohosp
#'
#' Import du fichier Ano
#'
#' Formats depuis 2012 pris en charge
#' Structure du nom du fichier attendu (sortie de Genrha) :
#' \emph{finess.annee.moisc.ano}
#'
#' \strong{750712184.2016.2.ano}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param typano Type de donnees in / out
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame, tibble) contenant les données Anohosp SSR du Out.
#'
#' @examples
#' \dontrun{
#' anoh <- iano_psy('750712184',2015,12,"~/Documents/data/psy")
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irpsa}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage iano_psy(finess, annee, mois, path, lib = T, tolower_names = F, ...)
#' @export iano_psy
#' @export
iano_psy <- function(...){
UseMethod('iano_psy')
}
#' @export
iano_psy.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iano_psy.default, param2)
}
#' @export
iano_psy.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iano_psy.default, param2)
}
#' @export
iano_psy.default <- function(finess, annee, mois, path, typano = c('out', 'in'), lib=T, tolower_names = F, ...){
if (annee<2012|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
typano <- match.arg(typano)
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (typano=="out"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'psy', table == 'rpsa_ano', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
extz <- function(x,pat){unlist(lapply(stringr::str_extract_all(x,pat),toString) )}
if (annee<=2012){
ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSOR = lubridate::dmy(DTSOR, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') ==7),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTRMBAMC = MTRMBAMC/100)
}
if (annee>2012){
ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSOR = lubridate::dmy(DTSOR, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRSECU=='0')+(CRDNAI=='0')+ (CRSEXE=='0') + (CRNODA=='0') +
(CRFUSHOSP=='0') + (CRFUSPMSI=='0') + (CRDTENT=='0') +
(CRCDNAI=='0') + (CRCSEXE=='0')==9),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
MTRMBAMC = MTRMBAMC/100,
TAUXRM = TAUXRM /100)
}
if (lib == T){
ano_i <- ano_i %>% sjlabelled::set_label(c(libelles,'Chaînage Ok'))
ano_i <- ano_i %>% dplyr::select(-dplyr::starts_with("Fill"))
}
}
if (typano=="in"){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'psy', table == 'rps_ano', an == substr(as.character(annee),3,4))
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (2011<annee){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".anohosp.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTHOSP = lubridate::dmy(DTHOSP, quiet = TRUE),
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTRMAMC = MTRMAMC /100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
if (annee == 2011){
ano_i<-readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".anohosp.txt"),
readr::fwf_widths(af,an), col_types =at, na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(
MTFACTMO = MTFACTMO/100,
MTFORJOU = MTFORJOU/100,
MTFACTOT = MTFACTOT/100,
MTBASERM = MTBASERM/100,
TAUXRM = TAUXRM /100,
MTMAJPAR = MTMAJPAR/100)
}
Fillers <- names(ano_i)
Fillers <- Fillers[stringr::str_sub(Fillers,1,3)=="FIL"]
ano_i <- ano_i[,!(names(ano_i) %in% Fillers)]
if (lib==T){
v <- libelles[!is.na(libelles)]
ano_i <- ano_i %>% sjlabelled::set_label(v)
}
}
if (tolower_names){
names(ano_i) <- tolower(names(ano_i))
}
attr(ano_i,"problems") <- synthese_import
return(ano_i)
}
##############################################
####################### DICO #################
##############################################
#' ~ Dico - Dictionnaire des tables
#'
#' Obtenir le dictionnaire d'une table
#'
#'
#' @param table Table dont on veut le dictionnaire de variables
#'
#' @examples
#' \dontrun{
#' # N'importer qu'une ligne du fichier :
#' irsa('750712184', 2016, 8, '~/path/path', typi= 1, n_max = 1) -> import
#' dico(import$rsa)
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irsa}}, \code{\link{irum}}
#' @export
dico <- function(table){
tibble::tibble(
nom = names(table),
label = sjlabelled::get_label(table),
type = sapply(table, class)
) %>% sjlabelled::set_label(c("Nom de la variable","Libellé, de la variable", "Type"))
}
##############################################
####################### Tidy #################
##############################################
#' ~ Tidy - Tidy Diagnostics
#'
#' Restructurer les diagnostics
#'
#' On obtient une table contenant tous les diagnostics par séjour, sur le principe suivant :
#' Une variable numérique indique la position des diagnostics
#' - pour les rsa : 1 : DP du rsa, 2 : DR du rsa, 3 : DPUM, 4 : DRUM, 5 : DAS
#' - pour les rum : 1 : DP du rum, 2 : DR du rum, 3 : DAS, 4 : DAD
#' - pour les rha : 1 : MMP du rha, 2 : FPPC du rha, 3 : AE, 4 : DA
#'
#' @param d Objet S3 resultat de l'import pmeasyr (irsa, irum, irha)
#' @param include booleen : defaut a T; T : restructure l'objet S3 (agglomere dp, dr, das et dad, par exemple)
#'
#' @examples
#' \dontrun{
#' # avec include = T
#' irum('750712184', 2016, 8, '~/path/path', typi = 3) -> d1
#' tdiag(d1) -> d1
#' d1$diags
#' d1$actes
#' d1$dad
#' irsa('750712184', 2016, 8, '~/path/path', typi = 4) -> d1
#' tdiag(d1, include = F) -> alldiag
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irsa}}, \code{\link{irum}}, \code{\link{irha}}
#' @export
tdiag <- function (d, include = T){
if (names(d)[1] == "rsa") {
if ('DP' %in% names(d$rsa)){
temp <- d$rsa %>% dplyr::select(CLE_RSA, NSEQRUM = NOSEQRUM, DP, DR) %>%
sjlabelled::set_label(rep("", 4))
e <- temp %>% tidyr::gather(position, diag, -CLE_RSA, - NSEQRUM,
na.rm = T)
f <- e %>% dplyr::filter(diag != "")
g <- d$das %>% dplyr::select(CLE_RSA,NSEQRUM,diag = DAS) %>% dplyr::mutate(position = "DAS")
h <- dplyr::bind_rows(f, g)
temp <- d$rsa_um %>% dplyr::select(CLE_RSA, NSEQRUM, DPUM, DRUM) %>%
sjlabelled::set_label(rep("", 4))
e <- temp %>% tidyr::gather(position, diag, -CLE_RSA, - NSEQRUM,
na.rm = T)
f <- e %>% dplyr::filter(diag != "")
h <- dplyr::bind_rows(h, f) %>% dplyr::mutate(position = as.numeric(as.character(forcats::fct_recode(position,`1` = "DP", `2` = "DR", `3` = "DPUM", `4` = "DRUM",
`5` = "DAS"))))
# h <- sjlabelled::remove_all_labels(h)
if (!is.null(sjlabelled::get_label(d$rsa$NOFINESS))){
h <- h %>% sjlabelled::set_label(c("Clé rsa", "N° du RUM","1:DP, 2:DR, 3:DPUM, 4:DRUM, 5:DAS",
"Diagnostic"))
}
if (include == F) {
return(h %>% dplyr::as_tibble())
}
else {
return(list(rsa = d$rsa %>% dplyr::as_tibble(),
rsa_um = d$rsa_um %>% dplyr::as_tibble(),
actes = d$actes %>% dplyr::as_tibble(),
diags = h %>% dplyr::as_tibble()))
}
}
else if ('dp' %in% names(d$rsa)){
temp <- d$rsa %>% dplyr::select(cle_rsa, nseqrum = noseqrum, dp, dr) %>%
sjlabelled::set_label(rep("", 4))
e <- temp %>% tidyr::gather(position, diag, -cle_rsa, - nseqrum,
na.rm = T)
f <- e %>% dplyr::filter(diag != "")
g <- d$das %>% dplyr::select(cle_rsa,nseqrum,diag = das) %>% dplyr::mutate(position = "das")
h <- dplyr::bind_rows(f, g)
temp <- d$rsa_um %>% dplyr::select(cle_rsa, nseqrum, dpum, drum) %>%
sjlabelled::set_label(rep("", 4))
e <- temp %>% tidyr::gather(position, diag, -cle_rsa, - nseqrum,
na.rm = T)
f <- e %>% dplyr::filter(diag != "")
h <- dplyr::bind_rows(h, f) %>% dplyr::mutate(position = as.numeric(as.character(forcats::fct_recode(position,`1` = "dp", `2` = "dr", `3` = "dpum", `4` = "drum",
`5` = "das"))))
# h <- sjlabelled::remove_all_labels(h)
if (!is.null(sjlabelled::get_label(d$rsa$nofiness))){
h <- h %>% sjlabelled::set_label(c("Clé rsa", "N° du RUM","1:DP, 2:DR, 3:DPUM, 4:DRUM, 5:DAS",
"Diagnostic"))
}
if (include == F) {
return(h %>% dplyr::as_tibble())
}
else {
return(list(rsa = d$rsa %>% dplyr::as_tibble(),
rsa_um = d$rsa_um %>% dplyr::as_tibble(),
actes = d$actes %>% dplyr::as_tibble(),
diags = h %>% dplyr::as_tibble()))
}
}
}
if (names(d)[1] == "rum") {
if ("DP" %in% names(d$rum)){
temp <- d$rum %>% dplyr::select(NAS,NORUM, DP, DR) %>% sjlabelled::set_label(rep("",4))
e <- temp %>% tidyr::gather(position, diag, -NAS,- NORUM, na.rm = T)
f <- e %>% dplyr::filter(diag != "")
g <- d$das %>% dplyr::rename(diag = DAS) %>% dplyr::mutate(position = "DAS")
g2 <- d$dad %>% dplyr::rename(diag = DAD) %>% dplyr::mutate(position = "DAD")
h <- dplyr::bind_rows(list(f, g, g2)) %>%
dplyr::mutate(position = as.numeric(as.character(forcats::fct_recode(position,`1` = "DP", `2` = "DR", `3` = "DAS", `4`="DAD"))))
h <- sjlabelled::remove_all_labels(h)
if (!is.null(sjlabelled::get_label(d$rum$NOFINESS))){
h <- h %>% sjlabelled::set_label(c("N° administratif du séjour", "N° du RUM",
"1:DP, 2:DR, 3:DAS, 4:DAD", "Diagnostic"))
}
if (include == F) {
return(h %>% dplyr::as_tibble())
}
else {
return(list(rum = d$rum %>% dplyr::as_tibble(),
actes = d$actes %>% dplyr::as_tibble(),
diags = h %>% dplyr::as_tibble()))
}
}
else if ("dp" %in% names(d$rum)){
temp <- d$rum %>% dplyr::select(nas, norum, dp, dr) %>% sjlabelled::set_label(rep("",4))
e <- temp %>% tidyr::gather(position, diag, -nas,- norum, na.rm = T)
f <- e %>% dplyr::filter(diag != "")
g <- d$das %>% dplyr::rename(diag = das) %>% dplyr::mutate(position = "das")
g2 <- d$dad %>% dplyr::rename(diag = dad) %>% dplyr::mutate(position = "dad")
h <- dplyr::bind_rows(list(f, g, g2)) %>%
dplyr::mutate(position = as.numeric(as.character(forcats::fct_recode(position,`1` = "dp", `2` = "dr", `3` = "das", `4`="dad"))))
h <- sjlabelled::remove_all_labels(h)
if (!is.null(sjlabelled::get_label(d$rum$nofiness))){
h <- h %>% sjlabelled::set_label(c("N° administratif du séjour", "N° du RUM",
"1:DP, 2:DR, 3:DAS, 4:DAD", "Diagnostic"))}
if (include == F) {
return(h %>% dplyr::as_tibble())
}
else {
return(list(rum = d$rum %>% dplyr::as_tibble(),
actes = d$actes %>% dplyr::as_tibble(),
diags = h %>% dplyr::as_tibble()))
}
}
}
if (names(d)[1] == "rha") {
if ("MMP" %in% names(d$rha)){
temp <- d$rha %>% dplyr::select(NOSEQSEJ, NOSEQRHS, MMP, FPPC, AE) %>%
sjlabelled::set_label(rep("", 5))
e <- temp %>% tidyr::gather(position, diag, -NOSEQSEJ, - NOSEQRHS,
na.rm = T)
f <- e %>% dplyr::filter(diag != "")
g <- d$acdi %>% dplyr::filter(CODE == 'DA') %>% dplyr::select(NOSEQSEJ,NOSEQRHS,diag = DA) %>% dplyr::mutate(position = "DA")
h <- dplyr::bind_rows(f, g)
h <- dplyr::bind_rows(h, f) %>% dplyr::mutate(position = as.numeric(as.character(forcats::fct_recode(position,`1` = "MMP", `2` = "FPPC", `3` = "AE", `4` = "DA"))))
h <- h %>% sjlabelled::set_label(c("N° séquentiel du séjour", "N° séquentiel du RHS","1:MMP, 2:FPPC, 3:AE, 4:DA",
"Diagnostic"))
if (include == F) {
return(h %>% dplyr::as_tibble())
}
else {
return(list(rha = d$rha %>% dplyr::as_tibble(),
acdi = d$acdi %>% dplyr::as_tibble(),
diags = h %>% dplyr::as_tibble()))
}
}
else if ("mmp" %in% names(d$rha)){
temp <- d$rha %>% dplyr::select(noseqsej, noseqrhs, mmp, fppc, ae) %>%
sjlabelled::set_label(rep("", 5))
e <- temp %>% tidyr::gather(position, diag, -noseqsej, - noseqrhs,
na.rm = T)
f <- e %>% dplyr::filter(diag != "")
g <- d$acdi %>% dplyr::filter(code == 'DA') %>% dplyr::select(noseqsej,noseqrhs,diag = da) %>% dplyr::mutate(position = "da")
h <- dplyr::bind_rows(f, g)
h <- dplyr::bind_rows(h, f) %>% dplyr::mutate(position = as.numeric(as.character(forcats::fct_recode(position,`1` = "mmp", `2` = "fppc", `3` = "ae", `4` = "da"))))
h <- h %>% sjlabelled::set_label(c("N° séquentiel du séjour", "N° séquentiel du RHS","1:MMP, 2:FPPC, 3:AE, 4:DA",
"Diagnostic"))
if (include == F) {
return(h %>% dplyr::as_tibble())
}
else {
return(list(rha = d$rha %>% dplyr::as_tibble(),
acdi = d$acdi %>% dplyr::as_tibble(),
diags = h %>% dplyr::as_tibble()))
}
}
}
}
##############################################
####################### RSF ##################
##############################################
#' ~ RSF - Import des Rafael
#'
#' Import des Rafael et des Rafael reprises
#'
#' Formats depuis 2012 pour les rsfa
#' Formats depuis 2014 pour les rsfa-maj (reprise 2013)
#'
#' @return Une classe S3 contenant les tables (data.frame, tibble ou tbl) importées (rafaels)
#'
#' @examples
#' \dontrun{
#' irafael('750712184',2015,12,'~/Documents/data/rsf') -> rsfa15
#' irafael('750712184',2015,12,'~/Documents/data/rsf', lister = 'C', lamda = T) -> rsfa14_lamda
#' }
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lib Ajout des libelles de colonnes aux tables, par défaut a TRUE ; necessite le package \code{sjlabelled}
#' @param stat avec stat = T, un tableau synthetise le nombre de lignes par type de rafael
#' @param lister Liste des types d'enregistrements a importer
#' @param lamda a TRUE, importe les fichiers \code{rsfa-maj} de reprise de l'annee passee
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... Autres parametres a specifier \code{n_max = 1e3}, ...
#' @author G. Pressiat
#'
#' @seealso \code{\link{iano_rafael}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage irafael(finess, annee, mois, path, lib = T, tolower_names = F,
#' stat = T, lister = c("A", "B",
#' "C", "H", "L", "M", "P"), lamda = F, ...)
#' @export irafael
#' @export
irafael <- function(...){
UseMethod('irafael')
}
#' @export
irafael.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(irafael.default, param2)
}
#' @export
irafael.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(irafael.default, param2)
}
#' @export
irafael.default <- function(finess, annee, mois, path, lib = T, stat = T,
lister = c('A', 'B', 'C', 'H', 'L', 'M', 'P'),
lamda = F, tolower_names = F, ...){
if (annee<2011|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
op <- options(digits.secs = 6)
un<-Sys.time()
if (lamda == F){
# cat(paste("Import des RSFA / Rafael", annee, paste0("M",mois),"\n"))
# cat(paste("L'objet retourné prendra la forme d'une classe S3.
# $A pour les Rafael A, et B, C, ...\n"))
formats <- pmeasyr::formats %>% dplyr::filter(champ == "rsf", table == "rafael", an == substr(annee,3,4))
r <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rsfa"),
readr::fwf_widths(NA, 'lon'),
col_types = readr::cols('c'), ...)
readr::problems(r) -> synthese_import
typi_r <- 9
if (annee > 2016 & annee < 2020){typi_r <- 11}
# if (annee > 2019){typi_r <- 9}
}
if (lamda == T){
# cat(paste("Import des rsfa-maj", annee, paste0("M",mois),"\n"))
# cat(paste("L'objet retourné prendra la forme d'une classe S3.
# $A pour les Rafael A, et B, C, ...\n"))
#
formats <- pmeasyr::formats %>% dplyr::filter(champ == "rsf", table == "rafael-maj", an == substr(annee,3,4))
r <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".rsfa-maj"),
readr::fwf_widths(NA, 'lon'),
col_types = readr::cols('c'), ...)
readr::problems(r) -> synthese_import
typi_r <- 27
if (annee > 2017){typi_r <- 29}
}
former <- function(cla, col1){
switch(cla,
'c' = col1,
'trim' = col1 %>% stringr::str_trim(),
'i' = col1 %>% as.integer(),
'n' = (col1 %>% as.numeric() )/100)
}
cutt <- function(typs, lib){
fa <- formats %>% dplyr::filter(Typer == typs)
deb <- fa$position
fin <- fa$fin
u <- function(x, i){stringr::str_sub(x, deb[i], fin[i])}
r %>% dplyr::filter(substr(lon,typi_r,typi_r) == typs) -> one
for (i in 1:length(deb)){
temp <- dplyr::as_tibble(former(fa$cla[i], u(one$lon, i)))
names(temp) <- fa$nom[i]
one <- dplyr::bind_cols(one, temp)
}
one %>% dplyr::select(-lon) -> one
if (lib == T){
one %>% sjlabelled::set_label(fa$libelle) -> one
}
return(one)
}
if ('A' %in% lister){rafael_A <- suppressWarnings(cutt('A', lib))}else{rafael_A <- data.frame()}
r %>% dplyr::filter(substr(lon,typi_r,typi_r) != 'A') -> r
if ('B' %in% lister){rafael_B <- suppressWarnings(cutt('B', lib))}else{rafael_B <- data.frame()}
r %>% dplyr::filter(substr(lon,typi_r,typi_r) != 'B') -> r
if ('C' %in% lister){rafael_C <- suppressWarnings(cutt('C', lib))}else{rafael_C <- data.frame()}
r %>% dplyr::filter(substr(lon,typi_r,typi_r) != 'C') -> r
if ('M' %in% lister){rafael_M <- suppressWarnings(cutt('M', lib))}else{rafael_M <- data.frame()}
r %>% dplyr::filter(substr(lon,typi_r,typi_r) != 'M') -> r
if ('L' %in% lister){rafael_L <- suppressWarnings(cutt('L', lib))}else{rafael_L <- data.frame()}
r %>% dplyr::filter(substr(lon,typi_r,typi_r) != 'L') -> r
if ('P' %in% lister){rafael_P <- suppressWarnings(cutt('P', lib))}else{rafael_P <- data.frame()}
r %>% dplyr::filter(substr(lon,typi_r,typi_r) != 'P') -> r
if ('H' %in% lister){rafael_H <- suppressWarnings(cutt('H', lib))}else{rafael_H <- data.frame()}
rm(r)
deux<-Sys.time()
#at(paste("Rafaels",annee, paste0("M",mois),"chargés en : ",round(difftime(deux,un, units="secs"),0), "secondes\n"))
if (stat == T){
print(
knitr::kable(tibble::tibble(Rafael = c('A', 'B', 'C', 'H', 'L', 'M', 'P'),
Lignes = c(nrow(rafael_A),
nrow(rafael_B),
nrow(rafael_C),
nrow(rafael_H),
nrow(rafael_L),
nrow(rafael_M),
nrow(rafael_P)))))
}
if (tolower_names){
names(rafael_A) <- tolower(names(rafael_A))
names(rafael_B) <- tolower(names(rafael_B))
names(rafael_C) <- tolower(names(rafael_C))
names(rafael_H) <- tolower(names(rafael_H))
names(rafael_L) <- tolower(names(rafael_L))
names(rafael_M) <- tolower(names(rafael_M))
names(rafael_P) <- tolower(names(rafael_P))
}
r_ii <- list("A" = rafael_A,
"B" = rafael_B,
"C" = rafael_C,
"H" = rafael_H,
"L" = rafael_L,
"M" = rafael_M,
"P" = rafael_P)
attr(r_ii,"problems") <- synthese_import
return(r_ii)
}
#' ~ RSF - Import des Anohosp RSFA
#'
#' Import du fichier ANO-ACE RSF Out ou le ano-ace-maj (reprise)
#'
#' Formats depuis 2012 pris en charge pour les ano-ace
#' Formats depuis 2014 pris en charge pour les ano-ace-maj (reprise 2013)
#'
#' Structure du nom du fichier attendu :
#' \emph{finess.annee.moisc.ano}
#'
#' \strong{750712184.2016.2.ano}
#'
#' @param finess Finess du Out a importer : dans le nom du fichier
#' @param annee Annee PMSI (nb) des donnees sur 4 caracteres (2016)
#' @param mois Mois PMSI (nb) des donnees (janvier : 1, decembre : 12)
#' @param path Localisation du fichier de donnees
#' @param lamda a TRUE, importe le fichier ano-ace-maj
#' @param lib Ajout des libelles de colonnes aux tables, par defaut a \code{TRUE} ; necessite le package \code{sjlabelled}
#' @param tolower_names a TRUE les noms de colonnes sont tous en minuscules
#' @param ~... parametres supplementaires a passer
#' dans la fonction \code{\link[readr]{read_fwf}}, par exemple
#' \code{n_max = 1e3} pour lire les 1000 premieres lignes, \code{progress = F, skip = 1e3}
#'
#' @return Une table (data.frame ou tibble) qui contient les données Anohosp in / out
#'
#' @examples
#' \dontrun{
#' iano_rafael('750712184', 2015, 12,'~/Documents/data/rsf') -> ano_out15
#' iano_rafael('750712184', 2015, 12,'~/Documents/data/rsf', lamda = T) -> lamda_maj_ano_out14
#' }
#'
#' @author G. Pressiat
#'
#' @seealso \code{\link{irafael}},
#' utiliser un noyau de parametres avec \code{\link{noyau_pmeasyr}}
#' @usage iano_rafael(finess, annee, mois, path, lib = T, lamda = F, tolower_names = F, ...)
#' @export iano_rafael
#' @export
iano_rafael <- function(...){
UseMethod('iano_rafael')
}
#' @export
iano_rafael.pm_param <- function(params, ...){
new_par <- list(...)
param2 <- utils::modifyList(params, new_par)
do.call(iano_rafael.default, param2)
}
#' @export
iano_rafael.list <- function(l, ...){
.params <- l
new_par <- list(...)
param2 <- utils::modifyList(.params, new_par)
do.call(iano_rafael.default, param2)
}
#' @export
iano_rafael.default <- function(finess, annee, mois, path, lib = T, lamda = F, tolower_names = F, ...){
if (annee<2012|annee > 2024){
stop('Année PMSI non prise en charge\n')
}
if (mois<1|mois>12){
stop('Mois incorrect\n')
}
if (lamda == F){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'rsf', table == 'rafael_ano', an == substr(as.character(annee),3,4))
}
if (lamda == T){
format <- pmeasyr::formats %>% dplyr::filter(champ == 'rsf', table == 'rafael_ano-maj', an == substr(as.character(annee),3,4))
}
af <- format$longueur
libelles <- format$libelle
an <- format$nom
vec <- format$type
col_types <- vec
is_character <- vapply(col_types, is.character, logical(1))
col_concise <- function(x) {
switch(x,
"_" = ,
"-" = readr::col_skip(),
"?" = readr::col_guess(),
c = readr::col_character(),
D = readr::col_date(),
d = readr::col_double(),
i = readr::col_integer(),
l = readr::col_logical(),
n = readr::col_number(),
T = readr::col_datetime(),
t = readr::col_time(),
stop("Unknown shortcut: ", x, call. = FALSE)
)
}
col_types[is_character] <- lapply(col_types[is_character], col_concise)
at <- structure(
list(
cols = col_types
),
class = "col_spec"
)
if (lamda == F){ ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano-ace"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRNOSEC=='0')+(CRDNAIS=='0')+ (CRSEXE=='0') + (CRNAS=='0') +
(CRDENTR=='0') ==5)) %>% sjlabelled::set_label(c(libelles, 'Chaînage Ok'))
}
if (lamda == T){ ano_i <- readr::read_fwf(paste0(path,"/",finess,".",annee,".",mois,".ano-ace-maj"),
readr::fwf_widths(af,an), col_types = at , na=character(), ...)
readr::problems(ano_i) -> synthese_import
ano_i <- ano_i %>%
dplyr::mutate(DTSORT = lubridate::dmy(DTSORT, quiet = TRUE),
DTENT = lubridate::dmy(DTENT, quiet = TRUE),
cok = ((CRNOSEC=='0')+(CRDNAIS=='0')+ (CRSEXE=='0') + (CRNAS=='0') +
(CRDENTR=='0') ==5)) %>% sjlabelled::set_label(c(libelles, 'Chaînage Ok'))
}
if (tolower_names){
names(ano_i) <- tolower(names(ano_i))
}
attr(ano_i,"problems") <- synthese_import
return(ano_i)
}
#' Table des formats
#'
#' @name formats
#' @docType data
#' @author G. Pressiat
#' @keywords data
NULL
#' ~ par - Noyau de parametres
#'
#' Définir un noyau de paramètres
#'
#' Voir exemple
#'
#' @exportClass pm_param
#' @author G. Pressiat
#'
#' @examples
#' \dontrun{
#' library(magrittr)
#'
#' p <- noyau_pmeasyr(
#' finess = '750712184',
#' annee = 2016,
#' mois = 12,
#' path = '~/Documents/data/mco',
#' progress = F
#' )
#'
#' p %>% adezip(type = "out", liste = "")
#'
#' p %>% irsa() -> rsa
#' p %>% iano_mco() -> ano
#' p %>% ipo() -> po
#'
#' p %>% adezip(type = "in", liste = "")
#'
#' p %>% irum() -> rum
#'
#' # Modifier le type d'import :
#' irsa(p, typi = 6) -> rsa
#'
#' # Pour visualiser p :
#' p
#' print(p)
#' }
#' @seealso \code{\link{noyau_skeleton}}
#' @export
noyau_pmeasyr <- function(...){
params <- list(...)
#attr(params, "class") <- "list"
attr(params, "class") <- "pm_param"
#class(params) <- append(class(params),"pm_param")
return(params)
}
#' @rdname noyau_pmeasyr
#' @export
print.pm_param <- function(x, ...){
i <- unlist(x) %>%
t() %>%
as.data.frame(stringsAsFactors=F) %>%
tidyr::gather("parametre", "valeur")
a <- as.character(knitr::kable(i))
a <- paste0('', a)
a <- c('*** Noyau de param pmeasyr ***\n', a)
cat(a, sep="\n")
}
#' ~ par - Noyau de parametres
#'
#' Générer un squelette de noyau de paramètres
#'
#' Voir exemple
#'
#' @author G. Pressiat
#'
#' @examples
#' \dontrun{
#'
#' noyau_skeleton()
#' ## résultat :
#' ## noyau_pmeasyr(
#' ## finess = '.........',
#' ## annee = ....,
#' ## mois = ..,
#' ## path = ''
#' ## ) -> p
#'
#' noyau_skeleton("alpha_bravo", T)
#'
#' ## noyau_pmeasyr(
#' ## finess = '.........',
#' ## annee = ....,
#' ## mois = ..,
#' ## path = ''
#' ## ) -> alpha_bravo
#' ##
#' ## # adezip(alpha_bravo, type = 'out')
#' ## # adezip(alpha_bravo, type = 'in')
#'
#' }
#'
#' @seealso \code{\link{noyau_pmeasyr}}
#' @export
noyau_skeleton <- function(nom = "p", zip = F){
cat(paste0("\nnoyau_pmeasyr(
finess = \'.........\',
annee = ....,
mois = ..,
path = \'\'
) -> ", nom, "\n\n"))
if (zip){
cat(paste0("# adezip(", nom, ", type = \'out\')\n# adezip(", nom, ", type = \'in\')"))
}
}
##############################################
####################### LABELS ###############
##############################################
#' ~ Labels pour le PMSI
#'
#' Attribuer des libelles aux colonnes PMSI
#'
#' @param col Colonne à laquelle attribuer le libellé
#' @param Mode_entree '6' : 'Mutation'
#' @param Mode_sortie '9' : 'Décès'
#' @param Provenance '1' : 'MCO'
#' @param Destination '6' : 'HAD'
#' @param Sexe '2' : 'Femme'
#'
#' @return Un vecteur caractère ou facteur
#'
#' @examples
#' \dontrun{
#' labeleasier(rsa$rsa$SEXE, Sexe = T, F)
#' labeleasier(rsa$rsa$DEST, Destination = T, F)
#' }
#'
#' @author G. Pressiat
#'
#'
#' @import forcats
#' @export
labeleasier <- function(col,
Mode_entree = F,
Mode_sortie = F,
Provenance = F,
Destination = F,
Sexe = F,
facteur = F){
choix = c(Mode_entree,
Mode_sortie,
Provenance,
Destination,
Sexe)
noms <- c('Mode_entree',
'Mode_sortie',
'Provenance',
'Destination',
'Sexe')
if (sum( choix) != 1){
stop("Un et un seul format doit être spécifié par TRUE en paramètre")}
quoi <- noms[which(choix==T)]
r <- suppressWarnings(switch(quoi,
"Mode_entree" = forcats::fct_recode(col,
"PIE" = "0",
"Mutation" = "6",
"Transfert" = "7",
"Domicile" = "8",
"Inconnu" = ''),
"Mode_sortie" = forcats::fct_recode(col,
"Mutation" = "6",
"Transfert" = "7",
"Domicile" = "8",
"Décès" = "9",
"Inconnu" = ''),
"Provenance" = forcats::fct_recode(col,
"MCO" = "1",
"SSR" = "2",
"SLD" = "3",
"PSY" = "4",
"SAU" = "5",
"HAD" = "6",
"ESMS" = "7",
"SIAD" = "8",
"Inconnu" = ''
),
"Destination" = forcats::fct_recode(col,
"MCO" = "1",
"SSR" = "2",
"SLD" = "3",
"PSY" = "4",
"SAU" = "5",
"HAD" = "6",
"ESMS" = "7",
"SIAD" = "8",
"Inconnu" = ''
),
"Sexe" = forcats::fct_recode(col,
"Homme" = "1",
"Femme" = "2",
"Inconnu" = "9",
"Inconnu" = '0',
"Inconnu" = ''
)))
if (facteur == T){return(r)}else{return(as.character(r))}
}
##############################################
####################### DB ###################
##############################################
`%+%` <- function(x,y){paste0(x,y)}
#' ~ db - Copier les rsa dans une db
#'
#' Copier les rsa, les passages um, les actes et les diagnostics des rsa, et ano dans une db
#'
#' Les tables sont importées dans R puis copiées dans la db.
#' La table diag est créée, les variables ghm, année séquentielle des tarifs
#' et un champ caractère diagnostics sont ajoutés à la table rsa.
#' Le tra est ajouté aux tables.
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param p le noyau pmeasyr
#' @param remove a TRUE, les tables precedentes rsa de l'annee sont effacees avant
#' @param zip a TRUE les fichiers des archives sont dezippes et effaces apres integration dans la db
#' @param indexes index a ajouter a la table dans la base (voir \code{\link[dplyr]{copy_to}})
#' @return nothing
#' @export
#'
#' @usage db_mco_out(con, p, remove = T, zip = T, indexes = list(), ...)
#' @examples
#' \dontrun{
#' purrr::quietly(db_mco_out)(con, p) -> statuts ; gc(); #ok
#' purrr::quietly(db_mco_out)(con, p, annee = 2017, mois = 7) -> statuts ; gc(); #..
#' }
db_mco_out <- function (con, p, remove = T, zip = T, indexes = list(), ...){
p <- utils::modifyList(p, list(...))
an <- substr(as.character(p$annee), 3, 4)
if (remove == T) {
#u <- DBI::dbListTables(con)
u <- dplyr::src_tbls(con)
lr <- u[grepl("_rsa_", u) & grepl(an, u)]
lapply(lr, function(x) {
DBI::dbRemoveTable(con$con, x)
})
}
if (zip == T) {
adezip(p, type = "out", liste = c("rsa", "ano", "tra"))
}
rsa <- pmeasyr::irsa(p, typi = 6) %>% pmeasyr::tdiag()
rsa_ano <- pmeasyr::iano_mco(p)
tra <- pmeasyr::itra(p)
rsa$rsa <- pmeasyr::inner_tra(rsa$rsa, tra) %>% mutate(diags = paste0(dpdrum,
das, sep = " "))
rsa$actes <- pmeasyr::inner_tra(rsa$actes, tra)
rsa$diags <- pmeasyr::inner_tra(rsa$diags, tra)
rsa$rsa_um <- pmeasyr::inner_tra(rsa$rsa_um, tra)
rsa_ano <- pmeasyr::inner_tra(rsa_ano, tra)
purrr::flatten_int(purrr::map(indexes, length)) -> t_1
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsa$rsa))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsa$rsa), "mco_" %+% an %+% "_rsa_rsa", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsa$actes))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsa$actes), "mco_" %+% an %+% "_rsa_actes", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsa$diags))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsa$diags), "mco_" %+% an %+% "_rsa_diags", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsa$rsa_um))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsa$rsa_um), "mco_" %+% an %+% "_rsa_um", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsa_ano))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsa_ano), "mco_" %+% an %+% "_rsa_ano", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
if (zip == T) {
pmeasyr::adelete(p)
}
}
#' ~ db - Copier les rha dans une db
#'
#' Copier les rha, les actes, les diagnostics des rha, ssrha et ano dans une db
#'
#' Les tables sont importées dans R puis copiées dans la db.
#' Le tra est ajouté aux tables.
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param p le noyau pmeasyr
#' @param remove a TRUE, les tables precedentes rha de l'annee sont effacees avant
#' @param zip a TRUE les fichiers des archives sont dezippes et effaces apres integration dans la db
#' @param indexes index a ajouter a la table dans la base (voir \code{\link[dplyr]{copy_to}})
#' @return nothing
#' @export
#'
#' @usage db_ssr_out(con, p, remove = T, zip = T, indexes = list(), ...)
#' @examples
#' \dontrun{
#' purrr::quietly(db_ssr_out)(con, p) -> statuts ; gc(); #ok
#' purrr::quietly(db_ssr_out)(con, p, annee = 2017, mois = 7) -> statuts ; gc(); #..
#' }
db_ssr_out <- function (con, p, remove = T, zip = T, indexes = list(), ...){
p <- utils::modifyList(p, list(...))
an <- substr(as.character(p$annee), 3, 4)
if (remove == T) {
#u <- DBI::dbListTables(con)
u <- dplyr::src_tbls(con)
lr <- u[grepl("ssr", u) & grepl(an, u)]
lapply(lr, function(x) {
DBI::dbRemoveTable(con$con, x)
})
}
if (zip == T) {
pmeasyr::adezip(p, type = "out", liste = c("rha", "ano",
"sha", "tra"))
}
rha <- pmeasyr::irha(p)
ssrha <- pmeasyr::issrha(p)
rha_ano <- pmeasyr::iano_ssr(p)
tra <- pmeasyr::itra(p, champ = "ssr")
rha$rha <- pmeasyr::inner_tra(rha$rha, tra, champ = "ssr")
rha$acdi <- pmeasyr::inner_tra(rha$acdi, tra, champ = "ssr")
if (p$annee > 2016) {
ssrha$ssrha <- pmeasyr::inner_tra(ssrha$ssrha, tra, champ = "ssr")
ssrha$gme <- pmeasyr::inner_tra(ssrha$gme, tra, champ = "ssr")
}
else {
ssrha <- pmeasyr::inner_tra(ssrha, tra, champ = "ssr")
}
rha_ano <- pmeasyr::inner_tra(rha_ano, tra, champ = "ssr")
purrr::flatten_int(purrr::map(indexes, length)) -> t_1
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rha$rha))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rha$rha), "ssr_" %+% an %+% "_rha_rha", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rha$acdi))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rha$acdi), "ssr_" %+% an %+% "_rha_acdi", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rha_ano))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rha_ano), "ssr_" %+% an %+% "_rha_ano", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
if (p$annee > 2016) {
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(ssrha$ssrha))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(ssrha$ssrha), "ssr_" %+% an %+% "_rha_ssrha", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(ssrha$gme))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(ssrha$gme), "ssr_" %+% an %+% "_rha_gme", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
}
else {
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(ssrha))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(ssrha), "ssr_" %+% an %+% "_rha_ssrha", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
}
if (zip == T) {
pmeasyr::adelete(p)
}
}
#' ~ db - Copier les rapss dans une db
#'
#' Copier les rapss, les actes, les diagnostics et la table ano des rapss dans une db
#'
#' Les tables sont importées dans R puis copiées dans la db.
#' Le tra est ajouté aux tables.
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param p le noyau pmeasyr
#' @param remove a TRUE, les tables precedentes rapss de l'annee sont effacees avant
#' @param zip a TRUE les fichiers des archives sont dezippes et effaces apres integration dans la db
#' @param indexes index a ajouter a la table dans la base (voir \code{\link[dplyr]{copy_to}})
#' @return nothing
#' @export
#'
#' @usage db_had_out(con, p, remove = T, zip = T, indexes = list(), ...)
#' @examples
#' \dontrun{
#' purrr::quietly(db_had_out)(con, p) -> statuts ; gc(); #ok
#' purrr::quietly(db_had_out)(con, p, annee = 2017, mois = 7) -> statuts ; gc(); #..
#' }
db_had_out <- function (con, p, remove = T, zip = T, indexes = list(), ...){
p <- utils::modifyList(p, list(...))
an <- substr(as.character(p$annee), 3, 4)
if (remove == T) {
#u <- DBI::dbListTables(con)
u <- dplyr::src_tbls(con)
lr <- u[grepl("_rapss_", u) & grepl(an, u)]
lapply(lr, function(x) {
DBI::dbRemoveTable(con$con, x)
})
}
if (zip == T) {
pmeasyr::adezip(p, type = "out", liste = c("rapss", "ano",
"tra"))
}
rapss <- pmeasyr::irapss(p)
rapss_ano <- pmeasyr::iano_had(p)
tra <- pmeasyr::itra(p, champ = "had")
rapss$rapss <- pmeasyr::inner_tra(rapss$rapss, tra, champ = "had")
rapss$acdi <- pmeasyr::inner_tra(rapss$acdi, tra, champ = "had")
rapss_ano <- pmeasyr::inner_tra(rapss_ano, tra, champ = "had")
purrr::flatten_int(purrr::map(indexes, length)) -> t_1
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rapss$rapss))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rapss$rapss), "had_" %+% an %+% "_rapss_rapss", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rapss$acdi))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rapss$acdi), "had_" %+% an %+% "_rapss_acdi", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rapss_ano))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rapss_ano), "had_" %+% an %+% "_rapss_ano", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
if (zip == T) {
pmeasyr::adelete(p)
}
}
#' ~ db - Copier les rpsa dans une db
#'
#' Copier les rpsa, les actes, les diagnostics et la table ano des rpsa dans une db
#'
#' Les tables sont importées dans R puis copiées dans la db.
#' Le tra est ajouté aux tables.
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param p le noyau pmeasyr
#' @param remove a TRUE, les tables precedentes rpsa de l'annee sont effacees avant
#' @param zip a TRUE les fichiers des archives sont dezippes et effaces apres integration dans la db
#' @param indexes index a ajouter a la table dans la base (voir \code{\link[dplyr]{copy_to}})
#' @return nothing
#' @export
#'
#' @usage db_psy_out(con, p, remove = T, zip = T, indexes = list(), ...)
#' @examples
#' \dontrun{
#' purrr::quietly(db_psy_out)(con, p) -> statuts ; gc(); #ok
#' purrr::quietly(db_psy_out)(con, p, annee = 2017, mois = 6) -> statuts ; gc(); #..
#' }
db_psy_out <- function (con, p, remove = T, zip = T, indexes = list(), ...){
p <- utils::modifyList(p, list(...))
an <- substr(as.character(p$annee), 3, 4)
if (remove == T) {
#u <- DBI::dbListTables(con)
u <- dplyr::src_tbls(con)
lr <- u[grepl("psy", u) & grepl(an, u)]
lapply(lr, function(x) {
DBI::dbRemoveTable(con$con, x)
})
}
if (zip == T) {
pmeasyr::adezip(p, type = "out", liste = c("rpsa", "ano",
"tra", "tra.raa", "r3a"))
}
rpsa <- pmeasyr::irpsa(p)
rpsa_ano <- pmeasyr::iano_psy(p)
r3a <- pmeasyr::ir3a(p)
tra_rpsa <- pmeasyr::itra(p, champ = "psy_rpsa")
tra_r3a <- pmeasyr::itra(p, champ = "psy_r3a")
rpsa$rpsa <- pmeasyr::inner_tra(rpsa$rpsa, tra_rpsa, champ = "psy_rpsa")
rpsa$das <- pmeasyr::inner_tra(rpsa$das, tra_rpsa, champ = "psy_rpsa")
if (p$annee > 2016) {
rpsa$actes <- pmeasyr::inner_tra(rpsa$actes, tra_rpsa)
}
rpsa_ano <- pmeasyr::inner_tra(rpsa_ano, tra_rpsa, champ = "psy_rpsa")
r3a$r3a <- pmeasyr::inner_tra(r3a$r3a, tra_r3a, champ = "psy_r3a")
r3a$da <- pmeasyr::inner_tra(r3a$da, tra_r3a, champ = "psy_r3a")
purrr::flatten_int(purrr::map(indexes, length)) -> t_1
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rpsa$rpsa))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rpsa$rpsa), "psy_" %+% an %+% "_rpsa_rpsa", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rpsa$das))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rpsa$das), "psy_" %+% an %+% "_rpsa_das", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
if (p$annee > 2016) {
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rpsa$actes))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rpsa$actes), "psy_" %+% an %+% "_rpsa_actes", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
}
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rpsa_ano))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rpsa_ano), "psy_" %+% an %+% "_rpsa_ano", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(r3a$r3a))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(r3a$r3a), "psy_" %+% an %+% "_r3a_r3a", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(r3a$das))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(r3a$das), "psy_" %+% an %+% "_r3a_das", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
if (zip == T) {
pmeasyr::adelete(p)
}
}
#' ~ db - Copier les rum dans une db
#'
#' Copier les rum, les actes et les diagnostics des rums dans une db
#'
#' Les tables sont importées dans R puis copiées dans la db
#' La table diag est créée et la durée des rum est calculée (DUREESEJPART)
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param p le noyau pmeasyr
#' @param remove a TRUE, les tables precedentes rum de l'annee sont effacees avant
#' @param zip a TRUE les fichiers des archives sont dezippes et effaces apres integration dans la db
#' @param indexes index a ajouter a la table dans la base (voir \code{\link[dplyr]{copy_to}})
#' @return nothing
#' @export
#'
#' @usage db_mco_in(con, p, remove = T, zip = T, indexes = list(), ...)
#' @examples
#' \dontrun{
#' purrr::quietly(db_mco_in)(con, p) -> statuts ; gc(); #ok
#' purrr::quietly(db_mco_in)(con, p, annee = 2015) -> statuts ; gc(); #..
#' }
db_mco_in <- function (con, p, remove = T, zip = T, indexes = list(), ...) {
p <- utils::modifyList(p, list(...))
an <- substr(as.character(p$annee), 3, 4)
if (remove == T) {
#u <- DBI::dbListTables(con)
u <- dplyr::src_tbls(con)
lr <- u[grepl("_rum_", u) & grepl(an, u)]
lapply(lr, function(x) {
dbRemoveTable(con$con, x)
})
}
if (zip == T) {
pmeasyr::adezip(p, type = "in", liste = "rss")
}
rum <- pmeasyr::irum(p, typi = 4) %>% pmeasyr::tdiag()
purrr::flatten_int(purrr::map(indexes, length)) -> t_1
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rum$rum))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rum$rum), "mco_" %+% an %+% "_rum_rum", temporary = FALSE, overwrite = TRUE, indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rum$diags))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rum$diags), "mco_" %+% an %+% "_rum_diags", temporary = FALSE, overwrite = TRUE, indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rum$actes))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rum$actes), "mco_" %+% an %+% "_rum_actes", temporary = FALSE, overwrite = TRUE, indexes = indexes[t_1 == t_2])
if (zip == T) {
pmeasyr::adelete(p)
}
}
#' ~ db - Copier les rsf dans une db
#'
#' Copier tous les rsf (lettre par lettre, A, B, C, ...), les ano-ace dans une db
#'
#' Les tables sont importées dans R puis copiées dans la db
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param p le noyau pmeasyr
#' @param remove a TRUE, les tables precedentes rafael de l'annee sont effacees avant
#' @param zip a TRUE les fichiers des archives sont dezippes et effaces apres integration dans la db
#' @param indexes index a ajouter a la table dans la base (voir \code{\link[dplyr]{copy_to}})
#' @return nothing
#'
#' @import DBI
#' @export
#'
#' @usage db_rsf_out(con, p, remove = T, zip = T, indexes = list(), ...)
#' @examples
#' \dontrun{
#' purrr::quietly(db_rsf_out)(con, p) -> statuts ; gc(); #ok
#' purrr::quietly(db_rsf_out)(con, p, annee = 2014) -> statuts ; gc(); #ok
#' }
db_rsf_out <- function (con, p, remove = T, zip = T, indexes = list(), ...){
p <- utils::modifyList(p, list(...))
an <- substr(as.character(p$annee), 3, 4)
if (remove == T) {
u <- dplyr::src_tbls(con)
lr <- u[grepl("_rafael_", u) & grepl(an, u)]
lapply(lr, function(x) {
DBI::dbRemoveTable(con$con, x)
})
}
if (zip == T) {
pmeasyr::adezip(p, type = "out", liste = c("rsfa", "ano-ace"))
}
rsf <- pmeasyr::irafael(p)
rsf_ano <- pmeasyr::iano_rafael(p)
purrr::flatten_int(purrr::map(indexes, length)) -> t_1
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf$A))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf$A), "rsf_" %+% an %+% "_rafael_a", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf$B))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf$B), "rsf_" %+% an %+% "_rafael_b", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf$C))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf$C), "rsf_" %+% an %+% "_rafael_c", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf$H))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf$H), "rsf_" %+% an %+% "_rafael_h", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf$L))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf$L), "rsf_" %+% an %+% "_rafael_l", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf$M))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf$M), "rsf_" %+% an %+% "_rafael_m", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf$P))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf$P), "rsf_" %+% an %+% "_rafael_p", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(rsf_ano))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(rsf_ano), "rsf_" %+% an %+% "_rafael_ano", temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
if (zip == T) {
pmeasyr::adelete(p)
}
}
#' ~ db - Lister les tables d'une db en tableau
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param nb le nombre de lignes du tableau
#'
#' @return nothing
#' @export
#'
#' @usage db_liste_tables(con, nb = 15)
#' @examples
#' \dontrun{
#' db_liste_tables(con)
#' }
#' @export
db_liste_tables <- function(con, nb = 15){
DBI::dbListTables(con) -> liste
suppressWarnings(matrix(c(sort(liste), rep('',nb - length(liste) %% nb)),
nrow = nb)) %>% tibble::as_tibble() %>%
knitr::kable(col.names = paste0(nb %+% ' tables, n°',
1:(floor((length(liste)/ nb) )+1)))
}
#' ~ db - remote access aux tables mco
#'
#' @param con Connexion à la base de données
#' @param an Année pmsi (ex: 16)
#' @param table Table à requêter
#' @return remote table
#'
#' @usage tbl_mco(con, an, table)
#' @examples
#' \dontrun{
#' tbl_mco(con, 16, 'rsa_rsa')
#' }
#' @export
tbl_mco <- function(con, an, table){
dplyr::tbl(con, 'mco_' %+% an %+% '_' %+% table)
}
#' ~ db - remote access aux tables rsf
#'
#' @param con Connexion à la base de données
#' @param an Année pmsi (ex: 16)
#' @param table Table à requêter
#' @return remote table
#'
#' @usage tbl_rsf(con, an, table)
#' @examples
#' \dontrun{
#' tbl_rsf(con, 16, 'rsf_rafael_ano')
#' }
#' @export
tbl_rsf <- function(con, an, table){
dplyr::tbl(con, 'rsf_' %+% an %+% '_' %+% table)
}
#' ~ db - remote access aux tables ssr
#'
#' @param con Connexion à la base de données
#' @param an Année pmsi (ex: 16)
#' @param table Table à requêter
#' @return remote table
#'
#' @usage tbl_ssr(con, an, table)
#' @examples
#' \dontrun{
#' tbl_ssr(con, 16, 'rha_rha')
#' }
#' @export
tbl_ssr <- function(con, an, table){
dplyr::tbl(con, 'ssr_' %+% an %+% '_' %+% table)
}
#' ~ db - remote access aux tables had
#'
#' @param con Connexion à la base de données
#' @param an Année pmsi (ex: 16)
#' @param table Table à requêter
#' @return remote table
#' @return tibble
#'
#' @usage tbl_had(con, an, table)
#' @examples
#' \dontrun{
#' tbl_had(con, 16, 'rapss_rapss')
#' }
#' @export
tbl_had <- function(con, an, table){
dplyr::tbl(con, 'had_' %+% an %+% '_' %+% table)
}
#' ~ db - remote access aux tables psy
#'
#' @param con Connexion à la base de données
#' @param an Année pmsi (ex: 16)
#' @param table Table à requêter
#' @return remote table
#' @return tibble
#'
#' @usage tbl_psy(con, an, table)
#' @examples
#' \dontrun{
#' tbl_psy(con, 16, 'rpsa_rpsa')
#' }
#' @export
tbl_psy <- function(con, an, table){
dplyr::tbl(con, 'psy_' %+% an %+% '_' %+% table)
}
#' ~ db - Copier un tibble dans une db
#'
#' Copier une table R dans une db
#'
#' La tables déjà importée dans R est copiée dans la db
#'
#' @param con la connexion a la base de donnees (src_..)
#' @param an l'annee pmsi
#' @param table La table R (tibble) a copier dans la db
#' @param prefix prefixe de la table dans la db (ex : mco, rsf, ssr, ...)
#' @param suffix suffixe de la table dans la db (ex : rum_rum, rha_actes, rapss_rapss, ...)
#' @param indexes index a ajouter a la table dans la base (voir \code{\link[dplyr]{copy_to}})
#'
#' @return nothing
#'
#'
#' @usage db_generique(con, an, table, prefix, suffix, indexes = list(), remove = T)
#' @examples
#' \dontrun{
#' purrr::quietly(db_generique)(con, 16, ma_table, 'had', 'rapss_ano') -> statuts ; gc(); #
#' # Result in db : had_16_rapss_ano
#' }
#' @export
db_generique <- function(con, an, table, prefix, suffix, indexes = list(), remove = T){
nom <- prefix %+% "_" %+% an %+% "_" %+% suffix
if (remove == T){
#DBI::dbListTables(con) -> u
dplyr::src_tbls(con) -> u
if (length(u[u == nom])>0){
DBI::dbRemoveTable(con$con, nom)}
}
purrr::flatten_int(purrr::map(indexes, length)) -> t_1
purrr::flatten_int(purrr::map(indexes, function(x)(sum(x %in% names(table))))) -> t_2
dplyr::copy_to(con, dplyr::as_tibble(table), nom, temporary = FALSE, overwrite = TRUE,
indexes = indexes[t_1 == t_2])
}
##############################################
################## REQUETES ##################
##############################################
#' ~ req : mise en forme d'une liste de codes
#'
#'
#' @examples
#' \dontrun{
#' li <- c('QEFA003', 'QEFA005', 'QEFA010', 'QEFA013', 'QEFA015', 'QEFA019', 'QEFA020')
#'
#' enrobeur(li, robe="", interstice="|") %>% cat()
#'
#' enrobeur(li, robe="\'", interstice=",") %>% cat()
#'
#' enrobeur(li, robe="\'%", interstice="\n", symetrique = T) %>% cat()
#' }
#'
#' @author G. Pressiat
#' voir \url{https://guillaumepressiat.shinyapps.io/transcodeur/} pour son utilisation interactive hors AP-HP
#' @export
enrobeur <- function(a, robe = "\'", colonne = F, interstice = ", ", symetrique = F){
strReverse <- function(x) sapply(lapply(strsplit(x, NULL), rev), paste,
collapse="")
b <- paste0(robe,a,ifelse(symetrique == F,robe, strReverse(robe)))
if (colonne == F){
return(paste0(b, collapse = interstice))
}
else { return(b)}
}
#' ~ req : requeter les rsa avec une liste
#'
#'
#' @examples
#' \dontrun{
#' liste = list(actes = c('EBLA003', 'EQLF002'))
#' requete(rsa, liste)
#'
#' liste = list(actes = c('EBLA003', 'EQLF002'), dureemax = 0)
#' requete(rsa, liste)
#' }
#'
#' @return un tibble contenant les rsa respectant la requete : les rsa qui ont un acte de la liste, un diag, une duree correspondante, etc.
#'
#' @author G. Pressiat
#' @importFrom dplyr mutate inner_join select filter_ distinct tibble tibble data_frame
#' @importFrom purrr flatten_chr
#' @importFrom sqldf sqldf
#' @export
requete <- function (tables, elements, vars = NULL) {
chaine = list()
if (length(elements[["ghm"]]) > 0) {
chaine$ghm <- paste0("grepl('", enrobeur(elements$ghm,
robe = "", colonne = F, interstice = "|"), "', ghm) ")
}
if (length(elements[["ghm_exclus"]]) > 0) {
chaine$ghm_exclus <- paste0("!grepl('", enrobeur(elements$ghm_exclus,
robe = "", colonne = F, interstice = "|"), "', ghm) ")
}
if (length(elements[["diags_exclus"]]) > 0) {
chaine$diags_exclus = paste0("!grepl('", enrobeur(elements$diags_exclus,
robe = "", colonne = F, interstice = "|"), "', diags) ")
}
if (length(elements[["agemin"]]) > 0) {
chaine$agemin = paste0("agean >= ", elements$agemin)
}
if (length(elements[["agemax"]]) > 0) {
chaine$agemax = paste0("agean <= ", elements$agemax)
}
if ((length(elements[["agejrmin"]]) > 0) & ((length(elements[["agemmax"]]) >
0) | (length(elements[["agemin"]]) > 0))) {
chaine$agejrmin = paste0("agean >= ", elements$agejrmin/365.25)
}
if ((length(elements[["agejrmax"]]) > 0) & ((length(elements[["agemmax"]]) >
0) | (length(elements[["agemin"]]) > 0))) {
chaine$agejrmax = paste0("agean <= ", elements$agejrmax/365.25)
}
if (length(elements[["agejrmin"]]) > 0 & (length(elements[["agemmax"]]) ==
0) & (length(elements[["agemin"]]) == 0)) {
chaine$agejrmin = paste0("!is.na(agejr) & agejr >= ",
elements$agejrmin)
}
if (length(elements[["agejrmax"]]) > 0 & (length(elements[["agemmax"]]) ==
0) & (length(elements[["agemin"]]) == 0)) {
chaine$agejrmin = paste0("!is.na(agejr) & agejr <= ",
elements$agejrmax)
}
if (length(elements[["dureemax"]]) > 0) {
chaine$dureemax = paste0("duree <= ", elements$dureemax)
}
if (length(elements[["dureemin"]]) > 0) {
chaine$dureemin <- paste0("duree >= ", elements$dureemin)
}
if (length(elements[["poidsmin"]]) > 0) {
chaine$poidsmin <- paste0("poids >= ", elements$poidsmin)
}
if (length(elements[["poidsmax"]]) > 0) {
chaine$podsmax <- paste0("poids <= ", elements$poidsmax)
}
if (length(elements[["autres"]]) > 0) {
if (!identical(chaine, character())) {
chaine$autres <- paste0(elements$autres)
}
else {
chaine <- paste0(elements$autres)
}
}
if (length(chaine) == 0) {
chaine = list("TRUE")
}
chaine <- rlang::parse_exprs(paste0(purrr::flatten_chr(chaine),
collapse = " & ")) # Again, note the plural s
rsa_filtre <- tables$rsa %>% dplyr::filter(!!!chaine) %>%
dplyr::select(cle_rsa)
# rsa_filtre <- tables$rsa %>% filter_(paste0(purrr::flatten_chr(chaine),
# collapse = " & ")) %>% select(cle_rsa)
if (length(elements[["diags"]]) > 0) {
if (elements[["positions_diags"]][1] == "toutes") {
d <- tables$diags
s <- paste0("select distinct cle_rsa from d where ",
paste0("diag like '", elements$diags, "%'",
collapse = " or "))
diags <- sqldf::sqldf(s) %>% tibble::as_tibble()
}
else if (elements[["positions_diags"]][1] == "dp") {
d <- tables$rsa
s <- paste0("select cle_rsa from d where (",
paste0("dp like '", elements$diags, "%'",
collapse = " or "), ")")
diags <- sqldf::sqldf(s) %>% tibble::as_tibble() %>%
dplyr::select(cle_rsa)
}
else {
d <- tables$diags
s <- paste0("select distinct cle_rsa from d where position in (",
paste0(elements$positions_diags, collapse = ", "),
") and ( ", paste0("diag like '", elements$diags,
"%'", collapse = " or "), " )")
diags <- sqldf::sqldf(s) %>% tibble::as_tibble()
}}
else {
diags = dplyr::tibble()
}
if (length(elements[["actes"]]) > 0) {
liste_actes = tibble::tibble(cdccam = elements$actes) %>%
tibble::as_tibble()
if (length(elements[["activite_actes"]]) > 0) {
actes = dplyr::inner_join(tables$actes %>% filter(act %in%
elements[["activite_actes"]]), liste_actes,
by = c(cdccam = "cdccam")) %>% dplyr::distinct(cle_rsa)
}
else {
actes = dplyr::inner_join(tables$actes, liste_actes,
by = c(cdccam = "cdccam")) %>% dplyr::distinct(cle_rsa)
}
}
else {
actes = dplyr::tibble()
}
resultat <- tables$rsa %>% dplyr::inner_join(rsa_filtre,
by = "cle_rsa")
if (length(elements[["actes"]]) > 0) {
resultat <- resultat %>% dplyr::inner_join(actes, by = "cle_rsa")
}
if (length(elements[["diags"]]) > 0) {
resultat <- resultat %>% dplyr::inner_join(diags, by = "cle_rsa")
}
resultat
if (is.null(vars)) {
return(dplyr::distinct(resultat, cle_rsa))
}
else {
return(resultat %>% dplyr::select(cle_rsa, vars))
}
}
#' ~ req : requeter les rsa dans une db avec une liste
#'
#' @examples
#' \dontrun{
#' liste = list(actes = c('EBLA003', 'EQLF002'))
#' requete_db(con, an, liste)
#'
#' liste = list(actes = c('EBLA003', 'EQLF002'), dureemax = 0)
#' requete_db(con, 16, liste)
#' }
#'
#' @return un tibble contenant les rsa respectant la requete : les rsa qui ont un acte de la liste, un diag, une duree correspondante, etc.
#'
#' @author G. Pressiat
#' @importFrom dplyr mutate inner_join select filter_ distinct tibble tibble data_frame
#' @export
requete_db <- function (con, an, elements, vars = NULL)
{
chaine = list()
if (length(elements[["ghm"]]) > 0) {
chaine$ghm <- paste0("(", paste0("ghm %like% '", elements$ghm,
"%'", collapse = " | "), ")")
}
if (length(elements[["ghm_exclus"]]) > 0) {
chaine$ghm_exclus <- paste0("(", paste0("!(ghm %like% '",
elements$ghm_exclus, "%')", collapse = " & "), ")")
}
if (length(elements[["agemin"]]) > 0) {
chaine$agemin = paste0("agean >= ", elements$agemin)
}
if (length(elements[["agemax"]]) > 0) {
chaine$agemax = paste0("agean <= ", elements$agemax)
}
if ((length(elements[["agejrmin"]]) > 0) & ((length(elements[["agemmax"]]) >
0) | (length(elements[["agemin"]]) > 0))) {
chaine$agejrmin = paste0("agean >= ", elements$agejrmin/365.25)
}
if ((length(elements[["agejrmax"]]) > 0) & ((length(elements[["agemmax"]]) >
0) | (length(elements[["agemin"]]) > 0))) {
chaine$agejrmax = paste0("agean <= ", elements$agejrmax/365.25)
}
if (length(elements[["agejrmin"]]) > 0 & (length(elements[["agemmax"]]) ==
0) & (length(elements[["agemin"]]) == 0)) {
chaine$agejrmin = paste0("!is.na(agejr) & agejr >= ",
elements$agejrmin)
}
if (length(elements[["agejrmax"]]) > 0 & (length(elements[["agemmax"]]) ==
0) & (length(elements[["agemin"]]) == 0)) {
chaine$agejrmin = paste0("!is.na(agejr) & agejr <= ",
elements$agejrmax)
}
if (length(elements[["dureemax"]]) > 0) {
chaine$dureemax = paste0("duree <= ", elements$dureemax)
}
if (length(elements[["dureemin"]]) > 0) {
chaine$dureemin <- paste0("duree >= ", elements$dureemin)
}
if (length(elements[["poidsmin"]]) > 0) {
chaine$poidsmin <- paste0("poids >= ", elements$poidsmin)
}
if (length(elements[["poidsmax"]]) > 0) {
chaine$podsmax <- paste0("poids <= ", elements$poidsmax)
}
if (length(elements[["autres"]]) > 0) {
if (!identical(chaine, character())) {
chaine$autres <- paste0(elements$autres)
}
else {
chaine <- paste0(elements$autres)
}
}
if (length(chaine) == 0) {
chaine = list("TRUE")
}
chaine <- rlang::parse_exprs(paste0(purrr::flatten_chr(chaine),
collapse = " & "))
rsa_filtre <- tbl_mco(con, an, "rsa_rsa") %>% dplyr::filter(!!!chaine) %>% dplyr::select(cle_rsa)
if (length(elements[["diags"]]) > 0) {
if (elements[["positions_diags"]][1] == "toutes"){
chaine_d <- paste0("(", paste0("diag %like% '",elements$diags, "%'", collapse = " | "), ' )')
} else
if (elements[["positions_diags"]][1] == "dp"){
chaine_d <- paste0("position == '1' & ( ", paste0("diag %like% '",elements$diags, "%'", collapse = " | "), ' )')
} else {
chaine_d <- paste0("position %in% c(", paste0(elements$positions_diags,
collapse = ", "), ") & (", paste0("diag %like% '",
elements$diags, "%'", collapse = " | "), ' )')
}
chaine_d <- rlang::parse_exprs(chaine_d)
diags_filtre <- tbl_mco(con, an, "rsa_diags") %>%
dplyr::filter(!!!chaine_d) %>% dplyr::distinct(cle_rsa)
}
else {
diags_filtre <- NULL
}
if (length(elements[["diags_exclus"]]) > 0) {
chaine_d <- paste0('( ', paste0("diag %like% '", elements$diags_exclus, "%'", collapse = " | "), ' )')
chaine_d <- rlang::parse_exprs(chaine_d)
antidiags_filtre <- tbl_mco(con, an, "rsa_diags") %>%
dplyr::filter(!!!chaine_d) %>% dplyr::distinct(cle_rsa)
}
else {
antidiags_filtre <- NULL
}
if (length(elements[["actes"]]) > 0) {
if (length(elements[["activite_actes"]]) > 0){
liste_actes = dplyr::data_frame(cdccam = elements$actes) %>%
dplyr::tibble() %>% dplyr::copy_to(con, ., "acc",
overwrite = T)
actes_filtre = dplyr::inner_join(tbl_mco(con, an, "rsa_actes") %>% filter(act %in% elements[['activite_actes']]),
dplyr::tbl(con, "acc"), by = c(cdccam = "cdccam")) %>%
dplyr::distinct(cle_rsa)
} else {
liste_actes = dplyr::data_frame(cdccam = elements$actes) %>%
dplyr::tibble() %>% dplyr::copy_to(con, ., "acc",
overwrite = T)
actes_filtre = dplyr::inner_join(tbl_mco(con, an, "rsa_actes"),
dplyr::tbl(con, "acc"), by = c(cdccam = "cdccam")) %>%
dplyr::distinct(cle_rsa)
}
}
else {
actes_filtre = NULL
}
resultat <- rsa_filtre
if (length(elements[["diags"]]) > 0) {
resultat <- resultat %>% dplyr::inner_join(diags_filtre,
by = "cle_rsa")
}
if (length(elements[["diags_exclus"]]) > 0) {
resultat <- resultat %>% dplyr::anti_join(antidiags_filtre,
by = "cle_rsa")
}
if (length(elements[["actes"]]) > 0) {
resultat <- resultat %>% dplyr::inner_join(actes_filtre,
by = "cle_rsa")
}
if (is.null(vars)) {
return(resultat %>% dplyr::collect())
}
else {
return(resultat %>% dplyr::inner_join(tbl_mco(con,
an, "rsa_rsa") %>% dplyr::select(cle_rsa, vars),
by = "cle_rsa") %>% dplyr::collect())
}
}
#' ~ req : lancer une ou plusieurs requetes dans une db avec une ou des listes
#'
#'
#' @examples
#' \dontrun{
#' get_all_listes('Recours Exceptionnel') -> listes_re
#' lancer_requete_db(con, an, listes_re)
#'
#' get_liste('chir_bariatrique_total') -> liste_bari
#' lancer_requete_db(con, an, liste_bari)
#' }
#'
#' @return un tibble concatenant les resultats de toutes les requetes : les rsa qui ont un acte de la liste, un diag, une duree correspondante, etc.
#' @author G. Pressiat
#' @importFrom dplyr mutate bind_rows
#' @export
lancer_requete_db <- function(con, an, elements, vars = NULL){
if (length(elements$nom) == 1){
cat(elements$nom, "\n")
return(elements %>%
requete_db(con, an, ., vars) %>%
dplyr::mutate(Requete = elements$nom,
Thematique = elements$thematique))}
else {
return(dplyr::bind_rows(lapply(elements,
function(elements1){
cat(elements1$nom, "\n")
elements1 %>%
requete_db(con, an, ., vars) %>%
dplyr::mutate(Requete = elements1$nom,
Thematique = elements1$thematique)})))}
}
#' ~ req : lancer une ou plusieurs requetes avec une ou des listes
#'
#'
#' @examples
#' \dontrun{
#' prepare_rsa(rsa) -> rsa
#' get_all_listes('Recours Exceptionnel') -> listes_re
#' lancer_requete(rsa, listes_re)
#'
#' get_liste('chir_bariatrique_total') -> liste_bari
#' lancer_requete(rsa, liste_bari)
#' }
#'
#' @return un tibble concatenant les resultats de toutes les requetes : les rsa qui ont un acte de la liste, un diag, une duree correspondante, etc.
#' @author G. Pressiat
#' @importFrom dplyr mutate bind_rows
#' @export
lancer_requete <- function(tables, elements, vars = NULL){
if (length(elements$nom) == 1){
cat(elements$nom, "\n")
return(elements %>%
requete(tables, ., vars) %>%
dplyr::mutate(Requete = elements$nom,
Thematique = elements$thematique))}
else {
return(dplyr::bind_rows(lapply(elements,
function(elements1){
cat(elements1$nom, "\n")
elements1 %>%
requete(tables, ., vars) %>%
dplyr::mutate(Requete = elements1$nom,
Thematique = elements1$thematique)})))}
}
#' ~ req : preparer les rsa pour la requete
#'
#' On selectionne certaines variables et on en cree d'autres utiles lors de l'execution de la requete
#'
#' @examples
#' \dontrun{
#' tab <- irsa(typi = 6)
#' prepare_rsa(tab)
#' }
#'
#' @return un objet de classe rsa de pmeasyr
#' @author G. Pressiat
#' @importFrom dplyr select mutate
#' @importFrom tidyr unite
#' @export
prepare_rsa <- function(rsa){
rsa$rsa <- rsa$rsa %>%
# tidyr::unite(ghm, RSACMD, RSATYPE, RSANUM, RSACOMPX, sep = "") %>%
#dplyr::select(NOFINESS, CLE_RSA, NOSEQRUM, MOISSOR, ghm, DP, DR, ECHPMSI, PROV, DEST, SCHPMSI, AGEAN,POIDS, AGEJR, dpdrum, DUREE, das, actes, um) %>%
dplyr::mutate(diags = paste(dpdrum, das),
agean = dplyr::if_else(is.na(agean), as.numeric(agejr)/365.25, as.numeric(agean))) %>%
dplyr::mutate(rsatype = substr(ghm, 3,3))
rsa <- tdiag(rsa)
# sjlabelled::remove_all_labels(rsa$rsa) -> rsa$rsa
# sjlabelled::remove_all_labels(rsa$actes) -> rsa$actes
# sjlabelled::remove_all_labels(rsa$diags) -> rsa$diags
# sjlabelled::remove_all_labels(rsa$rsa_um) -> rsa$rsa_um
return(rsa)
}
#' ~ req : collecter les rsa présents dans une db
#'
#' On selectionne certaines variables et on en cree d'autres utiles lors de l'execution de la requete
#'
#' @param con Connexion à la base de données
#' @param an année des rsa (ex: 17)
#' @param n Nombre de lignes à importer (équivalent `head`)
#' @examples
#' \dontrun{
#' rsa <- collect_rsa_from_db(con, 16, n = 1e5)
#' }
#'
#' @return un liste rsa similaire à un import de pmeasyr
#' @author G. Pressiat
#' @export
collect_rsa_from_db <- function(con, an, n = Inf){
rsa <- list()
to_up <- function(table){
names(table) <- toupper(names(table))
table
}
# %>% to_up() %>% rename(ghm = GHM,
# dpdrum = DPDRUM,
# das = DAS,
# actes = ACTES, um = UM)
tbl_mco(con, an, 'rsa_rsa') %>% dplyr::collect(n = n) -> rsa$rsa
tbl_mco(con, an, 'rsa_actes') %>% dplyr::collect(n = n) -> rsa$actes
tbl_mco(con, an, 'rsa_diags') %>% dplyr::filter(position == 5) %>% dplyr::collect(n = n) %>% dplyr::rename(DAS = DIAG) -> rsa$das
tbl_mco(con, an, 'rsa_um') %>% dplyr::collect(n = n) -> rsa$rsa_um
rsa
}
#' ~ req : creer un json pour partager une liste
#'
#' On selectionne certaines variables et on en cree d'autres utiles lors de l'execution de la requete
#'
#' @param requete `list` qui contient la requête
#' @param chemin Nom du fichier json qui sera créé
#' @examples
#' \dontrun{
#' liste = list(nom_abrege = "pac",
#' thematique = "test",
#' actes = c('EBLA003', 'EQLF002'),
#' dureemax = 0,
#' auteur = "John Doe",
#' date_saisie = "1960-01-01")
#' creer_json(liste, paste0('~/Documents/listes/', liste$nom_abrege, '.json'))
#' }
#'
#' @return un objet de classe rsa de pmeasyr
#' @author G. Pressiat
#' @importFrom jsonlite write_json
#' @export
creer_json <- function(requete, chemin){
jsonlite::write_json(requete, chemin, method='C', pretty = T)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.