1 ;;; $Id: obj-sql.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $
5 (declaim (optimize (speed 3) (safety 1)))
7 (defvar *current-srl* nil)
10 (defun current-srl! (srl)
11 (setq *current-srl* srl))
15 (defun post-import-sql ()
19 #+pubmed (create-pmsearch-table))
21 ;;; Accessors (read on demand)
23 ;; defines a slot-unbound method for class and slot-name, fills
24 ;; the slot by calling reader function with the slot values of
25 ;; the instance's reader-keys
26 (defmacro def-lazy-reader (class slot-name reader &rest reader-keys)
27 (let* ((the-slot-name (gensym))
29 (the-instance (gensym))
31 (dolist (key reader-keys)
32 (push (list 'slot-value the-instance (list 'quote key)) keys))
33 (setq keys (nreverse keys))
34 `(defmethod slot-unbound (,the-class (,the-instance ,class)
35 (,the-slot-name (eql ',slot-name)))
36 (declare (ignore ,the-class))
37 (setf (slot-value ,the-instance ,the-slot-name)
40 (def-lazy-reader ucon s#term find-uterm-cui cui)
41 (def-lazy-reader ucon s#def find-udef-cui cui)
42 (def-lazy-reader ucon s#sty find-usty-cui cui)
43 (def-lazy-reader ucon s#rel find-urel-cui cui)
44 (def-lazy-reader ucon s#coc find-ucoc-cui cui)
45 (def-lazy-reader ucon s#lo find-ulo-cui cui)
46 (def-lazy-reader ucon s#atx find-uatx-cui cui)
47 (def-lazy-reader ucon s#sat find-usat-ui cui)
50 (def-lazy-reader uterm s#str find-ustr-cuilui cui lui)
51 (def-lazy-reader uterm s#sat find-usat-ui cui lui)
54 (def-lazy-reader ustr s#sat find-usat-ui cui lui sui)
55 (def-lazy-reader ustr s#cxt find-ucxt-cuisui cui sui)
56 (def-lazy-reader ustr s#so find-uso-cuisui cui sui)
60 ;;; Lookup functions for uterms,ustr in ucons
62 (defun find-uterm-in-ucon (ucon lui)
63 (find lui (s#term ucon) :key #'uterm-lui :test 'equal))
65 (defun find-ustr-in-uterm (uterm sui)
66 (find sui (s#str uterm) :key #'ustr-sui :test 'equal))
68 (defun find-ustr-in-ucon (ucon sui)
69 (let ((found-ustr nil))
70 (dolist (uterm (s#term ucon))
72 (dolist (ustr (s#str uterm))
74 (when (string-equal sui (sui ustr))
75 (setq found-ustr ustr))))))
79 (defun find-ucon-cui (cui &key (srl *current-srl*))
82 (setq cui (parse-cui cui)))
84 (let ((ls (format nil "select KPFSTR,KCUILRL from MRCON where CUI=~d"
87 (string-append ls (format nil " and KCUILRL <= ~d limit 1" srl))
88 (string-append ls " limit 1"))
89 (gu:awhen (car (mutex-sql-query ls))
90 (make-instance 'ucon :cui cui :pfstr (car gu::it)
91 :lrl (ensure-integer (cadr gu::it)))))
94 (defun find-ucon-lui (lui &key (srl *current-srl*))
95 "Find list of ucon for lui"
97 (setq lui (parse-lui lui)))
100 (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where LUI=~d" lui)))
102 (string-append ls (format nil " and KCUILRL <= ~d" srl)))
103 (dolist (tuple (mutex-sql-query ls))
104 (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple))
106 :lrl (ensure-integer (nth 2 tuple)))
111 (defun find-ucon-sui (sui &key (srl *current-srl*))
112 "Find list of ucon for sui"
114 (setq sui (parse-sui sui)))
117 (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where SUI=~d" sui)))
119 (string-append ls (format nil " and KCUILRL <= ~d" srl)))
120 (let ((tuples (mutex-sql-query ls)))
121 (dolist (tuple tuples)
122 (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple))
124 :lrl (ensure-integer (nth 2 tuple)))
129 (defun find-ucon-cuisui (cui sui &key (srl *current-srl*))
130 "Find ucon for cui/sui"
132 (setq cui (parse-cui cui)))
134 (setq sui (parse-sui sui)))
136 (let ((ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where KCUISUI=~d"
137 (make-cuisui cui sui))))
139 (string-append ls (format nil " and KCUILRL <= ~d" srl)))
140 (gu:aif (car (mutex-sql-query ls))
141 (make-instance 'ucon :cui (ensure-integer (nth 0 gu::it))
142 :pfstr (nth 1 gu::it)
143 :lrl (ensure-integer (nth 2 gu::it)))
147 (defun find-ucon-str (str &key (srl *current-srl*))
148 "Find ucon that are exact match for str"
151 (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where STR='~a'" str)))
153 (string-append ls " and KCUILRL <= ~d" srl))
154 (dolist (tuple (mutex-sql-query ls))
155 (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple))
157 :lrl (ensure-integer (nth 2 tuple))) ucons))
161 (defun find-ucon-all (&key (srl *current-srl*))
162 "Return list of all ucon's"
163 (let ((ls "select distinct CUI,KPFSTR,KCUILRL from MRCON"))
165 (string-append ls (format nil " where KCUILRL <= ~d" srl)))
166 (string-append ls " order by CUI asc")
167 (with-sql-connection (db)
170 #'(lambda (cui pfstr cuilrl)
171 (make-instance 'ucon :cui (ensure-integer cui)
173 :lrl (ensure-integer cuilrl)))
179 (defun find-udef-cui (cui &key (srl *current-srl*))
180 "Return a list of udefs for cui"
182 (ls (format nil "select SAB,DEF from MRDEF where CUI=~d" cui)))
184 (string-append ls (format nil " and KSRL <= ~d" srl)))
185 (dolist (tuple (mutex-sql-query ls))
186 (push (make-instance 'udef :sab (car tuple) :def (cadr tuple)) udefs))
189 (defun find-usty-cui (cui &key (srl *current-srl*))
190 "Return a list of usty for cui"
192 (ls (format nil "select TUI,STY from MRSTY where CUI=~d" cui)))
194 (string-append ls (format nil " and KLRL <= ~d" srl)))
195 (dolist (tuple (mutex-sql-query ls))
196 (push (make-instance 'usty :tui (ensure-integer (car tuple)) :sty (cadr tuple)) ustys))
199 (defun find-usty-word (word &key (srl *current-srl*))
200 "Return a list of usty that match word"
202 (ls (format nil "select distinct TUI,STY from MRSTY where STY like '%~a%'" word)))
204 (string-append ls (format nil " and KLRL <= ~d" srl)))
205 (dolist (tuple (mutex-sql-query ls))
206 (push (make-instance 'usty :tui (ensure-integer (car tuple)) :sty (cadr tuple)) ustys))
209 (defun find-urel-cui (cui &key (srl *current-srl*))
210 "Return a list of urel for cui"
212 (ls (format nil "select REL,CUI2,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI1=~d" cui)))
214 (string-append ls (format nil " and KSRL <= ~d" srl)))
215 (dolist (tuple (mutex-sql-query ls))
216 (push (make-instance 'urel
219 :cui2 (ensure-integer (nth 1 tuple))
224 :pfstr2 (nth 6 tuple))
228 (defun find-urel-cui2 (cui2 &key (srl *current-srl*))
229 "Return a list of urel for cui2"
231 (ls (format nil "select REL,CUI1,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI2=~d" cui2)))
233 (string-append ls (format nil " and SRL <= ~d" srl)))
234 (dolist (tuple (mutex-sql-query ls))
235 (push (make-instance 'urel
238 :cui1 (ensure-integer (nth 1 tuple))
243 :pfstr2 (nth 6 tuple))
247 (defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*))
249 #'(lambda (cui) (find-ucon-cui cui :key srl))
250 (remove-duplicates (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl)))))
252 (defun find-ucoc-cui (cui &key (srl *current-srl*))
253 "Return a list of ucoc for cui"
255 (ls (format nil "select CUI2,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI1=~d" cui)))
257 (string-append ls (format nil " and KLRL <= ~d" srl)))
258 (string-append ls " order by COF asc")
259 (dolist (tuple (mutex-sql-query ls))
260 (let ((cui2 (ensure-integer (nth 0 tuple))))
263 (push (make-instance 'ucoc :cui1 cui
267 :cof (ensure-integer (nth 3 tuple))
269 :pfstr2 (nth 5 tuple))
271 ucocs)) ;; akready ordered by SQL select
273 (defun find-ucoc-cui2 (cui2 &key (srl *current-srl*))
274 "Return a list of ucoc for cui2"
276 (ls (format nil "select CUI1,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI2=~d" cui2)))
278 (string-append ls (format nil " and KSRL <= ~d" srl)))
279 (string-append ls " order by COF asc")
280 (dolist (tuple (mutex-sql-query ls))
281 (push (make-instance 'ucoc :cui1 (ensure-integer (nth 0 tuple))
285 :cof (ensure-integer (nth 3 tuple))
287 :pfstr2 (nth 5 tuple))
289 ucocs)) ;; already ordered by SQL select
291 (defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*))
292 "List of ucon with co-occurance cui2"
294 #'(lambda (cui) (find-ucon-cui cui :key srl))
295 (remove-duplicates (mapcar #'cui1 (find-ucoc-cui2 cui2 :srl srl)))))
297 (defun find-ulo-cui (cui &key (srl *current-srl*))
298 "Return a list of ulo for cui"
300 (ls (format nil "select ISN,FR,UN,SUI,SNA,SOUI from MRLO where CUI=~d" cui)))
302 (string-append ls (format nil " and KLRL <= ~d" srl)))
303 (dolist (tuple (mutex-sql-query ls))
304 (push (make-instance 'ulo :isn (nth 0 tuple)
305 :fr (ensure-integer (nth 1 tuple))
307 :sui (ensure-integer (nth 3 tuple))
313 (defmethod suistr ((lo ulo))
314 "Return the string for a ulo object"
315 (find-string-sui (sui lo)))
317 (defun find-uatx-cui (cui &key (srl *current-srl*))
318 "Return a list of uatx for cui"
320 (ls (format nil "select SAB,REL,ATX from MRATX where CUI=~d" cui)))
322 (string-append ls (format nil " and KSRL <= ~d" srl)))
323 (dolist (tuple (mutex-sql-query ls))
324 (push (make-instance 'uatx :sab (nth 0 tuple)
331 (defun find-uterm-cui (cui &key (srl *current-srl*))
332 "Return a list of uterm for cui"
334 (ls (format nil "select distinct LUI,LAT,TS,KLUILRL from MRCON where CUI=~d" cui)))
336 (string-append ls (format nil " and KLUILRL <= ~d" srl)))
337 (dolist (tuple (mutex-sql-query ls))
338 (push (make-instance 'uterm :lui (ensure-integer (nth 0 tuple))
342 :lrl (ensure-integer (nth 3 tuple)))
346 (defun find-uterm-lui (lui &key (srl *current-srl*))
347 "Return a list of uterm for lui"
349 (setq lui (parse-lui lui)))
351 (ls (format nil "select distinct CUI,LAT,TS,KLUILRL from MRCON where LUI=~d" lui)))
353 (string-append ls (format nil " and KLUILRL <= ~d" srl)))
354 (dolist (tuple (mutex-sql-query ls))
355 (push (make-instance 'uterm :cui (ensure-integer (nth 0 tuple))
359 :lrl (ensure-integer (nth 3 tuple)))
363 (defun find-uterm-cuilui (cui lui &key (srl *current-srl*))
364 "Return single uterm for cui/lui"
365 (let ((ls (format nil "select LAT,TS,KLUILRL from MRCON where KCUILUI=~d limit 1" (make-cuilui cui lui))))
367 (string-append ls (format nil " and KLUILRL <= ~d" srl)))
368 (gu:aif (car (mutex-sql-query ls))
369 (make-instance 'uterm :cui cui
373 :lrl (ensure-integer (nth 2 gu::it)))
376 (defun find-ustr-cuilui (cui lui &key (srl *current-srl*))
377 "Return a list of ustr for cui/lui"
378 (declare (fixnum cui lui))
380 (ls (format nil "select SUI,STT,STR,LRL from MRCON where KCUILUI=~d" (make-cuilui cui lui))))
382 (string-append ls (format nil " and LRL <= ~d" srl)))
383 (dolist (tuple (mutex-sql-query ls))
384 (let* ((sui (ensure-integer (car tuple)))
385 (ustr (make-instance 'ustr :sui sui
387 :cuisui (make-cuisui cui sui)
391 :lrl (ensure-integer (nth 3 tuple)))))
395 (defun find-ustr-cuisui (cui sui &key (srl *current-srl*))
396 "Return the single ustr for cuisui"
397 (let ((ls (format nil "select LUI,STT,STR,LRL from MRCON where KCUISUI=~d"
398 (make-cuisui cui sui))))
400 (string-append ls (format nil " and LRL <= ~d" srl)))
401 (gu:aif (car (mutex-sql-query ls))
402 (make-instance 'ustr :sui sui
404 :cuisui (make-cuisui cui sui)
405 :lui (ensure-integer (nth 0 gu::it))
408 :lrl (ensure-integer (nth 3 gu::it)))
411 (defun find-ustr-sui (sui &key (srl *current-srl*))
412 "Return the list of ustr for sui"
414 (setq sui (parse-sui sui)))
416 (ls (format nil "select CUI,LUI,STT,STR,LRL from MRCON where SUI=~d" sui)))
418 (string-append ls (format nil " and LRL <= ~d" srl)))
419 (dolist (tuple (mutex-sql-query ls))
420 (let ((cui (ensure-integer (car tuple))))
421 (push (make-instance 'ustr :sui sui
423 :cuisui (make-cuisui cui sui)
424 :lui (ensure-integer (nth 1 tuple))
427 :lrl (ensure-integer (nth 4 tuple)))
431 (defun find-ustr-sab (sab &key (srl *current-srl*))
432 "Return the list of ustr for sab"
434 (ls (format nil "select KCUISUI from MRSO where SAB='~a'" sab)))
436 (string-append ls (format nil " and SRL <= ~d" srl)))
437 (dolist (tuple (mutex-sql-query ls))
438 (let ((cuisui (ensure-integer (car tuple))))
439 (push (apply #'find-ustr-cuisui
441 (multiple-value-list (decompose-cuisui cuisui))
446 (defun find-ustr-all (&key (srl *current-srl*))
447 "Return list of all ustr's"
448 (let ((ls "select distinct CUI,LUI,SUI,STT,LRL,KPFSTR from MRCON"))
450 (string-append ls (format nil " where LRL <= ~d" srl)))
451 (string-append ls " order by SUI asc")
452 (with-sql-connection (db)
455 #'(lambda (cui lui sui stt lrl pfstr)
456 (setq cui (ensure-integer cui))
457 (setq lui (ensure-integer lui))
458 (setq sui (ensure-integer sui))
459 (setq lrl (ensure-integer lrl))
460 (make-instance 'ustr :cui cui
463 :cuisui (make-cuisui cui sui)
470 (defun find-string-sui (sui &key (srl *current-srl*))
471 "Return the string associated with sui"
472 (let ((ls (format nil "select STR from MRCON where SUI=~d" sui)))
474 (string-append ls (format nil " and LRL <= ~d" srl)))
475 (string-append ls " limit 1")
476 (caar (mutex-sql-query ls))))
478 (defun find-uso-cuisui (cui sui &key (srl *current-srl*))
479 (declare (fixnum cui sui))
481 (ls (format nil "select SAB,CODE,SRL,TTY from MRSO where KCUISUI=~d"
482 (make-cuisui cui sui))))
484 (string-append ls (format nil " and SRL <= ~d" srl)))
485 (dolist (tuple (mutex-sql-query ls))
486 (push (make-instance 'uso :sab (nth 0 tuple) :code (nth 1 tuple)
487 :srl (nth 2 tuple) :tty (nth 3 tuple))
491 (defun find-ucxt-cuisui (cui sui &key (srl *current-srl*))
492 (declare (fixnum cui sui))
494 (ls (format nil "select SAB,CODE,CXN,CXL,RNK,CXS,CUI2,HCD,RELA,XC from MRCXT where KCUISUI=~d"
495 (make-cuisui cui sui))))
497 (string-append ls (format nil " and KSRL <= ~d" srl)))
498 (dolist (tuple (mutex-sql-query ls))
499 (push (make-instance 'ucxt :sab (nth 0 tuple)
501 :cxn (ensure-integer (nth 2 tuple))
503 :rnk (ensure-integer (nth 4 tuple))
505 :cui2 (ensure-integer (nth 6 tuple))
512 (defun find-usat-ui (cui &optional (lui nil) (sui nil) &key (srl *current-srl*))
513 (let ((ls (format nil "select CODE,ATN,SAB,ATV from MRSAT where ")))
515 (sui (string-append ls (format nil "KCUISUI=~d" (make-cuisui cui sui))))
516 (lui (string-append ls (format nil "KCUILUI=~d and sui=0" (make-cuilui cui lui))))
517 (t (string-append ls (format nil "cui=~d and lui=0 and sui=0" cui))))
519 (string-append ls (format nil " and KSRL <= ~d" srl)))
521 (dolist (tuple (mutex-sql-query ls))
522 (push (make-instance 'usat :code (nth 0 tuple)
529 (defun find-bsab-sab (sab)
530 (gu:aif (car (mutex-sql-query
531 (format nil "select NAME,COUNT from BONUS_SAB where SAB='~a'" sab)))
532 (make-instance 'bsab :sab sab :name (nth 0 gu::it)
533 :hits (ensure-integer (nth 1 gu::it)))
536 (defun find-bsab-all ()
538 (dolist (tuple (mutex-sql-query "select SAB,NAME,COUNT from BONUS_SAB"))
540 (make-instance 'bsab :sab (nth 0 tuple) :name (nth 1 tuple)
541 :hits (ensure-integer (nth 2 tuple)))
545 (defun find-btty-tty (tty)
546 (gu:aif (car (mutex-sql-query
547 (format nil "select NAME from BONUS_TTY where TTY='~a'" tty)))
548 (make-instance 'btty :tty tty :name (nth 0 gu::it))
551 (defun find-btty-all ()
553 (dolist (tuple (mutex-sql-query "select TTY,NAME from BONUS_TTY"))
555 (make-instance 'btty :tty (nth 0 tuple) :name (nth 1 tuple))
559 (defun find-brel-rel (rel)
561 (dolist (tuple (mutex-sql-query
562 (format nil "select SAB,SL,REL,RELA,COUNT from BONUS_REL where REL='~a'" rel)))
564 (make-instance 'brel :sab (nth 0 tuple) :sl (nth 1 tuple) :rel (nth 2 tuple)
565 :rela (nth 3 tuple) :hits (ensure-integer (nth 4 tuple)))
569 (defun find-pfstr-cui (cui)
570 (caar (mutex-sql-query (format nil "select KPFSTR from MRCON where CUI=~d limit 1" cui))))
572 (defun find-usty-tui (tui)
574 (setq tui (parse-tui tui))
575 (gu:aif (car (mutex-sql-query
576 (format nil "select STY from MRSTY where TUI=~d limit 1" tui)))
577 (make-instance 'usty :tui tui :sty (nth 0 gu::it))
580 (defun find-usty-sty (sty)
581 "Find usty for a sty"
582 (gu:aif (car (mutex-sql-query
583 (format nil "select TUI from MRSTY where STY='~a' limit 1" sty)))
584 (make-instance 'usty :tui (ensure-integer (nth 0 gu::it)) :sty sty)
587 (defun find-usty-all ()
588 "Return list of usty's for all semantic types"
590 (dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY"))
591 (push (find-usty-tui (nth 0 tuple)) ustys))
594 (defun find-usty_freq-all ()
595 (let ((usty_freqs '()))
596 (dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY"))
597 (let* ((tui (car tuple))
598 (freq (ensure-integer
599 (caar (mutex-sql-query
600 (format nil "select count(*) from MRSTY where TUI=~a" tui))))))
601 (push (make-instance 'usty_freq :usty (find-usty-tui tui) :freq freq) usty_freqs)))
602 (sort usty_freqs #'> :key #'usty_freq-freq)))
605 (defun make-user-table ()
606 (mutex-sql-execute "create table UMLISP_USERS (ID integer UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY,FIRST_NAME varchar(20),LAST_NAME varchar(20),ORGANIZATION varchar(80),ADDRESS1 varchar(60),ADDRESS2 varchar(60),CITY varchar(30),STATE char(2),ZIP char(10),COUNTRY varchar(40),OCCUPATION varchar(120),EMAIL varchar(80),PASSWD varchar(20),MAILLIST char(1),LICENSED char(1),SRL integer,TIMEOUT integer,DATETIME_CREATED datetime,DATETIME_MODIFIED datetime)"))
608 (defun find-umlisp-user-email (email)
609 (let ((tuple (car (mutex-sql-query
610 (format nil "select ID,FIRST_NAME,LAST_NAME,ORGANIZATION,ADDRESS1,ADDRESS2,CITY,STATE,ZIP,COUNTRY,OCCUPATION,LICENSED,MAILLIST,PASSWD,SRL,TIMEOUT,DATETIME_CREATED,DATETIME_MODIFIED from UMLISP_USERS where EMAIL='~a'" email)))))
612 (make-instance 'umlisp-user :email email
613 :id (ensure-integer (nth 0 tuple))
614 :first-name (nth 1 tuple)
615 :last-name (nth 2 tuple)
616 :organization (nth 3 tuple)
617 :address1 (nth 4 tuple)
618 :address2 (nth 5 tuple)
622 :country (nth 9 tuple)
623 :occupation (nth 10 tuple)
624 :licensed (if (string-equal "Y" (nth 11 tuple)) t nil)
625 :maillist (if (string-equal "Y" (nth 12 tuple)) t nil)
626 :passwd (nth 13 tuple)
627 :srl (ensure-integer (nth 14 tuple))
628 :timeout (ensure-integer (nth 15 tuple))
629 :datetime-created (nth 16 tuple)
630 :datetime-modified (nth 17 tuple)))))
632 (defun find-umlisp-user-all ()
634 (dolist (email (find-umlisp-user-all-email))
635 (push (find-umlisp-user-email email) users))
638 (defun find-umlisp-user-all-email ()
640 (dolist (tuple (mutex-sql-query "select EMAIL from UMLISP_USERS"))
641 (push (car tuple) emails))
644 (defun find-umlisp-user-announce-email ()
646 (dolist (tuple (mutex-sql-query
647 "select EMAIL from UMLISP_USERS where MAILLIST='Y'"))
648 (push (car tuple) emails))
651 (defun add-umlisp-user (user)
652 (if (typep user 'umlisp-user)
655 (format nil "insert into UMLISP_USERS (FIRST_NAME,LAST_NAME,ORGANIZATION,ADDRESS1,ADDRESS2,CITY,STATE,ZIP,COUNTRY,OCCUPATION,LICENSED,MAILLIST,EMAIL,PASSWD,SRL,TIMEOUT,DATETIME_CREATED,DATETIME_MODIFIED) values ('~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a',~d,~d,NOW(),NOW())"
656 (first-name user) (last-name user)
658 (address1 user) (address2 user)
659 (city user) (state user)
660 (zip user) (country user) (occupation user)
661 (if (licensed user) #\Y #\N)
662 (if (maillist user) #\Y #\N)
664 (passwd user) (srl user)
666 (let ((read-user (find-umlisp-user-email (email user))))
667 (setf (slot-value user 'id) (id read-user)
668 (slot-value user 'datetime-created) (datetime-created read-user)
669 (slot-value user 'datetime-modified) (datetime-modified read-user)))
673 (defun umlisp-user-verify-passwd (user passwd)
675 (string-equal passwd (passwd user))))
677 (defun umlisp-user-set-srl (email srl)
678 (when (and (integerp srl) (find-umlisp-user-email email))
680 (format nil "update UMLISP_USERS set SRL=~d,DATETIME_MODIFIED=NOW() where EMAIL='~a'" srl email))
683 (defun make-ustats ()
684 (with-sql-connection (conn)
685 (sql-execute "drop table if exists USTATS" conn)
686 (sql-execute "create table USTATS (NAME varchar(160), COUNT bigint, SRL integer)" conn)
689 (insert-ustats-count conn "Concept Count" "MRCON" "distinct CUI" "KCUILRL" srl)
690 (insert-ustats-count conn "Term Count" "MRCON" "distinct KCUILUI" "KCUILRL" srl)
691 (insert-ustats-count conn "Distinct Term Count" "MRCON" "distinct LUI" "KLUILRL" srl)
692 (insert-ustats-count conn "String Count" "MRCON" "*" "LRL" srl)
693 (insert-ustats-count conn "Distinct String Count" "MRCON" "distinct SUI" "LRL" srl)
694 (insert-ustats-count conn "Associated Expression Count" "MRATX" "*" "KSRL" srl)
695 (insert-ustats-count conn "Context Count" "MRCXT" "*" "KSRL" srl)
696 (insert-ustats-count conn "Co-occuring Concept Count" "MRCOC" "*" "KLRL" srl)
697 (insert-ustats-count conn "Definition Count" "MRDEF" "*" "KSRL" srl)
698 (insert-ustats-count conn "Locator Count" "MRLO" "*" "KLRL" srl)
699 (insert-ustats-count conn "Rank Count" "MRRANK" "*" "KSRL" srl)
700 (insert-ustats-count conn "Relationship Count" "MRREL" "*" "KSRL" srl)
701 (insert-ustats-count conn "Semantic Type Count" "MRSTY" "*" "KLRL" srl)
702 (insert-ustats-count conn "Simple Attribute Count" "MRSAT" "*" "KSRL" srl)
703 (insert-ustats-count conn "Source Count" "MRSO" "*" "SRL" srl)
704 (insert-ustats-count conn "Word Index Count" "MRXW_ENG" "*" "KLRL" srl)
705 (insert-ustats-count conn "Normalized Word Index Count" "MRXNW_ENG" "*" "KLRL" srl)
706 (insert-ustats-count conn "Normalized String Index Count" "MRXNS_ENG" "*" "KLRL" srl)
707 (insert-ustats-count conn "Bonus Attribute Name Count" "BONUS_ATN" "*" nil srl)
708 (insert-ustats-count conn "Bonus Relationship Count" "BONUS_REL" "*" nil srl)
709 (insert-ustats-count conn "Bonus Source Abbreviation Count" "BONUS_SAB" "*" nil srl)
710 (insert-ustats-count conn "Bonus Term Type Count" "BONUS_TTY" "*" nil srl))
711 (sql-execute "create index USTATS_SRL on USTATS (SRL)" conn))
714 (defun insert-ustats-count (conn name table count-variable srl-control srl)
715 (insert-ustats conn name (find-count-table conn table srl count-variable srl-control) srl))
717 (defun find-count-table (conn table srl count-variable srl-control)
719 ((stringp srl-control)
721 (caar (sql-query (format nil "select count(~a) from ~a where ~a <= ~d"
722 count-variable table srl-control srl)
726 (caar (sql-query (format nil "select count(~a) from ~a"
727 count-variable table )
730 (error "Unknown srl-control")
733 (defun insert-ustats (conn name count srl)
734 (sql-execute (format nil "insert into USTATS (name,count,srl) values ('~a',~d,~d)"
735 name count (if srl srl 3))
738 (defun find-ustats-all (&key (srl *current-srl*))
740 (ls "select NAME,COUNT,SRL from USTATS"))
742 (string-append ls (format nil " where SRL=~d" srl)))
743 (string-append ls " order by NAME asc")
744 (dolist (tuple (mutex-sql-query ls))
745 (push (make-instance 'ustats :name (nth 0 tuple)
746 :hits (ensure-integer (nth 1 tuple))
747 :srl (ensure-integer (nth 2 tuple)))
751 (defun find-ustats-srl (srl)
753 (dolist (tuple (mutex-sql-query
754 (format nil "select NAME,COUNT from USTATS where SRL=~d order by NAME asc" srl)))
755 (push (make-instance 'ustats :name (nth 0 tuple)
756 :hits (ensure-integer (nth 1 tuple))
762 (with-sql-connection (conn)
763 (sql-execute "drop table if exists USRL" conn)
764 (sql-execute "create table USRL (sab varchar(80), srl integer)" conn)
765 (dolist (tuple (mutex-sql-query "select distinct SAB,SRL from MRSO order by SAB asc"))
766 (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)"
767 (car tuple) (ensure-integer (cadr tuple)))
771 (defun find-usrl-all ()
773 (tuples (mutex-sql-query "select SAB,SRL from USRL order by SAB desc")))
774 (dolist (tuple tuples)
775 (push (make-instance 'usrl :sab (nth 0 tuple)
776 :srl (ensure-integer (nth 1 tuple))) usrls))
777 usrls)) ;; already reversed by sql
779 (defun find-usrl_freq-all ()
781 (dolist (usrl (find-usrl-all))
782 (let ((freq (ensure-integer
783 (caar (mutex-sql-query
784 (format nil "select count(*) from MRSO where SAB='~a'"
786 (push (make-instance 'usrl_freq :usrl usrl :freq freq) freqs)))
787 (sort freqs #'> :key #'usrl_freq-freq)))
789 (defun find-cui-max ()
790 (let ((cui (caar (mutex-sql-query "select max(CUI) from MRCON"))))
791 (ensure-integer cui)))
793 ;;;; Cross table find functions
795 (defun find-ucon-tui (tui &key (srl *current-srl*))
796 "Find list of ucon for tui"
798 (setq tui (parse-tui tui)))
800 (ls (format nil "select CUI from MRSTY where TUI=~d" tui)))
802 (string-append ls (format nil " and KLRL <= ~d" srl)))
803 (string-append ls " order by cui desc")
804 (dolist (tuple (mutex-sql-query ls))
805 (push (find-ucon-cui (ensure-integer (car tuple)) :srl srl) ucons))
808 (defun find-ucon-word (word &key (srl *current-srl*) (like nil))
809 "Return list of ucons that match word. Optionally, use SQL's LIKE syntax"
811 (ls (format nil "select distinct cui from MRXW_ENG where wd~A'~A'"
812 (if like " LIKE " "=")
815 (string-append ls (format nil " and KLRL <= ~d" srl)))
816 (string-append ls " order by cui desc")
817 (dolist (tuple (mutex-sql-query ls))
818 (push (find-ucon-cui (car tuple) :srl srl) ucons))
821 (defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil))
822 "Return list of ucons that match word, optionally use SQL's LIKE syntax"
824 (ls (format nil "select distinct cui from MRXNW_ENG where nwd~A'~A'"
825 (if like " LIKE " "=")
828 (string-append ls (format nil " and KLRL <= ~d" srl)))
829 (string-append ls " order by cui desc")
830 (dolist (tuple (mutex-sql-query ls))
831 (push (find-ucon-cui (car tuple) :srl srl) ucons))
834 (defun find-ustr-word (word &key (srl *current-srl*))
835 "Return list of ustrs that match word"
837 (ls (format nil "select cui,sui from MRXW_ENG where wd='~a'" word)))
839 (string-append ls (format nil " and KLRL <= ~d" srl)))
840 (string-append ls " order by cui desc,sui desc")
841 (dolist (tuple (mutex-sql-query ls))
842 (push (find-ustr-cuisui (ensure-integer (car tuple)) (ensure-integer (cadr tuple)) :srl srl)
846 (defun find-ustr-normalized-word (word &key (srl *current-srl*))
847 "Return list of ustrs that match word"
849 (ls (format nil "select cui,sui from MRXNW_ENG where nwd='~a'" word)))
851 (string-append ls (format nil " and KLRL <= ~d" srl)))
852 (string-append ls " order by cui desc,sui desc")
853 (dolist (tuple (mutex-sql-query ls))
854 (push (find-ustr-cuisui (ensure-integer (car tuple)) (ensure-integer (cadr tuple)) :srl srl)
859 ;;; Multiword lookup and score functions
861 (defun find-ucon-multiword (str &key (srl *current-srl*))
862 "Return sorted list of ucon's that match a multiword string"
863 (let* ((words (delimited-string-to-list str #\space))
866 (setq ucons (append ucons (find-ucon-word word :srl srl))))
867 (sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui))))
869 (defun find-ucon-normalized-multiword (str &key (srl *current-srl*))
870 "Return sorted list of ucon's that match a multiword string"
871 (let* ((words (delimited-string-to-list str #\space))
875 (let ((nws (lvg:process-terms word)))
877 (push nword nwords))))
878 (dolist (word nwords)
879 (setq ucons (append ucons (find-ucon-word word :srl srl))))
880 (sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui))))
882 (defun find-ustr-multiword (str &key (srl *current-srl*))
883 "Return sorted list of ustr's that match a multiword string"
884 (let* ((words (delimited-string-to-list str #\space))
887 (setq ustrs (append ustrs (find-ustr-word word :srl srl))))
888 (sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'cui))))
890 (defun find-ustr-normalized-multiword (str &key (srl *current-srl*))
891 "Return sorted list of ustr's that match a multiword string"
892 (let* ((words (delimited-string-to-list str #\space))
896 (let ((nws (lvg:process-terms word)))
898 (push nword nwords))))
899 (dolist (word nwords)
900 (setq ustrs (append ustrs (find-ustr-word word :srl srl))))
901 (sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'ustr-cui))))
904 (find-normalized-matches-for-str str #'find-ustr-normalized-word #'ustr-sui))
906 (defun find-normalized-matches-for-str (str lookup-func key-func)
907 "Return list of objects that normalize match for words in string,
908 eliminate duplicates."
911 (dolist (word (delimited-string-to-list str #\space))
912 (dolist (nword (lvg:process-terms word))
913 (unless (member nword nwords :test #'string-equal)
914 (push nword nwords))))
916 (setq objs (append objs (funcall lookup-func nw))))
917 (delete-duplicates objs :key key-func :test #'eql)))
919 (defun sort-score-ucon-str (str ucons)
920 "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
921 (sort-score-umlsclass-str ucons str #'pfstr))
923 (defun sort-score-ustr-str (str ustrs)
924 "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
925 (sort-score-umlsclass-str ustrs str #'str))
927 (defun sort-score-umlsclass-str (objs str lookup-func)
928 "Sort a list of objects based on scoring to a string"
933 (score-multiword-match str (funcall lookup-func obj)))
935 (mapcar #'car (sort scored #'> :key #'cadr))))
937 (defun score-multiword-match (s1 s2)
938 "Score a match between two strings with s1 being reference string"
939 (let* ((word-list-1 (delimited-string-to-list s1 #\space))
940 (word-list-2 (delimited-string-to-list s2 #\space))
941 (n1 (length word-list-1))
942 (n2 (length word-list-2))
947 short-list long-list)
948 (declare (fixnum n1 n2 nshort nlong score unmatched))
953 (setq long-list word-list-1)
954 (setq short-list word-list-2))
958 (setq long-list word-list-2)
959 (setq short-list word-list-1)))
960 (decf score (- nlong nshort)) ;; reduce score for extra words
961 (dotimes (iword nshort)
962 (declare (fixnum iword))
963 (gu:aif (position (nth iword short-list) long-list :test #'string-equal)
965 (incf score (- 10 (abs (- gu::it iword))))
967 (decf score (* 2 unmatched))
971 ;;; LEX SQL functions
973 (defun find-lexterm-eui (eui)
974 (gu:awhen (car (mutex-sql-query
975 (format nil "select WRD from LRWD where EUI=~d" eui)))
976 (make-instance 'lexterm :eui eui :wrd (nth 0 gu:it))))
978 (defun find-lexterm-word (wrd)
979 (gu:awhen (mutex-sql-query
980 (format nil "select EUI from LRWD where WRD='~a'" wrd))
982 (dolist (tuple gu:it)
983 (let ((eui (ensure-integer (nth 0 tuple))))
985 (make-instance 'lexterm :eui eui :wrd (copy-seq wrd))
989 ;; LEXTERM accessors, read on demand
991 (def-lazy-reader lexterm s#abr find-labr-eui eui)
992 (def-lazy-reader lexterm s#agr find-lagr-eui eui)
993 (def-lazy-reader lexterm s#cmp find-lcmp-eui eui)
994 (def-lazy-reader lexterm s#mod find-lmod-eui eui)
995 (def-lazy-reader lexterm s#nom find-lnom-eui eui)
996 (def-lazy-reader lexterm s#prn find-lprn-eui eui)
997 (def-lazy-reader lexterm s#prp find-lprp-eui eui)
998 (def-lazy-reader lexterm s#spl find-lspl-eui eui)
999 (def-lazy-reader lexterm s#trm find-ltrm-eui eui)
1000 (def-lazy-reader lexterm s#typ find-ltyp-eui eui)
1002 ;; LEX SQL Read functions
1004 (defun find-labr-eui (eui)
1005 (gu:awhen (mutex-sql-query
1006 (format nil "select BAS,ABR,EUI2,BAS2 from LRABR where EUI=~d" eui))
1007 (let ((results '()))
1008 (dolist (tuple gu::it)
1010 (make-instance 'labr :eui eui
1013 :eui2 (ensure-integer (nth 2 tuple))
1014 :bas2 (nth 3 tuple))
1016 (nreverse results))))
1018 (defun find-labr-bas (bas)
1019 (gu:awhen (mutex-sql-query
1020 (format nil "select EUI,ABR,EUI2,BAS2 from LRABR where BAS='~a'" bas))
1021 (let ((results '()))
1022 (dolist (tuple gu::it)
1024 (make-instance 'labr :eui (ensure-integer (nth 0 tuple))
1027 :eui2 (ensure-integer (nth 2 tuple))
1028 :bas2 (nth 3 tuple))
1030 (nreverse results))))
1032 (defun find-lagr-eui (eui)
1033 (gu:awhen (mutex-sql-query
1034 (format nil "select STR,SCA,AGR,CIT,BAS from LRAGR where EUI=~d" eui))
1035 (let ((results '()))
1036 (dolist (tuple gu::it)
1038 (make-instance 'lagr
1046 (nreverse results))))
1048 (defun find-lcmp-eui (eui)
1049 (gu:awhen (mutex-sql-query
1050 (format nil "select BAS,SCA,COM from LRCMP where EUI=~d" eui))
1051 (let ((results '()))
1052 (dolist (tuple gu::it)
1054 (make-instance 'lcmp
1060 (nreverse results))))
1062 (defun find-lmod-eui (eui)
1063 (gu:awhen (mutex-sql-query
1064 (format nil "select BAS,SCA,PSN_MOD,FEA from LRMOD where EUI=~d" eui))
1065 (let ((results '()))
1066 (dolist (tuple gu::it)
1068 (make-instance 'lmod
1072 :psnmod (nth 2 tuple)
1075 (nreverse results))))
1077 (defun find-lnom-eui (eui)
1078 (gu:awhen (mutex-sql-query
1079 (format nil "select BAS,SCA,EUI2,BAS2,SCA2 from LRNOM where EUI=~d" eui))
1080 (let ((results '()))
1081 (dolist (tuple gu::it)
1083 (make-instance 'lnom
1087 :eui2 (ensure-integer (nth 2 tuple))
1089 :sca2 (nth 4 tuple))
1091 (nreverse results))))
1093 (defun find-lprn-eui (eui)
1094 (gu:awhen (mutex-sql-query
1095 (format nil "select BAS,NUM,GND,CAS,POS,QNT,FEA from LRPRN where EUI=~d" eui))
1096 (let ((results '()))
1097 (dolist (tuple gu::it)
1099 (make-instance 'lprn
1109 (nreverse results))))
1111 (defun find-lprp-eui (eui)
1112 (gu:awhen (mutex-sql-query
1113 (format nil "select BAS,STR,SCA,FEA from LRPRP where EUI=~d" eui))
1114 (let ((results '()))
1115 (dolist (tuple gu::it)
1117 (make-instance 'lprp
1124 (nreverse results))))
1126 (defun find-lspl-eui (eui)
1127 (gu:awhen (mutex-sql-query
1128 (format nil "select SPV,BAS from LRSPL where EUI=~d" eui))
1129 (let ((results '()))
1130 (dolist (tuple gu::it)
1132 (make-instance 'lspl
1137 (nreverse results))))
1140 (defun find-ltrm-eui (eui)
1141 (gu:awhen (mutex-sql-query
1142 (format nil "select BAS,GEN from LRTRM where EUI=~d" eui))
1143 (let ((results '()))
1144 (dolist (tuple gu::it)
1146 (make-instance 'ltrm
1151 (nreverse results))))
1153 (defun find-ltyp-eui (eui)
1154 (gu:awhen (mutex-sql-query
1155 (format nil "select BAS,SCA,TYP from LRTYP where EUI=~d" eui))
1156 (let ((results '()))
1157 (dolist (tuple gu::it)
1159 (make-instance 'ltyp
1165 (nreverse results))))
1167 (defun find-lwd-wrd (wrd)
1168 (gu:awhen (mutex-sql-query
1169 (format nil "select EUI from LRWD where WRD='~a'" wrd))
1170 (let ((results '()))
1171 (dolist (tuple gu::it)
1172 (push (ensure-integer (nth 0 tuple)) results))
1173 (make-instance 'lwd :wrd wrd
1174 :euilist (nreverse results)))))
1176 ;;; Semantic Network SQL access functions
1178 (defun find-sdef-ui (ui)
1179 (gu:awhen (car (mutex-sql-query
1180 (format nil "select RT,STY_RL,STN_RTN,DEF,EX,UN,RH,ABR,RIN from SRDEF where UI=~d" ui)))
1181 (make-instance 'sdef :rt (nth 0 gu::it)
1183 :styrl (nth 1 gu::it)
1184 :stnrtn (nth 2 gu::it)
1190 :rin (nth 8 gu::it))))
1192 (defun find-sstre1-ui (ui)
1193 (gu:awhen (mutex-sql-query
1194 (format nil "select UI2,UI3 from SRSTRE1 where UI=~d" ui))
1195 (let ((results '()))
1196 (dolist (tuple gu::it)
1198 (make-instance 'sstre1 :ui ui
1199 :ui2 (ensure-integer (nth 0 tuple))
1200 :ui3 (ensure-integer (nth 1 tuple)))
1202 (nreverse results))))
1204 (defun find-sstre1-ui2 (ui2)
1205 (gu:awhen (mutex-sql-query
1206 (format nil "select UI,UI3 from SRSTRE1 where UI2=~d" ui2))
1207 (let ((results '()))
1208 (dolist (tuple gu::it)
1210 (make-instance 'sstre1 :ui (ensure-integer (nth 0 tuple))
1212 :ui3 (ensure-integer (nth 1 tuple)))
1214 (nreverse results))))
1216 (defun find-sstr-rl (rl)
1217 (gu:awhen (mutex-sql-query
1218 (format nil "select STY_RL,STY_RL2,LS from SRSTRE where RL='~a'" rl))
1219 (let ((results '()))
1220 (dolist (tuple gu::it)
1222 (make-instance 'sstr
1224 :styrl (nth 0 tuple)
1225 :styrl2 (nth 1 tuple)
1228 (nreverse results))))
1231 (defun find-sstre2-sty (sty)
1232 (gu:awhen (mutex-sql-query
1233 (format nil "select RL,STY2 from SRSTRE2 where STY='~a'" sty))
1234 (let ((results '()))
1235 (dolist (tuple gu::it)
1237 (make-instance 'sstre2
1240 :sty2 (nth 1 tuple))
1242 (nreverse results))))
1244 (defun find-sstr-styrl (styrl)
1245 (gu:awhen (mutex-sql-query
1246 (format nil "select RL,STY_RL2,LS from SRSTR where RL='~a'" styrl))
1247 (let ((results '()))
1248 (dolist (tuple gu::it)
1250 (make-instance 'sstr :styrl styrl
1252 :styrl2 (nth 1 tuple)
1255 (nreverse results))))