sql-classes.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:     sql-classes.lisp
   6 ;;;; Purpose:  Routines for reading UMLS objects from SQL database
   7 ;;;; Author:   Kevin M. Rosenberg
   8 ;;;; Created:  Apr 2000
   9 ;;;;
  10 ;;;; This file, part of UMLisp, is
  11 ;;;;    Copyright (c) 2000-2010 by Kevin M. Rosenberg, M.D.
  12 ;;;;
  13 ;;;; UMLisp users are granted the rights to distribute and use this software
  14 ;;;; as governed by the terms of the GNU General Public License.
  15 ;;;; *************************************************************************
  16
  17 (in-package #:umlisp)
  18
  19
  20 (defvar *current-srl* nil)
  21 (defun current-srl ()
  22   *current-srl*)
  23 (defun set-current-srl (srl)
  24   (setq *current-srl* srl))
  25
  26 (defmacro query-string (table fields srl where-name where-value
  27                         &key (lrl "KCUILRL") single distinct order like limit
  28                         filter)
  29   (let* ((%%fields (format nil "SELECT ~A~{~:@(~A~)~^,~} FROM ~:@(~A~)"
  30                            (if distinct "DISTINCT " "") fields table))
  31          (%%order (if order (format nil " ORDER BY ~{~:@(~A~) ~(~A~)~^,~}"
  32                                     order)
  33                       ""))
  34          (%%lrl (format nil " AND ~:@(~A~)<=" lrl))
  35          (%%where (when where-name
  36                     (format nil " WHERE ~:@(~A~)~A" where-name
  37                           (if like " like " ""))))
  38          (%filter (gensym "FILTER-"))
  39          (%single (gensym "SINGLE-"))
  40          (%limit (gensym "LIMIT-")))
  41     `(let ((,%limit ,limit)
  42            (,%single ,single)
  43            (,%filter ,filter))
  44        (concatenate
  45         'string
  46         ,%%fields
  47         ,@(when %%where (list %%where))
  48         ,@(when %%where
  49             `((typecase ,where-value
  50                 #+ignore
  51                 (fixnum
  52                  (concatenate 'string "='" (prefixed-fixnum-string ,where-value #\0 10) "'"))
  53                 (number
  54                  (concatenate 'string "='" (write-to-string ,where-value) "'"))
  55                 (null
  56                  " IS NULL")
  57                 (t
  58                  (format nil ,(if like "'%~A%'" "='~A'") ,where-value)))))
  59         (if ,%filter (concatenate 'string
  60                                   ,(if %%where " AND " " WHERE ")
  61                                   ,%filter) "")
  62         (if ,srl (concatenate 'string ,%%lrl (write-to-string ,srl)) "")
  63         ,@(when %%order (list %%order))
  64         (cond
  65          ((and ,%single ,%limit)
  66           (error  "Can't set single (~S) and limit (~S)" ,%single ,%limit))
  67          (,%single
  68           " LIMIT 1")
  69          (,%limit
  70           (format nil " LIMIT ~D" ,%limit))
  71          (t
  72           ""))))))
  73
  74 (defun query-string-eval (table fields srl where-name where-value
  75                           &key (lrl "KCUILRL") single distinct order like limit filter)
  76   (when single (setq limit 1))
  77   (concatenate
  78    'string
  79    (format nil "SELECT ~A~{~:@(~A~)~^,~} FROM ~:@(~A~)"
  80            (if distinct "DISTINCT " "") fields table)
  81    (if where-name (format nil " WHERE ~:@(~A~)" where-name) "")
  82    (if where-name
  83        (format nil
  84                (typecase where-value
  85                  (number "='~D'")
  86                  (null " IS NULL")
  87                  (t
  88                   (if like " LINK '%~A%""='~A'")))
  89                where-value)
  90        "")
  91    (if filter (concatenate 'string " AND " filter) nil)
  92    (if srl (format nil " AND ~:@(~A~)<=~D" lrl srl) "")
  93    (if order (format nil " ORDER BY ~{~:@(~A~) ~(~A~)~^,~}" order) "")
  94    (if limit (format nil " LIMIT ~D" limit) "")))
  95
  96
  97 (defmacro umlisp-query (table fields srl where-name where-value
  98                      &key (lrl "KCUILRL") single distinct order like
  99                      limit filter (query-cmd 'mutex-sql-query))
 100   "Query the UMLisp database. Return a list of umlisp objects whose name
 101 is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 102   `(,query-cmd
 103     (query-string ,table ,fields ,srl ,where-name ,where-value
 104      :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like
 105      :filter ,filter :limit ,limit)))
 106
 107 (defmacro umlisp-query-eval (table fields srl where-name where-value
 108                      &key (lrl "KCUILRL") single distinct order like
 109                      filter limit)
 110   "Query the UMLisp database. Return a list of umlisp objects whose name
 111 is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 112   `(mutex-sql-query
 113     (query-string-eval ,table ,fields ,srl ,where-name ,where-value
 114      :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like
 115      :filter ,filter :limit ,limit)))
 116
 117 ;; only WHERE-VALUE and SRL are evaluated
 118 (defmacro collect-umlisp-query ((table fields srl where-name where-value
 119                                     &key (lrl "KCUILRL") distinct single
 120                                     order like (query-cmd 'mutex-sql-query)
 121                                     filter limit)
 122                                 &body body)
 123   (let ((value (gensym))
 124         (r (gensym)))
 125     (if single
 126         (if (and limit (> limit 1))
 127             (error "Can't set limit along with single.")
 128           `(let* ((,value ,where-value)
 129                   (tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value
 130                                             :lrl ,lrl :single ,single
 131                                             :distinct ,distinct :order ,order
 132                                             :like ,like :filter ,filter
 133                                             :query-cmd ,query-cmd))))
 134              ,@(unless where-name `((declare (ignore ,value))))
 135              (when tuple
 136                (destructuring-bind ,fields tuple
 137                  ,@body))))
 138         `(let ((,value ,where-value))
 139            ,@(unless where-name `((declare (ignore ,value))))
 140            (let ((,r '()))
 141              (dolist (tuple (umlisp-query ,table ,fields ,srl ,where-name ,value
 142                                           :lrl ,lrl :single ,single :distinct ,distinct
 143                                           :order ,order :filter ,filter :like ,like
 144                                           :limit ,limit))
 145                (push (destructuring-bind ,fields tuple ,@body) ,r))
 146              (nreverse ,r))
 147            #+ignore
 148            (loop for tuple in
 149                  (umlisp-query ,table ,fields ,srl ,where-name ,value
 150                                :lrl ,lrl :single ,single :distinct ,distinct
 151                                :order ,order :like ,like :filter ,filter :limit ,limit)
 152                collect (destructuring-bind ,fields tuple ,@body))))))
 153
 154 (defmacro collect-umlisp-query-eval ((table fields srl where-name where-value
 155                                          &key (lrl "KCUILRL") distinct single
 156                                          order like filter limit)
 157                                   &body body)
 158   (let ((value (gensym))
 159         (r (gensym))
 160         (eval-fields (cadr fields)))
 161     (if single
 162         `(let* ((,value ,where-value)
 163                 (tuple (car (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
 164                                                :lrl ,lrl :single ,single
 165                                                :distinct ,distinct :order ,order
 166                                                :like ,like :filter ,filter
 167                                                :limit ,limit))))
 168           (when tuple
 169             (destructuring-bind ,eval-fields tuple
 170               ,@body)))
 171         `(let ((,value ,where-value)
 172                (,r '()))
 173            (dolist (tuple (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
 174                                              :lrl ,lrl :single ,single :distinct ,distinct
 175                                              :order ,order :like ,like
 176                                              :filter ,filter :limit ,limit))
 177              (push (destructuring-bind ,eval-fields tuple ,@body) ,r))
 178            (nreverse ,r)
 179            #+ignore
 180            (loop for tuple in
 181                  (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
 182                                     :lrl ,lrl :single ,single :distinct ,distinct
 183                                     :order ,order :like ,like :filter ,filter
 184                                     :limit ,limit)
 185                collect (destructuring-bind ,eval-fields tuple ,@body))))))
 186
 187 ;;;
 188 ;;; Read from SQL database
 189
 190 (defmacro ensure-cui-integer (cui)
 191   `(if (stringp ,cui)
 192     (setq ,cui (parse-cui ,cui))
 193     ,cui))
 194
 195 (defmacro ensure-lui-integer (lui)
 196   `(if (stringp ,lui)
 197     (setq ,lui (parse-lui ,lui))
 198     ,lui))
 199
 200 (defmacro ensure-sui-integer (sui)
 201   `(if (stringp ,sui)
 202     (setq ,sui (parse-sui ,sui))
 203     ,sui))
 204
 205 (defmacro ensure-aui-integer (aui)
 206   `(if (stringp ,aui)
 207     (setq ,aui (parse-aui ,aui))
 208     ,aui))
 209
 210 (defmacro ensure-rui-integer (rui)
 211   `(if (stringp ,rui)
 212     (setq ,rui (parse-rui ,rui))
 213     ,rui))
 214
 215 (defmacro ensure-tui-integer (tui)
 216   `(if (stringp ,tui)
 217     (setq ,tui (parse-tui ,tui))
 218     ,tui))
 219
 220 (defmacro ensure-eui-integer (eui)
 221   `(if (stringp ,eui)
 222     (setq ,eui (parse-eui ,eui))
 223     ,eui))
 224
 225 (defun make-ucon-cui (cui)
 226   (ensure-cui-integer cui)
 227   (when cui
 228     (make-instance 'ucon :cui cui)))
 229
 230 (defun find-ucon-cui (cui &key (srl *current-srl*) without-pfstr)
 231   "Find ucon for a cui. If set SAB, the without-pfstr is on by default"
 232   (ensure-cui-integer cui)
 233   (unless cui (return-from find-ucon-cui nil))
 234
 235   (if without-pfstr
 236       (collect-umlisp-query (mrconso (kcuilrl) srl cui cui :single t)
 237                             (make-instance 'ucon :cui cui :lrl (ensure-integer kcuilrl)
 238                                            :pfstr nil)))
 239    (or
 240      (collect-umlisp-query (mrconso (kcuilrl str) srl cui cui :single t :filter "KPFENG=1")
 241         (make-instance 'ucon :cui cui :pfstr str
 242                        :lrl kcuilrl))
 243      (collect-umlisp-query (mrconso (kcuilrl str) srl cui cui :single t)
 244         (make-instance 'ucon :cui cui :pfstr str
 245                        :lrl kcuilrl))))
 246
 247 (defun find-uconso-cui (cui &key sab (srl *current-srl*))
 248   "Find uconso for a cui."
 249   (ensure-cui-integer cui)
 250   (unless cui (return-from find-uconso-cui nil))
 251
 252   (collect-umlisp-query (mrconso (lat ts lui stt sui ispref aui saui scui sdui sab tty code str
 253                                       srl suppress cvf kpfeng kcuisui kcuilui kcuilrl
 254                                       kluilrl ksuilrl) srl cui cui
 255                                       :filter (if sab (concatenate 'string "SAB='" sab "'") nil))
 256     (make-instance 'uconso :cui cui :lat lat :ts ts :lui lui :stt stt :sui sui :ispref ispref
 257                    :aui aui :saui saui :scui scui :sdui sdui :sab sab :tty tty :code code
 258                    :str str :srl srl :suppress suppress :cvf cvf :kpfeng kpfeng
 259                    :kcuisui kcuisui :kcuilui kcuilui :kcuilrl kcuilrl :kluilrl kluilrl
 260                    :ksuilrl ksuilrl)))
 261
 262
 263 (defun find-uconso-code (code &key first sab (srl *current-srl*) (like nil))
 264   "Return list of uconso objects that match code. Optional, filter for SAB. Optionally, use SQL's LIKE syntax"
 265   (collect-umlisp-query (mrconso (cui sab) srl code code :like like :distinct t
 266                                  :lrl klrl
 267                                  :filter (if sab (concatenate 'string "SAB='" sab "'") nil))
 268     (let ((uconsos (find-uconso-cui cui :sab sab :srl srl)))
 269       (if first
 270           (first uconsos)
 271           uconsos))))
 272
 273 (defun find-uconso-sui (sui &key sab (srl *current-srl*))
 274   "Find uconso for a sui. If set SAB, the without-pfstr is on by default"
 275   (ensure-sui-integer sui)
 276   (unless (and sui (stringp sab))
 277     (return-from find-uconso-sui nil))
 278
 279   (collect-umlisp-query (mrconso (cui lat ts lui stt sui ispref aui saui scui sdui sab tty code str
 280                                       srl suppress cvf kpfeng kcuisui kcuilui kcuilrl
 281                                       kluilrl ksuilrl) srl sui sui
 282                                       :distinct t
 283                                       :filter (if sab (concatenate 'string "SAB='" sab "'") nil))
 284     (make-instance 'uconso :cui cui :lat lat :ts ts :lui lui :stt stt :sui sui :ispref ispref
 285                    :aui aui :saui saui :scui scui :sdui sdui :sab sab :tty tty :code code
 286                    :str str :srl srl :suppress suppress :cvf cvf :kpfeng kpfeng
 287                    :kcuisui kcuisui :kcuilui kcuilui :kcuilrl kcuilrl :kluilrl kluilrl
 288                    :ksuilrl ksuilrl)))
 289
 290 (defun find-pfstr-cui (cui &key (srl *current-srl*))
 291   "Find preferred string for a cui"
 292   (ensure-cui-integer cui)
 293   (or
 294    (collect-umlisp-query (mrconso (str) srl cui cui :distinct t
 295                                   :filter " KPFENG=1" :single t)
 296       str)
 297    (collect-umlisp-query (mrconso (str) srl cui cui :distinct t
 298                                   :single t)
 299                          str)))
 300
 301 (defun find-lrl-cui (cui &key (srl *current-srl*))
 302   "Find LRL for a cui"
 303   (ensure-cui-integer cui)
 304   (collect-umlisp-query (mrconso (kcuilrl) srl cui cui :distinct t :single t)
 305                         (ensure-integer kcuilrl)))
 306
 307 (defun find-ucon-lui (lui &key (srl *current-srl*))
 308   "Find list of ucon for lui"
 309   (ensure-lui-integer lui)
 310   (unless lui (return-from find-ucon-lui nil))
 311   (or
 312    (collect-umlisp-query (mrconso (cui kcuilrl str) srl lui lui
 313                                   :filter " KPFENG=1" :single t)
 314       (make-instance 'ucon :cui (ensure-integer cui)
 315                      :pfstr str :lrl (ensure-integer kcuilrl)))
 316    (collect-umlisp-query (mrconso (cui kcuilrl str) srl lui lui
 317                                   :single t)
 318       (make-instance 'ucon :cui (ensure-integer cui)
 319                      :pfstr str :lrl (ensure-integer kcuilrl)))))
 320
 321 (defun find-ucon-sui (sui &key (srl *current-srl*))
 322   "Find list of ucon for sui"
 323   (ensure-sui-integer sui)
 324   (collect-umlisp-query (mrconso (cui kcuilrl) srl sui sui :distinct t)
 325     (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui)
 326                    :lrl (ensure-integer kcuilrl))))
 327
 328 (defun find-ucon-aui (aui &key (srl *current-srl*))
 329   "Find list of ucon for aui"
 330   (ensure-aui-integer aui)
 331   (collect-umlisp-query (mrconso (cui kcuilrl) srl aui aui :distinct t)
 332     (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui)
 333                    :lrl (ensure-integer kcuilrl))))
 334
 335 (defun find-ucon-cuisui (cui sui &key (srl *current-srl*))
 336   "Find ucon for cui/sui"
 337   (ensure-cui-integer cui)
 338   (ensure-sui-integer sui)
 339   (when (and cui sui)
 340     (collect-umlisp-query (mrconso (kcuilrl) srl kcuisui
 341                               (make-cuisui cui sui))
 342       (make-instance 'ucon :cui cui
 343                      :pfstr (find-pfstr-cui cui)
 344                      :lrl (ensure-integer kcuilrl)))))
 345
 346 (defun find-ucon-str (str &key (srl *current-srl*))
 347   "Find ucon that are exact match for str"
 348   (collect-umlisp-query (mrconso (cui kcuilrl) srl str str :distinct t)
 349     (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui)
 350                    :lrl (ensure-integer kcuilrl))))
 351
 352 (defun find-ucon-all (&key (srl *current-srl*))
 353   "Return list of all ucon's"
 354   (with-sql-connection (db)
 355     (clsql:map-query
 356      'list
 357      #'(lambda (tuple)
 358          (destructuring-bind (cui cuilrl) tuple
 359              (make-instance 'ucon :cui (ensure-integer cui)
 360                             :pfstr (find-pfstr-cui cui)
 361                             :lrl (ensure-integer cuilrl))))
 362      (query-string mrconso (cui kcuilrl) srl nil nil
 363                    :order (cui asc) :distinct t)
 364      :database db)))
 365
 366 (defun find-ucon-all2 (&key (srl *current-srl*))
 367   "Return list of all ucon's"
 368   (collect-umlisp-query (mrconso (cui kcuilrl) srl nil nil :order (cui asc)
 369                             :distinct t)
 370     (make-instance 'ucon :cui (ensure-integer cui)
 371                    :pfstr (find-pfstr-cui cui)
 372                    :lrl (ensure-integer kcuilrl))))
 373
 374 (defun find-cui-ucon-all (&key (srl *current-srl*))
 375   "Return list of CUIs for all ucons"
 376   (collect-umlisp-query (mrconso (cui) srl nil nil :order (cui asc)
 377                                :distinct t)
 378                         cui))
 379
 380 (defun map-ucon-all (fn &key (srl *current-srl*))
 381   "Map a function over all ucon's"
 382   (with-sql-connection (db)
 383     (clsql:map-query
 384      nil
 385      #'(lambda (tuple)
 386          (destructuring-bind (cui cuilrl) tuple
 387            (funcall fn (make-instance 'ucon :cui (ensure-integer cui)
 388                                       :pfstr (find-pfstr-cui cui)
 389                                       :lrl (ensure-integer cuilrl)))))
 390      (query-string mrconso (cui kcuilrl) srl nil nil :order (cui asc)
 391                    :distinct t)
 392      :database db)))
 393
 394
 395 (defun find-udef-cui (cui &key (srl *current-srl*))
 396   "Return a list of udefs for cui"
 397   (ensure-cui-integer cui)
 398   (collect-umlisp-query (mrdef (sab def suppress) srl cui cui :lrl "KSRL")
 399     (make-instance 'udef :sab sab :def def :suppress suppress)))
 400
 401 (defun find-udoc-key (key)
 402   "Return list of abbreviation documentation for a key"
 403   (collect-umlisp-query (mrdoc (value type expl) nil dockey key)
 404     (make-instance 'udoc :dockey key :dvalue value :dtype type :expl expl)))
 405
 406 (defun find-udoc-value (value)
 407   "Return abbreviation documentation"
 408   (collect-umlisp-query (mrdoc (dockey type expl) nil value value)
 409     (make-instance 'udoc :dockey dockey :dvalue value :dtype type :expl expl)))
 410
 411 (defun find-udoc-key-value (dockey value)
 412   (collect-umlisp-query (mrdoc (type expl) nil dockey dockey :filter (format nil "VALUE='~A'" value))
 413       (make-instance 'udoc :dockey dockey :dvalue value :dtype type :expl expl)))
 414
 415 (defun find-udoc-all ()
 416   "Return all abbreviation documentation"
 417   (collect-umlisp-query (mrdoc (dockey value type expl) nil nil nil)
 418     (make-instance 'udoc :dockey dockey :dvalue value :dtype type :expl expl)))
 419
 420 (defun find-usty-cui (cui &key (srl *current-srl*))
 421   "Return a list of usty for cui"
 422   (ensure-cui-integer cui)
 423   (collect-umlisp-query (mrsty (tui sty) srl cui cui :lrl "KLRL")
 424     (make-instance 'usty :tui (ensure-integer tui) :sty sty)))
 425
 426 (defun find-usty-word (word &key (srl *current-srl*))
 427   "Return a list of usty that match word"
 428   (collect-umlisp-query (mrsty (tui sty) srl sty word :lrl klrl :like t
 429                             :distinct t)
 430     (make-instance 'usty :tui (ensure-integer tui) :sty sty)))
 431
 432 (defun find-urel-cui (cui &key (srl *current-srl*) filter without-pfstr2)
 433   "Return a list of urel for cui"
 434   (ensure-cui-integer cui)
 435   (collect-umlisp-query (mrrel (aui1 rel stype1 cui2 aui2 stype2 rela rui srui sab sl rg dir suppress cvf)
 436                                srl cui1 cui :lrl "KSRL" :filter filter)
 437     (let ((rel
 438       (make-instance 'urel :cui1 cui :aui1 (ensure-integer aui1) :stype1 stype1 :rel rel
 439                      :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2) :stype2 stype2
 440                      :rui (ensure-integer rui) :srui srui :rela rela :sab sab :sl sl :rg rg :dir dir
 441                      :suppress suppress :cvf cvf)))
 442       (unless without-pfstr2
 443         (setf (slot-value rel 'pfstr2) (find-pfstr-cui cui2)))
 444       rel)))
 445
 446 (defun find-urel-rui (rui &key (srl *current-srl*))
 447   "Return the urel for a rui"
 448   (ensure-rui-integer rui)
 449   (collect-umlisp-query (mrrel (aui1 rel stype1 cui1 cui2 aui2 stype2 rela rui srui sab sl rg dir suppress cvf)
 450                                srl rui rui :lrl "KSRL" :single t)
 451     (make-instance 'urel :cui1 cui1 :aui1 (ensure-integer aui1) :stype1 stype1 :rel rel
 452                    :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2) :stype2 stype2
 453                    :rui (ensure-integer rui) :srui srui :rela rela :sab sab :sl sl :rg rg :dir dir
 454                    :suppress suppress :cvf cvf :pfstr2 (find-pfstr-cui cui2))))
 455
 456 (defun find-cui2-urel-cui (cui &key (srl *current-srl*))
 457   "Return a list of urel for cui"
 458   (ensure-cui-integer cui)
 459   (collect-umlisp-query (mrrel (cui2) srl cui1
 460                                cui :lrl "KSRL")
 461                         cui2))
 462
 463 (defun find-urel-cui2 (cui2 &key (srl *current-srl*))
 464   "Return a list of urel for cui2"
 465   (ensure-cui-integer cui2)
 466   (collect-umlisp-query (mrrel (rel cui1 aui1 stype1 aui2 stype2 rela rui srui sab sl rg dir suppress cvf)
 467                                srl cui2 cui2 :lrl "KSRL")
 468     (make-instance 'urel :cui2 cui2 :rel rel :aui2 (ensure-integer aui2)
 469                    :stype2 stype2 :rui (ensure-integer rui) :srui srui
 470                    :stype1 stype1 :cui1 (ensure-integer cui1)
 471                    :aui1 (ensure-integer aui1)
 472                    :rela rela :sab sab :sl sl :rg rg :dir dir :suppress suppress :cvf cvf
 473                    :pfstr2 (find-pfstr-cui cui2))))
 474
 475 (defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*))
 476   (ensure-cui-integer cui2)
 477   (loop for cui in (remove-duplicates
 478                     (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl)))
 479         collect (find-ucon-cui cui :srl srl)))
 480
 481 (defun find-ucoc-cui (cui &key (srl *current-srl*))
 482   "Return a list of ucoc for cui"
 483   (ensure-cui-integer cui)
 484   (collect-umlisp-query (mrcoc (aui1 cui2 aui2 sab cot cof coa) srl cui1
 485                             cui :lrl klrl :order (cof asc))
 486     (setq cui2 (ensure-integer cui2))
 487     (when (eql 0 cui2) (setq cui2 nil))
 488     (make-instance 'ucoc :cui1 cui :aui1 (ensure-integer aui1)
 489                    :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2)
 490                    :cot cot :cof (ensure-integer cof) :coa coa :sab sab
 491                    :pfstr2 (find-pfstr-cui cui2))))
 492
 493 (defun find-ucoc-cui2 (cui2 &key (srl *current-srl*))
 494   "Return a list of ucoc for cui2"
 495   (ensure-cui-integer cui2)
 496   (collect-umlisp-query (mrcoc (cui1 aui1 aui2 sab cot cof coa) srl cui2
 497                             cui2 :lrl klrl :order (cof asc))
 498     (when (zerop cui2) (setq cui2 nil))
 499     (make-instance 'ucoc :cui1 (ensure-integer cui1) :cui2 cui2
 500                    :aui1 (ensure-integer aui1) :aui2 (ensure-integer aui2)
 501                    :sab sab :cot cot :cof (ensure-integer cof) :coa coa
 502                    :pfstr2 (find-pfstr-cui cui2))))
 503
 504 (defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*))
 505   "List of ucon with co-occurance cui2"
 506   (ensure-cui-integer cui2)
 507   (mapcar
 508    #'(lambda (cui) (find-ucon-cui cui :srl srl))
 509    (remove-duplicates (mapcar #'cui1 (find-ucoc-cui2 cui2 :srl srl)))))
 510
 511
 512 (defun find-uterm-cui (cui &key (srl *current-srl*))
 513   "Return a list of uterm for cui"
 514   (ensure-cui-integer cui)
 515   (collect-umlisp-query (mrconso (lui lat ts kluilrl) srl cui cui
 516                             :lrl kluilrl :distinct t)
 517     (make-instance 'uterm :lui (ensure-integer lui) :cui cui
 518                    :lat lat :ts ts :lrl (ensure-integer kluilrl))))
 519
 520 (defun find-uterm-lui (lui &key (srl *current-srl*))
 521   "Return a list of uterm for lui"
 522   (ensure-lui-integer lui)
 523   (collect-umlisp-query (mrconso (cui lat ts kluilrl) srl lui lui
 524                              :lrl kluilrl :distinct t)
 525     (make-instance 'uterm :cui (ensure-integer cui) :lui lui
 526                    :lat lat :ts ts :lrl (ensure-integer kluilrl))))
 527
 528 (defun find-uterm-cuilui (cui lui &key (srl *current-srl*))
 529   "Return single uterm for cui/lui"
 530   (ensure-cui-integer cui)
 531   (ensure-lui-integer lui)
 532   (collect-umlisp-query (mrconso (lat ts kluilrl) srl kcuilui
 533                              (make-cuilui cui lui)
 534                              :lrl kluilrl :single t)
 535     (make-instance 'uterm :cui cui :lui lui :lat lat :ts ts
 536                    :lrl (ensure-integer kluilrl))))
 537
 538 (defun find-ustr-cuilui (cui lui &key (srl *current-srl*))
 539   "Return a list of ustr for cui/lui"
 540   (ensure-cui-integer cui)
 541   (ensure-lui-integer lui)
 542   (collect-umlisp-query (mrconso (sui stt str suppress ksuilrl) srl kcuilui
 543                                  (make-cuilui cui lui) :lrl ksuilrl)
 544                 (make-instance 'ustr :sui (ensure-integer sui) :cui cui :lui lui
 545                    :cuisui (make-cuisui cui sui) :stt stt :str str :suppress suppress
 546                    :lrl (ensure-integer ksuilrl))))
 547
 548 (defun find-ustr-cuisui (cui sui &key (srl *current-srl*))
 549   "Return the single ustr for cuisui"
 550   (ensure-cui-integer cui)
 551   (ensure-sui-integer sui)
 552   (collect-umlisp-query (mrconso (lui stt str suppress ksuilrl) srl kcuisui
 553                             (make-cuisui cui sui) :lrl lsuilrl :single t)
 554     (make-instance 'ustr :sui sui :cui cui :cuisui (make-cuisui cui sui)
 555                    :lui (ensure-integer lui) :stt stt :str str :suppress suppress
 556                    :lrl (ensure-integer ksuilrl))))
 557
 558 (defun find-ustr-sui (sui &key (srl *current-srl*))
 559   "Return the list of ustr for sui"
 560   (ensure-sui-integer sui)
 561   (collect-umlisp-query (mrconso (cui lui stt str suppress ksuilrl) srl sui sui
 562                             :lrl ksuilrl)
 563     (make-instance 'ustr :sui sui :cui cui :stt stt :str str
 564                    :cuisui (make-cuisui (ensure-integer cui) sui)
 565                    :suppress suppress
 566                    :lui (ensure-integer lui) :lrl (ensure-integer ksuilrl))))
 567
 568 (defun find-ustr-sab (sab &key (srl *current-srl*))
 569   "Return the list of ustr for sab"
 570   (collect-umlisp-query (mrconso (kcuisui) srl sab sab :lrl srl)
 571     (let ((cuisui (ensure-integer kcuisui)))
 572       (apply #'find-ustr-cuisui
 573              (append
 574               (multiple-value-list (decompose-cuisui cuisui))
 575               (list :srl srl))))))
 576
 577 (defun find-ustr-all (&key (srl *current-srl*))
 578   "Return list of all ustr's"
 579     (with-sql-connection (db)
 580       (clsql:map-query
 581        'list
 582        #'(lambda (tuple)
 583            (destructuring-bind (cui lui sui stt ksuilrl suppress) tuple
 584              (make-instance 'ustr :cui (ensure-integer cui)
 585                             :lui (ensure-integer lui) :sui (ensure-integer sui)
 586                             :stt stt :str (find-pfstr-cui cui)
 587                             :cuisui (make-cuisui (ensure-integer cui)
 588                                                  (ensure-integer sui))
 589                             :suppress suppress
 590                             :lrl (ensure-integer ksuilrl))))
 591        (query-string mrconso (cui lui sui stt ksuilrl) srl nil nil :lrl ksuilrl
 592                      :distinct t
 593                      :order (sui asc))
 594        :database db)))
 595
 596 (defun find-string-sui (sui &key (srl *current-srl*))
 597   "Return the string associated with sui"
 598   (ensure-sui-integer sui)
 599   (collect-umlisp-query (mrconso (str) srl sui sui :lrl ksuilrl :single t)
 600     str))
 601
 602 (defun find-uso-cuisui (cui sui &key (srl *current-srl*))
 603   (ensure-sui-integer sui)
 604   (ensure-cui-integer cui)
 605   (collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui lat str)
 606                                  srl kcuisui (make-cuisui cui sui) :lrl srl)
 607     (make-instance 'uso :aui aui :sab sab :code code :srl srl :tty tty
 608                    :cui cui :sui sui :saui saui :sdui sdui :scui scui
 609                    :lat lat :str str)))
 610
 611 (defun find-uso-cui (cui &key (srl *current-srl*) (english-only nil) limit)
 612   (ensure-cui-integer cui)
 613   (collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui lat str sui)
 614                                  srl cui cui :lrl srl :limit limit
 615                                  :filter (when english-only "LAT='ENG'"))
 616      (make-instance 'uso :aui aui :sab sab :code code :srl srl :tty tty
 617                     :cui cui :sui sui :saui saui :sdui sdui :scui scui
 618                     :lat lat :str str)))
 619
 620 (defun find-uso-aui (aui &key (srl *current-srl*))
 621   (ensure-sui-integer aui)
 622   (collect-umlisp-query (mrconso (sab cui sui code srl tty saui sdui scui lat
 623                                       str) srl aui aui :lrl srl :single t)
 624     (make-instance 'uso :aui aui :cui cui :sab sab :code code :srl srl :tty tty
 625                    :sui sui :saui saui :sdui sdui :scui scui :lat lat
 626                    :str str)))
 627
 628 (defun find-uhier-cui (cui &key (srl *current-srl*))
 629   (ensure-cui-integer cui)
 630   (collect-umlisp-query (mrhier (aui cxn paui sab rela ptr hcd cvf)
 631                             srl cui cui :lrl ksrl)
 632     (make-instance 'uhier :cui cui :aui (ensure-integer aui)
 633                    :cxn (ensure-integer cxn)
 634                    :paui (ensure-integer paui)
 635                    :sab sab :rela rela :ptr ptr :hcd hcd :cvf cvf)))
 636
 637 (defun find-uhier-all (&key (srl *current-srl*))
 638   (collect-umlisp-query (mrhier (cui aui cxn paui sab rela ptr hcd cvf)
 639                             srl nil nil :lrl ksrl)
 640     (make-instance 'uhier :cui cui :aui (ensure-integer aui)
 641                    :cxn (ensure-integer cxn)
 642                    :paui (ensure-integer paui)
 643                    :sab sab :rela rela :ptr ptr :hcd hcd :cvf cvf)))
 644
 645 (defun find-usat-ui (cui &optional lui sui &key (srl *current-srl*))
 646   (ensure-cui-integer cui)
 647   (ensure-lui-integer lui)
 648   (ensure-sui-integer sui)
 649   (let ((ls "SELECT CODE,ATN,SAB,ATV FROM MRSAT WHERE "))
 650     (cond
 651       (sui (string-append ls "KCUISUI='"
 652                           (integer-string (make-cuisui cui sui) 14)
 653                           "'"))
 654       (lui (string-append ls "KCUILUI='"
 655                           (integer-string (make-cuilui cui lui) 14)
 656                           "' and sui='0'"))
 657       (t (string-append ls "cui='" (prefixed-fixnum-string cui nil 7)
 658                         "' and lui='0' and sui='0'")))
 659     (when srl
 660       (string-append ls " and KSRL<=" (prefixed-fixnum-string srl nil 3)))
 661     (loop for tuple in (mutex-sql-query ls) collect
 662           (destructuring-bind (code atn sab atv) tuple
 663             (make-instance 'usat :code code :atn atn :sab sab :atv atv)))))
 664
 665 (defun find-usty-tui (tui)
 666   "Find usty for tui"
 667   (ensure-tui-integer tui)
 668   (collect-umlisp-query (mrsty (sty) nil tui tui :single t)
 669     (make-instance 'usty :tui tui :sty sty)))
 670
 671 (defun find-usty-sty (sty)
 672   "Find usty for a sty"
 673   (collect-umlisp-query (mrsty (tui) nil sty sty :single t)
 674     (make-instance 'usty :tui (ensure-integer tui) :sty sty)))
 675
 676 (defun find-usty-all ()
 677   "Return list of usty's for all semantic types"
 678   (collect-umlisp-query (mrsty (tui) nil nil nil :distinct t)
 679     (find-usty-tui tui)))
 680
 681 (defun find-usab-all ()
 682   "Return all usab objects"
 683   (collect-umlisp-query (mrsab (vcui rcui vsab rsab son sf sver vstart vend imeta
 684                                   rmeta slc scc srl tfr cfr cxty ttyl atnl lat
 685                                   cenc curver sabin ssn scit) nil nil nil)
 686     (make-instance 'usab :vcui (ensure-integer vcui)
 687                    :rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son
 688                    :sf sf :sver sver :vstart vstart :vend vend :imeta imeta
 689                    :rmeta rmeta :slc slc :scc scc  :srl (ensure-integer srl)
 690                    :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
 691                    :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
 692                    :curver curver :sabin sabin :ssn ssn :scit scit)))
 693
 694 (defun find-usab-by-key (key-name key)
 695   "Find usab for a key"
 696   (collect-umlisp-query-eval ('mrsab '(vcui rcui vsab rsab son sf sver vstart
 697                                        vend imeta rmeta slc scc srl tfr cfr cxty
 698                                        ttyl atnl lat cenc curver sabin
 699                                        ssn scit)
 700                                      nil key-name key :single t)
 701      (make-instance 'usab :vcui (ensure-integer vcui)
 702                     :rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son
 703                     :sf sf :sver sver :vstart vstart :vend vend :imeta imeta
 704                     :rmeta rmeta :slc slc :scc scc :srl (ensure-integer srl)
 705                     :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
 706                     :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
 707                     :curver curver :sabin sabin
 708                     :ssn ssn :scit scit)))
 709
 710 (defun find-usab-rsab (rsab)
 711   "Find usab for rsab"
 712   (find-usab-by-key 'rsab rsab))
 713
 714 (defun find-usab-vsab (vsab)
 715   "Find usab for vsab"
 716   (find-usab-by-key 'vsab vsab))
 717
 718 (defun find-cui-max ()
 719   (ensure-integer (caar (mutex-sql-query "select max(CUI) from MRCON"))))
 720
 721 (defun find-umap-cui (cui)
 722   (ensure-cui-integer cui)
 723   (collect-umlisp-query (mrmap (mapsetsab mapsubsetid maprank fromid fromsid fromexpr
 724                                           fromtype fromrule fromres rel rela toid tosid
 725                                           toexpr totype torule tores maprule maptype
 726                                           mapatn mapatv cvf)
 727                                nil mapsetcui cui)
 728     (make-instance 'umap :mapsetcui cui :mapsetsab mapsetsab :mapsubsetid mapsubsetid
 729                    :maprank (ensure-integer maprank) :fromid fromid :fromsid fromsid
 730                    :fromexpr fromexpr :fromtype fromtype :fromrule fromrule :fromres fromres
 731                    :rel rel :rela rela :toid toid :tosid tosid :toexpr toexpr :totype totype
 732                    :torule torule :tores tores :maprule maprule :maptype maptype :mapatn mapatn
 733                    :mapatv mapatv :cvf cvf)))
 734
 735 (defun find-usmap-cui (cui)
 736   (ensure-cui-integer cui)
 737   (collect-umlisp-query (mrsmap (mapsetsab fromexpr fromtype rel rela toexpr totype cvf)
 738                                nil mapsetcui cui)
 739     (make-instance 'usmap :mapsetcui cui :mapsetsab mapsetsab
 740                    :fromexpr fromexpr :fromtype fromtype
 741                    :rel rel :rela rela :toexpr toexpr :totype totype
 742                    :cvf cvf)))
 743
 744 ;;;; Cross table find functions
 745
 746 (defun find-ucon-tui (tui &key (srl *current-srl*))
 747   "Find list of ucon for tui"
 748   (ensure-tui-integer tui)
 749   (collect-umlisp-query (mrsty (cui) srl tui tui :lrl klrl :order (cui asc))
 750     (find-ucon-cui (ensure-integer cui) :srl srl)))
 751
 752 (defun mrconso-query-word-cui (word sab srl like)
 753   (format nil "SELECT DISTINCT c.cui FROM MRCONSO c,MRXW_ENG x WHERE x.WD~A'~A' AND x.cui=c.cui~A~A"
 754           (if like " LIKE " "=")
 755           (clsql-sys::sql-escape-quotes word)
 756           (etypecase sab
 757             (string
 758              (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
 759             (cons
 760              (format nil " AND c.sab IN (~{'~A'~^,~})"
 761                      (mapcar 'clsql-sys::sql-escape-quotes sab)))
 762             (null
 763              ""))
 764           (if srl (format nil " AND KCUILRL <= ~A" srl) "")))
 765
 766 (defun mrconso-query-word-sui (word sab srl like)
 767   (format nil "SELECT DISTINCT c.sui FROM MRCONSO c,MRXW_ENG x WHERE x.WD~A'~A' AND x.sui=c.sui~A~A"
 768           (if like " LIKE " "=")
 769           (clsql-sys::sql-escape-quotes word)
 770           (etypecase sab
 771             (string
 772              (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
 773             (cons
 774              (format nil " AND c.sab IN (~{'~A'~^,~})"
 775                      (mapcar 'clsql-sys::sql-escape-quotes sab)))
 776             (null
 777              ""))
 778           (if srl (format nil " AND KCUILRL <= ~A" srl) "")))
 779
 780 (defun find-uconso-word (word &key sab (srl *current-srl*) (like nil))
 781   "Return list of uconso that match word. Optionally, matching SAB. Optionally, use SQL's LIKE syntax"
 782   (cond
 783     (sab
 784      (let ((sui-query (mrconso-query-word-sui word sab srl like))
 785            (uconsos nil))
 786        (dolist (sui (remove-duplicates (sort (mapcar 'car (mutex-sql-query sui-query)) #'<)))
 787          (setq uconsos (nconc uconsos (find-uconso-sui sui :sab sab))))
 788        (remove-duplicates uconsos :key 'cui)))
 789     (t
 790      (collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t
 791                                            :lrl 'klrl :order '(cui asc))
 792        (find-uconso-cui cui :srl srl)))))
 793
 794 (defun find-ucon-word (word &key sab (srl *current-srl*) (like nil))
 795   "Return list of ucon that match word in matching SAB. Optionally, use SQL's LIKE syntax"
 796   (cond
 797     (sab
 798      (let ((query (mrconso-query-word-cui word sab srl like)))
 799        (loop for tuple in (mutex-sql-query query)
 800              collect (make-instance 'ucon :cui (first tuple)))))
 801     (t
 802      (collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t
 803                                            :lrl 'klrl :order '(cui asc))
 804        (find-ucon-cui cui :srl srl)))))
 805
 806 (defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil))
 807   "Return list of ucons that match word, optionally use SQL's LIKE syntax"
 808   (collect-umlisp-query-eval ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t
 809                                       :lrl 'klrl :order '(cui asc))
 810     (find-ucon-cui cui :srl srl)))
 811
 812 (defun find-cui-normalized-word (word &key (srl *current-srl*) (like nil))
 813   "Return list of cui that match word, optionally use SQL's LIKE syntax"
 814   (collect-umlisp-query-eval ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t
 815                                          :lrl 'klrl :order '(cui asc))
 816                              cui))
 817
 818 (defun find-lui-normalized-word (word &key (srl *current-srl*) (like nil))
 819   "Return list of cui that match word, optionally use SQL's LIKE syntax"
 820   (collect-umlisp-query-eval ('mrxnw_eng '(lui) srl 'nwd word :like like :distinct t
 821                                          :lrl 'klrl :order '(cui asc))
 822                              lui))
 823
 824 (defun find-sui-normalized-word (word &key (srl *current-srl*) (like nil))
 825   "Return list of cui that match word, optionally use SQL's LIKE syntax"
 826   (collect-umlisp-query-eval ('mrxnw_eng '(sui) srl 'nwd word :like like :distinct t
 827                                          :lrl 'klrl :order '(cui asc))
 828                              sui))
 829
 830 (defun find-ustr-word (word &key sab (srl *current-srl*) (like nil))
 831   "Return list of ustr that match word in matching SAB. Optionally, use SQL's LIKE syntax"
 832   (cond
 833     (sab
 834      (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"
 835                           (if like "LIKE" "=")
 836                           (clsql-sys::sql-escape-quotes word)
 837                           (typecase sab
 838                             (string
 839                              (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
 840                             (cons
 841                              (format nil " AND c.sab IN (~('~A'~^,~))"
 842                                      (mapcar 'clsql-sys::sql-escape-quotes sab)))
 843                             (null
 844                              ""))
 845                           (if srl (format nil " AND KCUILRL <= ~D" srl) ""))))
 846        (loop for tuple in (mutex-sql-query query)
 847              collect (destructuring-bind (sui cui lui str lrl stt suppress cuisui) tuple
 848                        (make-instance 'ustr :sui sui :cui cui :lui lui :str str :lrl lrl
 849                                       :stt stt :suppress suppress :cuisui cuisui)))))
 850     (t
 851      (collect-umlisp-query (mrxw_eng (cui sui) srl wd word :lrl klrl
 852                                      :order (cui asc sui asc))
 853        (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))))
 854
 855 (defun find-ustr-normalized-word (word &key (srl *current-srl*))
 856   "Return list of ustrs that match word"
 857   (collect-umlisp-query (mrxnw_eng (cui sui) srl nwd word :lrl klrl
 858                                  :order (cui asc sui asc))
 859     (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
 860
 861 (defun find-uterm-word (word &key (srl *current-srl*))
 862   "Return list of uterms that match word"
 863   (collect-umlisp-query (mrxw_eng (cui lui) srl wd word :lrl klrl
 864                                :order (cui asc lui asc))
 865     (find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl)))
 866
 867 (defun find-uterm-normalized-word (word &key (srl *current-srl*))
 868   "Return list of uterms that match word"
 869   (collect-umlisp-query (mrxnw_eng (cui lui) srl nwd word :lrl klrl
 870                                  :order (cui asc lui asc))
 871     (find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl)))
 872
 873 (defun find-ucon-noneng-word (word &key (srl *current-srl*) (like nil))
 874   "Return list of ucons that match non-english word"
 875   (collect-umlisp-query-eval ('mrxw_noneng '(cui) srl 'wd word :like like
 876                                         :distinct t :lrl 'klrl :order '(cui asc))
 877     (find-ucon-cui cui :srl srl)))
 878
 879 (defun find-ustr-noneng-word (word &key (srl *current-srl*))
 880   "Return list of ustrs that match non-english word"
 881   (collect-umlisp-query (mrxw_noneng (cui sui) srl wd word :lrl klrl
 882                                   :order (cui asc sui asc))
 883     (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
 884
 885 ;; Special tables
 886
 887 (defun find-usrl-all ()
 888   (collect-umlisp-query (usrl (sab srl) nil nil nil :order (sab asc))
 889     (make-instance 'usrl :sab sab :srl (ensure-integer srl))))
 890
 891 ;;; Multiword lookup and score functions
 892
 893 (defun find-uobj-multiword (str obj-lookup-fun sort-fun key srl
 894                                 only-exact-if-match limit &key extra-lookup-args)
 895   (let ((uobjs '()))
 896     (dolist (word (delimited-string-to-list str #\space))
 897       (setq uobjs (append uobjs (apply obj-lookup-fun word :srl srl extra-lookup-args))))
 898     (let ((sorted
 899            (funcall sort-fun str
 900                     (delete-duplicates uobjs :test #'= :key key))))
 901       (let ((len (length sorted)))
 902         (cond
 903          ((zerop len)
 904           (return-from find-uobj-multiword nil))
 905          ((and only-exact-if-match (multiword-match str (pfstr (first sorted))))
 906           (first sorted))
 907          (limit
 908           (if (and (plusp limit) (> len limit))
 909               (subseq sorted 0 limit)
 910             limit))
 911          (t
 912           sorted))))))
 913
 914 (defun find-ucon-multiword (str &key (srl *current-srl*)
 915                                      (only-exact-if-match t)
 916                                      limit
 917                                      sab)
 918   (find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str
 919                        #'cui srl only-exact-if-match limit
 920                        :extra-lookup-args (list :sab sab)))
 921
 922 (defun find-uconso-multiword (str &key (srl *current-srl*)
 923                                      (only-exact-if-match t)
 924                                      limit
 925                                      sab)
 926   (find-uobj-multiword str #'find-uconso-word #'sort-score-pfstr-str
 927                        #'cui srl only-exact-if-match limit
 928                        :extra-lookup-args (list :sab sab)))
 929
 930 (defun find-uterm-multiword (str &key (srl *current-srl*)
 931                                       (only-exact-if-match t)
 932                                       limit)
 933   (find-uobj-multiword str #'find-uterm-word #'sort-score-pfstr-str
 934                        #'lui srl only-exact-if-match limit))
 935
 936 (defun find-ustr-multiword (str &key (srl *current-srl*)
 937                                      (only-exact-if-match t)
 938                                      limit
 939                                      sab)
 940   (find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str
 941                        #'sui srl only-exact-if-match limit
 942                        :extra-lookup-args (list :sab sab)))
 943
 944 (defun sort-score-pfstr-str (str uobjs)
 945   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
 946   (sort-score-umlsclass-str uobjs str #'pfstr))
 947
 948 (defun sort-score-ustr-str (str ustrs)
 949   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
 950   (sort-score-umlsclass-str ustrs str #'str))
 951
 952 (defun sort-score-umlsclass-str (objs str lookup-func)
 953   "Sort a list of objects based on scoring to a string"
 954   (let ((scored '()))
 955     (dolist (obj objs)
 956       (push (list obj (score-multiword-match str (funcall lookup-func obj)))
 957        scored))
 958     (mapcar #'car (sort scored #'> :key #'cadr))))
 959
 960
 961 ;;; LEX SQL functions
 962
 963 (defun find-lexterm-eui (eui)
 964   (ensure-eui-integer eui)
 965   (collect-umlisp-query (lrwd (wrd) nil eui eui :single t)
 966     (make-instance 'lexterm :eui eui :wrd wrd)))
 967
 968 (defun find-lexterm-word (wrd)
 969   (collect-umlisp-query (lrwd (eui) nil wrd wrd)
 970     (make-instance 'lexterm :eui (ensure-integer eui)
 971                    :wrd (copy-seq wrd))))
 972
 973 ;; LEX SQL Read functions
 974
 975 (defun find-labr-eui (eui)
 976   (ensure-eui-integer eui)
 977   (collect-umlisp-query (lrabr (bas abr eui2 bas2) nil eui eui)
 978     (make-instance 'labr :eui eui :bas bas :abr abr :bas2 bas2
 979                    :eui2 (ensure-integer eui2))))
 980
 981 (defun find-labr-bas (bas)
 982   (collect-umlisp-query (labr (eui abr eui2 bas2) nil bas bas)
 983     (make-instance 'labr :eui (ensure-integer eui) :abr abr :bas2 bas2
 984                    :bas (copy-seq bas) :eui2 (ensure-integer eui2))))
 985
 986 (defun find-lagr-eui (eui)
 987   (ensure-eui-integer eui)
 988   (collect-umlisp-query (lragr (str sca agr cit bas) nil eui eui)
 989     (make-instance 'lagr :eui eui :str str :sca sca :agr agr
 990                    :cit cit :bas bas)))
 991
 992 (defun find-lcmp-eui (eui)
 993   (ensure-eui-integer eui)
 994   (collect-umlisp-query (lrcmp (bas sca com) nil eui eui)
 995     (make-instance 'lcmp :eui eui :bas bas :sca sca :com com)))
 996
 997 (defun find-lmod-eui (eui)
 998   (ensure-eui-integer eui)
 999   (collect-umlisp-query (lrmod (bas sca psn_mod fea) nil eui eui)
1000     (make-instance 'lmod :eui eui :bas bas :sca sca :psnmod psn_mod :fea fea)))
1001
1002 (defun find-lnom-eui (eui)
1003   (ensure-eui-integer eui)
1004   (collect-umlisp-query (lrnom (bas sca eui2 bas2 sca2) nil eui eui)
1005     (make-instance 'lnom :eui eui :bas bas :sca sca :bas2 bas2 :sca2 sca2
1006                    :eui2 (ensure-integer eui2))))
1007
1008 (defun find-lprn-eui (eui)
1009   (ensure-eui-integer eui)
1010   (collect-umlisp-query (lrprn (bas num gnd cas pos qnt fea) nil eui eui)
1011     (make-instance 'lprn :eui eui :bas bas :num num :gnd gnd
1012                    :cas cas :pos pos :qnt qnt :fea fea)))
1013
1014 (defun find-lprp-eui (eui)
1015   (ensure-eui-integer eui)
1016   (collect-umlisp-query (lrprp (bas str sca fea) nil eui eui)
1017     (make-instance 'lprp :eui eui :bas bas :str str :sca sca :fea fea)))
1018
1019 (defun find-lspl-eui (eui)
1020   (ensure-eui-integer eui)
1021   (collect-umlisp-query (lrspl (spv bas) nil eui eui)
1022     (make-instance 'lspl :eui eui :spv spv :bas bas)))
1023
1024 (defun find-ltrm-eui (eui)
1025   (ensure-eui-integer eui)
1026   (collect-umlisp-query (lrtrm (bas gen) nil eui eui)
1027     (make-instance 'ltrm :eui eui :bas bas :gen gen)))
1028
1029 (defun find-ltyp-eui (eui)
1030   (ensure-eui-integer eui)
1031   (collect-umlisp-query (lrtyp (bas sca typ) nil eui eui)
1032     (make-instance 'ltyp :eui eui :bas bas :sca sca :typ typ)))
1033
1034 (defun find-lwd-wrd (wrd)
1035   (make-instance 'lwd :wrd wrd
1036                  :euilist (collect-umlisp-query (lrwd (eui) nil wrd wrd)
1037                                                 (ensure-integer eui))))
1038
1039 ;;; Semantic Network SQL access functions
1040
1041 (defun find-sdef-ui (ui)
1042   (collect-umlisp-query (srdef (rt sty_rl stn_rtn def ex un rh abr rin)
1043                             nil ui ui :single t)
1044     (make-instance 'sdef :rt rt :ui ui :styrl sty_rl :stnrtn stn_rtn
1045                    :def def :ex ex :un un :rh rh :abr abr :rin rin)))
1046
1047 (defun find-sstre1-ui (ui)
1048   (collect-umlisp-query (srstre1 (ui2 ui3) nil ui ui)
1049     (make-instance 'sstre1 :ui ui :ui2 (ensure-integer ui2)
1050                    :ui3 (ensure-integer ui3))))
1051
1052 (defun find-sstre1-ui2 (ui2)
1053   (collect-umlisp-query (srstre1 (ui ui3) nil ui2 ui2)
1054     (make-instance 'sstre1 :ui (ensure-integer ui) :ui2 ui2
1055                    :ui3 (ensure-integer ui3))))
1056
1057 (defun find-sstr-rl (rl)
1058   (collect-umlisp-query (srstre (sty_rl sty_rl2 ls) nil rl rl)
1059     (make-instance 'sstr :rl rl :styrl sty_rl :styrl2 sty_rl2 :ls ls)))
1060
1061 (defun find-sstre2-sty (sty)
1062   (collect-umlisp-query (srstre2 (rl sty2) nil sty sty)
1063     (make-instance 'sstre2 :sty (copy-seq sty) :rl rl :sty2 sty2)))
1064
1065 (defun find-sstr-styrl (styrl)
1066   (collect-umlisp-query (srstr (rl sty_rl2 ls) nil styrl styrl)
1067     (make-instance 'sstr :styrl styrl :rl rl :styrl2 sty_rl2 :ls ls)))
1068
1069
1070 ;;; **************************
1071 ;;; Local Classes
1072 ;;; **************************
1073
1074
1075 (defun make-ustats ()
1076   (with-sql-connection (conn)
1077     (ignore-errors (sql-execute "drop table USTATS" conn))
1078     (sql-execute "create table USTATS (NAME varchar(160), COUNT bigint, SRL integer)" conn)
1079
1080     (dotimes (srl 5)
1081       (insert-ustats-count conn "Concept Count" "MRCONSO" "distinct CUI" "KCUILRL" srl)
1082       (insert-ustats-count conn "Term Count" "MRCONSO" "distinct KCUILUI" "KCUILRL" srl)
1083       (insert-ustats-count conn "Distinct Term Count" "MRCONSO" "distinct LUI" "KLUILRL" srl)
1084       (insert-ustats-count conn "String Count" "MRCONSO" "*" "KSUILRL" srl)
1085       (insert-ustats-count conn "Distinct String Count" "MRCONSO" "distinct SUI" "KSUILRL" srl)
1086       (insert-ustats-count conn "Hierarchcy" "MRHIER" "*" "KSRL" srl)
1087       (insert-ustats-count conn "Mappings" "MRMAP" "*" "KSRL" srl)
1088       (insert-ustats-count conn "Simple Mappings" "MRSMAP" "*" "KSRL" srl)
1089       (insert-ustats-count conn "Co-occuring Concept Count" "MRCOC" "*" "KLRL" srl)
1090       (insert-ustats-count conn "Definition Count" "MRDEF" "*" "KSRL" srl)
1091       (insert-ustats-count conn "Rank Count" "MRRANK" "*" "KSRL" srl)
1092       (insert-ustats-count conn "Relationship Count" "MRREL" "*" "KSRL" srl)
1093       (insert-ustats-count conn "Semantic Type Count" "MRSTY" "*" "KLRL" srl)
1094       (insert-ustats-count conn "Simple Attribute Count" "MRSAT" "*" "KSRL" srl)
1095       (insert-ustats-count conn "Source Abbreviation Count" "MRSAB" "*" "SRL" srl)
1096       (insert-ustats-count conn "Word Index Count" "MRXW_ENG" "*" "KLRL" srl)
1097       (insert-ustats-count conn "Normalized Word Index Count" "MRXNW_ENG" "*" "KLRL" srl)
1098       (insert-ustats-count conn "Normalized String Index Count" "MRXNS_ENG" "*" "KLRL" srl))
1099     (sql-execute "create index USTATS_SRL on USTATS (SRL)" conn))
1100   (find-ustats-all))
1101
1102 (defun insert-ustats-count (conn name table count-variable srl-control srl)
1103   (insert-ustats conn name (find-count-table conn table srl count-variable srl-control) srl))
1104
1105 (defun find-count-table (conn table srl count-variable srl-control)
1106   (cond
1107    ((stringp srl-control)
1108     (ensure-integer
1109      (caar (sql-query (format nil "select count(~a) from ~a where ~a <= ~d"
1110                               count-variable table srl-control srl)
1111                       conn))))
1112    ((null srl-control)
1113     (ensure-integer
1114      (caar (sql-query (format nil "select count(~a) from ~a"
1115                               count-variable table )
1116                       conn))))
1117    (t
1118     (error "Unknown srl-control")
1119     0)))
1120
1121 (defun insert-ustats (conn name count srl)
1122   (sql-execute (format nil "insert into USTATS (name,count,srl) values ('~a',~d,~d)"
1123                        name count (if srl srl 3))
1124                conn))
1125
1126 (defun find-ustats-all (&key (srl *current-srl*))
1127   (if srl
1128       (collect-umlisp-query (ustats (name count srl) nil srl srl
1129                                     :order (name asc))
1130                             (make-instance 'ustats :name name
1131                                            :hits (ensure-integer count)
1132                                            :srl (ensure-integer srl)))
1133     (collect-umlisp-query (ustats (name count srl) nil nil nil
1134                                   :order (name asc))
1135                           (make-instance 'ustats :name name
1136                                          :hits (ensure-integer count)
1137                                          :srl (ensure-integer srl)))))
1138
1139 (defun find-ustats-srl (srl)
1140   (collect-umlisp-query (ustats (name count) nil srl srl :order (name asc))
1141                            (make-instance 'ustats :name name :hits (ensure-integer count))))
1142