clinic: add create patient endpoint

clinic/docker-compose.yaml

@@ -68,10 +68,12 @@ services:
       hapi.fhir.default_encoding: json
       spring.jpa.properties.hibernate.dialect: ca.uhn.fhir.jpa.model.dialect.HapiFhirPostgres94Dialect
       spring.jpa.properties.hibernate.search.enabled: false
+      server.port: 8090
+      hapi.fhir.tester.home.server_address: http://localhost:8090/fhir
     volumes:
       - hapi-data:/data/hapi
     ports:
-      - 8090:8080
+      - 8090:8090
     networks: [default]
 
 networks:

clinic/project.clj

@@ -2,11 +2,19 @@
   :description "Onboarding project #2"
   :url "https://github.com/nilenso/ashutosh-onboarding/blob/main/clinic"
   :dependencies [[aero "1.1.6"]
+                 [clj-http "3.12.3"]
+                 [compojure "1.7.0"]
                  [mount "0.1.17"]
-                 [org.clojure/clojure "1.11.1"]]
+                 [org.clojure/clojure "1.11.1"]
+                 [ring/ring-core "1.10.0"]
+                 [ring/ring-jetty-adapter "1.10.0"]
+                 [ring/ring-json "0.5.1"]]
   :source-paths ["src/clj"]
+  :test-paths ["test/clj"]
   :main ^:skip-aot clinic.core
   :target-path "target/%s"
-  :profiles {:uberjar {:aot :all
+  :profiles {:dev {:dependencies [[org.clojure/test.check "0.9.0"]]}
+             :test {:dependencies [[ring/ring-mock "0.4.0"]]}
+             :uberjar {:aot :all
                        :jvm-opts ["-Dclojure.compiler.direct-linking=true"]}}
   :plugins [[lein-cloverage "1.2.2"]])

clinic/src/clj/clinic/config.clj

@@ -1,5 +1,4 @@
 (ns clinic.config
-  (:refer-clojure :exclude [read])
   (:require [aero.core :as aero]
             [clojure.java.io :as io]
             [mount.core :refer [defstate]]))
@@ -10,5 +9,16 @@
              (aero/read-config))
   :stop nil)
 
-(defn read [key]
+(defn get-value
+  "Returns the configuration value corresponding to the given `key` in
+   `resources/config.edn`."
+  [key]
   (get config key))
+
+(defn wrap
+  "Ring middleware to add `:config` key to incoming requests."
+  [next-handler]
+  (fn [request]
+    (-> {:config config}
+        (into request)
+        (next-handler))))

clinic/src/clj/clinic/core.clj

@@ -1,7 +1,26 @@
 (ns clinic.core
   (:require [clinic.config :as config]
-            [mount.core :as mount]))
+            [clinic.routes.core :as routes]
+            [mount.core :as mount]
+            [ring.adapter.jetty :as jetty]))
+
+(defonce server (atom nil))
+
+(defn- start
+  ([] (start false))
+  ([join-thread]
+   (mount/start)
+   (reset! server
+           (jetty/run-jetty (config/wrap #'routes/handler)
+                            {:port (config/get-value :http-port)
+                             :join? join-thread}))))
 
 (defn -main []
-  (mount/start)
-  (prn (config/read :fhir-server-base-url) (config/read :http-port)))
+  (start true))
+
+;; REPL helpers
+(comment (start))
+(comment
+  (when @server
+    (.stop @server))
+  (mount/stop))

clinic/src/clj/clinic/fhir/client.clj

@@ -0,0 +1,17 @@
+(ns clinic.fhir.client
+  (:require [cheshire.core :as json]
+            [clj-http.client :as c]))
+
+(defn create!
+  "Performs a HTTP POST request on a FHIR server at the given `base-url` for a
+   given `resource` with given HTTP `headers`.
+
+   Returns HTTP response of the server after JSON parsing its body."
+  [base-url resource headers]
+  (-> (if (= "Bundle" (resource :resourceType))
+        base-url ; Bundle resources should POST at the server root
+        (str base-url "/" (resource :resourceType)))
+      (c/post {:headers (into {"Content-Type" "application/fhir+json"} headers)
+               :body (json/generate-string resource)
+               :throw-exceptions false})
+      (update :body json/parse-string true)))

clinic/src/clj/clinic/fhir/utils.clj

@@ -0,0 +1,20 @@
+(ns clinic.fhir.utils)
+
+(defn find-code
+  "Returns the value of the `code` attribute corresponding to the given `system`
+   in a FHIR Codeable Concept."
+  [system codeable-concept]
+  (some-> codeable-concept
+          (get :coding)
+          ((partial filter #(= system (get % :system))))
+          (first)
+          (get :code)))
+
+(defn find-value
+  "Returns the value corresponding to the given `system` in a collection of
+   `elements`."
+  [system elements]
+  (some-> elements
+          ((partial filter #(= system (% :system))))
+          (first)
+          (get :value)))

clinic/src/clj/clinic/routes/core.clj

@@ -0,0 +1,22 @@
+(ns clinic.routes.core
+  (:require [clinic.routes.patient :as patient]
+            [compojure.core :refer [context defroutes]]
+            [ring.middleware.json :refer [wrap-json-body wrap-json-response]]
+            [ring.util.response :as r]))
+
+(defroutes ^:private routes
+  (context "/api/v1" _
+    (context "/patients" _ patient/handler)))
+
+(defn- wrap-exception-handler [next-handler]
+  (fn [request]
+    (try (next-handler request)
+         (catch Throwable _
+           (r/status 500)))))
+
+(def handler
+  "The default API route handler."
+  (-> routes
+      (wrap-json-body {:keywords? true})
+      (wrap-json-response)
+      (wrap-exception-handler)))

clinic/src/clj/clinic/routes/patient.clj

@@ -0,0 +1,19 @@
+(ns clinic.routes.patient
+  (:require [clinic.service.patient :as svc]
+            [compojure.core :refer [defroutes POST]]
+            [ring.util.response :as r]))
+
+(defn- create-patient [{{fhir-server-url :fhir-server-base-url} :config
+                        params :body}]
+  (try
+    (-> (svc/create! fhir-server-url params)
+        (r/response)
+        (r/status 201))
+    (catch Exception e
+      (case (:type (ex-data e))
+        :invalid-params (r/status 400)
+        :mrn-conflict (r/status 503)
+        (throw e)))))
+
+(defroutes handler
+  (POST "/" _ create-patient))

clinic/src/clj/clinic/service/patient.clj

@@ -0,0 +1,108 @@
+(ns clinic.service.patient
+  (:require [clinic.fhir.client :as fc]
+            [clinic.fhir.utils :as fu]
+            [clojure.spec.alpha :as s]
+            [clojure.string :as string]))
+
+(def mrn-system "urn:nilenso:clinic:mrn")
+(def marital-status-system "http://hl7.org/fhir/ValueSet/marital-status")
+(def email-system "email")
+(def phone-system "phone")
+
+(def ^:private not-blank? (complement string/blank?))
+
+(s/def ::id (s/and string? not-blank?))
+(s/def ::mrn (s/and string? not-blank?))
+(s/def ::first-name (s/and string? not-blank?))
+(s/def ::last-name (s/and string? not-blank?))
+(s/def ::birth-date (s/and string? not-blank?))
+(s/def ::gender #{"male" "female" "other" "unknown"})
+(s/def ::marital-status #{nil, "A" "D" "I" "L" "M" "P" "S" "T" "U" "W" "UNK"})
+(s/def ::email (s/nilable (s/and string? not-blank?)))
+(s/def ::phone (s/nilable (s/and string? not-blank?)))
+
+(s/def ::create-params
+  (s/keys :req-un [::first-name ::last-name ::birth-date ::gender]
+          :opt-un [::marital-status ::email ::phone]))
+
+(s/def ::patient
+  (s/keys :req-un [::id ::mrn ::first-name ::last-name ::birth-date ::gender]
+          :opt-un [::marital-status ::email ::phone]))
+
+(defn- generate-mrn []
+  (String/format "%03d-%03d-%03d"
+                 (into-array [(rand-int 999)
+                              (rand-int 999)
+                              (rand-int 999)])))
+
+(defn- domain->fhir [params]
+  (let [resource (atom {:resourceType "Patient"
+                        :identifier [{:system mrn-system
+                                      :value (params :mrn)}]
+                        :name [{:family (params :last-name)
+                                :given [(params :first-name)]}]
+                        :birthDate (params :birth-date)
+                        :gender (params :gender)
+                        :maritalStatus {:coding [{:system marital-status-system
+                                                  :code (or (get params :marital-status)
+                                                            "UNK")}]}
+                        :telecom []
+                        :active true})]
+    (when (params :email)
+      (swap! resource update :telecom conj {:system email-system
+                                            :value (params :email)}))
+    (when (params :phone)
+      (swap! resource update :telecom conj {:system phone-system
+                                            :value (params :phone)}))
+    @resource))
+
+(defn- fhir->domain [resource]
+  (let [entity (atom {:id (resource :id)
+                      :mrn (->> resource
+                                (:identifier)
+                                (fu/find-value mrn-system))
+                      :first-name (string/join " " (get-in resource [:name 0 :given]))
+                      :last-name (get-in resource [:name 0 :family])
+                      :birth-date (resource :birthDate)
+                      :gender (resource :gender)
+                      :marital-status (some->> resource
+                                               (:maritalStatus)
+                                               (fu/find-code marital-status-system))})
+        email (some->> resource
+                       (:telecom)
+                       (fu/find-value email-system))
+        phone (some->> resource
+                       (:telecom)
+                       (fu/find-value phone-system))]
+    (when email
+      (swap! entity assoc :email email))
+    (when phone
+      (swap! entity assoc :phone phone))
+    (s/conform ::patient @entity)))
+
+(defn create!
+  "Creates a new patient resource using attributes of the given `params` and
+   uses the FHIR server at the given `fhir-server-url` to persist these Patient
+   resources."
+  [fhir-server-url params]
+  (when-not (s/valid? ::create-params params)
+    (throw (ex-info "invalid create params"
+                    {:type :invalid-params
+                     :details (s/explain-data ::create-params params)})))
+  (loop [retry-count 3]
+    (let [mrn (generate-mrn)
+          resource (-> params
+                       (assoc :mrn mrn)
+                       (domain->fhir))
+          response (fc/create! fhir-server-url
+                               resource
+                               {"If-None-Exist" (str "identifier=" mrn-system "|" mrn)})
+          {status :status body :body} response]
+      (cond
+        (= 0 retry-count) (throw (ex-info "couldn't generate a unique MRN"
+                                          {:type :mrn-conflict}))
+        (= status 200) (recur (dec retry-count)) ;; MRN conflict
+        (= status 201) (fhir->domain body)
+        :else (throw (ex-info "upstream service error"
+                              {:type :upstream-error
+                               :response {:status status :body body}}))))))

clinic/test/clj/clinic/config_test.clj

@@ -1,10 +1,19 @@
-(ns clj.clinic.config-test
-  (:require [clojure.test :refer [deftest is]]
-            [aero.core :as aero]
+(ns clinic.config-test
+  (:require [aero.core :as aero]
             [clinic.config :as config]
+            [clojure.test :refer [deftest is]]
             [mount.core :as mount]))
 
-(deftest read-test
+(deftest get-value-test
   (with-redefs [aero/read-config (constantly {:test-key "test-val"})]
     (mount/start #'config/config)
-    (is (= "test-val" (config/read :test-key)))))
+    (is (= "test-val" (config/get-value :test-key)))))
+
+(deftest wrap-test
+  (let [request (atom {})
+        next-handler (partial reset! request)
+        test-config {:test-key "test-val"}]
+    (with-redefs [aero/read-config (constantly test-config)]
+      (mount/start #'config/config)
+      ((config/wrap next-handler) {:method :get})
+      (is (= test-config (@request :config))))))

clinic/test/clj/clinic/fhir/client_test.clj

@@ -0,0 +1,29 @@
+(ns clinic.fhir.client-test
+  (:require [clinic.fhir.client :as client]
+            [clj-http.client :as c]
+            [clojure.test :refer [deftest is testing]]))
+
+(deftest create-test
+  (let [post-params (atom [])]
+    (with-redefs [c/post (fn [& args]
+                           (reset! post-params (vec args))
+                           {:status 201
+                            :headers (get-in @post-params [1 :headers])
+                            :body (get-in @post-params [1 :body])})]
+      (testing "with Test resource"
+        (let [resp (client/create! "http://test.base.url/fhir"
+                                   {:resourceType "Test"
+                                    :key "resource-val"}
+                                   {:header "header-val"})]
+          (is (= "http://test.base.url/fhir/Test" (@post-params 0)))
+          (is (= "resource-val" (get-in resp [:body :key])))
+          (is (= "header-val" (get-in @post-params [1 :headers :header])))))
+
+      (testing "with Bundle resource"
+        (let [resp (client/create! "http://test.base.url/fhir"
+                                   {:resourceType "Bundle"
+                                    :key "resource-val"}
+                                   {:header "header-val"})]
+          (is (= "http://test.base.url/fhir" (@post-params 0)))
+          (is (= "resource-val" (get-in resp [:body :key])))
+          (is (= "header-val" (get-in @post-params [1 :headers :header]))))))))

clinic/test/clj/clinic/fhir/utils_test.clj

@@ -0,0 +1,25 @@
+(ns clinic.fhir.utils-test
+  (:require [clinic.fhir.utils :as fu]
+            [clojure.test :refer [deftest is]]))
+
+(deftest find-code-test
+  (let [codeable-concept {:coding [{:system "test-system-1"
+                                    :code "code-1"}
+                                   {:system "test-system-2"
+                                    :code "code-2"}
+                                   {:system "test-system-3"
+                                    :code "code-3"}]}]
+    (is (= "code-1" (fu/find-code "test-system-1" codeable-concept)))
+    (is (= "code-2" (fu/find-code "test-system-2" codeable-concept)))
+    (is (= "code-3" (fu/find-code "test-system-3" codeable-concept)))))
+
+(deftest find-value-test
+  (let [elements [{:system "test-system-1"
+                   :value "value-1"}
+                  {:system "test-system-2"
+                   :value "value-2"}
+                  {:system "test-system-3"
+                   :value "value-3"}]]
+    (is (= "value-1" (fu/find-value "test-system-1" elements)))
+    (is (= "value-2" (fu/find-value "test-system-2" elements)))
+    (is (= "value-3" (fu/find-value "test-system-3" elements)))))