r11613:

[umlisp.git] / sql-classes.lisp

diff --git a/sql-classes.lisp b/sql-classes.lisp
index ec68c5e159066c798df3ece2e3223d2e13da7e79..eba8ce104b525a46fcb1c63679c61c6e5d95e37a 100644 (file)
--- a/sql-classes.lisp
+++ b/sql-classes.lisp
@@ -246,14 +246,32 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
         (make-instance 'ucon :cui cui :pfstr str
                        :lrl kcuilrl))))
 
         (make-instance 'ucon :cui cui :pfstr str
                        :lrl kcuilrl))))
 

-(defun find-uconso-cui (cui &key (srl *current-srl*))
-  "Find ucon for a cui. If set SAB, the without-pfstr is on by default"
+(defun find-uconso-cui (cui &key sab (srl *current-srl*))
+  "Find uconso for a cui."

   (ensure-cui-integer cui)
   (unless cui (return-from find-uconso-cui nil))
 
   (collect-umlisp-query (mrconso (lat ts lui stt sui ispref aui saui scui sdui sab tty code str
                                       srl suppress cvf kpfeng kcuisui kcuilui kcuilrl
   (ensure-cui-integer cui)
   (unless cui (return-from find-uconso-cui nil))
 
   (collect-umlisp-query (mrconso (lat ts lui stt sui ispref aui saui scui sdui sab tty code str
                                       srl suppress cvf kpfeng kcuisui kcuilui kcuilrl

-                                      kluilrl ksuilrl) srl cui cui)
+                                      kluilrl ksuilrl) srl cui cui
+                                      :filter (if sab (concatenate 'string "SAB='" sab "'") nil))
+    (make-instance 'uconso :cui cui :lat lat :ts ts :lui lui :stt stt :sui sui :ispref ispref
+                   :aui aui :saui saui :scui scui :sdui sdui :sab sab :tty tty :code code
+                   :str str :srl srl :suppress suppress :cvf cvf :kpfeng kpfeng
+                   :kcuisui kcuisui :kcuilui kcuilui :kcuilrl kcuilrl :kluilrl kluilrl
+                   :ksuilrl ksuilrl)))
+
+(defun find-uconso-sui (sui &key sab (srl *current-srl*))
+  "Find uconso for a sui. If set SAB, the without-pfstr is on by default"
+  (ensure-sui-integer sui)
+  (unless (and sui (stringp sab))
+    (return-from find-uconso-sui nil))
+
+  (collect-umlisp-query (mrconso (cui lat ts lui stt sui ispref aui saui scui sdui sab tty code str
+                                      srl suppress cvf kpfeng kcuisui kcuilui kcuilrl
+                                      kluilrl ksuilrl) srl sui sui
+                                      :distinct t
+                                      :filter (if sab (concatenate 'string "SAB='" sab "'") nil))

     (make-instance 'uconso :cui cui :lat lat :ts ts :lui lui :stt stt :sui sui :ispref ispref
                    :aui aui :saui saui :scui scui :sdui sdui :sab sab :tty tty :code code
                    :str str :srl srl :suppress suppress :cvf cvf :kpfeng kpfeng
     (make-instance 'uconso :cui cui :lat lat :ts ts :lui lui :stt stt :sui sui :ispref ispref
                    :aui aui :saui saui :scui scui :sdui sdui :sab sab :tty tty :code code
                    :str str :srl srl :suppress suppress :cvf cvf :kpfeng kpfeng


@@ -722,63 +740,66 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   (collect-umlisp-query (mrsty (cui) srl tui tui :lrl klrl :order (cui asc))
     (find-ucon-cui (ensure-integer cui) :srl srl)))
 
   (collect-umlisp-query (mrsty (cui) srl tui tui :lrl klrl :order (cui asc))
     (find-ucon-cui (ensure-integer cui) :srl srl)))
 

-(defun find-ucon-word (word &key (srl *current-srl*) (like nil))
-  "Return list of ucons that match word. Optionally, use SQL's LIKE syntax"
-  (collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t
-                                    :lrl 'klrl :order '(cui asc))
-    (find-ucon-cui cui :srl srl)))
-
-(defun find-uconso-word (word &key (srl *current-srl*) (like nil))
-  "Return list of uconso objects that match word. Optionally, use SQL's LIKE syntax"
-  (collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t
-                                    :lrl 'klrl :order '(cui asc))
-    (find-uconso-cui cui :srl srl)))
+(defun find-uconso-code (code &key sab (srl *current-srl*) (like nil))
+  "Return list of uconso objects that match code. Optional, filter for SAB. Optionally, use SQL's LIKE syntax"
+  (collect-umlisp-query (mrconso (sui sab) srl code code :like like :distinct t
+                                 :lrl klrl
+                                 :filter (if sab (concatenate 'string "SAB='" sab "'") nil))
+    (find-uconso-sui sui :sab sab :srl srl)))

 
 (defun mrconso-query-word-cui (word sab srl like)
 
 (defun mrconso-query-word-cui (word sab srl like)

-  (format nil "SELECT c.cui FROM MRCONSO c,MRXW_ENG x WHERE x.WD  ~A '~A' AND x.cui=c.cui AND ~A ~A"
-          (if like "LIKE" "=")
+  (format nil "SELECT DISTINCT c.cui FROM MRCONSO c,MRXW_ENG x WHERE x.WD~A'~A' AND x.cui=c.cui~A~A"
+          (if like " LIKE " "=")

           (clsql-sys::sql-escape-quotes word)
           (etypecase sab
             (string
           (clsql-sys::sql-escape-quotes word)
           (etypecase sab
             (string

-             (format nil " c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
+             (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))

             (cons
             (cons

-             (format nil " c.sab IN (~{'~A'~^,~})"
+             (format nil " AND c.sab IN (~{'~A'~^,~})"

                      (mapcar 'clsql-sys::sql-escape-quotes sab)))
             (null
                      (mapcar 'clsql-sys::sql-escape-quotes sab)))
             (null

-             (error "SAB missing")))
-          (if srl (format nil "AND KCUILRL <= ~A" srl) "")))
+             ""))
+          (if srl (format nil " AND KCUILRL <= ~A" srl) "")))

 
 

-(defun find-uconso-word-sab (word &key sab (srl *current-srl*) (like nil))
-  "Return list of uconso that match word in matching SAB. Optionally, use SQL's LIKE syntax"
-  (let ((query (mrconso-query-word-cui word sab srl like)))
-    (loop for cui in (remove-duplicates (sort (mapcar 'car (mutex-sql-query query)) #'<))
-          collect (find-uconso-cui cui))))
+(defun mrconso-query-word-sui (word sab srl like)
+  (format nil "SELECT DISTINCT c.sui FROM MRCONSO c,MRXW_ENG x WHERE x.WD~A'~A' AND x.sui=c.sui~A~A"
+          (if like " LIKE " "=")
+          (clsql-sys::sql-escape-quotes word)
+          (etypecase sab
+            (string
+             (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
+            (cons
+             (format nil " AND c.sab IN (~{'~A'~^,~})"
+                     (mapcar 'clsql-sys::sql-escape-quotes sab)))
+            (null
+             ""))
+          (if srl (format nil " AND KCUILRL <= ~A" srl) "")))

 
 

-(defun find-ucon-word-sab (word &key sab (srl *current-srl*) (like nil))
+(defun find-uconso-word (word &key sab (srl *current-srl*) (like nil))
+  "Return list of uconso that match word. Optionally, matching SAB. Optionally, use SQL's LIKE syntax"
+  (cond
+    (sab
+     (let ((sui-query (mrconso-query-word-sui word sab srl like))
+           (uconsos nil))
+       (dolist (sui (remove-duplicates (sort (mapcar 'car (mutex-sql-query sui-query)) #'<)))
+         (setq uconsos (nconc uconsos (find-uconso-sui sui :sab sab))))
+       (remove-duplicates uconsos :key 'cui)))
+    (t
+     (collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t
+                                           :lrl 'klrl :order '(cui asc))
+       (find-uconso-cui cui :srl srl)))))
+
+(defun find-ucon-word (word &key sab (srl *current-srl*) (like nil))

   "Return list of ucon that match word in matching SAB. Optionally, use SQL's LIKE syntax"
   "Return list of ucon that match word in matching SAB. Optionally, use SQL's LIKE syntax"

-  (let ((query (mrconso-query-word-cui word sab srl like)))
-    (loop for tuple in (mutex-sql-query query)
-          collect (make-instance 'ucon :cui (first tuple)))))
-
-(defun find-ustr-word-sab (word &key sab (srl *current-srl*) (like nil))
-  "Return list of ustr that match word in matching SAB. Optionally, use SQL's LIKE syntax"
-  (let ((query (format nil "SELECT c.sui,c.cui,c.lui,c.str,c.lrl,c.stt,c.suppress,c.cuisui FROM MRCONSO c,MRXW_ENG x WHERE x.WD ~A '~A' AND x.cui=c.cui AND x.lui=c.lui AND x.sui=c.sui AND ~A ~A"
-                       (if like "LIKE" "=")
-                       (clsql-sys::sql-escape-quotes word)
-                       (typecase sab
-                         (string
-                          (format nil " c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
-                         (cons
-                          (format nil " c.sab IN (~('~A'~^,~))"
-                                  (mapcar 'clsql-sys::sql-escape-quotes sab)))
-                         (t
-                          (error "SAB missing")))
-                       (if srl (format nil "AND KCUILRL <= ~D" srl) ""))))
-    (loop for tuple in (mutex-sql-query query)
-          collect (destructuring-bind (sui cui lui str lrl stt suppress cuisui) tuple
-                    (make-instance 'ustr :sui sui :cui cui :lui lui :str str :lrl lrl
-                                   :stt stt :suppress suppress :cuisui cuisui)))))
-
+  (cond
+    (sab
+     (let ((query (mrconso-query-word-cui word sab srl like)))
+       (loop for tuple in (mutex-sql-query query)
+             collect (make-instance 'ucon :cui (first tuple)))))
+    (t
+     (collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t
+                                           :lrl 'klrl :order '(cui asc))
+       (find-ucon-cui cui :srl srl)))))

 
 (defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil))
   "Return list of ucons that match word, optionally use SQL's LIKE syntax"
 
 (defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil))
   "Return list of ucons that match word, optionally use SQL's LIKE syntax"


@@ -804,11 +825,30 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
                                         :lrl 'klrl :order '(cui asc))
                             sui))
 
                                         :lrl 'klrl :order '(cui asc))
                             sui))
 

-(defun find-ustr-word (word &key (srl *current-srl*))
-  "Return list of ustrs that match word"
-  (collect-umlisp-query (mrxw_eng (cui sui) srl wd word :lrl klrl
-                              :order (cui asc sui asc))
-    (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
+(defun find-ustr-word (word &key sab (srl *current-srl*) (like nil))
+  "Return list of ustr that match word in matching SAB. Optionally, use SQL's LIKE syntax"
+  (cond
+    (sab
+     (let ((query (format nil "SELECT c.sui,c.cui,c.lui,c.str,c.lrl,c.stt,c.suppress,c.cuisui FROM MRCONSO c,MRXW_ENG x WHERE x.WD ~A '~A' AND x.cui=c.cui AND x.lui=c.lui AND x.sui=c.sui~A~A"
+                          (if like "LIKE" "=")
+                          (clsql-sys::sql-escape-quotes word)
+                          (typecase sab
+                            (string
+                             (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
+                            (cons
+                             (format nil " AND c.sab IN (~('~A'~^,~))"
+                                     (mapcar 'clsql-sys::sql-escape-quotes sab)))
+                            (null
+                             ""))
+                          (if srl (format nil " AND KCUILRL <= ~D" srl) ""))))
+       (loop for tuple in (mutex-sql-query query)
+             collect (destructuring-bind (sui cui lui str lrl stt suppress cuisui) tuple
+                       (make-instance 'ustr :sui sui :cui cui :lui lui :str str :lrl lrl
+                                      :stt stt :suppress suppress :cuisui cuisui)))))
+    (t
+     (collect-umlisp-query (mrxw_eng (cui sui) srl wd word :lrl klrl
+                                     :order (cui asc sui asc))
+       (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))))

 
 (defun find-ustr-normalized-word (word &key (srl *current-srl*))
   "Return list of ustrs that match word"
 
 (defun find-ustr-normalized-word (word &key (srl *current-srl*))
   "Return list of ustrs that match word"


@@ -873,23 +913,17 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
                                     (only-exact-if-match t)
                                      limit
                                      sab)
                                     (only-exact-if-match t)
                                      limit
                                      sab)

-  (if sab
-      (find-uobj-multiword str #'find-ucon-word-sab #'sort-score-pfstr-str
-                           #'cui srl only-exact-if-match limit
-                           :extra-lookup-args (list :sab sab))
-    (find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str
-                         #'cui srl only-exact-if-match limit)))
+  (find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str
+                       #'cui srl only-exact-if-match limit
+                       :extra-lookup-args (list :sab sab)))

 
 (defun find-uconso-multiword (str &key (srl *current-srl*)
                                     (only-exact-if-match t)
                                      limit
                                      sab)
 
 (defun find-uconso-multiword (str &key (srl *current-srl*)
                                     (only-exact-if-match t)
                                      limit
                                      sab)

-  (if sab
-      (find-uobj-multiword str #'find-uconso-word-sab #'sort-score-pfstr-str
-                           #'cui srl only-exact-if-match limit
-                           :extra-lookup-args (list :sab sab))
-    (find-uobj-multiword str #'find-uconso-word #'sort-score-pfstr-str
-                         #'cui srl only-exact-if-match limit)))
+  (find-uobj-multiword str #'find-uconso-word #'sort-score-pfstr-str
+                       #'cui srl only-exact-if-match limit
+                       :extra-lookup-args (list :sab sab)))

 
 (defun find-uterm-multiword (str &key (srl *current-srl*)
                                      (only-exact-if-match t)
 
 (defun find-uterm-multiword (str &key (srl *current-srl*)
                                      (only-exact-if-match t)


@@ -901,12 +935,9 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
                                     (only-exact-if-match t)
                                      limit
                                      sab)
                                     (only-exact-if-match t)
                                      limit
                                      sab)

-  (if sab
-      (find-uobj-multiword str #'find-ustr-word-sab #'sort-score-ustr-str
-                           #'sui srl only-exact-if-match limit
-                           :extra-lookup-args (list :sab sab))
-    (find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str
-                         #'sui srl only-exact-if-match limit)))
+  (find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str
+                       #'sui srl only-exact-if-match limit
+                       :extra-lookup-args (list :sab sab)))

 
 (defun sort-score-pfstr-str (str uobjs)
   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
 
 (defun sort-score-pfstr-str (str uobjs)
   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"