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