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 " LIKE '%~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 ts)
 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 :ts ts)))
 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 &key current)
 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                                      :filter (when current "RMETA=''"))
 702      (make-instance 'usab :vcui (ensure-integer vcui)
 703                     :rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son
 704                     :sf sf :sver sver :vstart vstart :vend vend :imeta imeta
 705                     :rmeta rmeta :slc slc :scc scc :srl (ensure-integer srl)
 706                     :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
 707                     :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
 708                     :curver curver :sabin sabin
 709                     :ssn ssn :scit scit)))
 710
 711 (defun find-usab-rsab (rsab &key (current t))
 712   "Find usab for rsab"
 713   (find-usab-by-key 'rsab rsab))
 714
 715 (defun find-usab-vsab (vsab &key (current t))
 716   "Find usab for vsab"
 717   (find-usab-by-key 'vsab vsab))
 718
 719 (defun find-cui-max ()
 720   (ensure-integer (caar (mutex-sql-query "select max(CUI) from MRCON"))))
 721
 722 (defun find-umap-cui (cui)
 723   (ensure-cui-integer cui)
 724   (collect-umlisp-query (mrmap (mapsetsab mapsubsetid maprank fromid fromsid fromexpr
 725                                           fromtype fromrule fromres rel rela toid tosid
 726                                           toexpr totype torule tores maprule maptype
 727                                           mapatn mapatv cvf)
 728                                nil mapsetcui cui)
 729     (make-instance 'umap :mapsetcui cui :mapsetsab mapsetsab :mapsubsetid mapsubsetid
 730                    :maprank (ensure-integer maprank) :fromid fromid :fromsid fromsid
 731                    :fromexpr fromexpr :fromtype fromtype :fromrule fromrule :fromres fromres
 732                    :rel rel :rela rela :toid toid :tosid tosid :toexpr toexpr :totype totype
 733                    :torule torule :tores tores :maprule maprule :maptype maptype :mapatn mapatn
 734                    :mapatv mapatv :cvf cvf)))
 735
 736 (defun find-usmap-cui (cui)
 737   (ensure-cui-integer cui)
 738   (collect-umlisp-query (mrsmap (mapsetsab fromexpr fromtype rel rela toexpr totype cvf)
 739                                nil mapsetcui cui)
 740     (make-instance 'usmap :mapsetcui cui :mapsetsab mapsetsab
 741                    :fromexpr fromexpr :fromtype fromtype
 742                    :rel rel :rela rela :toexpr toexpr :totype totype
 743                    :cvf cvf)))
 744
 745 ;;;; Cross table find functions
 746
 747 (defun find-ucon-tui (tui &key (srl *current-srl*))
 748   "Find list of ucon for tui"
 749   (ensure-tui-integer tui)
 750   (collect-umlisp-query (mrsty (cui) srl tui tui :lrl klrl :order (cui asc))
 751     (find-ucon-cui (ensure-integer cui) :srl srl)))
 752
 753 (defun mrconso-query-word-cui (word sab srl like)
 754   (format nil "SELECT DISTINCT c.cui FROM MRCONSO c,MRXW_ENG x WHERE x.WD~A'~A' AND x.cui=c.cui~A~A"
 755           (if like " LIKE " "=")
 756           (clsql-sys::sql-escape-quotes word)
 757           (etypecase sab
 758             (string
 759              (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
 760             (cons
 761              (format nil " AND c.sab IN (~{'~A'~^,~})"
 762                      (mapcar 'clsql-sys::sql-escape-quotes sab)))
 763             (null
 764              ""))
 765           (if srl (format nil " AND KCUILRL <= ~A" srl) "")))
 766
 767 (defun mrconso-query-word-sui (word sab srl like)
 768   (format nil "SELECT DISTINCT c.sui FROM MRCONSO c,MRXW_ENG x WHERE x.WD~A'~A' AND x.sui=c.sui~A~A"
 769           (if like " LIKE " "=")
 770           (clsql-sys::sql-escape-quotes word)
 771           (etypecase sab
 772             (string
 773              (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
 774             (cons
 775              (format nil " AND c.sab IN (~{'~A'~^,~})"
 776                      (mapcar 'clsql-sys::sql-escape-quotes sab)))
 777             (null
 778              ""))
 779           (if srl (format nil " AND KCUILRL <= ~A" srl) "")))
 780
 781 (defun find-uconso-word (word &key sab (srl *current-srl*) (like nil))
 782   "Return list of uconso that match word. Optionally, matching SAB. Optionally, use SQL's LIKE syntax"
 783   (cond
 784     (sab
 785      (let ((sui-query (mrconso-query-word-sui word sab srl like))
 786            (uconsos nil))
 787        (dolist (sui (remove-duplicates (sort (mapcar 'car (mutex-sql-query sui-query)) #'<)))
 788          (setq uconsos (nconc uconsos (find-uconso-sui sui :sab sab))))
 789        (remove-duplicates uconsos :key 'cui)))
 790     (t
 791      (collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t
 792                                            :lrl 'klrl :order '(cui asc))
 793        (find-uconso-cui cui :srl srl)))))
 794
 795 (defun find-ucon-word (word &key sab (srl *current-srl*) (like nil))
 796   "Return list of ucon that match word in matching SAB. Optionally, use SQL's LIKE syntax"
 797   (cond
 798     (sab
 799      (let ((query (mrconso-query-word-cui word sab srl like)))
 800        (loop for tuple in (mutex-sql-query query)
 801              collect (make-instance 'ucon :cui (first tuple)))))
 802     (t
 803      (collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t
 804                                            :lrl 'klrl :order '(cui asc))
 805        (find-ucon-cui cui :srl srl)))))
 806
 807 (defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil))
 808   "Return list of ucons that match word, optionally use SQL's LIKE syntax"
 809   (collect-umlisp-query-eval ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t
 810                                       :lrl 'klrl :order '(cui asc))
 811     (find-ucon-cui cui :srl srl)))
 812
 813 (defun find-cui-normalized-word (word &key (srl *current-srl*) (like nil))
 814   "Return list of cui that match word, optionally use SQL's LIKE syntax"
 815   (collect-umlisp-query-eval ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t
 816                                          :lrl 'klrl :order '(cui asc))
 817                              cui))
 818
 819 (defun find-lui-normalized-word (word &key (srl *current-srl*) (like nil))
 820   "Return list of cui that match word, optionally use SQL's LIKE syntax"
 821   (collect-umlisp-query-eval ('mrxnw_eng '(lui) srl 'nwd word :like like :distinct t
 822                                          :lrl 'klrl :order '(cui asc))
 823                              lui))
 824
 825 (defun find-sui-normalized-word (word &key (srl *current-srl*) (like nil))
 826   "Return list of cui that match word, optionally use SQL's LIKE syntax"
 827   (collect-umlisp-query-eval ('mrxnw_eng '(sui) srl 'nwd word :like like :distinct t
 828                                          :lrl 'klrl :order '(cui asc))
 829                              sui))
 830
 831 (defun find-ustr-word (word &key sab (srl *current-srl*) (like nil))
 832   "Return list of ustr that match word in matching SAB. Optionally, use SQL's LIKE syntax"
 833   (cond
 834     (sab
 835      (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"
 836                           (if like "LIKE" "=")
 837                           (clsql-sys::sql-escape-quotes word)
 838                           (typecase sab
 839                             (string
 840                              (format nil " AND c.sab='~A'" (clsql-sys::sql-escape-quotes sab)))
 841                             (cons
 842                              (format nil " AND c.sab IN (~('~A'~^,~))"
 843                                      (mapcar 'clsql-sys::sql-escape-quotes sab)))
 844                             (null
 845                              ""))
 846                           (if srl (format nil " AND KCUILRL <= ~D" srl) ""))))
 847        (loop for tuple in (mutex-sql-query query)
 848              collect (destructuring-bind (sui cui lui str lrl stt suppress cuisui) tuple
 849                        (make-instance 'ustr :sui sui :cui cui :lui lui :str str :lrl lrl
 850                                       :stt stt :suppress suppress :cuisui cuisui)))))
 851     (t
 852      (collect-umlisp-query (mrxw_eng (cui sui) srl wd word :lrl klrl
 853                                      :order (cui asc sui asc))
 854        (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))))
 855
 856 (defun find-ustr-normalized-word (word &key (srl *current-srl*))
 857   "Return list of ustrs that match word"
 858   (collect-umlisp-query (mrxnw_eng (cui sui) srl nwd word :lrl klrl
 859                                  :order (cui asc sui asc))
 860     (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
 861
 862 (defun find-uterm-word (word &key (srl *current-srl*))
 863   "Return list of uterms that match word"
 864   (collect-umlisp-query (mrxw_eng (cui lui) srl wd word :lrl klrl
 865                                :order (cui asc lui asc))
 866     (find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl)))
 867
 868 (defun find-uterm-normalized-word (word &key (srl *current-srl*))
 869   "Return list of uterms that match word"
 870   (collect-umlisp-query (mrxnw_eng (cui lui) srl nwd word :lrl klrl
 871                                  :order (cui asc lui asc))
 872     (find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl)))
 873
 874 (defun find-ucon-noneng-word (word &key (srl *current-srl*) (like nil))
 875   "Return list of ucons that match non-english word"
 876   (collect-umlisp-query-eval ('mrxw_noneng '(cui) srl 'wd word :like like
 877                                         :distinct t :lrl 'klrl :order '(cui asc))
 878     (find-ucon-cui cui :srl srl)))
 879
 880 (defun find-ustr-noneng-word (word &key (srl *current-srl*))
 881   "Return list of ustrs that match non-english word"
 882   (collect-umlisp-query (mrxw_noneng (cui sui) srl wd word :lrl klrl
 883                                   :order (cui asc sui asc))
 884     (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
 885
 886 ;; Special tables
 887
 888 (defun find-usrl-all ()
 889   (collect-umlisp-query (usrl (sab srl) nil nil nil :order (sab asc))
 890     (make-instance 'usrl :sab sab :srl (ensure-integer srl))))
 891
 892 ;;; Multiword lookup and score functions
 893
 894 (defun find-uobj-multiword (str obj-lookup-fun sort-fun key srl
 895                                 only-exact-if-match limit &key extra-lookup-args)
 896   (let ((uobjs '()))
 897     (dolist (word (delimited-string-to-list str #\space))
 898       (setq uobjs (append uobjs (apply obj-lookup-fun word :srl srl extra-lookup-args))))
 899     (let ((sorted
 900            (funcall sort-fun str
 901                     (delete-duplicates uobjs :test #'= :key key))))
 902       (let ((len (length sorted)))
 903         (cond
 904          ((zerop len)
 905           (return-from find-uobj-multiword nil))
 906          ((and only-exact-if-match (multiword-match str (pfstr (first sorted))))
 907           (first sorted))
 908          (limit
 909           (if (and (plusp limit) (> len limit))
 910               (subseq sorted 0 limit)
 911             limit))
 912          (t
 913           sorted))))))
 914
 915 (defun find-ucon-multiword (str &key (srl *current-srl*)
 916                                      (only-exact-if-match t)
 917                                      limit
 918                                      sab)
 919   (find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str
 920                        #'cui srl only-exact-if-match limit
 921                        :extra-lookup-args (list :sab sab)))
 922
 923 (defun find-uconso-multiword (str &key (srl *current-srl*)
 924                                      (only-exact-if-match t)
 925                                      limit
 926                                      sab)
 927   (find-uobj-multiword str #'find-uconso-word #'sort-score-pfstr-str
 928                        #'cui srl only-exact-if-match limit
 929                        :extra-lookup-args (list :sab sab)))
 930
 931 (defun find-uterm-multiword (str &key (srl *current-srl*)
 932                                       (only-exact-if-match t)
 933                                       limit)
 934   (find-uobj-multiword str #'find-uterm-word #'sort-score-pfstr-str
 935                        #'lui srl only-exact-if-match limit))
 936
 937 (defun find-ustr-multiword (str &key (srl *current-srl*)
 938                                      (only-exact-if-match t)
 939                                      limit
 940                                      sab)
 941   (find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str
 942                        #'sui srl only-exact-if-match limit
 943                        :extra-lookup-args (list :sab sab)))
 944
 945 (defun sort-score-pfstr-str (str uobjs)
 946   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
 947   (sort-score-umlsclass-str uobjs str #'pfstr))
 948
 949 (defun sort-score-ustr-str (str ustrs)
 950   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
 951   (sort-score-umlsclass-str ustrs str #'str))
 952
 953 (defun sort-score-umlsclass-str (objs str lookup-func)
 954   "Sort a list of objects based on scoring to a string"
 955   (let ((scored '()))
 956     (dolist (obj objs)
 957       (push (list obj (score-multiword-match str (funcall lookup-func obj)))
 958        scored))
 959     (mapcar #'car (sort scored #'> :key #'cadr))))
 960
 961
 962 ;;; LEX SQL functions
 963
 964 (defun find-lexterm-eui (eui)
 965   (ensure-eui-integer eui)
 966   (collect-umlisp-query (lrwd (wrd) nil eui eui :single t)
 967     (make-instance 'lexterm :eui eui :wrd wrd)))
 968
 969 (defun find-lexterm-word (wrd)
 970   (collect-umlisp-query (lrwd (eui) nil wrd wrd)
 971     (make-instance 'lexterm :eui (ensure-integer eui)
 972                    :wrd (copy-seq wrd))))
 973
 974 ;; LEX SQL Read functions
 975
 976 (defun find-labr-eui (eui)
 977   (ensure-eui-integer eui)
 978   (collect-umlisp-query (lrabr (bas abr eui2 bas2) nil eui eui)
 979     (make-instance 'labr :eui eui :bas bas :abr abr :bas2 bas2
 980                    :eui2 (ensure-integer eui2))))
 981
 982 (defun find-labr-bas (bas)
 983   (collect-umlisp-query (labr (eui abr eui2 bas2) nil bas bas)
 984     (make-instance 'labr :eui (ensure-integer eui) :abr abr :bas2 bas2
 985                    :bas (copy-seq bas) :eui2 (ensure-integer eui2))))
 986
 987 (defun find-lagr-eui (eui)
 988   (ensure-eui-integer eui)
 989   (collect-umlisp-query (lragr (str sca agr cit bas) nil eui eui)
 990     (make-instance 'lagr :eui eui :str str :sca sca :agr agr
 991                    :cit cit :bas bas)))
 992
 993 (defun find-lcmp-eui (eui)
 994   (ensure-eui-integer eui)
 995   (collect-umlisp-query (lrcmp (bas sca com) nil eui eui)
 996     (make-instance 'lcmp :eui eui :bas bas :sca sca :com com)))
 997
 998 (defun find-lmod-eui (eui)
 999   (ensure-eui-integer eui)
1000   (collect-umlisp-query (lrmod (bas sca psn_mod fea) nil eui eui)
1001     (make-instance 'lmod :eui eui :bas bas :sca sca :psnmod psn_mod :fea fea)))
1002
1003 (defun find-lnom-eui (eui)
1004   (ensure-eui-integer eui)
1005   (collect-umlisp-query (lrnom (bas sca eui2 bas2 sca2) nil eui eui)
1006     (make-instance 'lnom :eui eui :bas bas :sca sca :bas2 bas2 :sca2 sca2
1007                    :eui2 (ensure-integer eui2))))
1008
1009 (defun find-lprn-eui (eui)
1010   (ensure-eui-integer eui)
1011   (collect-umlisp-query (lrprn (bas num gnd cas pos qnt fea) nil eui eui)
1012     (make-instance 'lprn :eui eui :bas bas :num num :gnd gnd
1013                    :cas cas :pos pos :qnt qnt :fea fea)))
1014
1015 (defun find-lprp-eui (eui)
1016   (ensure-eui-integer eui)
1017   (collect-umlisp-query (lrprp (bas str sca fea) nil eui eui)
1018     (make-instance 'lprp :eui eui :bas bas :str str :sca sca :fea fea)))
1019
1020 (defun find-lspl-eui (eui)
1021   (ensure-eui-integer eui)
1022   (collect-umlisp-query (lrspl (spv bas) nil eui eui)
1023     (make-instance 'lspl :eui eui :spv spv :bas bas)))
1024
1025 (defun find-ltrm-eui (eui)
1026   (ensure-eui-integer eui)
1027   (collect-umlisp-query (lrtrm (bas gen) nil eui eui)
1028     (make-instance 'ltrm :eui eui :bas bas :gen gen)))
1029
1030 (defun find-ltyp-eui (eui)
1031   (ensure-eui-integer eui)
1032   (collect-umlisp-query (lrtyp (bas sca typ) nil eui eui)
1033     (make-instance 'ltyp :eui eui :bas bas :sca sca :typ typ)))
1034
1035 (defun find-lwd-wrd (wrd)
1036   (make-instance 'lwd :wrd wrd
1037                  :euilist (collect-umlisp-query (lrwd (eui) nil wrd wrd)
1038                                                 (ensure-integer eui))))
1039
1040 ;;; Semantic Network SQL access functions
1041
1042 (defun find-sdef-ui (ui)
1043   (collect-umlisp-query (srdef (rt sty_rl stn_rtn def ex un rh abr rin)
1044                             nil ui ui :single t)
1045     (make-instance 'sdef :rt rt :ui ui :styrl sty_rl :stnrtn stn_rtn
1046                    :def def :ex ex :un un :rh rh :abr abr :rin rin)))
1047
1048 (defun find-sstre1-ui (ui)
1049   (collect-umlisp-query (srstre1 (ui2 ui3) nil ui ui)
1050     (make-instance 'sstre1 :ui ui :ui2 (ensure-integer ui2)
1051                    :ui3 (ensure-integer ui3))))
1052
1053 (defun find-sstre1-ui2 (ui2)
1054   (collect-umlisp-query (srstre1 (ui ui3) nil ui2 ui2)
1055     (make-instance 'sstre1 :ui (ensure-integer ui) :ui2 ui2
1056                    :ui3 (ensure-integer ui3))))
1057
1058 (defun find-sstr-rl (rl)
1059   (collect-umlisp-query (srstre (sty_rl sty_rl2 ls) nil rl rl)
1060     (make-instance 'sstr :rl rl :styrl sty_rl :styrl2 sty_rl2 :ls ls)))
1061
1062 (defun find-sstre2-sty (sty)
1063   (collect-umlisp-query (srstre2 (rl sty2) nil sty sty)
1064     (make-instance 'sstre2 :sty (copy-seq sty) :rl rl :sty2 sty2)))
1065
1066 (defun find-sstr-styrl (styrl)
1067   (collect-umlisp-query (srstr (rl sty_rl2 ls) nil styrl styrl)
1068     (make-instance 'sstr :styrl styrl :rl rl :styrl2 sty_rl2 :ls ls)))
1069
1070
1071 ;;; **************************
1072 ;;; Local Classes
1073 ;;; **************************
1074
1075
1076 (defun make-ustats ()
1077   (with-sql-connection (conn)
1078     (ignore-errors (sql-execute "drop table USTATS" conn))
1079     (sql-execute "create table USTATS (NAME varchar(160), COUNT bigint, SRL integer)" conn)
1080
1081     (dotimes (srl 5)
1082       (insert-ustats-count conn "Concept Count" "MRCONSO" "distinct CUI" "KCUILRL" srl)
1083       (insert-ustats-count conn "Term Count" "MRCONSO" "distinct KCUILUI" "KCUILRL" srl)
1084       (insert-ustats-count conn "Distinct Term Count" "MRCONSO" "distinct LUI" "KLUILRL" srl)
1085       (insert-ustats-count conn "String Count" "MRCONSO" "*" "KSUILRL" srl)
1086       (insert-ustats-count conn "Distinct String Count" "MRCONSO" "distinct SUI" "KSUILRL" srl)
1087       (insert-ustats-count conn "Hierarchcy" "MRHIER" "*" "KSRL" srl)
1088       (insert-ustats-count conn "Mappings" "MRMAP" "*" "KSRL" srl)
1089       (insert-ustats-count conn "Simple Mappings" "MRSMAP" "*" "KSRL" srl)
1090       (insert-ustats-count conn "Co-occuring Concept Count" "MRCOC" "*" "KLRL" srl)
1091       (insert-ustats-count conn "Definition Count" "MRDEF" "*" "KSRL" srl)
1092       (insert-ustats-count conn "Rank Count" "MRRANK" "*" "KSRL" srl)
1093       (insert-ustats-count conn "Relationship Count" "MRREL" "*" "KSRL" srl)
1094       (insert-ustats-count conn "Semantic Type Count" "MRSTY" "*" "KLRL" srl)
1095       (insert-ustats-count conn "Simple Attribute Count" "MRSAT" "*" "KSRL" srl)
1096       (insert-ustats-count conn "Source Abbreviation Count" "MRSAB" "*" "SRL" srl)
1097       (insert-ustats-count conn "Word Index Count" "MRXW_ENG" "*" "KLRL" srl)
1098       (insert-ustats-count conn "Normalized Word Index Count" "MRXNW_ENG" "*" "KLRL" srl)
1099       (insert-ustats-count conn "Normalized String Index Count" "MRXNS_ENG" "*" "KLRL" srl))
1100     (sql-execute "create index USTATS_SRL on USTATS (SRL)" conn))
1101   (find-ustats-all))
1102
1103 (defun insert-ustats-count (conn name table count-variable srl-control srl)
1104   (insert-ustats conn name (find-count-table conn table srl count-variable srl-control) srl))
1105
1106 (defun find-count-table (conn table srl count-variable srl-control)
1107   (cond
1108    ((stringp srl-control)
1109     (ensure-integer
1110      (caar (sql-query (format nil "select count(~a) from ~a where ~a <= ~d"
1111                               count-variable table srl-control srl)
1112                       conn))))
1113    ((null srl-control)
1114     (ensure-integer
1115      (caar (sql-query (format nil "select count(~a) from ~a"
1116                               count-variable table )
1117                       conn))))
1118    (t
1119     (error "Unknown srl-control")
1120     0)))
1121
1122 (defun insert-ustats (conn name count srl)
1123   (sql-execute (format nil "insert into USTATS (name,count,srl) values ('~a',~d,~d)"
1124                        name count (if srl srl 3))
1125                conn))
1126
1127 (defun find-ustats-all (&key (srl *current-srl*))
1128   (if srl
1129       (collect-umlisp-query (ustats (name count srl) nil srl srl
1130                                     :order (name asc))
1131                             (make-instance 'ustats :name name
1132                                            :hits (ensure-integer count)
1133                                            :srl (ensure-integer srl)))
1134     (collect-umlisp-query (ustats (name count srl) nil nil nil
1135                                   :order (name asc))
1136                           (make-instance 'ustats :name name
1137                                          :hits (ensure-integer count)
1138                                          :srl (ensure-integer srl)))))
1139
1140 (defun find-ustats-srl (srl)
1141   (collect-umlisp-query (ustats (name count) nil srl srl :order (name asc))
1142                            (make-instance 'ustats :name name :hits (ensure-integer count))))
1143