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