r11333: add uconso object; query MRXW filtering by SAB

[umlisp.git] / sql-classes.lisp

diff --git a/sql-classes.lisp b/sql-classes.lisp
index 20ef37eafe82939234e727cfa8441c18f3edfa97..54519a02f44aca7943b91e76880378a164ad7ec6 100644 (file)
--- a/sql-classes.lisp
+++ b/sql-classes.lisp
@@ -230,7 +230,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
     (make-instance 'ucon :cui cui)))
   
 (defun find-ucon-cui (cui &key (srl *current-srl*) without-pfstr)
-  "Find ucon for a cui"
+  "Find ucon for a cui. If set SAB, the without-pfstr is on by default"
   (ensure-cui-integer cui)
   (unless cui (return-from find-ucon-cui nil))
 
@@ -246,6 +246,20 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
         (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"
+  (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)
+    (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-pfstr-cui (cui &key (srl *current-srl*))
   "Find preferred string for a cui"
   (ensure-cui-integer cui)
@@ -725,6 +739,43 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
                                     :lrl 'klrl :order '(cui asc))
     (find-ucon-cui cui :srl srl)))
 
+(defun find-ucon-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.cui FROM MRCONSO c,MRXW_ENG x WHERE x.WD  ~A '~A' AND x.cui=c.cui AND ~A ~A"
+                       (if like "LIKE" "=")
+                       (clsql-sys::sql-escape-quotes word)
+                       (typecase sab
+                         (stringp 
+                          (format nil " c.sab='" (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 (make-instance 'ucon (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
+                         (stringp 
+                          (format nil " c.sab='" (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)))))
+           
+
 (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"
   (collect-umlisp-query-eval ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t
@@ -794,10 +845,10 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 ;;; Multiword lookup and score functions
 
 (defun find-uobj-multiword (str obj-lookup-fun sort-fun key srl
-                           only-exact-if-match limit)
+                                only-exact-if-match limit &key extra-lookup-args)
   (let ((uobjs '()))
     (dolist (word (delimited-string-to-list str #\space))
-      (setq uobjs (append uobjs (funcall obj-lookup-fun word :srl srl))))
+      (setq uobjs (append uobjs (apply obj-lookup-fun word :srl srl extra-lookup-args))))
     (let ((sorted
           (funcall sort-fun str
                    (delete-duplicates uobjs :test #'= :key key))))
@@ -816,9 +867,14 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 
 (defun find-ucon-multiword (str &key (srl *current-srl*)
                                     (only-exact-if-match t)
-                                     limit)
-  (find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str
-                      #'cui srl only-exact-if-match limit))
+                                     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)))
 
 (defun find-uterm-multiword (str &key (srl *current-srl*)
                                      (only-exact-if-match t)
@@ -828,9 +884,14 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 
 (defun find-ustr-multiword (str &key (srl *current-srl*)
                                     (only-exact-if-match t)
-                                     limit)
-  (find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str
-                      #'sui srl only-exact-if-match limit))
+                                     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)))
 
 (defun sort-score-pfstr-str (str uobjs)
   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"