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