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