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