Skip to content

Commit

Permalink
Merge pull request #81 from life-research/80-stratifier-components
Browse files Browse the repository at this point in the history 
Implement Stratifier Components in Evaluate Measure
  • Loading branch information
@alexanderkiel
alexanderkiel authored Nov 24, 2019
2 parents 890920f + 1857b7d commit 4d68e04
Show file tree
Hide file tree
Showing 11 changed files with 643 additions and 66 deletions.
94 changes: 69 additions & 25 deletions ...les/operations/measure-evaluate-measure/src/blaze/fhir/operation/evaluate_measure/cql.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,19 +4,24 @@
[blaze.elm.compiler.protocols :refer [-eval]]
[clojure.core.reducers :as r]
[clojure.spec.alpha :as s]
[clojure.string :as str]
[cognitect.anomalies :as anom]
[datomic-spec.core :as ds])
(:import
[java.time OffsetDateTime]))


(defn- evaluate-expression-1
[context resource expression-defs]
(reduce
(fn [context {:keys [name] :life/keys [expression]}]
(let [res (-eval expression context resource nil)]
(update context :library-context assoc name res)))
context
expression-defs))
[context resource {expression-defs :life/compiled-expression-defs}
expression-name]
(-> (reduce
(fn [context {:keys [name] :life/keys [expression]}]
(let [res (-eval expression context resource nil)]
(update context :library-context assoc name res)))
context
expression-defs)
:library-context
(get expression-name)))


(def ^:private resource-cache (volatile! {}))
Expand All @@ -41,21 +46,33 @@
:expression-name string?))

(defn evaluate-expression
{:arglists '([db now library subject expression-name])}
[db now {expression-defs :life/compiled-expression-defs} subject
expression-name]
[db now library subject expression-name]
(let [context {:db db :now now}]
(r/fold
+
(fn [count resource]
(if (-> (evaluate-expression-1 context resource expression-defs)
:library-context
(get expression-name))
(if (evaluate-expression-1 context resource library expression-name)
(inc count)
count))
(list-resources db subject))))


(defn- incorrect-stratum [resource expression-name]
{::anom/category ::anom/incorrect
::anom/message
(format "CQL expression `%s` returned more than one value for resource `%s`."
expression-name (str/join "/" (datomic-util/literal-reference resource)))})


(defn- combine
([] {})
([a b]
(cond
(::anom/category a) a
(::anom/category b) b
:else (merge-with + a b))))


(s/fdef calc-stratums
:args (s/cat :db ::ds/db :now #(instance? OffsetDateTime %)
:library :life/compiled-library :subject string?
Expand All @@ -64,22 +81,49 @@

(defn calc-stratums
"Returns a map of stratum to count."
[db now {expression-defs :life/compiled-expression-defs} subject
population-expression-name expression-name]
[db now library subject population-expression-name expression-name]
(let [context {:db db :now now}]
(r/fold
(partial merge-with +)
combine
(fn [stratums resource]
(if (-> (evaluate-expression-1
context resource expression-defs)
:library-context
(get population-expression-name))
(let [stratum (-> (evaluate-expression-1
context resource expression-defs)
:library-context
(get expression-name))]
(if (evaluate-expression-1 context resource library
population-expression-name)
(let [stratum (evaluate-expression-1 context resource library
expression-name)]
(if (sequential? stratum)
(reduce #(update %1 %2 (fnil inc 0)) stratums stratum)
(reduced (incorrect-stratum resource expression-name))
(update stratums stratum (fnil inc 0))))
stratums))
(list-resources db subject))))


(s/fdef calc-mult-component-stratums
:args (s/cat :db ::ds/db :now #(instance? OffsetDateTime %)
:library :life/compiled-library :subject string?
:population-expression-name string?
:expression-names (s/coll-of string?)))

(defn calc-mult-component-stratums
"Returns a map of stratum to count."
[db now library subject population-expression-name expression-names]
(let [context {:db db :now now}]
(r/fold
combine
(fn [stratums resource]
(if (evaluate-expression-1 context resource library
population-expression-name)
(let [stratum-vector
(reduce
(fn [stratum-vector expression-name]
(let [stratum (evaluate-expression-1
context resource library expression-name)]
(if (sequential? stratum)
(reduced (incorrect-stratum resource expression-name))
(conj stratum-vector stratum))))
[]
expression-names)]
(if (::anom/category stratum-vector)
(reduced stratum-vector)
(update stratums stratum-vector (fnil inc 0))))
stratums))
(list-resources db subject))))
158 changes: 135 additions & 23 deletions ...operations/measure-evaluate-measure/src/blaze/fhir/operation/evaluate_measure/measure.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -84,6 +84,10 @@
:measure measure}))


(defn- pull-codeable-concept [db concept]
(pull/pull-non-primitive db :CodeableConcept concept))


(defn- compile-primary-library
"Returns the primary library from `measure` in compiled form or an anomaly
on errors."
Expand Down Expand Up @@ -118,7 +122,7 @@
(cond->
{"count" (cql/evaluate-expression db now library subject expression)}
code
(assoc "code" (pull/pull-non-primitive db :CodeableConcept code)))))
(assoc "code" (pull-codeable-concept db code)))))


(defn- code? [x]
Expand All @@ -131,7 +135,7 @@
(str stratum-value)))


(defn- evaluate-stratifier
(defn- evaluate-single-stratifier
{:arglists
'([db now library subject groupIdx populations stratifierIdx stratifier])}
[db now library subject groupIdx populations stratifierIdx
Expand All @@ -155,27 +159,135 @@
groupIdx stratifierIdx)}

:else
(cond->
{"stratum"
(into
[]
(map
(fn [[stratum-value count]]
{"value" {"text" (pull stratum-value)}
"population"
[{"code"
(pull/pull-non-primitive
db :CodeableConcept
(-> populations first :Measure.group.population/code))
"count" count}]}))
(->> (cql/calc-stratums
db now library subject
(-> populations first :Measure.group.population/criteria
:Expression/expression)
expression)
(sort-by key)))}
code
(assoc "code" [(pull/pull-non-primitive db :CodeableConcept code)]))))
(let [stratums (cql/calc-stratums
db now library subject
(-> populations first :Measure.group.population/criteria
:Expression/expression)
expression)]
(if (::anom/category stratums)
stratums
(cond->
{"stratum"
(->> stratums
(mapv
(fn [[stratum-value count]]
[(pull stratum-value) count]))
(sort-by first)
(mapv
(fn [[stratum-value count]]
{"value" {"text" stratum-value}
"population"
[{"code"
(pull-codeable-concept
db (-> populations first :Measure.group.population/code))
"count" count}]})))}
code
(assoc "code" [(pull-codeable-concept db code)]))))))


(defn- extract-stratifier-component
"Extracts code and expression-name from `stratifier-component`."
{:arglists '([groupIdx stratifierIdx componentIdx stratifier-component])}
[groupIdx stratifierIdx componentIdx
{{:Expression/keys [language expression]}
:Measure.group.stratifier.component/criteria
:Measure.group.stratifier.component/keys [code]}]
(cond
(nil? code)
{::anom/category ::anom/incorrect
::anom/message "Missing code."
:fhir/issue "required"
:fhir.issue/expression
(format "Measure.group[%d].stratifier[%d].component[%d].code"
groupIdx stratifierIdx componentIdx)}

(not= "text/cql" (:code/code language))
{::anom/category ::anom/unsupported
::anom/message (str "Unsupported language `" (:code/code language) "`.")
:fhir/issue "not-supported"
:fhir.issue/expression
(format "Measure.group[%d].stratifier[%d].component[%d].criteria.language"
groupIdx stratifierIdx componentIdx)}

(nil? expression)
{::anom/category ::anom/incorrect
::anom/message "Missing expression."
:fhir/issue "required"
:fhir.issue/expression
(format "Measure.group[%d].stratifier[%d].component[%d].criteria.expression"
groupIdx stratifierIdx componentIdx)}

:else [code expression]))


(defn- extract-stratifier-components
"Extracts code and expression-name from each of `stratifier-components`."
[groupIdx stratifierIdx stratifier-components]
(transduce
(map-indexed vector)
(completing
(fn [results [idx component]]
(let [result (extract-stratifier-component
groupIdx stratifierIdx idx component)]
(if (::anom/category result)
(reduced result)
(let [[code expression-name] result]
(-> results
(update :codes conj code)
(update :expression-names conj expression-name)))))))
{:codes []
:expression-names []}
stratifier-components))


(defn- evaluate-multi-component-stratifier
{:arglists
'([db now library subject groupIdx populations stratifierIdx stratifier])}
[db now library subject groupIdx populations stratifierIdx
{:Measure.group.stratifier/keys [component]}]
(let [results (extract-stratifier-components groupIdx stratifierIdx component)]
(if (::anom/category results)
results
(let [{:keys [codes expression-names]} results
stratums (cql/calc-mult-component-stratums
db now library subject
(-> populations first :Measure.group.population/criteria
:Expression/expression)
expression-names)]
(if (::anom/category stratums)
stratums
(let [codes (mapv #(pull-codeable-concept db %) codes)]
{"code" codes
"stratum"
(into
[]
(map
(fn [[stratum-values count]]
{"component"
(mapv
(fn [code value]
{"code" code
"value" {"text" (pull value)}})
codes
stratum-values)
"population"
[{"code"
(pull-codeable-concept
db (-> populations first :Measure.group.population/code))
"count" count}]}))
stratums)}))))))


(defn- evaluate-stratifier
{:arglists
'([db now library subject groupIdx populations stratifierIdx stratifier])}
[db now library subject groupIdx populations stratifierIdx
{:Measure.group.stratifier/keys [component] :as stratifier}]
(if (seq component)
(evaluate-multi-component-stratifier
db now library subject groupIdx populations stratifierIdx stratifier)
(evaluate-single-stratifier
db now library subject groupIdx populations stratifierIdx stratifier)))


(defn- evaluate-populations [db now library subject groupIdx populations]
Expand Down
Loading

0 comments on commit 4d68e04

Please sign in to comment.