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 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: sql-classes.lisp,v 1.14 2002/12/13 08:41:32 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of UMLisp, is
  13 ;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
  14 ;;;;
  15 ;;;; UMLisp users are granted the rights to distribute and use this software
  16 ;;;; as governed by the terms of the GNU General Public License.
  17 ;;;; *************************************************************************
  18
  19 (in-package :umlisp)
  20 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
  21
  22
  23 (defvar *current-srl* nil)
  24 (defun current-srl ()
  25   *current-srl*)
  26 (defun current-srl! (srl)
  27   (setq *current-srl* srl))
  28
  29 ;;; Object lookups
  30
  31 ;;; Lookup functions for uterms,ustr in ucons
  32
  33 (defun find-uterm-in-ucon (ucon lui)
  34   (find lui (s#term ucon) :key #'lui :test 'equal))
  35
  36 (defun find-ustr-in-uterm (uterm sui)
  37   (find sui (s#str uterm) :key #'sui :test 'equal))
  38
  39 (defun find-ustr-in-ucon (ucon sui)
  40   (let ((found-ustr nil))
  41     (dolist (uterm (s#term ucon))
  42       (unless found-ustr
  43         (dolist (ustr (s#str uterm))
  44           (unless found-ustr
  45             (when (string-equal sui (sui ustr))
  46               (setq found-ustr ustr))))))
  47     found-ustr))
  48
  49
  50 (defun find-ucon-cui (cui &key (srl *current-srl*))
  51   "Find ucon for a cui"
  52   (when (stringp cui) (setq cui (parse-cui cui)))
  53   (when cui
  54     (let ((ls (format nil "select KPFSTR,KCUILRL from MRCON where CUI=~d" cui)))
  55       (when srl
  56         (string-append ls (format nil " and KCUILRL <= ~d" srl)))
  57       (string-append ls " limit 1")
  58       (awhen (car (mutex-sql-query ls))
  59              (make-instance 'ucon :cui cui :pfstr (car it)
  60                             :lrl (ensure-integer (cadr it)))))))
  61
  62 (defun find-ucon-cui-sans-pfstr (cui &key (srl *current-srl*))
  63   "Find ucon for a cui"
  64   (when (stringp cui) (setq cui (parse-cui cui)))
  65   (when cui
  66     (let ((ls (format nil "select KCUILRL from MRCON where CUI=~d" cui)))
  67       (when srl
  68         (string-append ls (format nil " and KCUILRL <= ~d" srl)))
  69       (string-append ls " limit 1")
  70       (awhen (car (mutex-sql-query ls))
  71              (make-instance 'ucon :cui cui
  72                             :lrl (ensure-integer (cdr it)))))))
  73
  74 (defun find-pfstr-cui (cui &key (srl *current-srl*))
  75   "Find preferred string for a cui"
  76   (when (stringp cui)
  77       (setq cui (parse-cui cui)))
  78   (when cui
  79       (let ((ls (format nil "select KPFSTR from MRCON where CUI=~d" cui)))
  80         (when srl
  81           (string-append ls (format nil " and KCUILRL <= ~d" srl)))
  82         (string-append ls " limit 1")
  83         (awhen (car (mutex-sql-query ls))
  84                (car it)))))
  85
  86 (defun find-ucon-lui (lui &key (srl *current-srl*))
  87   "Find list of ucon for lui"
  88   (when (stringp lui) (setq lui (parse-lui lui)))
  89   (when lui
  90       (let ((ucons '())
  91             (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where LUI=~d" lui)))
  92         (if srl
  93             (string-append ls (format nil " and KCUILRL <= ~d" srl)))
  94         (dolist (tuple (mutex-sql-query ls))
  95           (destructuring-bind (cui pfstr lrl) tuple
  96             (push (make-instance 'ucon :cui (ensure-integer cui)
  97                                  :pfstr pfstr
  98                                  :lrl (ensure-integer lrl))
  99                   ucons)))
 100         (nreverse ucons))))
 101
 102 (defun find-ucon-sui (sui &key (srl *current-srl*))
 103   "Find list of ucon for sui"
 104   (when (stringp sui) (setq sui (parse-sui sui)))
 105   (when sui
 106     (let ((ucons '())
 107           (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where SUI=~d" sui)))
 108       (when srl
 109         (string-append ls (format nil " and KCUILRL <= ~d" srl)))
 110       (let ((tuples (mutex-sql-query ls)))
 111         (dolist (tuple tuples)
 112           (destructuring-bind (cui pfstr lrl) tuple
 113             (push (make-instance 'ucon :cui (ensure-integer cui)
 114                                  :pfstr pfstr
 115                                  :lrl (ensure-integer lrl))
 116                   ucons))))
 117       (nreverse ucons))))
 118
 119 (defun find-ucon-cuisui (cui sui &key (srl *current-srl*))
 120   "Find ucon for cui/sui"
 121   (when (stringp cui) (setq cui (parse-cui cui)))
 122   (when (stringp sui) (setq sui (parse-sui sui)))
 123   (when (and cui sui)
 124     (let ((ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where KCUISUI=~d"
 125                       (make-cuisui cui sui))))
 126       (when srl
 127         (string-append ls (format nil " and KCUILRL <= ~d" srl)))
 128       (awhen (car (mutex-sql-query ls))
 129              (destructuring-bind (cui pfstr lrl) it
 130                (make-instance 'ucon :cui (ensure-integer cui)
 131                               :pfstr pfstr
 132                               :lrl (ensure-integer lrl)))))))
 133
 134 (defun find-ucon-str (str &key (srl *current-srl*))
 135   "Find ucon that are exact match for str"
 136   (when str
 137     (let ((ucons '())
 138           (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where STR='~a'" str)))
 139       (when srl
 140         (string-append ls " and KCUILRL <= ~d" srl))
 141       (dolist (tuple (mutex-sql-query ls))
 142         (destructuring-bind (cui pfstr lrl) tuple
 143           (push (make-instance 'ucon :cui (ensure-integer cui)
 144                                :pfstr pfstr
 145                                :lrl (ensure-integer lrl))
 146                 ucons)))
 147         (nreverse ucons))))
 148
 149 (defun find-ucon-all (&key (srl *current-srl*))
 150   "Return list of all ucon's"
 151   (let ((ls "select distinct CUI,KPFSTR,KCUILRL from MRCON"))
 152     (when srl
 153       (string-append ls (format nil " where KCUILRL <= ~d" srl)))
 154     (string-append ls " order by CUI asc")
 155     (with-sql-connection (db)
 156       (clsql:map-query
 157        'list
 158        #'(lambda (cui pfstr cuilrl)
 159            (make-instance 'ucon :cui (ensure-integer cui)
 160                           :pfstr pfstr
 161                           :lrl (ensure-integer cuilrl)))
 162        ls
 163        :database db))))
 164
 165 (defun map-ucon-all (fn &key (srl *current-srl*))
 166   "Return list of all ucon's"
 167   (let ((ls "select distinct CUI,KPFSTR,KCUILRL from MRCON"))
 168     (when srl
 169       (string-append ls (format nil " where KCUILRL <= ~d" srl)))
 170     (string-append ls " order by CUI asc")
 171     (with-sql-connection (db)
 172       (clsql:map-query
 173        nil
 174        #'(lambda (cui pfstr cuilrl)
 175            (funcall fn
 176                     (make-instance 'ucon :cui (ensure-integer cui)
 177                                    :pfstr pfstr
 178                                    :lrl (ensure-integer cuilrl))))
 179        ls
 180        :database db))))
 181
 182
 183 (defun find-udef-cui (cui &key (srl *current-srl*))
 184   "Return a list of udefs for cui"
 185   (let ((udefs '())
 186         (ls (format nil "select SAB,DEF from MRDEF where CUI=~d" cui)))
 187     (when srl
 188         (string-append ls (format nil " and KSRL <= ~d" srl)))
 189     (dolist (tuple (mutex-sql-query ls))
 190       (destructuring-bind (sab def) tuple
 191         (push (make-instance 'udef :sab sab :def def) udefs)))
 192     (nreverse udefs)))
 193
 194 (defun find-usty-cui (cui &key (srl *current-srl*))
 195   "Return a list of usty for cui"
 196   (let ((ustys '())
 197         (ls (format nil "select TUI,STY from MRSTY where CUI=~d" cui)))
 198     (when srl
 199         (string-append ls (format nil " and KLRL <= ~d" srl)))
 200     (dolist (tuple (mutex-sql-query ls))
 201       (destructuring-bind (tui sty) tuple
 202         (push (make-instance 'usty :tui (ensure-integer tui) :sty sty) ustys)))
 203     ustys))
 204
 205 (defun find-usty-word (word &key (srl *current-srl*))
 206   "Return a list of usty that match word"
 207   (let ((ustys '())
 208         (ls (format nil "select distinct TUI,STY from MRSTY where STY like '%~a%'" word)))
 209     (when srl
 210         (string-append ls (format nil " and KLRL <= ~d" srl)))
 211     (dolist (tuple (mutex-sql-query ls))
 212       (destructuring-bind (tui sty) tuple
 213         (push (make-instance 'usty :tui (ensure-integer tui) :sty sty) ustys)))
 214     ustys))
 215
 216 (defun find-urel-cui (cui &key (srl *current-srl*))
 217   "Return a list of urel for cui"
 218   (let ((urels '())
 219         (ls (format nil "select REL,CUI2,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI1=~d" cui)))
 220     (when srl
 221         (string-append ls (format nil " and KSRL <= ~d" srl)))
 222     (dolist (tuple (mutex-sql-query ls))
 223       (destructuring-bind (rel cui2 rela sab sl mg pfstr2) tuple
 224         (push (make-instance 'urel
 225                              :cui1 cui
 226                              :rel rel
 227                              :cui2 (ensure-integer cui2)
 228                              :rela rela
 229                              :sab sab
 230                              :sl sl
 231                              :mg mg
 232                              :pfstr2 pfstr2)
 233               urels)))
 234     (nreverse urels)))
 235
 236 (defun find-urel-cui2 (cui2 &key (srl *current-srl*))
 237   "Return a list of urel for cui2"
 238   (let ((urels '())
 239         (ls (format nil "select REL,CUI1,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI2=~d" cui2)))
 240     (when srl
 241         (string-append ls (format nil " and SRL <= ~d" srl)))
 242     (dolist (tuple (mutex-sql-query ls))
 243       (destructuring-bind (rel cui1 rela sab sl mg pfstr2) tuple
 244         (push (make-instance 'urel
 245                              :cui2 cui2
 246                              :rel rel
 247                              :cui1 (ensure-integer cui1)
 248                              :rela rela
 249                              :sab sab
 250                              :sl sl
 251                              :mg mg
 252                              :pfstr2 pfstr2)
 253               urels)))
 254     (nreverse urels)))
 255
 256 (defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*))
 257   (mapcar
 258    #'(lambda (cui) (find-ucon-cui cui :srl srl))
 259    (remove-duplicates (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl)))))
 260
 261 (defun find-ucoc-cui (cui &key (srl *current-srl*))
 262   "Return a list of ucoc for cui"
 263   (let ((ucocs '())
 264         (ls (format nil "select CUI2,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI1=~d" cui)))
 265     (when srl
 266         (string-append ls (format nil " and KLRL <= ~d" srl)))
 267     (string-append ls " order by COF asc")
 268     (dolist (tuple (mutex-sql-query ls))
 269       (destructuring-bind (cui2 soc cot cof coa pfstr2) tuple
 270         (setq cui2 (ensure-integer cui2))
 271         (when (zerop cui2) (setq cui2 nil))
 272         (push (make-instance 'ucoc :cui1 cui
 273                              :cui2 cui2
 274                              :soc soc
 275                              :cot cot
 276                              :cof (ensure-integer cof)
 277                              :coa coa
 278                              :pfstr2 pfstr2)
 279               ucocs)))
 280     ucocs)) ;; akready ordered by SQL select
 281
 282 (defun find-ucoc-cui2 (cui2 &key (srl *current-srl*))
 283   "Return a list of ucoc for cui2"
 284   (let ((ucocs '())
 285         (ls (format nil "select CUI1,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI2=~d" cui2)))
 286     (when srl
 287         (string-append ls (format nil " and KSRL <= ~d" srl)))
 288     (string-append ls " order by COF asc")
 289     (dolist (tuple (mutex-sql-query ls))
 290       (destructuring-bind (cui1 soc cot cof coa pfstr2) tuple
 291         (push (make-instance 'ucoc :cui1 (ensure-integer cui1)
 292                              :cui2 cui2
 293                              :soc soc
 294                              :cot cot
 295                              :cof (ensure-integer cof)
 296                              :coa coa
 297                              :pfstr2 pfstr2)
 298               ucocs)))
 299     ucocs)) ;; already ordered by SQL select
 300
 301 (defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*))
 302   "List of ucon with co-occurance cui2"
 303   (mapcar
 304    #'(lambda (cui) (find-ucon-cui cui :srl srl))
 305    (remove-duplicates (mapcar #'cui1 (find-ucoc-cui2 cui2 :srl srl)))))
 306
 307 (defun find-ulo-cui (cui &key (srl *current-srl*))
 308   "Return a list of ulo for cui"
 309   (let ((ulos '())
 310         (ls (format nil "select ISN,FR,UN,SUI,SNA,SOUI from MRLO where CUI=~d" cui)))
 311     (when srl
 312         (string-append ls (format nil " and KLRL <= ~d" srl)))
 313     (dolist (tuple (mutex-sql-query ls))
 314       (destructuring-bind (isn fr un sui sna soui) tuple
 315         (push (make-instance 'ulo :isn isn
 316                              :fr (ensure-integer fr)
 317                              :un un
 318                              :sui (ensure-integer sui)
 319                              :sna sna
 320                              :soui soui)
 321               ulos)))
 322     (nreverse ulos)))
 323
 324 (defgeneric suistr (lo))
 325 (defmethod suistr ((lo ulo))
 326   "Return the string for a ulo object"
 327   (find-string-sui (sui lo)))
 328
 329 (defun find-uatx-cui (cui &key (srl *current-srl*))
 330   "Return a list of uatx for cui"
 331   (let ((uatxs '())
 332         (ls (format nil "select SAB,REL,ATX from MRATX where CUI=~d" cui)))
 333     (when srl
 334         (string-append ls (format nil " and KSRL <= ~d" srl)))
 335     (dolist (tuple (mutex-sql-query ls))
 336       (destructuring-bind (sab rel atx) tuple
 337         (push (make-instance 'uatx :sab sab :rel rel :atx atx) uatxs)))
 338     (nreverse uatxs)))
 339
 340
 341 (defun find-uterm-cui (cui &key (srl *current-srl*))
 342   "Return a list of uterm for cui"
 343   (let ((uterms '())
 344         (ls (format nil "select distinct LUI,LAT,TS,KLUILRL from MRCON where CUI=~d" cui)))
 345     (when srl
 346         (string-append ls (format nil " and KLUILRL <= ~d" srl)))
 347     (dolist (tuple (mutex-sql-query ls))
 348       (destructuring-bind (lui lat ts lrl) tuple
 349         (push (make-instance 'uterm :lui (ensure-integer lui) :cui cui
 350                              :lat lat :ts ts :lrl (ensure-integer lrl))
 351               uterms)))
 352     (nreverse uterms)))
 353
 354 (defun find-uterm-lui (lui &key (srl *current-srl*))
 355   "Return a list of uterm for lui"
 356   (if (stringp lui)
 357       (setq lui (parse-lui lui)))
 358   (let ((uterms '())
 359         (ls (format nil "select distinct CUI,LAT,TS,KLUILRL from MRCON where LUI=~d" lui)))
 360     (when srl
 361         (string-append ls (format nil " and KLUILRL <= ~d" srl)))
 362     (dolist (tuple (mutex-sql-query ls))
 363       (destructuring-bind (cui lat ts lrl) tuple
 364         (push (make-instance 'uterm :cui (ensure-integer cui) :lui lui
 365                              :lat lat :ts ts :lrl (ensure-integer lrl))
 366               uterms)))
 367     (nreverse uterms)))
 368
 369 (defun find-uterm-cuilui (cui lui &key (srl *current-srl*))
 370   "Return single uterm for cui/lui"
 371   (let ((ls (format nil "select LAT,TS,KLUILRL from MRCON where KCUILUI=~d limit 1" (make-cuilui cui lui))))
 372     (when srl (string-append ls (format nil " and KLUILRL <= ~d" srl)))
 373     (awhen (car (mutex-sql-query ls))
 374            (destructuring-bind (lat ts lrl) it
 375              (make-instance 'uterm :cui cui :lui lui :lat lat :ts ts
 376                             :lrl (ensure-integer lrl))))))
 377
 378 (defun find-ustr-cuilui (cui lui &key (srl *current-srl*))
 379   "Return a list of ustr for cui/lui"
 380   (declare (fixnum cui lui))
 381   (let ((ustrs '())
 382         (ls (format nil "select SUI,STT,STR,LRL from MRCON where KCUILUI=~d" (make-cuilui cui lui))))
 383     (when srl (string-append ls (format nil " and LRL <= ~d" srl)))
 384     (dolist (tuple (mutex-sql-query ls))
 385       (destructuring-bind (sui stt str lrl) tuple
 386         (push
 387          (make-instance 'ustr :sui (ensure-integer sui) :cui cui :lui lui
 388                         :cuisui (make-cuisui cui sui) :stt stt :str str
 389                         :lrl (ensure-integer lrl))
 390          ustrs)))
 391     (nreverse ustrs)))
 392
 393 (defun find-ustr-cuisui (cui sui &key (srl *current-srl*))
 394   "Return the single ustr for cuisui"
 395   (let ((ls (format nil "select LUI,STT,STR,LRL from MRCON where KCUISUI=~d"
 396                     (make-cuisui cui sui))))
 397     (when srl (string-append ls (format nil " and LRL <= ~d" srl)))
 398     (awhen (car (mutex-sql-query ls))
 399            (destructuring-bind (lui stt str lrl) it
 400              (make-instance 'ustr :sui sui :cui cui
 401                             :cuisui (make-cuisui cui sui)
 402                             :lui (ensure-integer lui) :stt stt :str str
 403                             :lrl (ensure-integer lrl))))))
 404
 405 (defun find-ustr-sui (sui &key (srl *current-srl*))
 406   "Return the list of ustr for sui"
 407   (if (stringp sui)
 408       (setq sui (parse-sui sui)))
 409   (let ((ustrs '())
 410         (ls (format nil "select CUI,LUI,STT,STR,LRL from MRCON where SUI=~d" sui)))
 411     (when srl (string-append ls (format nil " and LRL <= ~d" srl)))
 412     (dolist (tuple (mutex-sql-query ls))
 413       (destructuring-bind (cui lui stt str lrl) tuple
 414         (setq cui (ensure-integer cui))
 415         (push (make-instance 'ustr :sui sui :cui cui :stt stt :str str
 416                              :cuisui (make-cuisui cui sui)
 417                              :lui (ensure-integer lui)
 418                              :lrl (ensure-integer lrl))
 419               ustrs)))
 420     (nreverse ustrs)))
 421
 422 (defun find-ustr-sab (sab &key (srl *current-srl*))
 423   "Return the list of ustr for sab"
 424   (let ((ustrs '())
 425         (ls (format nil "select KCUISUI from MRSO where SAB='~a'" sab)))
 426     (when srl
 427         (string-append ls (format nil " and SRL <= ~d" srl)))
 428     (dolist (tuple (mutex-sql-query ls))
 429       (let ((cuisui (ensure-integer (car tuple))))
 430         (push (apply #'find-ustr-cuisui
 431                      (append
 432                       (multiple-value-list (decompose-cuisui cuisui))
 433                       (list :srl srl)))
 434               ustrs)))
 435     (nreverse ustrs)))
 436
 437 (defun find-ustr-all (&key (srl *current-srl*))
 438   "Return list of all ustr's"
 439   (let ((ls "select distinct CUI,LUI,SUI,STT,LRL,KPFSTR from MRCON"))
 440     (when srl
 441       (string-append ls (format nil " where LRL <= ~d" srl)))
 442     (string-append ls " order by SUI asc")
 443     (with-sql-connection (db)
 444       (clsql:map-query
 445        'list
 446        #'(lambda (cui lui sui stt lrl pfstr)
 447            (setq cui (ensure-integer cui))
 448            (setq lui (ensure-integer lui))
 449            (setq sui (ensure-integer sui))
 450            (setq lrl (ensure-integer lrl))
 451            (make-instance 'ustr :cui cui
 452                           :lui lui
 453                           :sui sui
 454                           :cuisui (make-cuisui cui sui)
 455                           :stt stt
 456                           :lrl lrl
 457                           :str pfstr))
 458        ls
 459        :database db))))
 460
 461 (defun find-string-sui (sui &key (srl *current-srl*))
 462   "Return the string associated with sui"
 463   (let ((ls (format nil "select STR from MRCON where SUI=~d" sui)))
 464     (when srl
 465       (string-append ls (format nil " and LRL <= ~d" srl)))
 466     (string-append ls " limit 1")
 467     (caar (mutex-sql-query ls))))
 468
 469 (defun find-uso-cuisui (cui sui &key (srl *current-srl*))
 470   (declare (fixnum cui sui))
 471   (let ((usos '())
 472         (ls (format nil "select SAB,CODE,SRL,TTY from MRSO where KCUISUI=~d"
 473                     (make-cuisui cui sui))))
 474     (when srl
 475         (string-append ls (format nil " and SRL <= ~d" srl)))
 476     (dolist (tuple (mutex-sql-query ls))
 477       (destructuring-bind (sab code srl tty) tuple
 478         (push (make-instance 'uso :sab sab :code code :srl srl :tty tty)
 479               usos)))
 480     (nreverse usos)))
 481
 482 (defun find-ucxt-cuisui (cui sui &key (srl *current-srl*))
 483   (declare (fixnum cui sui))
 484   (let ((ucxts '())
 485         (ls (format nil "select SAB,CODE,CXN,CXL,RNK,CXS,CUI2,HCD,RELA,XC from MRCXT where KCUISUI=~d"
 486                     (make-cuisui cui sui))))
 487     (when srl
 488         (string-append ls (format nil " and KSRL <= ~d" srl)))
 489     (dolist (tuple (mutex-sql-query ls))
 490       (destructuring-bind (sab code cxn cxl rnk cxs cui2 hcd rela xc) tuple
 491         (push (make-instance 'ucxt :sab sab :code code
 492                              :cxn (ensure-integer cxn)
 493                              :cxl cxl :cxs cxs :hcd hcd :rela rela :xc xc
 494                              :rnk (ensure-integer rnk)
 495                              :cui2 (ensure-integer cui2))
 496               ucxts)))
 497     (nreverse ucxts)))
 498
 499 (defun find-usat-ui (cui &optional (lui nil) (sui nil) &key (srl *current-srl*))
 500   (let ((ls (format nil "select CODE,ATN,SAB,ATV from MRSAT where ")))
 501     (cond
 502      (sui (string-append ls (format nil "KCUISUI=~d" (make-cuisui cui sui))))
 503      (lui (string-append ls (format nil "KCUILUI=~d and sui=0" (make-cuilui cui lui))))
 504      (t (string-append ls (format nil "cui=~d and lui=0 and sui=0" cui))))
 505     (when srl
 506         (string-append ls (format nil " and KSRL <= ~d" srl)))
 507     (let ((usats '()))
 508       (dolist (tuple (mutex-sql-query ls))
 509         (destructuring-bind (code atn sab atv) tuple
 510           (push (make-instance 'usat :code code :atn atn :sab sab :atv atv)
 511                 usats)))
 512       (nreverse usats))))
 513
 514
 515 (defun find-usty-tui (tui)
 516   "Find usty for tui"
 517   (setq tui (parse-tui tui))
 518   (awhen (car (mutex-sql-query
 519                (format nil "select STY from MRSTY where TUI=~d limit 1" tui)))
 520          (make-instance 'usty :tui tui :sty (car it))))
 521
 522 (defun find-usty-sty (sty)
 523   "Find usty for a sty"
 524   (awhen (car (mutex-sql-query
 525                (format nil "select TUI from MRSTY where STY='~a' limit 1" sty)))
 526          (make-instance 'usty :tui (ensure-integer (car it)) :sty sty)))
 527
 528 (defun find-usty-all ()
 529   "Return list of usty's for all semantic types"
 530   (let ((ustys '()))
 531     (dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY"))
 532       (push (find-usty-tui (nth 0 tuple)) ustys))
 533     (nreverse ustys)))
 534
 535 (defun find-usab-all ()
 536   "Find usab for a key"
 537   (let ((results '()))
 538     (dolist (tuple (mutex-sql-query "select VCUI,RCUI,VSAB,RSAB,SON,SF,SVER,MSTART,MEND,IMETA,RMETA,SLC,SCC,SRL,TFR,CFR,CXTY,TTYL,ATNL,LAT,CENC,CURVER,SABIN from MRSAB"))
 539       (destructuring-bind
 540             (vcui rcui vsab rsab son sf sver mstart mend imeta rmeta slc scc srl tfr cfr cxty ttyl atnl lat cenc curver sabin) tuple
 541         (push
 542          (make-instance 'usab :vcui (ensure-integer vcui)
 543                         :rcui (ensure-integer rcui)
 544                         :vsab vsab :rsab rsab :son son :sf sf :sver sver :mstart mstart
 545                         :mend mend :imeta imeta :rmeta rmeta :slc slc :scc scc
 546                         :srl (ensure-integer srl)
 547                         :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
 548                         :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
 549                         :curver curver :sabin sabin)
 550          results)))
 551     (nreverse results)))
 552
 553 (defun find-usab-by-key (key-name key)
 554   "Find usab for a key"
 555   (aif (car (mutex-sql-query
 556              (format nil "select VCUI,RCUI,VSAB,RSAB,SON,SF,SVER,MSTART,MEND,IMETA,RMETA,SLC,SCC,SRL,TFR,CFR,CXTY,TTYL,ATNL,LAT,CENC,CURVER,SABIN from MRSAB where ~A='~A'" key-name key)))
 557        (destructuring-bind
 558            (vcui rcui vsab rsab son sf sver mstart mend imeta rmeta slc scc srl tfr cfr cxty ttyl atnl lat cenc curver sabin) it
 559          (make-instance 'usab :vcui (ensure-integer vcui)
 560                         :rcui (ensure-integer rcui)
 561                         :vsab vsab :rsab rsab :son son :sf sf :sver sver :mstart mstart
 562                         :mend mend :imeta imeta :rmeta rmeta :slc slc :scc scc
 563                         :srl (ensure-integer srl)
 564                         :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
 565                         :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
 566                         :curver curver :sabin sabin))))
 567
 568 (defun find-usab-rsab (rsab)
 569   "Find usab for rsab"
 570   (find-usab-by-key "RSAB" rsab))
 571
 572 (defun find-usab-vsab (vsab)
 573   "Find usab for vsab"
 574   (find-usab-by-key "VSAB" vsab))
 575
 576 (defun find-cui-max ()
 577   (let ((cui (caar (mutex-sql-query "select max(CUI) from MRCON"))))
 578     (ensure-integer cui)))
 579
 580 ;;;; Cross table find functions
 581
 582 (defun find-ucon-tui (tui &key (srl *current-srl*))
 583   "Find list of ucon for tui"
 584   (when (stringp tui) (setq tui (parse-tui tui)))
 585   (let ((ucons '())
 586         (ls (format nil "select CUI from MRSTY where TUI=~d" tui)))
 587     (when srl (string-append ls (format nil " and KLRL <= ~d" srl)))
 588     (string-append ls " order by cui desc")
 589     (dolist (tuple (mutex-sql-query ls))
 590       (push (find-ucon-cui (ensure-integer (car tuple)) :srl srl) ucons))
 591     ucons))
 592
 593 (defun find-ucon-word (word &key (srl *current-srl*) (like nil))
 594   "Return list of ucons that match word. Optionally, use SQL's LIKE syntax"
 595   (let ((ucons '())
 596         (ls (format nil "select distinct cui from MRXW_ENG where wd~A'~A'"
 597                     (if like " LIKE " "=")
 598                     word)))
 599     (when srl (string-append ls (format nil " and KLRL <= ~d" srl)))
 600     (string-append ls " order by cui desc")
 601     (dolist (tuple (mutex-sql-query ls))
 602       (push (find-ucon-cui (car tuple) :srl srl) ucons))
 603     ucons))
 604
 605 (defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil))
 606   "Return list of ucons that match word, optionally use SQL's LIKE syntax"
 607   (let ((ucons '())
 608         (ls (format nil "select distinct cui from MRXNW_ENG where nwd~A'~A'"
 609                     (if like " LIKE " "=")
 610                     word)))
 611     (when srl (string-append ls (format nil " and KLRL <= ~d" srl)))
 612     (string-append ls " order by cui desc")
 613     (dolist (tuple (mutex-sql-query ls))
 614       (push (find-ucon-cui (car tuple) :srl srl) ucons))
 615     ucons))
 616
 617 (defun find-ustr-word (word &key (srl *current-srl*))
 618   "Return list of ustrs that match word"
 619   (let ((ustrs '())
 620         (ls (format nil "select cui,sui from MRXW_ENG where wd='~a'" word)))
 621     (when srl (string-append ls (format nil " and KLRL <= ~d" srl)))
 622     (string-append ls " order by cui desc,sui desc")
 623     (dolist (tuple (mutex-sql-query ls))
 624       (destructuring-bind (cui sui) tuple
 625         (push (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui)
 626                                 :srl srl)
 627               ustrs)))
 628     ustrs))
 629
 630 (defun find-ustr-normalized-word (word &key (srl *current-srl*))
 631   "Return list of ustrs that match word"
 632   (let ((ustrs '())
 633         (ls (format nil "select cui,sui from MRXNW_ENG where nwd='~a'" word)))
 634     (when srl
 635         (string-append ls (format nil " and KLRL <= ~d" srl)))
 636     (string-append ls " order by cui desc,sui desc")
 637     (dolist (tuple (mutex-sql-query ls))
 638       (destructuring-bind (cui sui) tuple
 639         (push (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui)
 640                                 :srl srl)
 641               ustrs)))
 642     ustrs))
 643
 644 ;; Special tables
 645
 646 (defun find-usrl-all ()
 647   (let ((usrls '())
 648         (tuples (mutex-sql-query "select SAB,SRL from USRL order by SAB desc")))
 649     (dolist (tuple tuples)
 650       (destructuring-bind (sab srl) tuple
 651         (push (make-instance 'usrl :sab sab :srl (ensure-integer srl)) usrls)))
 652     usrls))
 653
 654 ;;; Multiword lookup and score functions
 655
 656 (defun find-ucon-multiword (str &key (srl *current-srl*))
 657   "Return sorted list of ucon's that match a multiword string"
 658   (let* ((words (delimited-string-to-list str #\space))
 659          (ucons '()))
 660     (dolist (word words)
 661       (setq ucons (append ucons (find-ucon-word word :srl srl))))
 662     (sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui))))
 663
 664 (defun find-ustr-multiword (str &key (srl *current-srl*))
 665   "Return sorted list of ustr's that match a multiword string"
 666   (let* ((words (delimited-string-to-list str #\space))
 667          (ustrs '()))
 668     (dolist (word words)
 669       (setq ustrs (append ustrs (find-ustr-word word :srl srl))))
 670     (sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'cui))))
 671
 672 (defun sort-score-ucon-str (str ucons)
 673   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
 674   (sort-score-umlsclass-str ucons str #'pfstr))
 675
 676 (defun sort-score-ustr-str (str ustrs)
 677   "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
 678   (sort-score-umlsclass-str ustrs str #'str))
 679
 680 (defun sort-score-umlsclass-str (objs str lookup-func)
 681   "Sort a list of objects based on scoring to a string"
 682   (let ((scored '()))
 683     (dolist (obj objs)
 684       (push
 685        (list obj
 686              (score-multiword-match str (funcall lookup-func obj)))
 687        scored))
 688     (mapcar #'car (sort scored #'> :key #'cadr))))
 689
 690 (defun score-multiword-match (s1 s2)
 691   "Score a match between two strings with s1 being reference string"
 692   (let* ((word-list-1 (delimited-string-to-list s1 #\space))
 693          (word-list-2 (delimited-string-to-list s2 #\space))
 694          (n1 (length word-list-1))
 695          (n2 (length word-list-2))
 696          (unmatched n1)
 697          (score 0)
 698          (nlong 0)
 699          (nshort 0)
 700          short-list long-list)
 701     (declare (fixnum n1 n2 nshort nlong score unmatched))
 702     (if (> n1 n2)
 703         (progn
 704           (setq nlong n1)
 705           (setq nshort n2)
 706           (setq long-list word-list-1)
 707           (setq short-list word-list-2))
 708       (progn
 709         (setq nlong n2)
 710         (setq nshort n1)
 711         (setq long-list word-list-2)
 712         (setq short-list word-list-1)))
 713     (decf score (- nlong nshort)) ;; reduce score for extra words
 714     (dotimes (iword nshort)
 715       (declare (fixnum iword))
 716       (kmrcl:aif (position (nth iword short-list) long-list :test #'string-equal)
 717            (progn
 718              (incf score (- 10 (abs (- kmrcl::it iword))))
 719              (decf unmatched))))
 720     (decf score (* 2 unmatched))
 721     score))
 722
 723
 724 ;;; LEX SQL functions
 725
 726 (defun find-lexterm-eui (eui)
 727   (awhen (car (mutex-sql-query
 728                (format nil "select WRD from LRWD where EUI=~d" eui)))
 729             (make-instance 'lexterm :eui eui :wrd (car it))))
 730
 731 (defun find-lexterm-word (wrd)
 732   (let ((tuples (mutex-sql-query
 733                  (format nil "select EUI from LRWD where WRD='~a'" wrd)))
 734         (terms '()))
 735     (dolist (tuple tuples)
 736       (push (make-instance 'lexterm :eui (ensure-integer (car tuple))
 737                            :wrd (copy-seq wrd))
 738             terms))
 739     (nreverse terms)))
 740
 741 ;; LEX SQL Read functions
 742
 743 (defun find-labr-eui (eui)
 744   (let ((tuples
 745          (mutex-sql-query
 746           (format nil "select BAS,ABR,EUI2,BAS2 from LRABR where EUI=~d" eui)))
 747         (results '()))
 748     (dolist (tuple tuples)
 749       (destructuring-bind (bas abr eui2 bas2) tuple
 750         (push (make-instance 'labr :eui eui :bas bas :abr abr :bas2 bas2
 751                              :eui2 (ensure-integer eui2))
 752               results)))
 753     (nreverse results)))
 754
 755 (defun find-labr-bas (bas)
 756   (let ((tuples
 757          (mutex-sql-query
 758           (format nil "select EUI,ABR,EUI2,BAS2 from LRABR where BAS='~a'"
 759                   bas)))
 760         (results '()))
 761     (dolist (tuple tuples)
 762       (destructuring-bind (eui abr eui2 bas2) tuple
 763         (push
 764          (make-instance 'labr :eui (ensure-integer eui) :abr abr :bas2 bas2
 765                         :bas (copy-seq bas) :eui2 (ensure-integer eui2))
 766          results)))
 767     (nreverse results)))
 768
 769 (defun find-lagr-eui (eui)
 770   (let ((tuples
 771          (mutex-sql-query
 772           (format nil "select STR,SCA,AGR,CIT,BAS from LRAGR where EUI=~d" eui)))
 773         (results '()))
 774     (dolist (tuple tuples)
 775       (destructuring-bind (str sca agr cit bas) tuple
 776         (push (make-instance 'lagr :eui eui :str str :sca sca :agr agr
 777                              :cit cit :bas bas)
 778               results)))
 779     (nreverse results)))
 780
 781 (defun find-lcmp-eui (eui)
 782   (let ((tuples (mutex-sql-query
 783                  (format nil "select BAS,SCA,COM from LRCMP where EUI=~d" eui)))
 784         (results '()))
 785     (dolist (tuple tuples)
 786       (destructuring-bind (bas sca com) tuple
 787         (push (make-instance 'lcmp :eui eui :bas bas :sca sca :com com)
 788               results)))
 789     (nreverse results)))
 790
 791 (defun find-lmod-eui (eui)
 792   (let ((tuples
 793          (mutex-sql-query
 794           (format nil
 795                   "select BAS,SCA,PSN_MOD,FEA from LRMOD where EUI=~d" eui)))
 796         (results '()))
 797     (dolist (tuple tuples)
 798       (destructuring-bind (bas sca psnmod fea) tuple
 799         (push (make-instance 'lmod :eui eui :bas bas :sca sca :psnmod psnmod
 800                              :fea fea)
 801               results)))
 802     (nreverse results)))
 803
 804 (defun find-lnom-eui (eui)
 805   (let ((tuples
 806          (mutex-sql-query
 807           (format
 808            nil "select BAS,SCA,EUI2,BAS2,SCA2 from LRNOM where EUI=~d" eui)))
 809         (results '()))
 810     (dolist (tuple tuples)
 811       (destructuring-bind (bas sca eui2 bas2 sca2) tuple
 812         (push
 813          (make-instance 'lnom :eui eui :bas bas :sca sca :bas2 bas2 :sca2 sca2
 814                         :eui2 (ensure-integer eui2))
 815          results)))
 816     (nreverse results)))
 817
 818 (defun find-lprn-eui (eui)
 819   (let ((tuples
 820          (mutex-sql-query
 821           (format
 822            nil
 823            "select BAS,NUM,GND,CAS,POS,QNT,FEA from LRPRN where EUI=~d" eui)))
 824         (results '()))
 825     (dolist (tuple tuples)
 826       (destructuring-bind (bas num gnd cas pos qnt fea) tuple
 827         (push (make-instance 'lprn :eui eui :bas bas :num num :gnd gnd
 828                              :cas cas :pos pos :qnt qnt :fea fea)
 829               results)))
 830     (nreverse results)))
 831
 832 (defun find-lprp-eui (eui)
 833   (let ((tuples
 834          (mutex-sql-query
 835           (format nil "select BAS,STR,SCA,FEA from LRPRP where EUI=~d" eui)))
 836         (results '()))
 837     (dolist (tuple tuples)
 838       (destructuring-bind (bas str sca fea) tuple
 839         (push
 840          (make-instance 'lprp :eui eui :bas bas :str str :sca sca :fea fea)
 841          results)))
 842     (nreverse results)))
 843
 844 (defun find-lspl-eui (eui)
 845   (let ((tuples (mutex-sql-query
 846                  (format nil "select SPV,BAS from LRSPL where EUI=~d" eui)))
 847         (results '()))
 848     (dolist (tuple tuples)
 849       (destructuring-bind (spv bas) tuple
 850         (push (make-instance 'lspl :eui eui :spv spv :bas bas) results)))
 851     (nreverse results)))
 852
 853 (defun find-ltrm-eui (eui)
 854   (let ((tuples (mutex-sql-query
 855                  (format nil "select BAS,GEN from LRTRM where EUI=~d" eui)))
 856         (results '()))
 857     (dolist (tuple tuples)
 858       (destructuring-bind (bas gen) tuple
 859         (push (make-instance 'ltrm :eui eui :bas bas :gen gen) results)))
 860     (nreverse results)))
 861
 862 (defun find-ltyp-eui (eui)
 863   (let ((tuples (mutex-sql-query
 864                  (format nil "select BAS,SCA,TYP from LRTYP where EUI=~d" eui)))
 865         (results '()))
 866     (dolist (tuple tuples)
 867       (destructuring-bind (bas sca typ) tuple
 868           (push (make-instance 'ltyp :eui eui :bas bas :sca sca :typ typ)
 869                 results)))
 870     (nreverse results)))
 871
 872 (defun find-lwd-wrd (wrd)
 873   (let ((tuples (mutex-sql-query
 874                  (format nil "select EUI from LRWD where WRD='~a'" wrd)))
 875         (results '()))
 876     (dolist (tuple tuples)
 877       (push (ensure-integer (car tuple)) results))
 878     (make-instance 'lwd :wrd wrd :euilist (nreverse results))))
 879
 880 ;;; Semantic Network SQL access functions
 881
 882 (defun find-sdef-ui (ui)
 883   (awhen (car (mutex-sql-query
 884                   (format nil "select RT,STY_RL,STN_RTN,DEF,EX,UN,RH,ABR,RIN from SRDEF where UI=~d" ui)))
 885          (destructuring-bind (rt styrl stnrtn def ex un rh abr rin) it
 886            (make-instance 'sdef :rt rt :ui ui :styrl styrl :stnrtn stnrtn
 887                            :def def :ex ex :un un :rh rh :abr abr :rin rin))))
 888
 889 (defun find-sstre1-ui (ui)
 890   (let ((tuples (mutex-sql-query
 891                  (format nil "select UI2,UI3 from SRSTRE1 where UI=~d" ui)))
 892         (results '()))
 893     (dolist (tuple tuples)
 894       (destructuring-bind (ui2 ui3) tuple
 895         (push (make-instance 'sstre1 :ui ui :ui2 (ensure-integer ui2)
 896                              :ui3 (ensure-integer ui3))
 897               results)))
 898     (nreverse results)))
 899
 900 (defun find-sstre1-ui2 (ui2)
 901   (let ((tuples (mutex-sql-query
 902                  (format nil "select UI,UI3 from SRSTRE1 where UI2=~d" ui2)))
 903         (results '()))
 904     (dolist (tuple tuples)
 905       (destructuring-bind (ui ui3) tuple
 906         (push (make-instance 'sstre1 :ui (ensure-integer ui) :ui2 ui2
 907                              :ui3 (ensure-integer ui3))
 908               results)))
 909     (nreverse results)))
 910
 911 (defun find-sstr-rl (rl)
 912   (let ((tuples
 913          (mutex-sql-query
 914           (format nil "select STY_RL,STY_RL2,LS from SRSTRE where RL='~a'" rl)))
 915         (results '()))
 916     (dolist (tuple tuples)
 917       (destructuring-bind (styrl styrl2 ls) tuple
 918         (push (make-instance 'sstr :rl rl :styrl styrl :styrl2 styrl2 :ls ls)
 919               results)))
 920     (nreverse results)))
 921
 922
 923 (defun find-sstre2-sty (sty)
 924   (let ((tuples (mutex-sql-query
 925                  (format nil "select RL,STY2 from SRSTRE2 where STY='~a'" sty)))
 926         (results '()))
 927     (dolist (tuple tuples)
 928       (destructuring-bind (rl sty2) tuple
 929         (push (make-instance 'sstre2 :sty (copy-seq sty) :rl rl :sty2 sty2)
 930               results)))
 931     (nreverse results)))
 932
 933 (defun find-sstr-styrl (styrl)
 934   (let ((tuples
 935          (mutex-sql-query
 936           (format nil "select RL,STY_RL2,LS from SRSTR where RL='~a'" styrl)))
 937         (results '()))
 938     (dolist (tuple tuples)
 939       (destructuring-bind (rl styrl2 ls) tuple
 940       (push (make-instance 'sstr :styrl styrl :rl rl :styrl2 styrl2 :ls ls)
 941             results)))
 942     (nreverse results)))