;;;; $Id$
;;;;
;;;; This file, part of UMLisp, is
-;;;; Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D.
+;;;; Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D.
;;;;
;;;; UMLisp users are granted the rights to distribute and use this software
;;;; as governed by the terms of the GNU General Public License.
&key (lrl "KCUILRL") single distinct order like)
(concatenate
'string
- (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)"
+ (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)"
(if distinct "distinct " "") fields table)
(if where-name (format nil " where ~:@(~A~)" where-name) "")
(if where-name
"Query the UMLisp database. Return a list of umlisp objects whose name
is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
`(,query-cmd
- (query-string ,table ,fields ,srl ,where-name ,where-value
+ (query-string ,table ,fields ,srl ,where-name ,where-value
:lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like)))
(defmacro umlisp-query-eval (table fields srl where-name where-value
"Query the UMLisp database. Return a list of umlisp objects whose name
is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
`(mutex-sql-query
- (query-string-eval ,table ,fields ,srl ,where-name ,where-value
+ (query-string-eval ,table ,fields ,srl ,where-name ,where-value
:lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like)))
;; only WHERE-VALUE and SRL are evaluated
order like (query-cmd 'mutex-sql-query))
&body body)
(let ((value (gensym))
- (r (gensym)))
+ (r (gensym)))
(if single
`(let* ((,value ,where-value)
(tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value
(defun find-ucon-all (&key (srl *current-srl*))
"Return list of all ucon's"
(with-sql-connection (db)
- (clsql:map-query
+ (clsql:map-query
'list
#'(lambda (tuple)
(destructuring-bind (cui pfstr cuilrl) tuple
(defun map-ucon-all (fn &key (srl *current-srl*))
"Map a function over all ucon's"
(with-sql-connection (db)
- (clsql:map-query
+ (clsql:map-query
nil
#'(lambda (tuple)
(destructuring-bind (cui pfstr cuilrl) tuple
(make-instance 'udoc :key dockey :value value :type type :expl expl)))
(defun find-udoc-key-value (key value)
- (let ((tuple (car (mutex-sql-query
+ (let ((tuple (car (mutex-sql-query
(format nil "SELECT TYPE,EXPL FROM MRDOC WHERE DOCKEY='~A' AND VALUE='~A'"
key value)))))
(when tuple
(make-instance 'udoc :key key :value value :type (first tuple) :expl (second tuple)))))
-
+
(defun find-udoc-all ()
"Return all abbreviation documentation"
(collect-umlisp-query (mrdoc (dockey value type expl) nil nil nil)
(defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*))
"List of ucon with co-occurance cui2"
(ensure-cui-integer cui2)
- (mapcar
+ (mapcar
#'(lambda (cui) (find-ucon-cui cui :srl srl))
(remove-duplicates (mapcar #'cui1 (find-ucoc-cui2 cui2 :srl srl)))))
-(defun find-ulo-cui (cui &key (srl *current-srl*))
- "Return a list of ulo for cui"
- (ensure-cui-integer cui)
- (collect-umlisp-query (mrlo (isn fr un sui sna soui) srl cui cui
- :lrl "KLRL")
- (make-instance 'ulo :isn isn :fr (ensure-integer fr) :un un
- :sui (ensure-integer sui) :sna sna :soui soui)))
-
(defun find-uterm-cui (cui &key (srl *current-srl*))
"Return a list of uterm for cui"
(defun find-uterm-lui (lui &key (srl *current-srl*))
"Return a list of uterm for lui"
(ensure-lui-integer lui)
- (collect-umlisp-query (mrconso (cui lat ts kluilrl) srl lui lui
+ (collect-umlisp-query (mrconso (cui lat ts kluilrl) srl lui lui
:lrl kluilrl :distinct t)
(make-instance 'uterm :cui (ensure-integer cui) :lui lui
:lat lat :ts ts :lrl (ensure-integer kluilrl))))
:cuisui (make-cuisui (ensure-integer cui) sui)
:suppress suppress
:lui (ensure-integer lui) :lrl (ensure-integer ksuilrl))))
-
+
(defun find-ustr-sab (sab &key (srl *current-srl*))
"Return the list of ustr for sab"
(collect-umlisp-query (mrconso (kcuisui) srl sab sab :lrl srl)
(let ((cuisui (ensure-integer kcuisui)))
- (apply #'find-ustr-cuisui
+ (apply #'find-ustr-cuisui
(append
(multiple-value-list (decompose-cuisui cuisui))
(list :srl srl))))))
(defun find-ustr-all (&key (srl *current-srl*))
"Return list of all ustr's"
(with-sql-connection (db)
- (clsql:map-query
+ (clsql:map-query
'list
#'(lambda (tuple)
(destructuring-bind (cui lui sui stt ksuilrl suppress pfstr) tuple
"' and lui='0' and sui='0'")))
(when srl
(string-append ls " and KSRL<=" (prefixed-fixnum-string srl nil 3)))
- (loop for tuple in (mutex-sql-query ls) collect
+ (loop for tuple in (mutex-sql-query ls) collect
(destructuring-bind (code atn sab atv) tuple
(make-instance 'usat :code code :atn atn :sab sab :atv atv)))))
(collect-umlisp-query (mrsab (vcui rcui vsab rsab son sf sver vstart vend imeta
rmeta slc scc srl tfr cfr cxty ttyl atnl lat
cenc curver sabin ssn scit) nil nil nil)
- (make-instance 'usab :vcui (ensure-integer vcui)
+ (make-instance 'usab :vcui (ensure-integer vcui)
:rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son
:sf sf :sver sver :vstart vstart :vend vend :imeta imeta
:rmeta rmeta :slc slc :scc scc :srl (ensure-integer srl)
ttyl atnl lat cenc curver sabin
ssn scit)
nil key-name key :single t)
- (make-instance 'usab :vcui (ensure-integer vcui)
+ (make-instance 'usab :vcui (ensure-integer vcui)
:rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son
:sf sf :sver sver :vstart vstart :vend vend :imeta imeta
:rmeta rmeta :slc slc :scc scc :srl (ensure-integer srl)
(ensure-tui-integer tui)
(collect-umlisp-query (mrsty (cui) srl tui tui :lrl klrl :order (cui asc))
(find-ucon-cui (ensure-integer cui) :srl srl)))
-
+
(defun find-ucon-word (word &key (srl *current-srl*) (like nil))
"Return list of ucons that match word. Optionally, use SQL's LIKE syntax"
(collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t
(let ((uobjs '()))
(dolist (word (delimited-string-to-list str #\space))
(setq uobjs (append uobjs (funcall obj-lookup-fun word :srl srl))))
- (let ((sorted
+ (let ((sorted
(funcall sort-fun str
(delete-duplicates uobjs :test #'= :key key))))
(if (and (plusp (length sorted))
(multiword-match str (pfstr (first sorted))))
(first sorted)
sorted))))
-
+
(defun find-ucon-multiword (str &key (srl *current-srl*)
(only-exact-if-match t))
(find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str
(only-exact-if-match t))
(find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str
#'sui srl only-exact-if-match))
-
+
(defun sort-score-pfstr-str (str uobjs)
"Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
(sort-score-umlsclass-str uobjs str #'pfstr))
"Sort a list of objects based on scoring to a string"
(let ((scored '()))
(dolist (obj objs)
- (push (list obj (score-multiword-match str (funcall lookup-func obj)))
+ (push (list obj (score-multiword-match str (funcall lookup-func obj)))
scored))
(mapcar #'car (sort scored #'> :key #'cadr))))
(defun find-labr-eui (eui)
(ensure-eui-integer eui)
- (collect-umlisp-query (lrabr (bas abr eui2 bas2) nil eui eui)
+ (collect-umlisp-query (lrabr (bas abr eui2 bas2) nil eui eui)
(make-instance 'labr :eui eui :bas bas :abr abr :bas2 bas2
:eui2 (ensure-integer eui2))))
(defun find-ltrm-eui (eui)
(ensure-eui-integer eui)
- (collect-umlisp-query (lrtrm (bas gen) nil eui eui)
+ (collect-umlisp-query (lrtrm (bas gen) nil eui eui)
(make-instance 'ltrm :eui eui :bas bas :gen gen)))
(defun find-ltyp-eui (eui)
(with-sql-connection (conn)
(ignore-errors (sql-execute "drop table USTATS" conn))
(sql-execute "create table USTATS (NAME varchar(160), COUNT bigint, SRL integer)" conn)
-
+
(dotimes (srl 5)
(insert-ustats-count conn "Concept Count" "MRCONSO" "distinct CUI" "KCUILRL" srl)
(insert-ustats-count conn "Term Count" "MRCONSO" "distinct KCUILUI" "KCUILRL" srl)
(defun find-count-table (conn table srl count-variable srl-control)
(cond
((stringp srl-control)
- (ensure-integer
- (caar (sql-query (format nil "select count(~a) from ~a where ~a <= ~d"
+ (ensure-integer
+ (caar (sql-query (format nil "select count(~a) from ~a where ~a <= ~d"
count-variable table srl-control srl)
conn))))
((null srl-control)
(ensure-integer
- (caar (sql-query (format nil "select count(~a) from ~a"
+ (caar (sql-query (format nil "select count(~a) from ~a"
count-variable table )
conn))))
(t
0)))
(defun insert-ustats (conn name count srl)
- (sql-execute (format nil "insert into USTATS (name,count,srl) values ('~a',~d,~d)"
- name count (if srl srl 3))
+ (sql-execute (format nil "insert into USTATS (name,count,srl) values ('~a',~d,~d)"
+ name count (if srl srl 3))
conn))
(defun find-ustats-all (&key (srl *current-srl*))
(make-instance 'ustats :name name
:hits (ensure-integer count)
:srl (ensure-integer srl)))))
-
+
(defun find-ustats-srl (srl)
(collect-umlisp-query (ustats (name count) nil srl srl :order (name asc))
(make-instance 'ustats :name name :hits (ensure-integer count))))