(defun check-ui (ui start-char len)
(when (and (stringp ui)
- (= (length ui) (1+ len))
- (char-equal start-char (schar ui 0))
- (ignore-errors (parse-integer ui :start 1)))
+ (= (length ui) (1+ len))
+ (char-equal start-char (schar ui 0))
+ (ignore-errors (parse-integer ui :start 1)))
t))
(or (not is-term) is-english)))
(defun print-umlsclass (obj &key (stream *standard-output*)
- (vid :compact-text)
- (file-wrapper nil) (english-only t) (subobjects nil)
- (refvars nil) (link-printer nil))
+ (vid :compact-text)
+ (file-wrapper nil) (english-only t) (subobjects nil)
+ (refvars nil) (link-printer nil))
(view obj :stream stream :vid vid :subobjects subobjects
- :file-wrapper file-wrapper
- :filter (if english-only nil #'english-term-filter)
- :link-printer link-printer
- :refvars refvars))
+ :file-wrapper file-wrapper
+ :filter (if english-only nil #'english-term-filter)
+ :link-printer link-printer
+ :refvars refvars))
(defmacro define-lookup-display (newfuncname lookup-func)
"Defines functions for looking up and displaying objects"
`(defun ,newfuncname (keyval &key (stream *standard-output*) (vid :compact-text)
- (file-wrapper t) (english-only nil) (subobjects nil))
+ (file-wrapper t) (english-only nil) (subobjects nil))
(let ((obj (funcall ,lookup-func keyval)))
(print-umlsclass obj :stream stream :vid vid
- :file-wrapper file-wrapper :english-only english-only
- :subobjects subobjects)
+ :file-wrapper file-wrapper :english-only english-only
+ :subobjects subobjects)
obj)))
(define-lookup-display display-con #'find-ucon-cui)
(defmethod mesh-number ((ustr ustr))
(let ((codes
- (map-and-remove-nils
- (lambda (sat)
- (when (and (string-equal "MSH" (sab sat))
- (string-equal "MN" (atn sat)))
- (atv sat)))
- (s#sat ustr))))
+ (map-and-remove-nils
+ (lambda (sat)
+ (when (and (string-equal "MSH" (sab sat))
+ (string-equal "MN" (atn sat)))
+ (atv sat)))
+ (s#sat ustr))))
(if (= 1 (length codes))
- (car codes)
+ (car codes)
codes)))
(defun ucon-ustrs (ucon)
(let (res)
(dolist (term (s#term ucon) (nreverse res))
(dolist (str (s#str term))
- (push str res)))))
-
+ (push str res)))))
+
(defmethod pfstr ((uterm uterm))
"Return the preferred string for a uterm"
(setq stt (subseq stt 1)))
(loop for c across stt
collect
- (cond
- ((char-equal #\C c)
- "Upper/lower case")
- ((char-equal #\W c)
- "Word order")
- ((char-equal #\S c)
- "Singular")
- ((char-equal #\P c)
- "Plural")
- ((char-equal #\O c)
- "Other"))))
-
-
+ (cond
+ ((char-equal #\C c)
+ "Upper/lower case")
+ ((char-equal #\W c)
+ "Word order")
+ ((char-equal #\S c)
+ "Singular")
+ ((char-equal #\P c)
+ "Plural")
+ ((char-equal #\O c)
+ "Other"))))
+
+
(defun ucon-parents (con &optional sab)
(ucon-ancestors con sab t))
(defun ucon-ancestors (ucon &optional sab single-level)
"Returns a list of ancestor lists for a concept"
(let* ((parent-rels (filter-urels-by-rel (s#rel ucon) "par"))
- (anc nil))
+ (anc nil))
(when sab
- (setq parent-rels (delete-if-not
- (lambda (rel) (string-equal sab (sab rel)))
- parent-rels)))
+ (setq parent-rels (delete-if-not
+ (lambda (rel) (string-equal sab (sab rel)))
+ parent-rels)))
(dolist (rel parent-rels (nreverse anc))
(let ((parent (find-ucon-cui (cui2 rel))))
- (push
- (if single-level
- (list parent)
- (list* parent (car (ucon-ancestors parent (sab rel) nil))))
- anc)))))
+ (push
+ (if single-level
+ (list parent)
+ (list* parent (car (ucon-ancestors parent (sab rel) nil))))
+ anc)))))
(defgeneric cxt-ancestors (obj))
(defmethod cxt-ancestors ((con ucon))
(loop for term in (s#term con)
append (cxt-ancestors term)))
-
+
(defmethod cxt-ancestors ((term uterm))
(loop for str in (s#str term)
append (cxt-ancestors str)))
-
+
(defmethod cxt-ancestors ((str ustr))
"Return the ancestory contexts of a ustr"
(let* ((anc (remove-if-not
- (lambda (cxt) (string-equal "ANC" (cxl cxt)))
- (s#cxt str)))
- (num-contexts (if anc
- (apply #'max (mapcar (lambda (cxt) (cxn cxt)) anc))
- 0))
- (anc-lists '()))
+ (lambda (cxt) (string-equal "ANC" (cxl cxt)))
+ (s#cxt str)))
+ (num-contexts (if anc
+ (apply #'max (mapcar (lambda (cxt) (cxn cxt)) anc))
+ 0))
+ (anc-lists '()))
(dotimes (i num-contexts (nreverse anc-lists))
(let* ((anc-this-cxn (remove-if-not
- (lambda (cxt) (= (1+ i) (cxn cxt))) anc)))
- (push
- (sort anc-this-cxn (lambda (a b) (< (rnk a) (rnk b))))
- anc-lists)))))
+ (lambda (cxt) (= (1+ i) (cxn cxt))) anc)))
+ (push
+ (sort anc-this-cxn (lambda (a b) (< (rnk a) (rnk b))))
+ anc-lists)))))
+
-
#+scl
(dolist (c '(urank udef usat uso ucxt ustr ulo uterm usty urel ucoc uatx ucon uxw uxnw uxns lexterm labr lagr lcmp lmod lnom lprn lprp lspl ltrm ltyp lwd sdef sstr sstre1 sstre2 usrl))
(let ((cl (find-class c)))
(:default-print-slots sab srl)
(:description "Custom Table: Source Restriction Level"))
-
+
(defclass urank (umlsclass)
((rank :value-type fixnum :initarg :rank :reader rank)
(sab :value-type string :initarg :sab :reader sab)
(rcui :value-type fixnum :initarg :rcui :reader rcui :print-formatter fmt-cui)
(vsab :value-type string :initarg :vsab :reader vsab)
(rsab :value-type string :initarg :rsab :reader rsab :hyperlink find-ustr-sab
- :hyperlink-parameters (("subobjects" . "no")))
+ :hyperlink-parameters (("subobjects" . "no")))
(son :value-type string :initarg :son :reader son)
(sf :value-type string :initarg :sf :reader sf)
(sver :value-type string :initarg :sver :reader sver)
(:metaclass hyperobject-class)
(:user-name "Source Abbreviation")
(:default-print-slots vcui rcui vsab rsab son sf sver vstart vend imeta
- rmeta slc scc srl tfr cfr cxty ttyl atnl lat cenc
- curver sabin))
+ rmeta slc scc srl tfr cfr cxty ttyl atnl lat cenc
+ curver sabin))
(defclass uso (umlsclass)
((sab :value-type string :initarg :sab :reader sab :hyperlink find-usab-rsab)
(cxl :value-type string :initarg :cxl :reader cxl)
(cxs :value-type cdata :initarg :cxs :reader cxs)
(cui2 :value-type fixnum :initarg :cui2 :reader cui2 :hyperlink find-ucon-cui
- :print-formatter fmt-cui)
+ :print-formatter fmt-cui)
(hcd :value-type string :initarg :hcd :reader hcd)
(rela :value-type string :initarg :rela :reader rela)
(xc :value-type string :initarg :xc :reader xc))
(defclass ustr (umlsclass)
((sui :value-type fixnum :initarg :sui :reader sui :print-formatter fmt-sui
- :hyperlink find-ustr-sui)
+ :hyperlink find-ustr-sui)
(cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui
- :hyperlink find-ucon-cui)
+ :hyperlink find-ucon-cui)
(lui :value-type fixnum :initarg :lui :reader lui :print-formatter fmt-lui
- :hyperlink find-uterm-lui)
+ :hyperlink find-uterm-lui)
(cuisui :value-type integer :initarg :cuisui :reader cuisui )
(str :value-type cdata :initarg :str :reader str)
(lrl :value-type fixnum :initarg :lrl :reader lrl)
(defclass uterm (umlsclass)
((lui :value-type fixnum :initarg :lui :reader lui :print-formatter fmt-lui
- :hyperlink find-uterm-lui)
+ :hyperlink find-uterm-lui)
(cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui
- :hyperlink find-ucon-cui)
+ :hyperlink find-ucon-cui)
(lat :value-type string :initarg :lat :reader lat)
(ts :value-type string :initarg :ts :reader ts)
(lrl :value-type fixnum :initarg :lrl :reader lrl)
(defclass usty (umlsclass)
((tui :value-type fixnum :initarg :tui :reader tui :print-formatter fmt-tui
- :hyperlink find-ucon-tui
- :hyperlink-parameters (("subobjects" . "no")))
+ :hyperlink find-ucon-tui
+ :hyperlink-parameters (("subobjects" . "no")))
(sty :value-type string :initarg :sty :reader sty))
(:metaclass hyperobject-class)
(:user-name "Semantic Type")
((rel :value-type string :initarg :rel :reader rel :hyperlink find-brel-rel)
(cui1 :value-type fixnum :initarg :cui1 :reader cui1 :print-formatter fmt-cui)
(cui2 :value-type fixnum :initarg :cui2 :reader cui2 :hyperlink find-ucon-sui
- :print-formatter fmt-cui)
+ :print-formatter fmt-cui)
(pfstr2 :value-type cdata :initarg :pfstr2 :reader pfstr2)
(rela :value-type string :initarg :rela :reader rela)
(sab :value-type string :initarg :sab :reader sab :hyperlink find-usab-rsab)
(:metaclass hyperobject-class)
(:user-name "Relationship")
(:default-print-slots rel rela sab sl mg cui2 pfstr2))
-
+
(defclass ucoc (umlsclass)
((cui1 :value-type fixnum :initarg :cui1 :reader cui1 :print-formatter fmt-cui)
(cui2 :value-type fixnum :initarg :cui2 :reader cui2 :print-formatter fmt-cui
- :hyperlink find-ucon-cui)
+ :hyperlink find-ucon-cui)
(pfstr2 :value-type cdata :initarg :pfstr2 :reader pfstr2)
(soc :value-type string :initarg :soc :reader soc)
(cot :value-type string :initarg :cot :reader cot)
(:user-name "Co-occuring Concept")
(:default-print-slots soc cot cof coa cui2 pfstr2))
-
+
(defclass uatx (umlsclass)
((sab :value-type string :initarg :sab :reader sab)
(rel :value-type string :initarg :rel :reader rel)
(defclass ucon (umlsclass)
((cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui
- :hyperlink find-ucon-cui)
+ :hyperlink find-ucon-cui)
(lrl :value-type fixnum :initarg :lrl :reader lrl)
(pfstr :value-type cdata :initarg :pfstr :reader pfstr)
(s#def :reader s#def :subobject (find-udef-cui cui))
(defclass lexterm (umlsclass)
((eui :value-type fixnum :initarg :eui :reader eui :print-formatter fmt-eui
- :hyperlink find-lexterm-eui)
+ :hyperlink find-lexterm-eui)
(wrd :value-type string :initarg :wrd :reader wrd)
(s#abr :reader s#abr :subobject (find-labr-eui eui))
(s#agr :reader s#agr :subobject (find-lagr-eui eui))
(ui3 :value-type integer :initarg :ui3 :reader ui3 :print-formatter fmt-tui))
(:metaclass hyperobject-class)
(:user-name "Fully Inherited Set of Relation (TUIs)"
- "Fully Inherited Set of Relations (TUIs)")
+ "Fully Inherited Set of Relations (TUIs)")
(:default-print-slots ui ui2 ui3))
(defclass sstre2 (umlsclass)
(sty2 :value-type string :initarg :ui3 :reader sty2))
(:metaclass hyperobject-class)
(:user-name "Fully Inherited Set of Relation (strings)"
- "Fully Inherited Set of Relations (strings)")
+ "Fully Inherited Set of Relations (strings)")
(:default-print-slots sty rl sty2))
(defclass ustats (umlsclass)
((name :value-type string :initarg :name :reader name)
(hits :value-type integer :initarg :hits :reader hits
- :user-name "count"
- :print-formatter fmt-comma-integer)
+ :user-name "count"
+ :print-formatter fmt-comma-integer)
(srl :value-type fixnum :initarg :srl :reader srl))
(:metaclass hyperobject-class)
(:default-initargs :name nil :hits nil :srl nil)
(:default-print-slots name hits srl)
(:documentation "Custom Table: UMLS Database statistics."))
-
+
(defclass bsab (umlsclass)
((sab :value-type string :initarg :sab :reader sab
- :hyperlink find-ustr-sab
- :hyperlink-parameters (("subobjects" . "no")))
+ :hyperlink find-ustr-sab
+ :hyperlink-parameters (("subobjects" . "no")))
(name :value-type string :initarg :name :reader name)
(hits :value-type fixnum :initarg :hits :reader hits
- :user-name "count"
- :print-formatter fmt-comma-integer))
+ :user-name "count"
+ :print-formatter fmt-comma-integer))
(:metaclass hyperobject-class)
(:default-initargs :sab nil :name nil :hits nil)
(:user-name "Source of Abbreviation")
(:default-print-slots sab name hits)
(:documentation "Bonus SAB file"))
-
+
(defclass btty (umlsclass)
((tty :value-type string :initarg :tty :reader tty)
(name :value-type string :initarg :name :reader name)
(hits :value-type fixnum :initarg :hits :reader hits
- :user-name "count"
- :print-formatter fmt-comma-integer))
+ :user-name "count"
+ :print-formatter fmt-comma-integer))
(:metaclass hyperobject-class)
(:default-initargs :tty nil :name nil :hits nil)
(:user-name "Bonus TTY")
(:default-print-slots tty name hits)
(:documentation "Bonus TTY file"))
-
+
(defclass brel (umlsclass)
((sab :value-type string :initarg :sab :reader sab)
(sl :value-type string :initarg :sl :reader sl)
(rel :value-type string :initarg :rel :reader rel)
(rela :value-type string :initarg :rela :reader rela)
(hits :value-type fixnum :initarg :hits :reader hits
- :user-name "count"
- :print-formatter fmt-comma-integer))
+ :user-name "count"
+ :print-formatter fmt-comma-integer))
(:metaclass hyperobject-class)
(:default-initargs :sab nil :sl nil :rel nil :rela nil :hits nil)
(:user-name "Bonus REL")
((sab :value-type string :initarg :sab :reader sab)
(atn :value-type string :initarg :atn :reader atn)
(hits :value-type fixnum :initarg :hits :reader hits
- :user-name "count"
- :print-formatter fmt-comma-intger))
+ :user-name "count"
+ :print-formatter fmt-comma-intger))
(:metaclass hyperobject-class)
(:default-initargs :sab nil :atn nil)
(:user-name "Bonus ATN")
(defun tui-disease-or-syndrome ()
(find-tui-word "disease or syndrome"))
-(defun tui-sign-or-symptom ()
+(defun tui-sign-or-symptom ()
(find-tui-word "sign or symptom"))
(defun tui-finding ()
(find-tui-word "finding"))
(defun find-ucon2-tui (ucon tui cui2-func related-con-func)
"Returns a list of related ucons that have specific tui"
- (remove-duplicates
+ (remove-duplicates
(filter
- #'(lambda (c)
- (aif (funcall cui2-func c)
- (let ((ucon2 (find-ucon-cui it)))
- (when (ucon-is-tui? ucon2 tui)
- ucon2)) nil))
+ #'(lambda (c)
+ (aif (funcall cui2-func c)
+ (let ((ucon2 (find-ucon-cui it)))
+ (when (ucon-is-tui? ucon2 tui)
+ ucon2)) nil))
(funcall related-con-func ucon))
:key #'cui))
(defun find-ucon2-coc-tui (ucon tui)
"Return list of ucon's that have co-occuring concepts of semantic type tui"
(find-ucon2-tui ucon tui #'cui2 #'s#coc))
-
+
(defun find-ucon2-rel-tui (ucon tui)
"Return list of ucon's that have related concepts to ucon and semantic type tui"
(find-ucon2-tui ucon tui #'cui2 #'s#rel))
(defclass freq (hyperobject)
((freq :value-type integer :initarg :freq :accessor freq
- :print-formatter fmt-comma-integer))
+ :print-formatter fmt-comma-integer))
(:metaclass hyperobject-class)
(:default-initargs :freq 0)
(:user-name "Frequency class" "Frequency classes")
(let ((usty_freqs '()))
(dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY"))
(let* ((tui (car tuple))
- (freq (ensure-integer
- (caar (mutex-sql-query
- (format nil "select count(*) from MRSTY where TUI=~a" tui)))))
- (usty (find-usty-tui tui)))
- (push (make-instance 'usty_freq :sty (sty usty)
- :tui (tui usty) :freq freq) usty_freqs)))
+ (freq (ensure-integer
+ (caar (mutex-sql-query
+ (format nil "select count(*) from MRSTY where TUI=~a" tui)))))
+ (usty (find-usty-tui tui)))
+ (push (make-instance 'usty_freq :sty (sty usty)
+ :tui (tui usty) :freq freq) usty_freqs)))
(sort usty_freqs #'> :key #'freq)))
(defun find-usrl_freq-all ()
(let ((freqs '()))
(dolist (usrl (find-usrl-all))
- (let ((freq (ensure-integer
- (caar (mutex-sql-query
- (format nil "select count(*) from MRSO where SAB='~a'"
- (sab usrl)))))))
- (push (make-instance 'usrl_freq :sab (sab usrl) :srl (srl usrl)
- :freq freq)
- freqs)))
+ (let ((freq (ensure-integer
+ (caar (mutex-sql-query
+ (format nil "select count(*) from MRSO where SAB='~a'"
+ (sab usrl)))))))
+ (push (make-instance 'usrl_freq :sab (sab usrl) :srl (srl usrl)
+ :freq freq)
+ freqs)))
(sort freqs #'> :key #'freq)))
(defun find-ucon2_freq-coc-tui (ucon tui)
-"Return sorted list of tuples with ucon and freq that have co-occuring concepts of semantic type tui"
- (let ((ucon_freqs '()))
- (dolist (ucoc (s#coc ucon))
- (aif (cui2 ucoc)
- (let ((ucon2 (find-ucon-cui it)))
+"Return sorted list of tuples with ucon and freq that have co-occuring concepts of semantic type tui"
+ (let ((ucon_freqs '()))
+ (dolist (ucoc (s#coc ucon))
+ (aif (cui2 ucoc)
+ (let ((ucon2 (find-ucon-cui it)))
(when (ucon-is-tui? ucon2 tui)
- (push (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2)
- :pfstr (pfstr ucon2) :freq (cof ucoc))
- ucon_freqs)))))
+ (push (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2)
+ :pfstr (pfstr ucon2) :freq (cof ucoc))
+ ucon_freqs)))))
(setq ucon_freqs (delete-duplicates ucon_freqs :key #'cui))
(sort ucon_freqs #'> :key #'freq)))
-
+
(defun find-ucon2-str&sty (str sty lookup-func)
"Call lookup-func for ucon and usty for given str and sty"
(let ((ucon (car (find-ucon-str str)))
- (usty (car (find-usty-word sty))))
+ (usty (car (find-usty-word sty))))
(if (and ucon usty)
- (funcall lookup-func ucon (tui usty))
+ (funcall lookup-func ucon (tui usty))
nil)))
-
+
(defun find-ucon2-coc-str&sty (str sty)
"Find all ucons that are a co-occuring concept for concept named str
and that have semantic type of sty"
(let ((ucon_freqs (make-array (1+ (find-cui-max)) :initial-element nil)))
(dolist (ucon (find-ucon-tui tui)) ;; for all disease-or-syn
(dolist (ucon2 (funcall ucon2-tui-func ucon tui)) ;; for each related disease
- (aif (aref ucon_freqs (cui ucon2))
- (setf (freq it) (1+ (freq it)))
- (setf (aref ucon_freqs (cui ucon2))
- (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2)
- :pfstr (pfstr ucon2) :freq 1)))))
+ (aif (aref ucon_freqs (cui ucon2))
+ (setf (freq it) (1+ (freq it)))
+ (setf (aref ucon_freqs (cui ucon2))
+ (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2)
+ :pfstr (pfstr ucon2) :freq 1)))))
(let ((ucon_freq-list '()))
(dotimes (i (find-cui-max))
- (declare (fixnum i))
- (awhen (aref ucon_freqs i)
- (push it ucon_freq-list)))
+ (declare (fixnum i))
+ (awhen (aref ucon_freqs i)
+ (push it ucon_freq-list)))
(sort ucon_freq-list #'> :key #'freq))))
(defun find-ucon2_freq-rel-tui-all (tui)
#+(or scl)
(dolist (c '(ucon_freq ustr_freq usty_freq usrl_freq))
(let ((cl #+cmu (pcl:find-class c)
- #+scl (find-class c)))
+ #+scl (find-class c)))
#+cmu (pcl:finalize-inheritance cl)
#+scl (clos:finalize-inheritance cl)))
(defun create-table-cmd (file)
"Return sql command to create a table"
- (let ((col-func
- (lambda (c)
- (let ((sqltype (sqltype c)))
- (concatenate 'string
- (col c)
- " "
- (if (or (string-equal sqltype "VARCHAR")
- (string-equal sqltype "CHAR"))
- (format nil "~a (~a)" sqltype (cmax c))
- sqltype))))))
+ (let ((col-func
+ (lambda (c)
+ (let ((sqltype (sqltype c)))
+ (concatenate 'string
+ (col c)
+ " "
+ (if (or (string-equal sqltype "VARCHAR")
+ (string-equal sqltype "CHAR"))
+ (format nil "~a (~a)" sqltype (cmax c))
+ sqltype))))))
(format nil "CREATE TABLE ~a (~{~a~^,~})" (table file)
- (mapcar col-func (ucols file)))))
+ (mapcar col-func (ucols file)))))
(defun create-custom-table-cmd (tablename sql-cmd)
"Return SQL command to create a custom table"
(format nil "CREATE TABLE ~a AS ~a;" tablename sql-cmd))
(defun insert-col-value (col value)
- (if (null (parse-fun col))
+ (if (null (parse-fun col))
value
(format nil "~A" (funcall (parse-fun col) value))))
(defun insert-values-cmd (file values)
- "Return sql insert command for a row of values"
+ "Return sql insert command for a row of values"
(let ((insert-func
- (lambda (col value)
- (concatenate 'string (quote-str col)
- (insert-col-value col value)
- (quote-str col)))))
+ (lambda (col value)
+ (concatenate 'string (quote-str col)
+ (insert-col-value col value)
+ (quote-str col)))))
(format
nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~A)"
(table file)
(fields file)
(concat-separated-strings
- ","
+ ","
(mapcar insert-func (remove-custom-cols (ucols file)) values)
(custom-col-values (custom-ucols-for-file file) values t)))))
(defun custom-col-value (col values doquote)
(let ((custom-value (funcall (custom-value-fun col) values)))
(if custom-value
- (if doquote
- (concatenate 'string (quote-str col)
- (escape-backslashes custom-value)
- (quote-str col))
- (escape-backslashes custom-value))
- "")))
+ (if doquote
+ (concatenate 'string (quote-str col)
+ (escape-backslashes custom-value)
+ (quote-str col))
+ (escape-backslashes custom-value))
+ "")))
(defun custom-col-values (ucols values doquote)
"Returns a list of string column values for SQL inserts for custom columns"
(defun find-custom-col (filename col)
(find-if (lambda (x) (and (string-equal filename (car x))
- (string-equal col (cadr x)))) +custom-cols+))
+ (string-equal col (cadr x)))) +custom-cols+))
(defun custom-colnames-for-filename (filename)
(mapcar #'cadr (find-custom-cols-for-filename filename)))
(defun noneng-lang-index-files ()
(remove-if-not
(lambda (f) (and (> (length (fil f)) 4)
- (string-equal (fil f) "MRXW." :end1 5)
- (not (string-equal (fil f) "MRXW.ENG"))
- (not (string-equal (fil f) "MRXW.NONENG"))))
+ (string-equal (fil f) "MRXW." :end1 5)
+ (not (string-equal (fil f) "MRXW.ENG"))
+ (not (string-equal (fil f) "MRXW.NONENG"))))
*umls-files*))
;;; SQL Command Functions
(defun create-index-cmd (colname tablename length)
"Return sql create index command"
(format nil "CREATE INDEX ~a ON ~a (~a)"
- (concatenate 'string tablename "_" colname "_X")
- tablename
- (case *umls-sql-type*
- (:mysql
- (concatenate 'string colname
- (if (integerp length)
- (format nil " (~d)" length)
- "")))
- ((:postgresql :postgresql-socket)
- ;; FIXME: incorrect syntax
- (if (integerp length)
- (format nil "substr((~A)::text,1,~D)" colname length)
- colname))
- (t
- colname))))
+ (concatenate 'string tablename "_" colname "_X")
+ tablename
+ (case *umls-sql-type*
+ (:mysql
+ (concatenate 'string colname
+ (if (integerp length)
+ (format nil " (~d)" length)
+ "")))
+ ((:postgresql :postgresql-socket)
+ ;; FIXME: incorrect syntax
+ (if (integerp length)
+ (format nil "substr((~A)::text,1,~D)" colname length)
+ colname))
+ (t
+ colname))))
(defun create-all-tables-cmdfile ()
"Return sql commands to create all tables. Not need for automated SQL import"
(defun sql-drop-tables (conn)
"SQL Databases: drop all tables"
(dolist (file *umls-files*)
- (ignore-errors
+ (ignore-errors
(sql-execute (format nil "DROP TABLE ~a" (table file)) conn))))
(defun sql-create-tables (conn)
- "SQL Databases: create all tables"
+ "SQL Databases: create all tables"
(dolist (file *umls-files*)
(sql-execute (create-table-cmd file) conn)))
"SQL Databases: create all custom tables"
(dolist (ct +custom-tables+)
(sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn)))
-
+
(defun sql-insert-values (conn file)
- "SQL Databases: inserts all values for a file"
+ "SQL Databases: inserts all values for a file"
(with-umls-file (line (fil file))
(sql-execute (insert-values-cmd file line) conn)))
(defun sql-insert-all-values (conn)
- "SQL Databases: inserts all values for all files"
+ "SQL Databases: inserts all values for all files"
(dolist (file *umls-files*)
(sql-insert-values conn file)))
(case *umls-sql-type*
(:mysql
(format nil "DROP INDEX ~a ON ~a"
- (concatenate 'string tablename "_" colname "_X")
- tablename))
+ (concatenate 'string tablename "_" colname "_X")
+ tablename))
(t
(format nil "DROP INDEX ~a"
- (concatenate 'string tablename "_" colname "_X")))))
+ (concatenate 'string tablename "_" colname "_X")))))
(defun sql-create-indexes (conn &optional (indexes +index-cols+))
"SQL Databases: create all indexes"
(dolist (idx indexes)
(ignore-errors (sql-execute (drop-index-cmd (car idx) (cadr idx)) conn))
- (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn)))
+ (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn)))
(defun make-usrl (conn)
(if (eql :mysql *umls-sql-type*)
(ignore-errors (sql-execute "drop table USRL" conn)))
(sql-execute "create table USRL (sab varchar(80), srl integer)" conn)
(dolist (tuple (mutex-sql-query
- "select distinct SAB,SRL from MRSO order by SAB asc"))
- (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)"
- (car tuple) (ensure-integer (cadr tuple)))
- conn)))
+ "select distinct SAB,SRL from MRSO order by SAB asc"))
+ (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)"
+ (car tuple) (ensure-integer (cadr tuple)))
+ conn)))
(defun sql-create-special-tables (conn)
(make-usrl conn)
(sql-create-special-tables conn)))
(defun create-umls-db (&key (extension ".trans") (skip-translation nil))
- "SQL Databases: initializes entire database via SQL copy commands.
+ "SQL Databases: initializes entire database via SQL copy commands.
This is much faster that using create-umls-db-insert."
(ensure-ucols+ufiles)
(ensure-preparse)
(unless skip-translation
(translate-all-files extension))
(let ((copy-cmd
- (ecase (umls-sql-type)
- (:mysql #'mysql-copy-cmd)
- (:postgresql #'pg-copy-cmd))))
+ (ecase (umls-sql-type)
+ (:mysql #'mysql-copy-cmd)
+ (:postgresql #'pg-copy-cmd))))
(with-sql-connection (conn)
(clsql:truncate-database :database conn)
(sql-drop-tables conn)
(sql-create-tables conn)
(dolist (file *umls-files*)
- (sql-execute (funcall copy-cmd file extension) conn))
+ (sql-execute (funcall copy-cmd file extension) conn))
(sql-create-indexes conn)
(sql-create-custom-tables conn)
(sql-create-indexes conn +custom-index-cols+)
(defun make-noneng-index-file (extension)
"Make non-english index file"
(translate-files (find-ufile "MRXW.NONENG")
- extension (noneng-lang-index-files)))
+ extension (noneng-lang-index-files)))
(defun translate-files (out-ufile extension input-ufiles)
"Translate a umls file into a format suitable for sql copy cmd"
(let ((output-path (umls-pathname (fil out-ufile) extension)))
(if (probe-file output-path)
- (format t "File ~A already exists: skipping~%" output-path)
+ (format t "File ~A already exists: skipping~%" output-path)
(with-open-file (ostream output-path :direction :output)
- (dolist (input-ufile input-ufiles)
- (with-umls-file (line (fil input-ufile))
- (translate-line out-ufile line ostream)
- (princ #\newline ostream)))))))
+ (dolist (input-ufile input-ufiles)
+ (with-umls-file (line (fil input-ufile))
+ (translate-line out-ufile line ostream)
+ (princ #\newline ostream)))))))
(defun translate-line (file line strm)
"Translate a single line for sql output"
(flet ((col-value (col value)
- (if (eq (datatype col) 'sql-u)
- (let ((ui (parse-ui value "")))
- (if (stringp ui)
- ui
- (write-to-string ui)))
- (escape-backslashes value))))
+ (if (eq (datatype col) 'sql-u)
+ (let ((ui (parse-ui value "")))
+ (if (stringp ui)
+ ui
+ (write-to-string ui)))
+ (escape-backslashes value))))
(print-separated-strings
- strm "|"
+ strm "|"
(mapcar #'col-value (remove-custom-cols (ucols file)) line)
(custom-col-values (custom-ucols-for-file file) line nil))))
(defun pg-copy-cmd (file extension)
- "Return postgresql copy statement for a file"
+ "Return postgresql copy statement for a file"
(format
nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
(table file) (umls-pathname (fil file) extension)))
(defun mysql-copy-cmd (file extension &key local-file)
- "Return mysql copy statement for a file"
+ "Return mysql copy statement for a file"
(format
nil
"LOAD DATA ~AINFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\""
(if local-file "LOCAL " "")
(umls-pathname (fil file) extension) (table file)))
-
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Routines for analyzing cost of fixed size storage
(defun umls-fixed-size-waste ()
"Display storage waste if using all fixed size storage"
(let ((totalwaste 0)
- (totalunavoidable 0)
- (totalavoidable 0)
- (unavoidable '())
- (avoidable '()))
+ (totalunavoidable 0)
+ (totalavoidable 0)
+ (unavoidable '())
+ (avoidable '()))
(dolist (file *umls-files*)
(dolist (col (ucols file))
- (let* ((avwaste (- (cmax col) (av col)))
- (cwaste (* avwaste (rws file))))
- (when (plusp cwaste)
- (if (<= avwaste 6)
- (progn
- (incf totalunavoidable cwaste)
- (push (list (fil file) (col col)
- avwaste cwaste)
- unavoidable))
- (progn
- (incf totalavoidable cwaste)
- (push (list (fil file) (col col)
- avwaste cwaste)
- avoidable)))
- (incf totalwaste cwaste)))))
+ (let* ((avwaste (- (cmax col) (av col)))
+ (cwaste (* avwaste (rws file))))
+ (when (plusp cwaste)
+ (if (<= avwaste 6)
+ (progn
+ (incf totalunavoidable cwaste)
+ (push (list (fil file) (col col)
+ avwaste cwaste)
+ unavoidable))
+ (progn
+ (incf totalavoidable cwaste)
+ (push (list (fil file) (col col)
+ avwaste cwaste)
+ avoidable)))
+ (incf totalwaste cwaste)))))
(values totalwaste totalavoidable totalunavoidable
- (nreverse avoidable) (nreverse unavoidable))))
+ (nreverse avoidable) (nreverse unavoidable))))
(defun display-waste ()
(ensure-ucols+ufiles)
(declare (fixnum max))
(dolist (ucol *umls-cols*)
(when (> (cmax ucol) max)
- (setq max (cmax ucol))))
+ (setq max (cmax ucol))))
max))
(defun max-umls-row ()
(let ((rowsizes '()))
(dolist (file *umls-files*)
(let ((row 0))
- (dolist (ucol (ucols file))
- (incf row (1+ (cmax ucol))))
- (push row rowsizes)))
+ (dolist (ucol (ucols file))
+ (incf row (1+ (cmax ucol))))
+ (push row rowsizes)))
(car (sort rowsizes #'>))))
(make-pathname :directory '(:absolute "data" "umls" "2003AC"))
"Path for base of UMLS data files")
-(defvar *meta-path*
- (merge-pathnames
+(defvar *meta-path*
+ (merge-pathnames
(make-pathname :directory '(:relative "META"))
*umls-path*))
-(defvar *lex-path*
- (merge-pathnames
+(defvar *lex-path*
+ (merge-pathnames
(make-pathname :directory '(:relative "LEX"))
*umls-path*))
-(defvar *net-path*
- (merge-pathnames
+(defvar *net-path*
+ (merge-pathnames
(make-pathname :directory '(:relative "NET"))
*umls-path*))
;;; Structures for parsing UMLS text files
-
-(defparameter *umls-files* nil
+
+(defparameter *umls-files* nil
"List of umls file structures. Used when parsing text files.")
-(defparameter *umls-cols* nil
+(defparameter *umls-cols* nil
"List of meta column structures. Used when parsing text files.")
(fields :initarg :fields :accessor fields)
(ucols :initarg :ucols :accessor ucols))
(:default-initargs :fil nil :table nil :des nil :fmt nil :cls nil :rws nil :bts nil
- :fields nil :ucols nil)
+ :fields nil :ucols nil)
(:documentation "UMLS File"))
(defclass ucol ()
(datatype :initarg :datatype :accessor datatype)
(custom-value-fun :initarg :custom-value-fun :accessor custom-value-fun))
(:default-initargs :col nil :des nil :ref nil :min nil :av nil :max nil :fil nil
- :sqltype nil :dty nil :parse-fun nil :datatype nil
- :custom-value-fun nil)
+ :sqltype nil :dty nil :parse-fun nil :datatype nil
+ :custom-value-fun nil)
(:documentation "UMLS column"))
(format s "~A" (col obj))))
-
+
#:s#so #:s#cxt
#:pfstr #:pfstr2 #:lrl #:def #:ts #:cui1 #:cui2 #:rela #:sl #:mg #:rel
#:soc #:cot #:cof #:coa #:isn #:fr #:un #:sna #:soui #:hcd #:stt #:str
-
+
;; From class-support.lisp
#:ucon-has-tui
#:english-term-p #:remove-non-english-terms #:remove-english-terms
#:ucon-ancestors #:ucon-parents
#:mesh-number #:cxt-ancestors #:ucon-ustrs
#:lat-abbr-info #:stt-abbr-info
-
+
;; From sql.lisp
#:*umls-sql-db*
#:umls-sql-user!
#:with-mutex-sql
#:sql-query
#:sql-execute
-
+
;; From utils.lisp
#:fmt-cui
#:fmt-lui
#:find-ustr-in-ucon
#:*current-srl*
#:parse-cui #:parse-lui #:parse-sui #:parse-tui #:parse-eui
-
+
;; From sql-classes.lisp
-
+
#:find-udef-cui
#:find-usty-cui
#:find-usty-word
#:find-btty-all
#:find-btty-tty
#:find-brel-rel
-
+
;; composite.lisp
#:tui-finding
#:tui-sign-or-symptom
(lui-lrl-hash nil) ;;; LRL by LUI
(cuisui-lrl-hash nil) ;;; LRL by CUISUI
(sab-srl-hash nil)) ;;; SRL by SAB
-
+
(defun make-preparse-hash-table ()
(if pfstr-hash
- (progn
- (clrhash pfstr-hash)
- (clrhash cui-lrl-hash)
- (clrhash lui-lrl-hash)
- (clrhash cuisui-lrl-hash)
- (clrhash sab-srl-hash))
+ (progn
+ (clrhash pfstr-hash)
+ (clrhash cui-lrl-hash)
+ (clrhash lui-lrl-hash)
+ (clrhash cuisui-lrl-hash)
+ (clrhash sab-srl-hash))
(setf
- pfstr-hash (make-hash-table :size 800000)
- cui-lrl-hash (make-hash-table :size 800000)
- lui-lrl-hash (make-hash-table :size 1500000)
- cuisui-lrl-hash (make-hash-table :size 1800000)
- sab-srl-hash (make-hash-table :size 100 :test 'equal))))
-
+ pfstr-hash (make-hash-table :size 800000)
+ cui-lrl-hash (make-hash-table :size 800000)
+ lui-lrl-hash (make-hash-table :size 1500000)
+ cuisui-lrl-hash (make-hash-table :size 1800000)
+ sab-srl-hash (make-hash-table :size 100 :test 'equal))))
+
(defun buffered-ensure-preparse (&optional (force-read nil))
(when (or force-read (not *preparse-hash-init?*))
(make-preparse-hash-table)
(setq *preparse-hash-init?* t))
(with-buffered-umls-file (line "MRCON")
(let ((cui (parse-ui (aref line 0)))
- (lui (parse-ui (aref line 3)))
- (sui (parse-ui (aref line 5)))
- (lrl (parse-integer (aref line 7))))
- (unless (gethash cui pfstr-hash) ;; if haven't stored pfstr for cui
- (if (and (string-equal (aref line 1) "ENG") ; LAT
- (string-equal (aref line 2) "P") ; ts
- (string-equal (aref line 4) "PF")) ; stt
- (setf (gethash cui pfstr-hash) (aref line 6))))
- (set-lrl-hash cui lrl cui-lrl-hash)
- (set-lrl-hash lui lrl lui-lrl-hash)
- (set-lrl-hash (make-cuisui cui sui) lrl cuisui-lrl-hash)))
+ (lui (parse-ui (aref line 3)))
+ (sui (parse-ui (aref line 5)))
+ (lrl (parse-integer (aref line 7))))
+ (unless (gethash cui pfstr-hash) ;; if haven't stored pfstr for cui
+ (if (and (string-equal (aref line 1) "ENG") ; LAT
+ (string-equal (aref line 2) "P") ; ts
+ (string-equal (aref line 4) "PF")) ; stt
+ (setf (gethash cui pfstr-hash) (aref line 6))))
+ (set-lrl-hash cui lrl cui-lrl-hash)
+ (set-lrl-hash lui lrl lui-lrl-hash)
+ (set-lrl-hash (make-cuisui cui sui) lrl cuisui-lrl-hash)))
(with-buffered-umls-file (line "MRSO")
(let ((sab (aref line 3)))
- (unless (gethash sab sab-srl-hash) ;; if haven't stored
- (setf (gethash sab sab-srl-hash) (aref line 6))))))
-
+ (unless (gethash sab sab-srl-hash) ;; if haven't stored
+ (setf (gethash sab sab-srl-hash) (aref line 6))))))
+
(defun ensure-preparse (&optional (force-read nil))
(when (or force-read (not *preparse-hash-init?*))
(make-preparse-hash-table)
(setq *preparse-hash-init?* t))
(with-umls-file (line "MRCON")
(let ((cui (parse-ui (nth 0 line)))
- (lui (parse-ui (nth 3 line)))
- (sui (parse-ui (nth 5 line)))
- (lrl (parse-integer (nth 7 line))))
- (unless (gethash cui pfstr-hash) ;; if haven't stored pfstr for cui
- (if (and (string-equal (nth 1 line) "ENG") ; LAT
- (string-equal (nth 2 line) "P") ; ts
- (string-equal (nth 4 line) "PF")) ; stt
- (setf (gethash cui pfstr-hash) (nth 6 line))))
- (set-lrl-hash cui lrl cui-lrl-hash)
- (set-lrl-hash lui lrl lui-lrl-hash)
- (set-lrl-hash (make-cuisui cui sui) lrl cuisui-lrl-hash)))
+ (lui (parse-ui (nth 3 line)))
+ (sui (parse-ui (nth 5 line)))
+ (lrl (parse-integer (nth 7 line))))
+ (unless (gethash cui pfstr-hash) ;; if haven't stored pfstr for cui
+ (if (and (string-equal (nth 1 line) "ENG") ; LAT
+ (string-equal (nth 2 line) "P") ; ts
+ (string-equal (nth 4 line) "PF")) ; stt
+ (setf (gethash cui pfstr-hash) (nth 6 line))))
+ (set-lrl-hash cui lrl cui-lrl-hash)
+ (set-lrl-hash lui lrl lui-lrl-hash)
+ (set-lrl-hash (make-cuisui cui sui) lrl cuisui-lrl-hash)))
(with-umls-file (line "MRSO")
(let ((sab (nth 3 line)))
- (multiple-value-bind (val found) (gethash sab sab-srl-hash)
- (declare (ignore val))
- (unless found
- (setf (gethash sab sab-srl-hash) (parse-integer (nth 6 line))))))))
-
+ (multiple-value-bind (val found) (gethash sab sab-srl-hash)
+ (declare (ignore val))
+ (unless found
+ (setf (gethash sab sab-srl-hash) (parse-integer (nth 6 line))))))))
+
(defun pfstr-hash (cui)
(gethash cui pfstr-hash))
-
+
(defun cui-lrl (cui)
(gethash cui cui-lrl-hash))
-
+
(defun lui-lrl (lui)
(gethash lui lui-lrl-hash))
-
+
(defun cuisui-lrl (cuisui)
(gethash cuisui cuisui-lrl-hash))
-
+
(defun sab-srl (sab)
(aif (gethash sab sab-srl-hash) it 0))
)) ;; closure
"Set the least restrictive level in hash table"
(multiple-value-bind (hash-lrl found) (gethash key hash)
(if (or (not found) (< lrl hash-lrl))
- (setf (gethash key hash) lrl))))
+ (setf (gethash key hash) lrl))))
;; UMLS file and column structures
;;; SQL datatypes symbols
("UI" sql-u) ("UI2" sql-u) ("UI3" sql-u)
;; New fields for 2002AD
("RCUI" sql-u) ("VCUI" sql-u) ("CFR" sql-i) ("TFR" sql-i)
- )
+ )
"SQL data types for each non-string column")
(defparameter +custom-tables+
(defparameter +custom-cols+
'(("MRCON" "KPFSTR" "TEXT" 1024
- (lambda (x) (pfstr-hash (parse-ui (nth 0 x)))))
+ (lambda (x) (pfstr-hash (parse-ui (nth 0 x)))))
("MRCON" "KCUISUI" "BIGINT" 0
(lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 5 x))))))
("MRCON" "KCUILUI" "BIGINT" 0
("MRCON" "KLUILRL" "INTEGER" 0
(lambda (x) (write-to-string (lui-lrl (parse-ui (nth 3 x))))))
("MRLO" "KLRL" "INTEGER" 0
- (lambda (x) (write-to-string
- (if (zerop (length (nth 4 x)))
- (cui-lrl (parse-ui (nth 0 x)))
- (cuisui-lrl (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 4 x))))))))
+ (lambda (x) (write-to-string
+ (if (zerop (length (nth 4 x)))
+ (cui-lrl (parse-ui (nth 0 x)))
+ (cuisui-lrl (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 4 x))))))))
("MRSTY" "KLRL" "INTEGER" 0
(lambda (x) (write-to-string (cui-lrl (parse-ui (nth 0 x))))))
("MRCOC" "KLRL" "INTEGER" 0
- (lambda (x) (write-to-string
- (max (cui-lrl (parse-ui (nth 0 x)))
- (kmrcl:aif (cui-lrl (parse-ui (nth 1 x))) kmrcl::it 0)))))
+ (lambda (x) (write-to-string
+ (max (cui-lrl (parse-ui (nth 0 x)))
+ (kmrcl:aif (cui-lrl (parse-ui (nth 1 x))) kmrcl::it 0)))))
("MRSAT" "KSRL" "INTEGER" 0
(lambda (x) (write-to-string (sab-srl (nth 5 x)))))
("MRREL" "KSRL" "INTEGER" 0
("MRATX" "KSRL" "INTEGER" 0
(lambda (x) (write-to-string (sab-srl (nth 1 x)))))
("MRXW.ENG" "KLRL" "INTEGER" 0
- (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
- (parse-ui (nth 2 x))
- (parse-ui (nth 4 x)))))))
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
("MRXW.NONENG" "KLRL" "INTEGER" 0
- (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
- (parse-ui (nth 2 x))
- (parse-ui (nth 4 x)))))))
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
("MRXNW.ENG" "KLRL" "INTEGER" 0
- (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
- (parse-ui (nth 2 x))
- (parse-ui (nth 4 x)))))))
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
("MRXNS.ENG" "KLRL" "INTEGER" 0
- (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
- (parse-ui (nth 2 x))
- (parse-ui (nth 4 x)))))))
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
("MRREL" "KPFSTR2" "TEXT" 1024
(lambda (x) (pfstr-hash (parse-ui (nth 2 x)))))
("MRCOC" "KPFSTR2" "TEXT" 1024
(lambda (x) (pfstr-hash (parse-ui (nth 1 x)))))
- ("MRCXT" "KCUISUI" "BIGINT" 0
+ ("MRCXT" "KCUISUI" "BIGINT" 0
(lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
("MRSAT" "KCUILUI" "BIGINT" 0
(lambda (x) (write-to-string (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
("MRXW.NONENG" "CUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 2 x)))))
("MRXW.NONENG" "LUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 3 x)))))
("MRXW.NONENG" "SUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 4 x)))))
- ("MRXW.NONENG" "KCUISUI" "BIGINT" 0
+ ("MRXW.NONENG" "KCUISUI" "BIGINT" 0
(lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x)))))))
"Custom columns to create.(filename, col, sqltype, value-func).")
(defparameter +index-cols+
- '(("CUI" "MRATX") ("CUI1" "MRCOC") ("CUI" "MRCON") ("LUI" "MRCON")
+ '(("CUI" "MRATX") ("CUI1" "MRCOC") ("CUI" "MRCON") ("LUI" "MRCON")
("LRL" "MRCON")
("SUI" "MRCON") ("CUI" "MRCXT") ("CUI" "MRDEF") ("CUI" "MRLO")
("CUI1" "MRREL") ("CUI" "MRSAT") ("LUI" "MRSAT") ("SUI" "MRSAT")
("CUI" "MRSO") ("SAB" "MRSO") ("SRL" "MRSO") ("CUI" "MRSTY")
- ("TUI" "MRSTY") ("CUI" "MRXNS_ENG")
+ ("TUI" "MRSTY") ("CUI" "MRXNS_ENG")
#+ignore ("NSTR" "MRXNS_ENG" 10)
("CUI" "MRXNW_ENG") ("NWD" "MRXNW_ENG") ("WD" "MRXW_ENG")
("KCUISUI" "MRCON") ("KCUILUI" "MRCON") ("KCUILRL" "MRCON")
- ("KLUILRL" "MRCON") ("KCUISUI" "MRCXT")
+ ("KLUILRL" "MRCON") ("KCUISUI" "MRCXT")
("KCUISUI" "MRSO") ("KCUISUI" "MRSAT") ("KCUILUI" "MRSAT")
- ("KCUISUI" "MRXW_ENG") ("KCUISUI" "MRXNW_ENG")
+ ("KCUISUI" "MRXW_ENG") ("KCUISUI" "MRXNW_ENG")
("KCUISUI" "MRXNS_ENG") ("KCUISUI" "MRXW_NONENG")
- ("KSRL" "MRATX") ("KSRL" "MRCXT") ("KSRL" "MRDEF") ("KSRL" "MRRANK")
- ("KSRL" "MRREL") ("KSRL" "MRSAT") ("KLRL" "MRCOC")
+ ("KSRL" "MRATX") ("KSRL" "MRCXT") ("KSRL" "MRDEF") ("KSRL" "MRRANK")
+ ("KSRL" "MRREL") ("KSRL" "MRSAT") ("KLRL" "MRCOC")
("KLRL" "MRLO") ("KLRL" "MRSTY") ("KLRL" "MRXW_ENG") ("KLRL" "MRXNW_ENG")
("KLRL" "MRXNS_ENG") ("KLRL" "MRXW_NONENG")
;; LEX indices
("EUI" "LRABR") ("EUI2" "LRABR") ("EUI" "LRAGR") ("EUI" "LRCMP") ("EUI" "LRMOD")
("EUI" "LRNOM") ("EUI2" "LRNOM") ("EUI" "LRPRN") ("EUI" "LRPRP") ("EUI" "LRSPL")
("EUI" "LRTRM") ("EUI" "LRTYP") ("EUI" "LRWD") ("WRD" "LRWD")
- ("BAS" "LRABR")
+ ("BAS" "LRABR")
;; Semantic NET indices
- ("UI" "SRSTRE1") ("UI2" "SRSTRE1") ("UI3" "SRSTRE1")
+ ("UI" "SRSTRE1") ("UI2" "SRSTRE1") ("UI3" "SRSTRE1")
("STY_RL" "SRDEF") ("RT" "SRDEF") ("STY_RL" "SRSTR") ("STY_RL2" "SRSTR")
("RL" "SRSTR")
("SRL" "MRSAB") ("RSAB" "MRSAB") ("VSAB" "MRSAB") ("RCUI" "MRSAB")
(add-ucols (gen-ucols-generic "SRFLD")))
(defun gen-ucols-meta ()
-"Initialize all umls columns"
+"Initialize all umls columns"
(let ((cols '()))
(with-umls-file (line "MRCOLS")
(destructuring-bind (col des ref min av max fil dty) line
- (push (make-ucol col des ref (parse-integer min) (read-from-string av)
- (parse-integer max) fil dty)
- cols)))
+ (push (make-ucol col des ref (parse-integer min) (read-from-string av)
+ (parse-integer max) fil dty)
+ cols)))
(nreverse cols)))
(defun gen-ucols-custom ()
-"Initialize umls columns for custom columns"
+"Initialize umls columns for custom columns"
(loop for customcol in +custom-cols+
- collect
- (make-ucol (nth 1 customcol) "" 0 0 0 (nth 3 customcol)
- (nth 0 customcol) nil :sqltype (nth 2 customcol)
- :custom-value-fun (nth 4 customcol))))
+ collect
+ (make-ucol (nth 1 customcol) "" 0 0 0 (nth 3 customcol)
+ (nth 0 customcol) nil :sqltype (nth 2 customcol)
+ :custom-value-fun (nth 4 customcol))))
(defun gen-ucols-generic (col-filename)
-"Initialize for generic (LEX/NET) columns"
+"Initialize for generic (LEX/NET) columns"
(let ((cols '()))
(with-umls-file (line col-filename)
(destructuring-bind (nam des ref fil) line
- (setq nam (escape-column-name nam))
- (dolist (file (delimited-string-to-list fil #\,))
- (push
- (make-ucol nam des ref nil nil nil file nil)
- cols))))
+ (setq nam (escape-column-name nam))
+ (dolist (file (delimited-string-to-list fil #\,))
+ (push
+ (make-ucol nam des ref nil nil nil file nil)
+ cols))))
(nreverse cols)))
;; needs to come last
(add-ufiles (gen-ufiles-custom)))
-
+
(defun gen-ufiles-generic (files-filename)
-"Initialize all LEX file structures"
+"Initialize all LEX file structures"
(let ((files '()))
(with-umls-file (line files-filename)
(destructuring-bind (fil des fmt cls rws bts) line
- (push (make-ufile
- fil des (substitute #\_ #\. fil) (parse-integer cls)
- (parse-integer rws) (parse-integer bts)
- (concatenate 'list (umls-field-string-to-list fmt)
- (custom-colnames-for-filename fil)))
- files)))
+ (push (make-ufile
+ fil des (substitute #\_ #\. fil) (parse-integer cls)
+ (parse-integer rws) (parse-integer bts)
+ (concatenate 'list (umls-field-string-to-list fmt)
+ (custom-colnames-for-filename fil)))
+ files)))
(nreverse files)))
(defun gen-ufiles-custom ()
(make-ufile "MRXW.NONENG" "Custom NonEnglish Index" "MRXW_NONENG"
- 5 0 0 (fields (find-ufile "MRXW.ENG"))))
+ 5 0 0 (fields (find-ufile "MRXW.ENG"))))
"Return pathname for a umls filename with an optional extension"
(etypecase filename
(string
- (merge-pathnames
- (make-pathname :name (concatenate 'string filename extension))
+ (merge-pathnames
+ (make-pathname :name (concatenate 'string filename extension))
(case (schar filename 0)
- ((#\M #\m)
- *meta-path*)
- ((#\L #\l)
- *lex-path*)
- ((#\S #\s)
- *net-path*)
- (t
- *umls-path*))))
+ ((#\M #\m)
+ *meta-path*)
+ ((#\L #\l)
+ *lex-path*)
+ ((#\S #\s)
+ *net-path*)
+ (t
+ *umls-path*))))
(pathname
filename)))
"Read a line from a UMLS stream, split into fields"
(let ((line (read-line strm nil eof)))
(if (eq line eof)
- eof
- (delimited-string-to-list line #\| t))))
+ eof
+ (delimited-string-to-list line #\| t))))
;;; Find field lengths for LEX and NET files
(dolist (length-list (ufiles-field-lengths (ufiles-to-measure)))
(destructuring-bind (filename fields-max fields-av) length-list
(let ((file (find-ufile filename)))
- (unless file
- (error "Can't find ~A filename in ufiles" filename))
- (unless (= (length fields-max) (length (fields file)))
- (error
- "Number of file fields ~A not equal to field count in ufile ~S"
- fields-max file))
- (dotimes (i (length (fields file)))
- (declare (fixnum i))
- (let* ((field (nth i (fields file)))
- (col (find-ucol field filename)))
- (unless col
- (error "can't find column ~A" field))
- (setf (cmax col) (aref fields-max i))
- (setf (av col) (aref fields-av i))
- (ensure-ucol-datatype col (datatype-for-colname (col col)))))))))
-
+ (unless file
+ (error "Can't find ~A filename in ufiles" filename))
+ (unless (= (length fields-max) (length (fields file)))
+ (error
+ "Number of file fields ~A not equal to field count in ufile ~S"
+ fields-max file))
+ (dotimes (i (length (fields file)))
+ (declare (fixnum i))
+ (let* ((field (nth i (fields file)))
+ (col (find-ucol field filename)))
+ (unless col
+ (error "can't find column ~A" field))
+ (setf (cmax col) (aref fields-max i))
+ (setf (av col) (aref fields-av i))
+ (ensure-ucol-datatype col (datatype-for-colname (col col)))))))))
+
(defun ufiles-to-measure ()
"Returns a list of ufiles to measure"
(loop for ufile in *umls-files*
- unless (or (char= #\M (schar (fil ufile) 0))
- (char= #\m (schar (fil ufile) 0)))
- collect ufile))
-
-
+ unless (or (char= #\M (schar (fil ufile) 0))
+ (char= #\m (schar (fil ufile) 0)))
+ collect ufile))
+
+
(defun ufiles-field-lengths (ufiles)
"Returns a list of lists of containing (FILE MAX AV)"
(loop for ufile in ufiles collect (file-field-lengths (fil ufile))))
(let (fields-max fields-av num-fields (count-lines 0))
(with-umls-file (line filename)
(unless num-fields
- (setq num-fields (length line))
- (setq fields-max (make-array num-fields :element-type 'fixnum
- :initial-element 0))
- (setq fields-av (make-array num-fields :element-type 'number
- :initial-element 0)))
+ (setq num-fields (length line))
+ (setq fields-max (make-array num-fields :element-type 'fixnum
+ :initial-element 0))
+ (setq fields-av (make-array num-fields :element-type 'number
+ :initial-element 0)))
(dotimes (i num-fields)
- (declare (fixnum i))
- (let ((len (length (nth i line))))
- (incf (aref fields-av i) len)
- (when (> len (aref fields-max i))
- (setf (aref fields-max i) len))))
+ (declare (fixnum i))
+ (let ((len (length (nth i line))))
+ (incf (aref fields-av i) len)
+ (when (> len (aref fields-max i))
+ (setf (aref fields-max i) len))))
(incf count-lines))
(dotimes (i num-fields)
(setf (aref fields-av i) (float (/ (aref fields-av i) count-lines))))
"Returns list of umls-col structure for a column name and a filename"
(dolist (ucol ucols nil)
(when (and (string-equal filename (fil ucol))
- (string-equal colname (col ucol)))
+ (string-equal colname (col ucol)))
(return-from find-ucol-of-colname ucol))))
(defun ensure-col-in-columns (colname filename ucols)
(defun make-ucol-for-column (colname filename ucols)
;; try to find column name without a terminal digit
(let* ((len (length colname))
- (last-digit? (digit-char-p (schar colname (1- len))))
- (base-colname (if last-digit?
- (subseq colname 0 (1- len))
- colname))
- (ucol (when last-digit?
- (find-ucol-of-colname base-colname filename ucols))))
+ (last-digit? (digit-char-p (schar colname (1- len))))
+ (base-colname (if last-digit?
+ (subseq colname 0 (1- len))
+ colname))
+ (ucol (when last-digit?
+ (find-ucol-of-colname base-colname filename ucols))))
(when (and last-digit? (null ucol))
(error "Couldn't find a base column for col ~A in file ~A"
- colname filename))
+ colname filename))
(copy-or-new-ucol colname filename ucol)))
(defun copy-or-new-ucol (colname filename ucol)
nil)
(function
(if (compiled-function-p fun)
- fun
- (compile nil fun)))
+ fun
+ (compile nil fun)))
(list
(compile nil fun))))
(defun make-ucol (col des ref min av max fil dty
- &key (sqltype "VARCHAR") (parse-fun #'add-sql-quotes)
- (quote-str "'") (custom-value-fun))
+ &key (sqltype "VARCHAR") (parse-fun #'add-sql-quotes)
+ (quote-str "'") (custom-value-fun))
(let ((ucol (make-instance
- 'ucol
- :col col :des des :ref ref :min min :av av
- :max (if (eql max 0) 1 max) ;; ensure at least one char wide
- :fil fil
- :dty dty :sqltype sqltype :quote-str quote-str
- :parse-fun (ensure-compiled-fun parse-fun)
- :custom-value-fun (ensure-compiled-fun custom-value-fun))))
+ 'ucol
+ :col col :des des :ref ref :min min :av av
+ :max (if (eql max 0) 1 max) ;; ensure at least one char wide
+ :fil fil
+ :dty dty :sqltype sqltype :quote-str quote-str
+ :parse-fun (ensure-compiled-fun parse-fun)
+ :custom-value-fun (ensure-compiled-fun custom-value-fun))))
(ensure-ucol-datatype ucol (datatype-for-colname col))
ucol))
(ensure-col-in-columns colname filename *umls-cols*))
(defun find-ufile (filename)
- "Returns umls-file structure for a filename"
+ "Returns umls-file structure for a filename"
(find-if #'(lambda (f) (string-equal filename (fil f))) *umls-files*))
(defun find-ucols-for-ufile (ufile)
"Returns list of umls-cols for a file structure"
(loop for colname in (fields ufile)
- collect (find-ucol colname (fil ufile))))
+ collect (find-ucol colname (fil ufile))))
(defun umls-field-string-to-list (fmt)
"Converts a comma delimited list of fields into a list of field names. Will
append a unique number (starting at 2) onto a column name that is repeated in the list"
(let ((col-counts (make-hash-table :test 'equal)))
(loop for colname in (delimited-string-to-list (escape-column-name fmt) #\,)
- collect
- (multiple-value-bind (value found) (gethash colname col-counts)
- (cond
- (found
- (incf (gethash colname col-counts))
- (concatenate 'string colname (write-to-string (1+ value))))
- (t
- (setf (gethash colname col-counts) 1)
- colname))))))
+ collect
+ (multiple-value-bind (value found) (gethash colname col-counts)
+ (cond
+ (found
+ (incf (gethash colname col-counts))
+ (concatenate 'string colname (write-to-string (1+ value))))
+ (t
+ (setf (gethash colname col-counts) 1)
+ colname))))))
(defun make-ufile (fil des table cls rws bts fields)
(let ((ufile (make-instance 'ufile :fil fil :des des :table table :cls cls
- :rws rws :bts bts :fields fields)))
+ :rws rws :bts bts :fields fields)))
(setf (ucols ufile) (find-ucols-for-ufile ufile))
ufile))
(defun datatype-for-colname (colname)
-"Return datatype for column name"
+"Return datatype for column name"
(second (find colname +col-datatypes+ :key #'car :test #'string-equal)))
(defun ensure-ucol-datatype (col datatype)
(setf (datatype col) datatype)
(case datatype
(sql-u (setf (sqltype col) "INTEGER"
- (parse-fun col) #'parse-ui
- (quote-str col) ""))
- (sql-s (setf (sqltype col) "SMALLINT"
- (parse-fun col) #'parse-integer
- (quote-str col) ""))
- (sql-l (setf (sqltype col) "BIGINT"
- (parse-fun col) #'parse-integer
- (quote-str col) ""))
- (sql-i (setf (sqltype col) "INTEGER"
- (parse-fun col) #'parse-integer
- (quote-str col) ""))
- (sql-f (setf (sqltype col) "NUMERIC"
- (parse-fun col) #'read-from-string
- (quote-str col) ""))
- (t ; Default column type, optimized text storage
- (setf (parse-fun col) #'add-sql-quotes
- (quote-str col) "'")
+ (parse-fun col) #'parse-ui
+ (quote-str col) ""))
+ (sql-s (setf (sqltype col) "SMALLINT"
+ (parse-fun col) #'parse-integer
+ (quote-str col) ""))
+ (sql-l (setf (sqltype col) "BIGINT"
+ (parse-fun col) #'parse-integer
+ (quote-str col) ""))
+ (sql-i (setf (sqltype col) "INTEGER"
+ (parse-fun col) #'parse-integer
+ (quote-str col) ""))
+ (sql-f (setf (sqltype col) "NUMERIC"
+ (parse-fun col) #'read-from-string
+ (quote-str col) ""))
+ (t ; Default column type, optimized text storage
+ (setf (parse-fun col) #'add-sql-quotes
+ (quote-str col) "'")
(when (and (cmax col) (av col))
(if (> (cmax col) 255)
- (setf (sqltype col) "TEXT")
- (setf (sqltype col) "VARCHAR"))))))
+ (setf (sqltype col) "TEXT")
+ (setf (sqltype col) "VARCHAR"))))))
(defun escape-column-name (name)
(substitute #\_ #\/ name))
(defmacro with-umls-file ((line filename) &body body)
"Opens a UMLS and processes each parsed line with (body) argument"
(let ((ustream (gensym "STRM-"))
- (eof (gensym "EOF-")))
+ (eof (gensym "EOF-")))
`(let ((,eof (gensym "EOFSYM-")))
(with-open-file
- (,ustream (umls-pathname ,filename) :direction :input)
- (do ((,line (read-umls-line ,ustream ,eof)
- (read-umls-line ,ustream ,eof)))
- ((eq ,line ,eof) t)
- ,@body)))))
+ (,ustream (umls-pathname ,filename) :direction :input)
+ (do ((,line (read-umls-line ,ustream ,eof)
+ (read-umls-line ,ustream ,eof)))
+ ((eq ,line ,eof) t)
+ ,@body)))))
(defmacro with-buffered-umls-file ((line filename) &body body)
"Opens a UMLS and processes each parsed line with (body) argument"
(let ((ustream (gensym "STRM-"))
- (buffer (gensym "BUF-"))
- (eof (gensym "EOF-")))
+ (buffer (gensym "BUF-"))
+ (eof (gensym "EOF-")))
`(let ((,buffer (make-fields-buffer))
- (,eof (gensym "EOFSYM-")))
+ (,eof (gensym "EOFSYM-")))
(with-open-file
- (,ustream (umls-pathname ,filename) :direction :input)
- (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof)
- (read-buffered-fields ,buffer ,ustream #\| ,eof)))
- ((eq ,line ,eof) t)
- ,@body)))))
+ (,ustream (umls-pathname ,filename) :direction :input)
+ (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof)
+ (read-buffered-fields ,buffer ,ustream #\| ,eof)))
+ ((eq ,line ,eof) t)
+ ,@body)))))
(defmacro with-buffered2-umls-file ((line filename) &body body)
"Opens a UMLS and processes each parsed line with (body) argument"
(let ((ustream (gensym "STRM-"))
- (buffer (gensym "BUF-"))
- (eof (gensym "EOF-")))
+ (buffer (gensym "BUF-"))
+ (eof (gensym "EOF-")))
`(let ((,buffer (make-fields-buffer2))
- (,eof (gensym "EOFSYM-")))
+ (,eof (gensym "EOFSYM-")))
(with-open-file
- (,ustream (umls-pathname ,filename)
- :direction :input :if-exists :overwrite)
- (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof)
- (read-buffered-fields ,buffer ,ustream #\| ,eof)))
- ((eq ,line ,eof) t)
- ,@body)))))
+ (,ustream (umls-pathname ,filename)
+ :direction :input :if-exists :overwrite)
+ (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof)
+ (read-buffered-fields ,buffer ,ustream #\| ,eof)))
+ ((eq ,line ,eof) t)
+ ,@body)))))
(setq *current-srl* srl))
(defmacro query-string (table fields &optional srl where-name where-value
- &key (lrl "KCUILRL") single distinct order like)
+ &key (lrl "KCUILRL") single distinct order like)
(let* ((%%fields (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)"
- (if distinct "distinct " "") fields table))
- (%%order (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}"
- order)
- ""))
- (%%lrl (format nil " and ~:@(~A~)<=" lrl))
- (%%where (when where-name
- (format nil " where ~:@(~A~)~A" where-name
- (if like " like " "")))))
+ (if distinct "distinct " "") fields table))
+ (%%order (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}"
+ order)
+ ""))
+ (%%lrl (format nil " and ~:@(~A~)<=" lrl))
+ (%%where (when where-name
+ (format nil " where ~:@(~A~)~A" where-name
+ (if like " like " "")))))
`(concatenate
'string
,%%fields
,@(when %%where (list %%where))
,@(when %%where
- `((typecase ,where-value
- (fixnum
- (concatenate 'string "='" (prefixed-fixnum-string ,where-value #\0 10) "'"))
- (number
- (concatenate 'string "='" (write-to-string ,where-value) "'"))
- (null
- " is null")
- (t
- (format nil ,(if like "'%~A%'" "='~A'") ,where-value)))))
+ `((typecase ,where-value
+ (fixnum
+ (concatenate 'string "='" (prefixed-fixnum-string ,where-value #\0 10) "'"))
+ (number
+ (concatenate 'string "='" (write-to-string ,where-value) "'"))
+ (null
+ " is null")
+ (t
+ (format nil ,(if like "'%~A%'" "='~A'") ,where-value)))))
(if ,srl (concatenate 'string ,%%lrl (write-to-string ,srl)) "")
,@(when %%order (list %%order))
,@(when single (list " limit 1")))))
(defun query-string-eval (table fields &optional srl where-name where-value
- &key (lrl "KCUILRL") single distinct order like)
+ &key (lrl "KCUILRL") single distinct order like)
(concatenate
'string
- (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)"
- (if distinct "distinct " "") fields table)
+ (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)"
+ (if distinct "distinct " "") fields table)
(if where-name (format nil " where ~:@(~A~)" where-name) "")
(if where-name
(format nil
- (typecase where-value
- (number "=~D")
- (null " is null")
- (t
- (if like " like '%~A%""='~A'")))
- where-value)
+ (typecase where-value
+ (number "=~D")
+ (null " is null")
+ (t
+ (if like " like '%~A%""='~A'")))
+ where-value)
"")
(if srl (format nil " and ~:@(~A~)<=~D" lrl srl) "")
(if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}" order) "")
(defmacro umlisp-query (table fields srl where-name where-value
- &key (lrl "KCUILRL") single distinct order like
- (query-cmd 'mutex-sql-query))
+ &key (lrl "KCUILRL") single distinct order like
+ (query-cmd 'mutex-sql-query))
"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
- &key (lrl "KCUILRL") single distinct order like)
+ &key (lrl "KCUILRL") single distinct order like)
"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
(defmacro collect-umlisp-query ((table fields srl where-name where-value
- &key (lrl "KCUILRL") distinct single
- order like (query-cmd 'mutex-sql-query))
- &body body)
+ &key (lrl "KCUILRL") distinct single
+ 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
- :lrl ,lrl :single ,single
- :distinct ,distinct :order ,order
- :like ,like
- :query-cmd ,query-cmd))))
- ,@(unless where-name `((declare (ignore ,value))))
- (when tuple
- (destructuring-bind ,fields tuple
- ,@body)))
- `(let ((,value ,where-value))
- ,@(unless where-name `((declare (ignore ,value))))
- (let ((,r '()))
- (dolist (tuple (umlisp-query ,table ,fields ,srl ,where-name ,value
- :lrl ,lrl :single ,single :distinct ,distinct
- :order ,order :like ,like))
- (push (destructuring-bind ,fields tuple ,@body) ,r))
- (nreverse ,r))
- #+ignore
- (loop for tuple in
- (umlisp-query ,table ,fields ,srl ,where-name ,value
- :lrl ,lrl :single ,single :distinct ,distinct
- :order ,order :like ,like)
- collect (destructuring-bind ,fields tuple ,@body))))))
+ `(let* ((,value ,where-value)
+ (tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single
+ :distinct ,distinct :order ,order
+ :like ,like
+ :query-cmd ,query-cmd))))
+ ,@(unless where-name `((declare (ignore ,value))))
+ (when tuple
+ (destructuring-bind ,fields tuple
+ ,@body)))
+ `(let ((,value ,where-value))
+ ,@(unless where-name `((declare (ignore ,value))))
+ (let ((,r '()))
+ (dolist (tuple (umlisp-query ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :like ,like))
+ (push (destructuring-bind ,fields tuple ,@body) ,r))
+ (nreverse ,r))
+ #+ignore
+ (loop for tuple in
+ (umlisp-query ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :like ,like)
+ collect (destructuring-bind ,fields tuple ,@body))))))
(defmacro collect-umlisp-query-eval ((table fields srl where-name where-value
- &key (lrl "KCUILRL") distinct single
- order like)
- &body body)
+ &key (lrl "KCUILRL") distinct single
+ order like)
+ &body body)
(let ((value (gensym))
- (r (gensym))
- (eval-fields (cadr fields)))
+ (r (gensym))
+ (eval-fields (cadr fields)))
(if single
- `(let* ((,value ,where-value)
- (tuple (car (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
- :lrl ,lrl :single ,single
- :distinct ,distinct :order ,order
- :like ,like))))
- (when tuple
- (destructuring-bind ,eval-fields tuple
- ,@body)))
- `(let ((,value ,where-value)
- (,r '()))
- (dolist (tuple (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
- :lrl ,lrl :single ,single :distinct ,distinct
- :order ,order :like ,like))
- (push (destructuring-bind ,eval-fields tuple ,@body) ,r))
- (nreverse ,r)
- #+ignore
- (loop for tuple in
- (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
- :lrl ,lrl :single ,single :distinct ,distinct
- :order ,order :like ,like)
- collect (destructuring-bind ,eval-fields tuple ,@body))))))
+ `(let* ((,value ,where-value)
+ (tuple (car (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single
+ :distinct ,distinct :order ,order
+ :like ,like))))
+ (when tuple
+ (destructuring-bind ,eval-fields tuple
+ ,@body)))
+ `(let ((,value ,where-value)
+ (,r '()))
+ (dolist (tuple (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :like ,like))
+ (push (destructuring-bind ,eval-fields tuple ,@body) ,r))
+ (nreverse ,r)
+ #+ignore
+ (loop for tuple in
+ (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :like ,like)
+ collect (destructuring-bind ,eval-fields tuple ,@body))))))
;;;
;;; Read from SQL database
(ensure-cui-integer cui)
(collect-umlisp-query (mrcon (kpfstr kcuilrl) srl cui cui :single t)
(make-instance 'ucon :cui cui :pfstr kpfstr
- :lrl (ensure-integer kcuilrl))))
+ :lrl (ensure-integer kcuilrl))))
(defun find-ucon-cui-sans-pfstr (cui &key (srl *current-srl*))
"Find ucon for a cui"
(ensure-cui-integer cui)
(collect-umlisp-query (mrcon (kcuilrl) srl cui cui :single t)
(make-instance 'ucon :cui cui :lrl (ensure-integer kcuilrl)
- :pfstr nil)))
+ :pfstr nil)))
(defun find-pfstr-cui (cui &key (srl *current-srl*))
"Find preferred string for a cui"
"Find list of ucon for lui"
(ensure-lui-integer lui)
(collect-umlisp-query (mrcon (cui kpfstr kcuilrl) srl lui lui
- :distinct t)
+ :distinct t)
(make-instance 'ucon :cui (ensure-integer cui) :pfstr kpfstr
- :lrl (ensure-integer kcuilrl))))
+ :lrl (ensure-integer kcuilrl))))
(defun find-ucon-sui (sui &key (srl *current-srl*))
"Find list of ucon for sui"
(ensure-sui-integer sui)
(collect-umlisp-query (mrcon (cui kpfstr kcuilrl) srl sui sui :distinct t)
(make-instance 'ucon :cui (ensure-integer cui) :pfstr kpfstr
- :lrl (ensure-integer kcuilrl))))
+ :lrl (ensure-integer kcuilrl))))
(defun find-ucon-cuisui (cui sui &key (srl *current-srl*))
"Find ucon for cui/sui"
(ensure-sui-integer sui)
(when (and cui sui)
(collect-umlisp-query (mrcon (kpfstr kcuilrl) srl kcuisui
- (make-cuisui cui sui))
+ (make-cuisui cui sui))
(make-instance 'ucon :cui cui
- :pfstr kpfstr
- :lrl (ensure-integer kcuilrl)))))
+ :pfstr kpfstr
+ :lrl (ensure-integer kcuilrl)))))
(defun find-ucon-str (str &key (srl *current-srl*))
"Find ucon that are exact match for str"
(collect-umlisp-query (mrcon (cui kpfstr kcuilrl) srl str str :distinct t)
(make-instance 'ucon :cui (ensure-integer cui) :pfstr kpfstr
- :lrl (ensure-integer kcuilrl))))
+ :lrl (ensure-integer kcuilrl))))
(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
- (make-instance 'ucon :cui (ensure-integer cui)
- :pfstr pfstr
- :lrl (ensure-integer cuilrl))))
+ (destructuring-bind (cui pfstr cuilrl) tuple
+ (make-instance 'ucon :cui (ensure-integer cui)
+ :pfstr pfstr
+ :lrl (ensure-integer cuilrl))))
(query-string mrcon (cui kpfstr kcuilrl) srl nil nil
- :order (cui asc) :distinct t)
+ :order (cui asc) :distinct t)
:database db)))
(defun find-ucon-all2 (&key (srl *current-srl*))
"Return list of all ucon's"
(collect-umlisp-query (mrcon (cui kpfstr kcuilrl) srl nil nil :order (cui asc)
- :distinct t)
+ :distinct t)
(make-instance 'ucon :cui (ensure-integer cui)
- :pfstr kpfstr
- :lrl (ensure-integer kcuilrl))))
+ :pfstr kpfstr
+ :lrl (ensure-integer kcuilrl))))
(defun find-cui-ucon-all (&key (srl *current-srl*))
"Return list of CUIs for all ucons"
(collect-umlisp-query (mrcon (cui) srl nil nil :order (cui asc)
- :distinct t)
- cui))
+ :distinct t)
+ cui))
(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
- (funcall fn
- (make-instance 'ucon :cui (ensure-integer cui)
- :pfstr pfstr
- :lrl (ensure-integer cuilrl)))))
+ (destructuring-bind (cui pfstr cuilrl) tuple
+ (funcall fn
+ (make-instance 'ucon :cui (ensure-integer cui)
+ :pfstr pfstr
+ :lrl (ensure-integer cuilrl)))))
(query-string mrcon (cui kpfstr kcuilrl) srl nil nil :order (cui asc)
- :distinct t)
+ :distinct t)
:database db)))
(defun find-usty-word (word &key (srl *current-srl*))
"Return a list of usty that match word"
(collect-umlisp-query (mrsty (tui sty) srl sty word :lrl klrl :like t
- :distinct t)
+ :distinct t)
(make-instance 'usty :tui (ensure-integer tui) :sty sty)))
(defun find-urel-cui (cui &key (srl *current-srl*))
"Return a list of urel for cui"
(ensure-cui-integer cui)
(collect-umlisp-query (mrrel (rel cui2 rela sab sl mg kpfstr2) srl cui1
- cui :lrl "KSRL")
+ cui :lrl "KSRL")
(make-instance 'urel :cui1 cui :rel rel
- :cui2 (ensure-integer cui2) :rela rela :sab sab :sl sl
- :mg mg :pfstr2 kpfstr2)))
+ :cui2 (ensure-integer cui2) :rela rela :sab sab :sl sl
+ :mg mg :pfstr2 kpfstr2)))
(defun find-cui2-urel-cui (cui &key (srl *current-srl*))
"Return a list of urel for cui"
(ensure-cui-integer cui)
(collect-umlisp-query (mrrel (cui2) srl cui1
- cui :lrl "KSRL")
- cui2))
+ cui :lrl "KSRL")
+ cui2))
(defun find-urel-cui2 (cui2 &key (srl *current-srl*))
"Return a list of urel for cui2"
(ensure-cui-integer cui2)
(collect-umlisp-query (mrrel (rel cui1 rela sab sl mg kpfstr2) srl cui2
- cui2 :lrl "KSRL")
+ cui2 :lrl "KSRL")
(make-instance 'urel :cui2 cui2 :rel rel
- :cui1 (ensure-integer cui1) :rela rela :sab sab :sl sl
- :mg mg :pfstr2 kpfstr2)))
+ :cui1 (ensure-integer cui1) :rela rela :sab sab :sl sl
+ :mg mg :pfstr2 kpfstr2)))
(defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*))
(ensure-cui-integer cui2)
(loop for cui in (remove-duplicates
- (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl)))
- collect (find-ucon-cui cui :srl srl)))
+ (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl)))
+ collect (find-ucon-cui cui :srl srl)))
(defun find-ucoc-cui (cui &key (srl *current-srl*))
"Return a list of ucoc for cui"
(ensure-cui-integer cui)
(collect-umlisp-query (mrcoc (cui2 soc cot cof coa kpfstr2) srl cui1
- cui :lrl klrl :order (cof asc))
+ cui :lrl klrl :order (cof asc))
(setq cui2 (ensure-integer cui2))
(when (eql 0 cui2) (setq cui2 nil))
(make-instance 'ucoc :cui1 cui :cui2 (ensure-integer cui2)
- :soc soc :cot cot :cof (ensure-integer cof) :coa coa
- :pfstr2 kpfstr2)))
+ :soc soc :cot cot :cof (ensure-integer cof) :coa coa
+ :pfstr2 kpfstr2)))
(defun find-ucoc-cui2 (cui2 &key (srl *current-srl*))
"Return a list of ucoc for cui2"
(ensure-cui-integer cui2)
(collect-umlisp-query (mrcoc (cui1 soc cot cof coa kpfstr2) srl cui2
- cui2 :lrl klrl :order (cof asc))
+ cui2 :lrl klrl :order (cof asc))
(when (zerop cui2) (setq cui2 nil))
(make-instance 'ucoc :cui1 (ensure-integer cui1) :cui2 cui2
- :soc soc :cot cot :cof (ensure-integer cof) :coa coa
- :pfstr2 kpfstr2)))
+ :soc soc :cot cot :cof (ensure-integer cof) :coa coa
+ :pfstr2 kpfstr2)))
(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)))))
"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")
+ :lrl "KLRL")
(make-instance 'ulo :isn isn :fr (ensure-integer fr) :un un
- :sui (ensure-integer sui) :sna sna :soui soui)))
+ :sui (ensure-integer sui) :sna sna :soui soui)))
(defun find-uatx-cui (cui &key (srl *current-srl*))
"Return a list of uatx for cui"
"Return a list of uterm for cui"
(ensure-cui-integer cui)
(collect-umlisp-query (mrcon (lui lat ts kluilrl) srl cui cui
- :lrl kluilrl :distinct t)
+ :lrl kluilrl :distinct t)
(make-instance 'uterm :lui (ensure-integer lui) :cui cui
- :lat lat :ts ts :lrl (ensure-integer kluilrl))))
+ :lat lat :ts ts :lrl (ensure-integer kluilrl))))
(defun find-uterm-lui (lui &key (srl *current-srl*))
"Return a list of uterm for lui"
(ensure-lui-integer lui)
- (collect-umlisp-query (mrcon (cui lat ts kluilrl) srl lui lui
- :lrl kluilrl :distinct t)
+ (collect-umlisp-query (mrcon (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))))
+ :lat lat :ts ts :lrl (ensure-integer kluilrl))))
(defun find-uterm-cuilui (cui lui &key (srl *current-srl*))
"Return single uterm for cui/lui"
(ensure-cui-integer cui)
(ensure-lui-integer lui)
(collect-umlisp-query (mrcon (lat ts kluilrl) srl kcuilui
- (make-cuilui cui lui)
- :lrl kluilrl :single t)
+ (make-cuilui cui lui)
+ :lrl kluilrl :single t)
(make-instance 'uterm :cui cui :lui lui :lat lat :ts ts
- :lrl (ensure-integer kluilrl))))
+ :lrl (ensure-integer kluilrl))))
(defun find-ustr-cuilui (cui lui &key (srl *current-srl*))
"Return a list of ustr for cui/lui"
(ensure-cui-integer cui)
(ensure-lui-integer lui)
(collect-umlisp-query (mrcon (sui stt str lrl) srl kcuilui
- (make-cuilui cui lui) :lrl lrl)
+ (make-cuilui cui lui) :lrl lrl)
(make-instance 'ustr :sui (ensure-integer sui) :cui cui :lui lui
- :cuisui (make-cuisui cui sui) :stt stt :str str
- :lrl (ensure-integer lrl))))
+ :cuisui (make-cuisui cui sui) :stt stt :str str
+ :lrl (ensure-integer lrl))))
(defun find-ustr-cuisui (cui sui &key (srl *current-srl*))
"Return the single ustr for cuisui"
(ensure-cui-integer cui)
(ensure-sui-integer sui)
(collect-umlisp-query (mrcon (lui stt str lrl) srl kcuisui
- (make-cuisui cui sui) :lrl lrl :single t)
+ (make-cuisui cui sui) :lrl lrl :single t)
(make-instance 'ustr :sui sui :cui cui :cuisui (make-cuisui cui sui)
- :lui (ensure-integer lui) :stt stt :str str
- :lrl (ensure-integer lrl))))
+ :lui (ensure-integer lui) :stt stt :str str
+ :lrl (ensure-integer lrl))))
(defun find-ustr-sui (sui &key (srl *current-srl*))
"Return the list of ustr for sui"
(ensure-sui-integer sui)
(collect-umlisp-query (mrcon (cui lui stt str lrl) srl sui sui
- :lrl lrl)
+ :lrl lrl)
(make-instance 'ustr :sui sui :cui cui :stt stt :str str
- :cuisui (make-cuisui (ensure-integer cui) sui)
- :lui (ensure-integer lui) :lrl (ensure-integer lrl))))
-
+ :cuisui (make-cuisui (ensure-integer cui) sui)
+ :lui (ensure-integer lui) :lrl (ensure-integer lrl))))
+
(defun find-ustr-sab (sab &key (srl *current-srl*))
"Return the list of ustr for sab"
(collect-umlisp-query (mrso (kcuisui) srl sab sab :lrl srl)
(let ((cuisui (ensure-integer kcuisui)))
- (apply #'find-ustr-cuisui
- (append
- (multiple-value-list (decompose-cuisui cuisui))
- (list :srl srl))))))
+ (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 lrl pfstr) tuple
- (make-instance 'ustr :cui (ensure-integer cui)
- :lui (ensure-integer lui) :sui (ensure-integer sui)
- :stt stt :str pfstr
- :cuisui (make-cuisui (ensure-integer cui)
- (ensure-integer sui))
- :lrl (ensure-integer lrl))))
+ (destructuring-bind (cui lui sui stt lrl pfstr) tuple
+ (make-instance 'ustr :cui (ensure-integer cui)
+ :lui (ensure-integer lui) :sui (ensure-integer sui)
+ :stt stt :str pfstr
+ :cuisui (make-cuisui (ensure-integer cui)
+ (ensure-integer sui))
+ :lrl (ensure-integer lrl))))
(query-string mrcon (cui lui sui stt lrl kpfstr) srl nil nil :lrl lrl
- :distinct t
- :order (sui asc))
+ :distinct t
+ :order (sui asc))
:database db)))
(defun find-string-sui (sui &key (srl *current-srl*))
(ensure-sui-integer sui)
(ensure-cui-integer cui)
(collect-umlisp-query (mrso (sab code srl tty) srl kcuisui
- (make-cuisui cui sui) :lrl srl)
+ (make-cuisui cui sui) :lrl srl)
(make-instance 'uso :sab sab :code code :srl srl :tty tty)))
(defun find-ucxt-cuisui (cui sui &key (srl *current-srl*))
(ensure-cui-integer cui)
(ensure-sui-integer sui)
(collect-umlisp-query (mrcxt (sab code cxn cxl rnk cxs cui2 hcd rela xc)
- srl kcuisui (make-cuisui cui sui) :lrl ksrl)
+ srl kcuisui (make-cuisui cui sui) :lrl ksrl)
(make-instance 'ucxt :sab sab :code code
- :cxn (ensure-integer cxn) :cxl cxl :cxs cxs :hcd hcd
- :rela rela :xc xc :rnk (ensure-integer rnk)
- :cui2 (ensure-integer cui2))))
+ :cxn (ensure-integer cxn) :cxl cxl :cxs cxs :hcd hcd
+ :rela rela :xc xc :rnk (ensure-integer rnk)
+ :cui2 (ensure-integer cui2))))
(defun find-usat-ui (cui &optional (lui nil) (sui nil) &key (srl *current-srl*))
(ensure-cui-integer cui)
(let ((ls "select CODE,ATN,SAB,ATV from MRSAT where "))
(cond
(sui (string-append ls "KCUISUI='"
- (integer-string (make-cuisui cui sui) 14)
- "'"))
+ (integer-string (make-cuisui cui sui) 14)
+ "'"))
(lui (string-append ls "KCUILUI='"
- (integer-string (make-cuilui cui lui) 14)
- "' and sui='0'"))
+ (integer-string (make-cuilui cui lui) 14)
+ "' and sui='0'"))
(t (string-append ls "cui='" (prefixed-fixnum-string cui nil 7)
- "' and lui='0' and sui='0'")))
+ "' 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
- (destructuring-bind (code atn sab atv) tuple
- (make-instance 'usat :code code :atn atn :sab sab :atv atv)))))
+ (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)))))
(defun find-usty-tui (tui)
"Find usty for tui"
(defun find-usab-all ()
"Find usab for a key"
(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) nil nil nil)
- (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)
- :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
- :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
- :curver curver :sabin sabin)))
+ rmeta slc scc srl tfr cfr cxty ttyl atnl lat
+ cenc curver sabin) nil nil nil)
+ (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)
+ :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
+ :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
+ :curver curver :sabin sabin)))
(defun find-usab-by-key (key-name key)
"Find usab for a key"
(collect-umlisp-query-eval ('mrsab '(vcui rcui vsab rsab son sf sver vstart
- vend imeta rmeta slc scc srl tfr cfr cxty
- ttyl atnl lat cenc curver sabin)
- nil key-name key :single t)
- (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)
- :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
- :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
- :curver curver :sabin sabin)))
+ vend imeta rmeta slc scc srl tfr cfr cxty
+ ttyl atnl lat cenc curver sabin)
+ nil key-name key :single t)
+ (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)
+ :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
+ :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
+ :curver curver :sabin sabin)))
(defun find-usab-rsab (rsab)
"Find usab for rsab"
(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
- :lrl 'klrl :order '(cui asc))
+ :lrl 'klrl :order '(cui asc))
(find-ucon-cui cui :srl srl)))
(defun find-ucon-normalized-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 ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t
- :lrl 'klrl :order '(cui asc))
+ :lrl 'klrl :order '(cui asc))
(find-ucon-cui cui :srl srl)))
(defun find-cui-normalized-word (word &key (srl *current-srl*) (like nil))
"Return list of cui that match word, optionally use SQL's LIKE syntax"
(collect-umlisp-query-eval ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t
- :lrl 'klrl :order '(cui asc))
- cui))
+ :lrl 'klrl :order '(cui asc))
+ cui))
(defun find-lui-normalized-word (word &key (srl *current-srl*) (like nil))
"Return list of cui that match word, optionally use SQL's LIKE syntax"
(collect-umlisp-query-eval ('mrxnw_eng '(lui) srl 'nwd word :like like :distinct t
- :lrl 'klrl :order '(cui asc))
- lui))
+ :lrl 'klrl :order '(cui asc))
+ lui))
(defun find-sui-normalized-word (word &key (srl *current-srl*) (like nil))
"Return list of cui that match word, optionally use SQL's LIKE syntax"
(collect-umlisp-query-eval ('mrxnw_eng '(sui) srl 'nwd word :like like :distinct t
- :lrl 'klrl :order '(cui asc))
- sui))
+ :lrl 'klrl :order '(cui asc))
+ sui))
(defun find-ustr-word (word &key (srl *current-srl*))
"Return list of ustrs that match word"
(collect-umlisp-query (mrxw_eng (cui sui) srl wd word :lrl klrl
- :order (cui asc sui asc))
+ :order (cui asc sui asc))
(find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
(defun find-ustr-normalized-word (word &key (srl *current-srl*))
"Return list of ustrs that match word"
(collect-umlisp-query (mrxnw_eng (cui sui) srl nwd word :lrl klrl
- :order (cui asc sui asc))
+ :order (cui asc sui asc))
(find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
(defun find-uterm-word (word &key (srl *current-srl*))
"Return list of uterms that match word"
(collect-umlisp-query (mrxw_eng (cui lui) srl wd word :lrl klrl
- :order (cui asc lui asc))
+ :order (cui asc lui asc))
(find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl)))
(defun find-uterm-normalized-word (word &key (srl *current-srl*))
"Return list of uterms that match word"
(collect-umlisp-query (mrxnw_eng (cui lui) srl nwd word :lrl klrl
- :order (cui asc lui asc))
+ :order (cui asc lui asc))
(find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl)))
(defun find-ucon-noneng-word (word &key (srl *current-srl*) (like nil))
"Return list of ucons that match non-english word"
(collect-umlisp-query-eval ('mrxw_noneng '(cui) srl 'wd word :like like
- :distinct t :lrl 'klrl :order '(cui asc))
+ :distinct t :lrl 'klrl :order '(cui asc))
(find-ucon-cui cui :srl srl)))
(defun find-ustr-noneng-word (word &key (srl *current-srl*))
"Return list of ustrs that match non-english word"
(collect-umlisp-query (mrxw_noneng (cui sui) srl wd word :lrl klrl
- :order (cui asc sui asc))
+ :order (cui asc sui asc))
(find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
;; Special tables
;;; Multiword lookup and score functions
(defun find-uobj-multiword (str obj-lookup-fun sort-fun key srl
- only-exact-if-match)
+ only-exact-if-match)
(let ((uobjs '()))
(dolist (word (delimited-string-to-list str #\space))
(setq uobjs (append uobjs (funcall obj-lookup-fun word :srl srl))))
- (let ((sorted
- (funcall sort-fun str
- (delete-duplicates uobjs :test #'= :key key))))
+ (let ((sorted
+ (funcall sort-fun str
+ (delete-duplicates uobjs :test #'= :key key))))
(if (and (plusp (length sorted))
- only-exact-if-match
- (multiword-match str (pfstr (first sorted))))
- (first sorted)
- sorted))))
-
+ only-exact-if-match
+ (multiword-match str (pfstr (first sorted))))
+ (first sorted)
+ sorted))))
+
(defun find-ucon-multiword (str &key (srl *current-srl*)
- (only-exact-if-match t))
+ (only-exact-if-match t))
(find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str
- #'cui srl only-exact-if-match))
+ #'cui srl only-exact-if-match))
(defun find-uterm-multiword (str &key (srl *current-srl*)
- (only-exact-if-match t))
+ (only-exact-if-match t))
(find-uobj-multiword str #'find-uterm-word #'sort-score-pfstr-str
- #'lui srl only-exact-if-match))
+ #'lui srl only-exact-if-match))
(defun find-ustr-multiword (str &key (srl *current-srl*)
- (only-exact-if-match t))
+ (only-exact-if-match t))
(find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str
- #'sui srl only-exact-if-match))
-
+ #'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-lexterm-word (wrd)
(collect-umlisp-query (lrwd (eui) nil wrd wrd)
(make-instance 'lexterm :eui (ensure-integer eui)
- :wrd (copy-seq wrd))))
+ :wrd (copy-seq wrd))))
;; LEX SQL Read functions
(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))))
+ :eui2 (ensure-integer eui2))))
(defun find-labr-bas (bas)
(collect-umlisp-query (labr (eui abr eui2 bas2) nil bas bas)
(make-instance 'labr :eui (ensure-integer eui) :abr abr :bas2 bas2
- :bas (copy-seq bas) :eui2 (ensure-integer eui2))))
+ :bas (copy-seq bas) :eui2 (ensure-integer eui2))))
(defun find-lagr-eui (eui)
(ensure-eui-integer eui)
(collect-umlisp-query (lragr (str sca agr cit bas) nil eui eui)
(make-instance 'lagr :eui eui :str str :sca sca :agr agr
- :cit cit :bas bas)))
+ :cit cit :bas bas)))
(defun find-lcmp-eui (eui)
(ensure-eui-integer eui)
(ensure-eui-integer eui)
(collect-umlisp-query (lrnom (bas sca eui2 bas2 sca2) nil eui eui)
(make-instance 'lnom :eui eui :bas bas :sca sca :bas2 bas2 :sca2 sca2
- :eui2 (ensure-integer eui2))))
+ :eui2 (ensure-integer eui2))))
(defun find-lprn-eui (eui)
(ensure-eui-integer eui)
(collect-umlisp-query (lrprn (bas num gnd cas pos qnt fea) nil eui eui)
(make-instance 'lprn :eui eui :bas bas :num num :gnd gnd
- :cas cas :pos pos :qnt qnt :fea fea)))
+ :cas cas :pos pos :qnt qnt :fea fea)))
(defun find-lprp-eui (eui)
(ensure-eui-integer eui)
(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)
(defun find-lwd-wrd (wrd)
(make-instance 'lwd :wrd wrd
- :euilist (collect-umlisp-query (lrwd (eui) nil wrd wrd)
- (ensure-integer eui))))
+ :euilist (collect-umlisp-query (lrwd (eui) nil wrd wrd)
+ (ensure-integer eui))))
;;; Semantic Network SQL access functions
(defun find-sdef-ui (ui)
(collect-umlisp-query (srdef (rt sty_rl stn_rtn def ex un rh abr rin)
- nil ui ui :single t)
+ nil ui ui :single t)
(make-instance 'sdef :rt rt :ui ui :styrl sty_rl :stnrtn stn_rtn
- :def def :ex ex :un un :rh rh :abr abr :rin rin)))
+ :def def :ex ex :un un :rh rh :abr abr :rin rin)))
(defun find-sstre1-ui (ui)
(collect-umlisp-query (srstre1 (ui2 ui3) nil ui ui)
(make-instance 'sstre1 :ui ui :ui2 (ensure-integer ui2)
- :ui3 (ensure-integer ui3))))
+ :ui3 (ensure-integer ui3))))
(defun find-sstre1-ui2 (ui2)
(collect-umlisp-query (srstre1 (ui ui3) nil ui2 ui2)
(make-instance 'sstre1 :ui (ensure-integer ui) :ui2 ui2
- :ui3 (ensure-integer ui3))))
+ :ui3 (ensure-integer ui3))))
(defun find-sstr-rl (rl)
(collect-umlisp-query (srstre (sty_rl sty_rl2 ls) nil rl rl)
(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 4)
(insert-ustats-count conn "Concept Count" "MRCON" "distinct CUI" "KCUILRL" srl)
(insert-ustats-count conn "Term Count" "MRCON" "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"
- count-variable table srl-control srl)
- conn))))
+ (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"
- count-variable table )
- conn))))
+ (caar (sql-query (format nil "select count(~a) from ~a"
+ count-variable table )
+ conn))))
(t
(error "Unknown srl-control")
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))
- conn))
+ (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*))
(if srl
(collect-umlisp-query (ustats (name count srl) nil srl srl
- :order (name asc))
- (make-instance 'ustats :name name
- :hits (ensure-integer count)
- :srl (ensure-integer srl)))
+ :order (name asc))
+ (make-instance 'ustats :name name
+ :hits (ensure-integer count)
+ :srl (ensure-integer srl)))
(collect-umlisp-query (ustats (name count srl) nil nil nil
- :order (name asc))
- (make-instance 'ustats :name name
- :hits (ensure-integer count)
- :srl (ensure-integer srl)))))
-
+ :order (name asc))
+ (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))))
+ (make-instance 'ustats :name name :hits (ensure-integer count))))
(defun find-brel-rel (rel)
(collect-umlisp-query (bonus_rel (sab sl rel rela count) nil rel rel)
(make-instance 'brel :sab sab :sl sl :rel rel :rela rela
- :hits (ensure-integer count))))
+ :hits (ensure-integer count))))
(defun sql-connect ()
"Connect to UMLS database, automatically used pooled connections"
(clsql:connect (list *umls-sql-host* (lookup-db-name *umls-sql-db*)
- *umls-sql-user* *umls-sql-passwd*)
- :database-type *umls-sql-type* :pool t))
+ *umls-sql-user* *umls-sql-passwd*)
+ :database-type *umls-sql-type* :pool t))
(defun sql-disconnect (conn)
"Disconnect from UMLS database, but put connection back into pool"
(defmacro with-sql-connection ((conn) &body body)
`(let ((,conn (sql-connect)))
(unwind-protect
- (progn ,@body)
+ (progn ,@body)
(when ,conn (clsql:disconnect :database ,conn)))))
(defun sql (stmt conn)
(defmacro with-mutex-sql ((conn) &body body)
`(let ((,conn (sql-connect)))
(unwind-protect
- (progn ,@body)
+ (progn ,@body)
(when ,conn (sql-disconnect ,conn)))))
(defun mutex-sql-execute (cmd)
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: basic.lisp
+;;;; Purpose: Basic tests for UMLisp
+;;;; Author: Kevin M. Rosenberg
+;;;; Date Started: May 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2002 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.
+;;;; *************************************************************************
+
+(in-package #:umlisp-tests)
+
+(deftest qs.1 (umlisp::query-string mrcon (cui lui))
+ "select CUI,LUI from MRCON")
+
+(deftest qs.1e (umlisp::query-string-eval 'mrcon '(cui lui))
+ "select CUI,LUI from MRCON")
+
+(deftest qs.2 (umlisp::query-string mrcon (cui lui) 0)
+ "select CUI,LUI from MRCON and KCUILRL<=0")
+
+(deftest qs.2e (umlisp::query-string-eval 'mrcon '(cui lui) 0)
+ "select CUI,LUI from MRCON and KCUILRL<=0")
+
+(deftest qs.3 (umlisp::query-string mrcon (cui lui) nil cui 5)
+ "select CUI,LUI from MRCON where CUI=5")
+
+(deftest qs.3e (umlisp::query-string-eval 'mrcon '(cui lui) nil 'cui 5)
+ "select CUI,LUI from MRCON where CUI=5")
+
+(deftest qs.4 (umlisp::query-string mrcon (cui lui) nil kpfstr "Abc")
+ "select CUI,LUI from MRCON where KPFSTR='Abc'")
+
+(deftest qs.4e (umlisp::query-string-eval 'mrcon '(cui lui) nil 'kpfstr "Abc")
+ "select CUI,LUI from MRCON where KPFSTR='Abc'")
+
+(deftest qs.5 (umlisp::query-string mrcon (cui lui) 2 cui 5 :single t)
+ "select CUI,LUI from MRCON where CUI=5 and KCUILRL<=2 limit 1")
+
+(deftest qs.5e (umlisp::query-string-eval 'mrcon '(cui lui) 2 'cui 5 :single t)
+ "select CUI,LUI from MRCON where CUI=5 and KCUILRL<=2 limit 1")
+
+(deftest qs.6 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl :single t)
+ "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 limit 1")
+
+(deftest qs.6e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl :single t)
+ "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 limit 1")
+
+(deftest qs.7 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl :order (cui asc))
+ "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc")
+
+(deftest qs.7e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl :order '(cui asc))
+ "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc")
+
+(deftest qs.8 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl
+ :order (cui asc def desc))
+ "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc,DEF desc")
+
+(deftest qs.8e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl
+ :order '(cui asc def desc))
+ "select SAB,DEF from MRDEF where CUI=39 and KSRL<=2 order by CUI asc,DEF desc")
+
+(deftest ui.1 (umlisp::parse-cui "C0002341") 2341)
+(deftest ui.2 (umlisp::parse-lui "L0002341") 2341)
+(deftest ui.3 (umlisp::parse-sui "S0000000") 0)
+(deftest ui.4 (umlisp::parse-tui "T123") 123)
+(deftest ui.5 (fmt-cui 2341) "C0002341")
+(deftest ui.6 (fmt-lui 2341) "L0002341")
+(deftest ui.7 (fmt-sui 2341) "S0002341")
+(deftest ui.8 (fmt-tui 231) "T231")
+(deftest ui.9 (fmt-tui 231) "T231")
+(deftest ui.10 (fmt-eui 231) "E0000231")
+(deftest ui.11 (umlisp::make-cuisui 5 11) 50000011)
+(deftest ui.12 (umlisp::decompose-cuisui 50000011) 5 11)
+(deftest ui.13 (umlisp::parse-eui "E00002311") 2311)
+(deftest ui.14 (umlisp::parse-lui "1234") 1234)
+(deftest ui.15 (umlisp::parse-lui 1234) 1234)
+
+(defun f2 (&key (srl *current-srl*))
+ "Return list of all ucon's"
+ (umlisp::with-umlisp-query ('mrcon (cui kpfstr kcuilrl) srl nil nil)
+ (make-instance 'ucon :cui (ensure-integer cui) :pfstr kpfstr
+ :lrl (ensure-integer kcuilrl))))
+
+(defun f1 (&key (srl *current-srl*))
+ "Return list of all ucon's"
+ (umlisp::with-sql-connection (db)
+ (clsql:map-query
+ 'list
+ #'(lambda (cui pfstr cuilrl)
+ (make-instance 'ucon :cui (ensure-integer cui)
+ :pfstr pfstr
+ :lrl (ensure-integer cuilrl)))
+ (umlisp::query-string 'mrcon '(cui kpfstr kcuilrl) srl nil nil)
+ :database db)))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: parse.lisp
+;;;; Purpose: Parsing tests for UMLisp
+;;;; Author: Kevin M. Rosenberg
+;;;; Date Started: May 2003
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2002 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.
+;;;; *************************************************************************
+
+(in-package #:umlisp-tests)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (if (probe-file (umlisp::umls-pathname "MRFILES"))
+ (pushnew :umls-files cl:*features*)
+ (format t "~&Skipping tests based on UMLS distribution~%")))
+
+(import '(umlisp::*umls-files* umlisp::*umls-cols*))
+
+#+umls-files
+(progn
+ (umlisp::ensure-ucols+ufiles)
+ (deftest uparse.1 (length *umls-files*) 52)
+ (deftest uparse.2 (length *umls-cols*) 327)
+ (deftest uparse.3
+ (sort (mapcar #'u::col (umlisp::ucols (umlisp::find-ufile "MRCON")))
+ #'string<)
+ ("CUI" "KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFSTR" "LAT" "LRL" "LUI" "STR"
+ "STT" "SUI" "TS"))
+ (deftest uparse.4
+ (sort (umlisp::fields (umlisp::find-ufile "MRCON"))
+ #'string<)
+ ("CUI" "KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFSTR" "LAT" "LRL" "LUI" "STR"
+ "STT" "SUI" "TS"))
+ (deftest uparse.5
+ (sort
+ (umlisp::custom-colnames-for-filename "MRCON")
+ #'string<)
+ ("KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFSTR"))
+ (deftest uparse.6
+ (compiled-function-p
+ (umlisp::custom-value-fun
+ (umlisp::find-ucol "KCUISUI" "MRCON")))
+ t)
+ ) ;; umls-files
+
+#+umls-files
+(setq cl:*features* (delete :umls-files cl:*features*))
+
;;;; UMLisp users are granted the rights to distribute and use this software
;;;; as governed by the terms of the GNU General Public License.
;;;; *************************************************************************
-
+
(in-package #:umlisp-orf)
(declaim (inline make-cuisui make-cuilui parse-ui parse-cui))
(defun parse-ui (s &optional (nullvalue 0))
"Return integer value for a UMLS unique identifier."
(declare (simple-string s)
- (optimize (speed 3) (safety 0)))
+ (optimize (speed 3) (safety 0)))
(if (< (length s) 2)
nullvalue
(nth-value 0 (parse-integer s :start 1))))
(declare (optimize (speed 3) (safety 0)))
(if (stringp cui)
(let ((ch (schar cui 0)))
- (if (char-equal ch #\C)
- (parse-ui cui)
- (nth-value 0 (parse-integer cui))))
+ (if (char-equal ch #\C)
+ (parse-ui cui)
+ (nth-value 0 (parse-integer cui))))
cui))
-
+
(defun parse-lui (lui)
(declare (optimize (speed 3) (safety 0)))
(if (stringp lui)
(let ((ch (schar lui 0)))
- (if (char-equal ch #\L)
- (parse-ui lui)
- (nth-value 0 (parse-integer lui))))
+ (if (char-equal ch #\L)
+ (parse-ui lui)
+ (nth-value 0 (parse-integer lui))))
lui))
-
+
(defun parse-sui (sui)
(declare (optimize (speed 3) (safety 0)))
(if (stringp sui)
(let ((ch (schar sui 0)))
- (if (char-equal ch #\S)
- (parse-ui sui)
- (nth-value 0 (parse-integer sui))))
+ (if (char-equal ch #\S)
+ (parse-ui sui)
+ (nth-value 0 (parse-integer sui))))
sui))
-
+
(defun parse-tui (tui)
(declare (optimize (speed 3) (safety 0)))
(if (stringp tui)
(let ((ch (schar tui 0)))
- (if (char-equal ch #\T)
- (parse-ui tui)
- (nth-value 0 (parse-integer tui))))
+ (if (char-equal ch #\T)
+ (parse-ui tui)
+ (nth-value 0 (parse-integer tui))))
tui))
(defun parse-eui (eui)
(declare (optimize (speed 3) (safety 0)))
(if (stringp eui)
(let ((ch (schar eui 0)))
- (if (char-equal ch #\E)
- (parse-ui eui)
- (nth-value 0 (parse-integer eui))))
+ (if (char-equal ch #\E)
+ (parse-ui eui)
+ (nth-value 0 (parse-integer eui))))
eui))
-
+
(defconstant +cuisui-scale+ 10000000)
(declaim (type fixnum +cuisui-scale+))
(defun make-cuisui (cui sui)
(declare (fixnum cui sui)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 0) (space 0)))
(+ (* +cuisui-scale+ cui) sui))
(defun make-cuilui (cui lui)
(declare (fixnum cui lui)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 0) (space 0)))
(+ (* +cuisui-scale+ cui) lui))
(defun decompose-cuisui (cuisui)
(dolist (uterm (s#term ucon))
(dolist (ustr (s#str uterm))
(when (string-equal sui (sui ustr))
- (return-from find-ustr-in-ucon ustr)))))
+ (return-from find-ustr-in-ucon ustr)))))
(defun check-ui (ui start-char len)
(when (and (stringp ui)
- (= (length ui) (1+ len))
- (char-equal start-char (schar ui 0))
- (ignore-errors (parse-integer ui :start 1)))
+ (= (length ui) (1+ len))
+ (char-equal start-char (schar ui 0))
+ (ignore-errors (parse-integer ui :start 1)))
t))
(or (not is-term) is-english)))
(defun print-umlsclass (obj &key (stream *standard-output*)
- (vid :compact-text)
- (file-wrapper nil) (english-only t) (subobjects nil)
- (refvars nil) (link-printer nil))
+ (vid :compact-text)
+ (file-wrapper nil) (english-only t) (subobjects nil)
+ (refvars nil) (link-printer nil))
(view obj :stream stream :vid vid :subobjects subobjects
- :file-wrapper file-wrapper
- :filter (if english-only nil #'english-term-filter)
- :link-printer link-printer
- :refvars refvars))
+ :file-wrapper file-wrapper
+ :filter (if english-only nil #'english-term-filter)
+ :link-printer link-printer
+ :refvars refvars))
(defmacro define-lookup-display (newfuncname lookup-func)
"Defines functions for looking up and displaying objects"
`(defun ,newfuncname (keyval &key (stream *standard-output*) (vid :compact-text)
- (file-wrapper t) (english-only nil) (subobjects nil))
+ (file-wrapper t) (english-only nil) (subobjects nil))
(let ((obj (funcall ,lookup-func keyval)))
(print-umlsclass obj :stream stream :vid vid
- :file-wrapper file-wrapper :english-only english-only
- :subobjects subobjects)
+ :file-wrapper file-wrapper :english-only english-only
+ :subobjects subobjects)
obj)))
(define-lookup-display display-con #'find-ucon-cui)
(defmethod mesh-number ((ustr ustr))
(let ((codes
- (map-and-remove-nils
- (lambda (sat)
- (when (and (string-equal "MSH" (sab sat))
- (string-equal "MN" (atn sat)))
- (atv sat)))
- (s#sat ustr))))
+ (map-and-remove-nils
+ (lambda (sat)
+ (when (and (string-equal "MSH" (sab sat))
+ (string-equal "MN" (atn sat)))
+ (atv sat)))
+ (s#sat ustr))))
(if (= 1 (length codes))
- (car codes)
+ (car codes)
codes)))
(defun ucon-ustrs (ucon)
(let (res)
(dolist (term (s#term ucon) (nreverse res))
(dolist (str (s#str term))
- (push str res)))))
+ (push str res)))))
(defmethod pfstr ((uterm uterm))
(setq stt (subseq stt 1)))
(loop for c across stt
collect
- (cond
- ((char-equal #\C c)
- "Upper/lower case")
- ((char-equal #\W c)
- "Word order")
- ((char-equal #\S c)
- "Singular")
- ((char-equal #\P c)
- "Plural")
- ((char-equal #\O c)
- "Other"))))
+ (cond
+ ((char-equal #\C c)
+ "Upper/lower case")
+ ((char-equal #\W c)
+ "Word order")
+ ((char-equal #\S c)
+ "Singular")
+ ((char-equal #\P c)
+ "Plural")
+ ((char-equal #\O c)
+ "Other"))))
(defun uso-unique-codes (usos)
(let ((sab-codes (make-hash-table :test 'equal)))
(rcui :value-type fixnum :initarg :rcui :reader rcui :print-formatter fmt-cui)
(vsab :value-type string :initarg :vsab :reader vsab)
(rsab :value-type string :initarg :rsab :reader rsab :hyperlink find-ustr-sab
- :hyperlink-parameters (("subobjects" . "no")))
+ :hyperlink-parameters (("subobjects" . "no")))
(son :value-type string :initarg :son :reader son)
(sf :value-type string :initarg :sf :reader sf)
(sver :value-type string :initarg :sver :reader sver)
(:metaclass hyperobject-class)
(:user-name "Source Abbreviation")
(:default-print-slots 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))
+ rmeta slc scc srl tfr cfr cxty ttyl atnl lat cenc
+ curver sabin ssn scit))
(defclass uhier (umlsclass)
((cui :value-type fixnum :initarg :cui :reader cui :hyperlink find-ucon-cui
- :print-formatter fmt-cui)
+ :print-formatter fmt-cui)
(aui :value-type fixnum :initarg :aui :reader aui :hyperlink find-ucon-aui
- :print-formatter fmt-aui)
+ :print-formatter fmt-aui)
(cxn :value-type fixnum :initarg :cxn :reader cxn)
(paui :value-type fixnum :initarg :paui :reader paui
- :print-formatter fmt-aui)
+ :print-formatter fmt-aui)
(sab :value-type string :initarg :sab :reader sab :hyperlink find-usab-rsab)
(rela :value-type string :initarg :rela :reader rela)
(ptr :value-type string :initarg :ptr :reader ptr)
(defclass ustr (umlsclass)
((sui :value-type fixnum :initarg :sui :reader sui :print-formatter fmt-sui
- :hyperlink find-ustr-sui)
+ :hyperlink find-ustr-sui)
(cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui
- :hyperlink find-ucon-cui)
+ :hyperlink find-ucon-cui)
(lui :value-type fixnum :initarg :lui :reader lui :print-formatter fmt-lui
- :hyperlink find-uterm-lui)
+ :hyperlink find-uterm-lui)
(cuisui :value-type integer :initarg :cuisui :reader cuisui )
(str :value-type cdata :initarg :str :reader str)
(lrl :value-type fixnum :initarg :lrl :reader lrl)
((aui :value-type fixnum :initarg :aui :reader aui :print-formatter fmt-aui
:hyperlink find-ucon-aui)
(cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui
- :hyperlink find-ucon-cui)
+ :hyperlink find-ucon-cui)
(sui :value-type fixnum :initarg :sui :reader sui :print-formatter fmt-sui
- :hyperlink find-ucon-sui)
+ :hyperlink find-ucon-sui)
(saui :value-type string :initarg :saui :reader saui)
(sdui :value-type string :initarg :sdui :reader sdui)
(scui :value-type string :initarg :scui :reader scui)
(defclass uterm (umlsclass)
((lui :value-type fixnum :initarg :lui :reader lui :print-formatter fmt-lui
- :hyperlink find-uterm-lui)
+ :hyperlink find-uterm-lui)
(cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui
- :hyperlink find-ucon-cui)
+ :hyperlink find-ucon-cui)
(lat :value-type string :initarg :lat :reader lat)
(ts :value-type string :initarg :ts :reader ts)
(lrl :value-type fixnum :initarg :lrl :reader lrl)
(defclass usty (umlsclass)
((tui :value-type fixnum :initarg :tui :reader tui :print-formatter fmt-tui
- :hyperlink find-ucon-tui
- :hyperlink-parameters (("subobjects" . "no")))
+ :hyperlink find-ucon-tui
+ :hyperlink-parameters (("subobjects" . "no")))
(sty :value-type string :initarg :sty :reader sty))
(:metaclass hyperobject-class)
(:user-name "Semantic Type")
(aui1 :value-type fixnum :initarg :aui1 :reader aui1 :print-formatter fmt-aui)
(stype1 :value-type string :initarg :stype1 :reader stype1)
(cui2 :value-type fixnum :initarg :cui2 :reader cui2 :hyperlink find-ucon-sui
- :print-formatter fmt-cui)
+ :print-formatter fmt-cui)
(aui2 :value-type fixnum :initarg :aui2 :reader aui2 :hyperlink find-ucon-aui
- :print-formatter fmt-aui)
+ :print-formatter fmt-aui)
(pfstr2 :value-type cdata :initarg :pfstr2 :reader pfstr2)
(stype2 :value-type string :initarg :stype2 :reader stype2)
(rela :value-type string :initarg :rela :reader rela)
((cui1 :value-type fixnum :initarg :cui1 :reader cui1 :print-formatter fmt-cui)
(aui1 :value-type fixnum :initarg :aui1 :reader aui1 :print-formatter fmt-aui)
(cui2 :value-type fixnum :initarg :cui2 :reader cui2 :print-formatter fmt-cui
- :hyperlink find-ucon-cui)
+ :hyperlink find-ucon-cui)
(aui2 :value-type fixnum :initarg :aui2 :reader aui2 :print-formatter fmt-aui
- :hyperlink find-ucon-aui)
+ :hyperlink find-ucon-aui)
(pfstr2 :value-type cdata :initarg :pfstr2 :reader pfstr2)
(sab :value-type string :initarg :sab :reader sab)
(cot :value-type string :initarg :cot :reader cot)
(defclass ucon (umlsclass)
((cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui
- :hyperlink find-ucon-cui)
+ :hyperlink find-ucon-cui)
(lrl :value-type fixnum :initarg :lrl :reader lrl
:compute-cached-value (find-lrl-cui cui))
(pfstr :value-type cdata :initarg :pfstr :reader pfstr
(defclass uconso (umlsclass)
((cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui
- :hyperlink find-ucon-cui)
+ :hyperlink find-ucon-cui)
(pfstr :value-type cdata :initarg :pfstr :reader pfstr
:compute-cached-value (find-pfstr-cui cui))
(lat :value-type string :initarg :lat :reader lat)
(:metaclass hyperobject-class)
(:user-name "Mapping")
(:default-print-slots mapsetcui mapsetsab mapsubsetid maprank fromid fromsid fromexpr fromtype
- fromrule fromres rel rela toid tosid toexpr totype torule tores maprule
- maptype mapatn mapatv))
+ fromrule fromres rel rela toid tosid toexpr totype torule tores maprule
+ maptype mapatn mapatv))
(defclass usmap (umlsclass)
((mapsetcui :value-type fixnum :initarg :mapsetcui :reader mapsetcui)
(defclass lexterm (umlsclass)
((eui :value-type fixnum :initarg :eui :reader eui :print-formatter fmt-eui
- :hyperlink find-lexterm-eui)
+ :hyperlink find-lexterm-eui)
(wrd :value-type string :initarg :wrd :reader wrd)
(s#abr :reader s#abr :subobject (find-labr-eui eui))
(s#agr :reader s#agr :subobject (find-lagr-eui eui))
(ui3 :value-type integer :initarg :ui3 :reader ui3 :print-formatter fmt-tui))
(:metaclass hyperobject-class)
(:user-name "Fully Inherited Set of Relation (TUIs)"
- "Fully Inherited Set of Relations (TUIs)")
+ "Fully Inherited Set of Relations (TUIs)")
(:default-print-slots ui ui2 ui3))
(defclass sstre2 (umlsclass)
(sty2 :value-type string :initarg :ui3 :reader sty2))
(:metaclass hyperobject-class)
(:user-name "Fully Inherited Set of Relation (strings)"
- "Fully Inherited Set of Relations (strings)")
+ "Fully Inherited Set of Relations (strings)")
(:default-print-slots sty rl sty2))
(defclass ustats (umlsclass)
((name :value-type string :initarg :name :reader name)
(hits :value-type integer :initarg :hits :reader hits
- :user-name "count"
- :print-formatter fmt-comma-integer)
+ :user-name "count"
+ :print-formatter fmt-comma-integer)
(srl :value-type fixnum :initarg :srl :reader srl))
(:metaclass hyperobject-class)
(:default-initargs :name nil :hits nil :srl nil)
(defun tui-disease-or-syndrome ()
(find-tui-word "disease or syndrome"))
-(defun tui-sign-or-symptom ()
+(defun tui-sign-or-symptom ()
(find-tui-word "sign or symptom"))
(defun tui-finding ()
(find-tui-word "finding"))
(defun find-ucon2-tui (ucon tui cui2-func related-con-func)
"Returns a list of related ucons that have specific tui"
- (remove-duplicates
+ (remove-duplicates
(filter
- #'(lambda (c)
- (aif (funcall cui2-func c)
- (let ((ucon2 (find-ucon-cui it)))
- (when (ucon-is-tui? ucon2 tui)
- ucon2)) nil))
+ #'(lambda (c)
+ (aif (funcall cui2-func c)
+ (let ((ucon2 (find-ucon-cui it)))
+ (when (ucon-is-tui? ucon2 tui)
+ ucon2)) nil))
(funcall related-con-func ucon))
:key #'cui))
(defun find-ucon2-coc-tui (ucon tui)
"Return list of ucon's that have co-occuring concepts of semantic type tui"
(find-ucon2-tui ucon tui #'cui2 #'s#coc))
-
+
(defun find-ucon2-rel-tui (ucon tui)
"Return list of ucon's that have related concepts to ucon and semantic type tui"
(find-ucon2-tui ucon tui #'cui2 #'s#rel))
(defclass freq (hyperobject)
((freq :value-type integer :initarg :freq :accessor freq
- :print-formatter fmt-comma-integer))
+ :print-formatter fmt-comma-integer))
(:metaclass hyperobject-class)
(:default-initargs :freq 0)
(:user-name "Frequency class" "Frequency classes")
(let ((usty_freqs '()))
(dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY"))
(let* ((tui (car tuple))
- (freq (ensure-integer
- (caar (mutex-sql-query
- (format nil "select count(*) from MRSTY where TUI=~a" tui)))))
- (usty (find-usty-tui tui)))
- (push (make-instance 'usty_freq :sty (sty usty)
- :tui (tui usty) :freq freq) usty_freqs)))
+ (freq (ensure-integer
+ (caar (mutex-sql-query
+ (format nil "select count(*) from MRSTY where TUI=~a" tui)))))
+ (usty (find-usty-tui tui)))
+ (push (make-instance 'usty_freq :sty (sty usty)
+ :tui (tui usty) :freq freq) usty_freqs)))
(sort usty_freqs #'> :key #'freq)))
(defun find-usrl_freq-all ()
(let ((freqs '()))
(dolist (usrl (find-usrl-all))
- (let ((freq (ensure-integer
- (caar (mutex-sql-query
- (format nil "select count(*) from MRSO where SAB='~a'"
- (sab usrl)))))))
- (push (make-instance 'usrl_freq :sab (sab usrl) :srl (srl usrl)
- :freq freq)
- freqs)))
+ (let ((freq (ensure-integer
+ (caar (mutex-sql-query
+ (format nil "select count(*) from MRSO where SAB='~a'"
+ (sab usrl)))))))
+ (push (make-instance 'usrl_freq :sab (sab usrl) :srl (srl usrl)
+ :freq freq)
+ freqs)))
(sort freqs #'> :key #'freq)))
(defun find-ucon2_freq-coc-tui (ucon tui)
-"Return sorted list of tuples with ucon and freq that have co-occuring concepts of semantic type tui"
- (let ((ucon_freqs '()))
- (dolist (ucoc (s#coc ucon))
- (aif (cui2 ucoc)
- (let ((ucon2 (find-ucon-cui it)))
+"Return sorted list of tuples with ucon and freq that have co-occuring concepts of semantic type tui"
+ (let ((ucon_freqs '()))
+ (dolist (ucoc (s#coc ucon))
+ (aif (cui2 ucoc)
+ (let ((ucon2 (find-ucon-cui it)))
(when (ucon-is-tui? ucon2 tui)
- (push (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2)
- :pfstr (pfstr ucon2) :freq (cof ucoc))
- ucon_freqs)))))
+ (push (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2)
+ :pfstr (pfstr ucon2) :freq (cof ucoc))
+ ucon_freqs)))))
(setq ucon_freqs (delete-duplicates ucon_freqs :key #'cui))
(sort ucon_freqs #'> :key #'freq)))
-
+
(defun find-ucon2-str&sty (str sty lookup-func)
"Call lookup-func for ucon and usty for given str and sty"
(let ((ucon (car (find-ucon-str str)))
- (usty (car (find-usty-word sty))))
+ (usty (car (find-usty-word sty))))
(if (and ucon usty)
- (funcall lookup-func ucon (tui usty))
+ (funcall lookup-func ucon (tui usty))
nil)))
-
+
(defun find-ucon2-coc-str&sty (str sty)
"Find all ucons that are a co-occuring concept for concept named str
and that have semantic type of sty"
(let ((ucon_freqs (make-array (1+ (find-cui-max)) :initial-element nil)))
(dolist (ucon (find-ucon-tui tui)) ;; for all disease-or-syn
(dolist (ucon2 (funcall ucon2-tui-func ucon tui)) ;; for each related disease
- (aif (aref ucon_freqs (cui ucon2))
- (setf (freq it) (1+ (freq it)))
- (setf (aref ucon_freqs (cui ucon2))
- (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2)
- :pfstr (pfstr ucon2) :freq 1)))))
+ (aif (aref ucon_freqs (cui ucon2))
+ (setf (freq it) (1+ (freq it)))
+ (setf (aref ucon_freqs (cui ucon2))
+ (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2)
+ :pfstr (pfstr ucon2) :freq 1)))))
(let ((ucon_freq-list '()))
(dotimes (i (find-cui-max))
- (declare (fixnum i))
- (awhen (aref ucon_freqs i)
- (push it ucon_freq-list)))
+ (declare (fixnum i))
+ (awhen (aref ucon_freqs i)
+ (push it ucon_freq-list)))
(sort ucon_freq-list #'> :key #'freq))))
(defun find-ucon2_freq-rel-tui-all (tui)
#+(or scl)
(dolist (c '(ucon_freq ustr_freq usty_freq usrl_freq))
(let ((cl #+cmu (pcl:find-class c)
- #+scl (find-class c)))
+ #+scl (find-class c)))
#+cmu (pcl:finalize-inheritance cl)
#+scl (clos:finalize-inheritance cl)))
(defun create-table-cmd (file)
"Return sql command to create a table"
(let ((col-func
- (lambda (c)
- (let ((sqltype (sqltype c)))
- (case *umls-sql-type*
- (:oracle
- (cond
- ((string-equal sqltype "VARCHAR")
- (setq sqltype "VARCHAR2"))
- ((string-equal sqltype "BIGINT")
- (setq sqltype "VARCHAR2(20)")))))
-
- (concatenate 'string
- (col c)
- " "
- (if (or (string-equal sqltype "VARCHAR")
- (string-equal sqltype "CHAR"))
- (format nil "~a (~a)" sqltype (cmax c))
- sqltype))))))
+ (lambda (c)
+ (let ((sqltype (sqltype c)))
+ (case *umls-sql-type*
+ (:oracle
+ (cond
+ ((string-equal sqltype "VARCHAR")
+ (setq sqltype "VARCHAR2"))
+ ((string-equal sqltype "BIGINT")
+ (setq sqltype "VARCHAR2(20)")))))
+
+ (concatenate 'string
+ (col c)
+ " "
+ (if (or (string-equal sqltype "VARCHAR")
+ (string-equal sqltype "CHAR"))
+ (format nil "~a (~a)" sqltype (cmax c))
+ sqltype))))))
(format nil "CREATE TABLE ~a (~{~a~^,~})~A~A"
- (table file)
- (mapcar col-func (ucols file))
- (if (and (eq *umls-sql-type* :mysql)
- (string-equal (table file) "MRCXT"))
- " MAX_ROWS=200000000"
- "")
- (if (eq *umls-sql-type* :mysql)
- " TYPE=MYISAM CHARACTER SET utf8"
- ""))))
+ (table file)
+ (mapcar col-func (ucols file))
+ (if (and (eq *umls-sql-type* :mysql)
+ (string-equal (table file) "MRCXT"))
+ " MAX_ROWS=200000000"
+ "")
+ (if (eq *umls-sql-type* :mysql)
+ " TYPE=MYISAM CHARACTER SET utf8"
+ ""))))
(defun create-custom-table-cmd (tablename sql-cmd)
"Return SQL command to create a custom table"
(defun insert-values-cmd (file values)
"Return sql insert command for a row of values"
(let ((insert-func
- (lambda (col value)
- (concatenate 'string (quote-str col)
- (insert-col-value col value)
- (quote-str col)))))
+ (lambda (col value)
+ (concatenate 'string (quote-str col)
+ (insert-col-value col value)
+ (quote-str col)))))
(format
nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~A)"
(table file)
(defun custom-col-value (col values doquote)
(let ((custom-value (funcall (custom-value-fun col) values)))
(if custom-value
- (if doquote
- (concatenate 'string (quote-str col)
- (escape-backslashes custom-value)
- (quote-str col))
- (escape-backslashes custom-value))
- "")))
+ (if doquote
+ (concatenate 'string (quote-str col)
+ (escape-backslashes custom-value)
+ (quote-str col))
+ (escape-backslashes custom-value))
+ "")))
(defun custom-col-values (ucols values doquote)
"Returns a list of string column values for SQL inserts for custom columns"
(defun find-custom-col (filename col)
(find-if (lambda (x) (and (string-equal filename (car x))
- (string-equal col (cadr x)))) +custom-cols+))
+ (string-equal col (cadr x)))) +custom-cols+))
(defun custom-colnames-for-filename (filename)
(mapcar #'cadr (find-custom-cols-for-filename filename)))
(defun noneng-lang-index-files ()
(remove-if-not
(lambda (f) (and (> (length (fil f)) 4)
- (string-equal (fil f) "MRXW_" :end1 5)
- (not (string-equal (fil f) "MRXW_ENG.RRF"))
- (not (string-equal (fil f) "MRXW_NONENG.RRF"))))
+ (string-equal (fil f) "MRXW_" :end1 5)
+ (not (string-equal (fil f) "MRXW_ENG.RRF"))
+ (not (string-equal (fil f) "MRXW_NONENG.RRF"))))
*umls-files*))
;;; SQL Command Functions
(defun create-index-cmd (colname tablename length)
"Return sql create index command"
(format nil "CREATE INDEX ~a ON ~a (~a)"
- (concatenate 'string tablename "_" colname "_X")
- tablename
- (case *umls-sql-type*
- (:mysql
- (concatenate 'string colname
- (if (integerp length)
- (format nil " (~d)" length)
- "")))
- ((:postgresql :postgresql-socket)
- ;; FIXME: incorrect syntax for postgresql?
- (if (integerp length)
- (format nil "substr((~A)::text,1,~D)" colname length)
- colname))
- (t
- colname))))
+ (concatenate 'string tablename "_" colname "_X")
+ tablename
+ (case *umls-sql-type*
+ (:mysql
+ (concatenate 'string colname
+ (if (integerp length)
+ (format nil " (~d)" length)
+ "")))
+ ((:postgresql :postgresql-socket)
+ ;; FIXME: incorrect syntax for postgresql?
+ (if (integerp length)
+ (format nil "substr((~A)::text,1,~D)" colname length)
+ colname))
+ (t
+ colname))))
(defun create-all-tables-cmdfile ()
"Return sql commands to create all tables. Not need for automated SQL import"
(ignore-errors (execute-command "DROP TABLE KCON" :database conn))
(execute-command
(format nil "CREATE TABLE KCON (CUI INTEGER, STR ~A, LRL ~A)"
- (case *umls-sql-type*
- (:oracle
- (format nil "VARCHAR2(~D)"
- (slot-value (find-ucol "STR" "MRCONSO.RRF") 'max)))
- (t "TEXT"))
- (case *umls-sql-type*
- (:mysql "TINYINT")
- ((:postgresql :postgresql-socket) "INT2")
- (:oracle "NUMBER(2,0)")
- (t "INTEGER")))
+ (case *umls-sql-type*
+ (:oracle
+ (format nil "VARCHAR2(~D)"
+ (slot-value (find-ucol "STR" "MRCONSO.RRF") 'max)))
+ (t "TEXT"))
+ (case *umls-sql-type*
+ (:mysql "TINYINT")
+ ((:postgresql :postgresql-socket) "INT2")
+ (:oracle "NUMBER(2,0)")
+ (t "INTEGER")))
:database conn)
;; KCON deprecated by KPFENG field in MRCONSO
#+nil
(dolist (tuple (query "select distinct cui from MRCONSO order by cui"
- :database conn))
+ :database conn))
(let ((cui (car tuple)))
(execute-command
(format nil "INSERT into KCON VALUES (~D,'~A',~D)"
- cui
- (add-sql-quotes (pfstr-hash cui) )
- (cui-lrl cui))
+ cui
+ (add-sql-quotes (pfstr-hash cui) )
+ (cui-lrl cui))
:database conn))))
(defun sql-create-custom-tables (conn)
(case *umls-sql-type*
(:mysql
(format nil "DROP INDEX ~a ON ~a"
- (concatenate 'string tablename "_" colname "_X")
- tablename))
+ (concatenate 'string tablename "_" colname "_X")
+ tablename))
(t
(format nil "DROP INDEX ~a"
- (concatenate 'string tablename "_" colname "_X")))))
+ (concatenate 'string tablename "_" colname "_X")))))
(defun sql-create-indexes (conn &key (indexes +index-cols+) verbose)
"SQL Databases: create all indexes"
(ignore-errors (sql-execute "drop table USRL" conn)))
(sql-execute "create table USRL (sab varchar(80), srl integer)" conn)
(dolist (tuple (mutex-sql-query
- "select distinct SAB,SRL from MRCONSO order by SAB asc"))
+ "select distinct SAB,SRL from MRCONSO order by SAB asc"))
(sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)"
- (car tuple) (ensure-integer (cadr tuple)))
- conn)))
+ (car tuple) (ensure-integer (cadr tuple)))
+ conn)))
(defun sql-create-special-tables (conn)
(make-usrl conn)
(when verbose (format t "UMLS Import: Converting text UMLS files to optimized format.~%"))
(translate-all-files :extension extension :verbose verbose :force force-translation)
(let ((copy-cmd
- (ecase (umls-sql-type)
- (:mysql #'mysql-copy-cmd)
- (:postgresql #'pg-copy-cmd))))
+ (ecase (umls-sql-type)
+ (:mysql #'mysql-copy-cmd)
+ (:postgresql #'pg-copy-cmd))))
(with-sql-connection (conn)
(clsql:truncate-database :database conn)
(sql-drop-tables conn)
(sql-create-tables conn)
(dolist (file *umls-files*)
(when verbose (format t "UMLS Import: Importing file ~A to SQL.~%" (fil file)))
- (sql-execute (funcall copy-cmd file extension) conn))
+ (sql-execute (funcall copy-cmd file extension) conn))
(When verbose (format t "UMLS Import: Creating SQL indices.~%"))
(sql-create-indexes conn :verbose verbose)
(When verbose (format t "UMLS Import: Creating custom tables.~%"))
(defun make-noneng-index-file (extension &key force)
"Make non-english index file"
(translate-files (find-ufile "MRXW_NONENG.RRF")
- extension (noneng-lang-index-files) :force force))
+ extension (noneng-lang-index-files) :force force))
(defun verify-translation-file (output-path input-ufiles)
"Returns t if translation file exists and is correct size. Warns and deletes incomplete translation file."
(defun translate-line (file line strm)
"Translate a single line for sql output"
(flet ((col-value (col value)
- (if (eq (datatype col) 'sql-u)
- (let ((ui (parse-ui value "")))
- (if (stringp ui)
- ui
- (write-to-string ui)))
- (escape-backslashes value))))
+ (if (eq (datatype col) 'sql-u)
+ (let ((ui (parse-ui value "")))
+ (if (stringp ui)
+ ui
+ (write-to-string ui)))
+ (escape-backslashes value))))
(print-separated-strings
strm "|"
(mapcar #'col-value (remove-custom-cols (ucols file)) line)
(defun umls-fixed-size-waste ()
"Display storage waste if using all fixed size storage"
(let ((totalwaste 0)
- (totalunavoidable 0)
- (totalavoidable 0)
- (unavoidable '())
- (avoidable '()))
+ (totalunavoidable 0)
+ (totalavoidable 0)
+ (unavoidable '())
+ (avoidable '()))
(dolist (file *umls-files*)
(dolist (col (ucols file))
- (let* ((avwaste (- (cmax col) (av col)))
- (cwaste (* avwaste (rws file))))
- (when (plusp cwaste)
- (if (<= avwaste 6)
- (progn
- (incf totalunavoidable cwaste)
- (push (list (fil file) (col col)
- avwaste cwaste)
- unavoidable))
- (progn
- (incf totalavoidable cwaste)
- (push (list (fil file) (col col)
- avwaste cwaste)
- avoidable)))
- (incf totalwaste cwaste)))))
+ (let* ((avwaste (- (cmax col) (av col)))
+ (cwaste (* avwaste (rws file))))
+ (when (plusp cwaste)
+ (if (<= avwaste 6)
+ (progn
+ (incf totalunavoidable cwaste)
+ (push (list (fil file) (col col)
+ avwaste cwaste)
+ unavoidable))
+ (progn
+ (incf totalavoidable cwaste)
+ (push (list (fil file) (col col)
+ avwaste cwaste)
+ avoidable)))
+ (incf totalwaste cwaste)))))
(values totalwaste totalavoidable totalunavoidable
- (nreverse avoidable) (nreverse unavoidable))))
+ (nreverse avoidable) (nreverse unavoidable))))
(defun display-waste ()
(ensure-ucols+ufiles)
(declare (type (integer 0 1000000) max))
(dolist (ucol *umls-cols*)
(when (> (the (integer 0 1000000) (cmax ucol)) max)
- (setq max (cmax ucol))))
+ (setq max (cmax ucol))))
max))
(defun max-umls-row ()
(dolist (file *umls-files*)
(let ((row 0))
(declare (type (integer 0 1000000) row))
- (dolist (ucol (ucols file))
+ (dolist (ucol (ucols file))
(let* ((col-max (cmax ucol))
(max-with-delim (1+ col-max)))
(declare (type (integer 0 1000000) col-max max-with-delim))
(incf row max-with-delim)))
- (push row rowsizes)))
+ (push row rowsizes)))
(car (sort rowsizes #'>))))
(fields :initarg :fields :accessor fields)
(ucols :initarg :ucols :accessor ucols))
(:default-initargs :fil nil :table nil :des nil :fmt nil :cls nil :rws nil :bts nil
- :fields nil :ucols nil :subdir nil :dir nil)
+ :fields nil :ucols nil :subdir nil :dir nil)
(:documentation "UMLS File"))
(defclass ucol ()
(datatype :initarg :datatype :accessor datatype)
(custom-value-fun :initarg :custom-value-fun :accessor custom-value-fun))
(:default-initargs :col nil :des nil :ref nil :min nil :av nil :max nil :fil nil
- :sqltype nil :dty nil :parse-fun nil :datatype nil
- :custom-value-fun nil)
+ :sqltype nil :dty nil :parse-fun nil :datatype nil
+ :custom-value-fun nil)
(:documentation "UMLS column"))
(concatenate 'string (second name-list) (or extension "")))))
(merge-pathnames
(make-pathname :name name :type type
- :directory (cons :relative dirs))
+ :directory (cons :relative dirs))
*umls-path*)))
(defun umls-pathname (filename &optional (extension ""))
(dolist (length-list (ufiles-field-lengths (ufiles-to-measure)))
(destructuring-bind (filename fields-max fields-av) length-list
(let ((file (find-ufile filename)))
- (unless file
- (error "Can't find ~A filename in ufiles" filename))
- (unless (= (length fields-max) (length (fields file)))
- (error
- "Number of file fields ~A not equal to field count in ufile ~S"
- fields-max file))
- (dotimes (i (length (fields file)))
- (declare (fixnum i))
- (let* ((field (nth i (fields file)))
- (col (find-ucol field filename)))
- (unless col
- (error "can't find column ~A" field))
- (setf (cmax col) (aref fields-max i))
- (setf (av col) (aref fields-av i))
- (ensure-ucol-datatype col (datatype-for-colname (col col)))))))))
+ (unless file
+ (error "Can't find ~A filename in ufiles" filename))
+ (unless (= (length fields-max) (length (fields file)))
+ (error
+ "Number of file fields ~A not equal to field count in ufile ~S"
+ fields-max file))
+ (dotimes (i (length (fields file)))
+ (declare (fixnum i))
+ (let* ((field (nth i (fields file)))
+ (col (find-ucol field filename)))
+ (unless col
+ (error "can't find column ~A" field))
+ (setf (cmax col) (aref fields-max i))
+ (setf (av col) (aref fields-av i))
+ (ensure-ucol-datatype col (datatype-for-colname (col col)))))))))
(defun ufiles-to-measure ()
"Returns a list of ufiles to measure"
(loop for ufile in *umls-files*
- unless (or (char= #\M (schar (fil ufile) 0))
- (char= #\m (schar (fil ufile) 0)))
+ unless (or (char= #\M (schar (fil ufile) 0))
+ (char= #\m (schar (fil ufile) 0)))
collect ufile))
(declare (fixnum count-lines))
(with-umls-ufile (line ufile)
(unless num-fields
- (setq num-fields (length line))
- (setq fields-max (make-array num-fields :element-type 'fixnum
- :initial-element 0))
- (setq fields-av (make-array num-fields :element-type '(or integer float)
- :initial-element 0)))
+ (setq num-fields (length line))
+ (setq fields-max (make-array num-fields :element-type 'fixnum
+ :initial-element 0))
+ (setq fields-av (make-array num-fields :element-type '(or integer float)
+ :initial-element 0)))
(dotimes (i num-fields)
- (declare (fixnum i))
- (let* ((str (nth i line))
+ (declare (fixnum i))
+ (let* ((str (nth i line))
(len (length #-(and clisp unicode) str
#+(and clisp unicode)
(if *octet-sql-storage*
str))))
#-(and clisp unicode) (declare (string str))
(declare (type (integer 0 10000000) len))
- (incf (aref fields-av i) len)
- (when (> len (aref fields-max i))
- (setf (aref fields-max i) len))))
+ (incf (aref fields-av i) len)
+ (when (> len (aref fields-max i))
+ (setf (aref fields-max i) len))))
(incf count-lines))
(dotimes (i num-fields)
(setf (aref fields-av i) (float (/ (aref fields-av i) count-lines))))
"Returns list of umls-col structure for a column name and a filename"
(dolist (ucol ucols nil)
(when (and (string-equal filename (fil ucol))
- (string-equal colname (col ucol)))
+ (string-equal colname (col ucol)))
(return-from find-ucol-of-colname ucol))))
(defun ensure-col-in-columns (colname filename ucols)
(defun make-ucol-for-column (colname filename ucols)
;; try to find column name without a terminal digit
(let* ((len (length colname))
- (last-digit? (digit-char-p (schar colname (1- len))))
- (base-colname (if last-digit?
- (subseq colname 0 (1- len))
- colname))
- (ucol (when last-digit?
- (find-ucol-of-colname base-colname filename ucols))))
+ (last-digit? (digit-char-p (schar colname (1- len))))
+ (base-colname (if last-digit?
+ (subseq colname 0 (1- len))
+ colname))
+ (ucol (when last-digit?
+ (find-ucol-of-colname base-colname filename ucols))))
(when (and last-digit? (null ucol))
(error "Couldn't find a base column for col ~A in file ~A"
- colname filename))
+ colname filename))
(copy-or-new-ucol colname filename ucol)))
(defun copy-or-new-ucol (colname filename ucol)
nil)
(function
(if (compiled-function-p fun)
- fun
- (compile nil fun)))
+ fun
+ (compile nil fun)))
(list
(compile nil fun))))
(defun make-ucol (col des ref min av max fil dty
- &key (sqltype "VARCHAR") (parse-fun #'add-sql-quotes)
- (quote-str "'") (custom-value-fun))
+ &key (sqltype "VARCHAR") (parse-fun #'add-sql-quotes)
+ (quote-str "'") (custom-value-fun))
(let ((ucol (make-instance
- 'ucol
- :col col :des des :ref ref :min min :av av
- :max (if (eql max 0) 1 max) ;; ensure at least one char wide
- :fil fil
- :dty dty
- :sqltype sqltype
- :quote-str quote-str
- :parse-fun (ensure-compiled-fun parse-fun)
- :custom-value-fun (ensure-compiled-fun custom-value-fun))))
+ 'ucol
+ :col col :des des :ref ref :min min :av av
+ :max (if (eql max 0) 1 max) ;; ensure at least one char wide
+ :fil fil
+ :dty dty
+ :sqltype sqltype
+ :quote-str quote-str
+ :parse-fun (ensure-compiled-fun parse-fun)
+ :custom-value-fun (ensure-compiled-fun custom-value-fun))))
(ensure-ucol-datatype ucol (datatype-for-colname col))
ucol))
"Returns list of umls-cols for a file structure"
(loop for colname in (fields ufile)
collect (find-ucol colname
- (if (subdir ufile)
- (concatenate 'string (subdir ufile) "/" (fil ufile))
- (fil ufile)))))
+ (if (subdir ufile)
+ (concatenate 'string (subdir ufile) "/" (fil ufile))
+ (fil ufile)))))
(defun umls-field-string-to-list (fmt)
"Converts a comma delimited list of fields into a list of field names. Will
append a unique number (starting at 2) onto a column name that is repeated in the list"
(let ((col-counts (make-hash-table :test 'equal)))
(loop for colname in (delimited-string-to-list (escape-column-name fmt) #\,)
- collect
- (multiple-value-bind (value found) (gethash colname col-counts)
- (cond
- (found
- (incf (gethash colname col-counts))
- (concatenate 'string colname (write-to-string (1+ value))))
- (t
- (setf (gethash colname col-counts) 1)
- colname))))))
+ collect
+ (multiple-value-bind (value found) (gethash colname col-counts)
+ (cond
+ (found
+ (incf (gethash colname col-counts))
+ (concatenate 'string colname (write-to-string (1+ value))))
+ (t
+ (setf (gethash colname col-counts) 1)
+ colname))))))
(defun decompose-fil (fil)
(if fil
(let ((pos (position #\/ fil)))
- (if pos
- (values (subseq fil (1+ pos)) (subseq fil 0 pos))
- (values fil nil)))
+ (if pos
+ (values (subseq fil (1+ pos)) (subseq fil 0 pos))
+ (values fil nil)))
(values nil nil)))
(defun filename-to-tablename (file)
(defun make-ufile (dir fil des cls rws bts fields)
(multiple-value-bind (file subdir) (decompose-fil fil)
(let ((ufile (make-instance 'ufile :dir dir :fil file :subdir subdir
- :des des :cls cls
- :rws rws :bts bts :fields fields
- :table (filename-to-tablename file))))
+ :des des :cls cls
+ :rws rws :bts bts :fields fields
+ :table (filename-to-tablename file))))
ufile)))
(defun set-ucols-for-ufiles (ufiles)
(setf (datatype col) datatype)
(case datatype
(sql-u (setf (sqltype col) (canonicalize-column-type "INTEGER")
- (parse-fun col) #'parse-ui
- (quote-str col) ""))
+ (parse-fun col) #'parse-ui
+ (quote-str col) ""))
(sql-s (setf (sqltype col) (canonicalize-column-type "SMALLINT")
- (parse-fun col) #'parse-integer
- (quote-str col) ""))
+ (parse-fun col) #'parse-integer
+ (quote-str col) ""))
(sql-l (setf (sqltype col) (canonicalize-column-type "BIGINT")
- (parse-fun col) #'parse-integer
- (quote-str col) ""))
+ (parse-fun col) #'parse-integer
+ (quote-str col) ""))
(sql-i (setf (sqltype col) (canonicalize-column-type "INTEGER")
- (parse-fun col) #'parse-integer
- (quote-str col) ""))
+ (parse-fun col) #'parse-integer
+ (quote-str col) ""))
(sql-t (setf (sqltype col) (canonicalize-column-type "TINYINT")
- (parse-fun col) #'parse-integer
- (quote-str col) ""))
+ (parse-fun col) #'parse-integer
+ (quote-str col) ""))
(sql-f (setf (sqltype col) (canonicalize-column-type "NUMERIC")
- (parse-fun col) #'read-from-string
- (quote-str col) ""))
- (t ; Default column type, optimized text storage
+ (parse-fun col) #'read-from-string
+ (quote-str col) ""))
+ (t ; Default column type, optimized text storage
(setf (parse-fun col) #'add-sql-quotes
- (quote-str col) "'")
+ (quote-str col) "'")
(when (and (cmax col) (av col))
(if (> (cmax col) 255)
- (setf (sqltype col) (canonicalize-column-type "TEXT"))
- (setf (sqltype col) (canonicalize-column-type "VARCHAR")))))))
+ (setf (sqltype col) (canonicalize-column-type "TEXT"))
+ (setf (sqltype col) (canonicalize-column-type "VARCHAR")))))))
(defun escape-column-name (name)
(substitute #\_ #\/ name))
"Read a line from a UMLS stream, split into fields"
(let ((line (read-line strm nil eof)))
(if (eq line eof)
- eof
- (delimited-string-to-list line #\| t))))
+ eof
+ (delimited-string-to-list line #\| t))))
(defun source-files (path)
(if (probe-file path)
(list path)
(sort
(directory (make-pathname :defaults path
- :type :wild
- :name (concatenate 'string (pathname-name path)
- (aif (pathname-type path)
- (concatenate 'string "." it)
- ""))))
+ :type :wild
+ :name (concatenate 'string (pathname-name path)
+ (aif (pathname-type path)
+ (concatenate 'string "." it)
+ ""))))
#'(lambda (a b)
- (string-lessp (pathname-type a) (pathname-type b))))))
+ (string-lessp (pathname-type a) (pathname-type b))))))
(defmacro with-buffered-reading-umls-file ((line path) &body body)
"Opens a UMLS and processes each parsed line with (body) argument"
(let ((ustream (gensym "STRM-"))
- (buffer (gensym "BUF-"))
- (eof (gensym "EOF-"))
- (files (gensym "FILES-")))
+ (buffer (gensym "BUF-"))
+ (eof (gensym "EOF-"))
+ (files (gensym "FILES-")))
`(let ((,eof (gensym "EOFSYM-"))
- (,buffer (make-fields-buffer))
- (,files (source-files ,path)))
+ (,buffer (make-fields-buffer))
+ (,files (source-files ,path)))
(with-open-file (,ustream (first ,files) :direction :input
#+(and clisp unicode) :external-format
#+(and clisp unicode) charset:utf-8)
- (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof)
- (read-buffered-fields ,buffer ,ustream #\| ,eof)))
- ((eq ,line ,eof) t)
- (setq ,line (coerce ,line 'list))
- (print ,line)
- ,@body)))))
+ (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof)
+ (read-buffered-fields ,buffer ,ustream #\| ,eof)))
+ ((eq ,line ,eof) t)
+ (setq ,line (coerce ,line 'list))
+ (print ,line)
+ ,@body)))))
(defmacro with-reading-umls-file ((line path) &body body)
"Opens a UMLS and processes each parsed line with (body) argument"
(let ((ustream (gensym "STRM-"))
- (eof (gensym "EOF-"))
- (files (gensym "FILES-")))
+ (eof (gensym "EOF-"))
+ (files (gensym "FILES-")))
`(let ((,eof (gensym "EOFSYM-"))
- (,files (source-files ,path)))
+ (,files (source-files ,path)))
(unless ,files
(error "Can't find files for ~A~%" (namestring ,path)))
(with-open-file (,ustream (first ,files) :direction :input
(defmacro with-buffered-umls-file ((line filename) &body body)
"Opens a UMLS and processes each parsed line with (body) argument"
(let ((ustream (gensym "STRM-"))
- (buffer (gensym "BUF-"))
- (eof (gensym "EOF-")))
+ (buffer (gensym "BUF-"))
+ (eof (gensym "EOF-")))
`(let ((,buffer (make-fields-buffer))
- (,eof (gensym "EOFSYM-")))
+ (,eof (gensym "EOFSYM-")))
(with-open-file
- (,ustream (umls-pathname ,filename) :direction :input)
- (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof)
- (read-buffered-fields ,buffer ,ustream #\| ,eof)))
- ((eq ,line ,eof) t)
- ,@body)))))
+ (,ustream (umls-pathname ,filename) :direction :input)
+ (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof)
+ (read-buffered-fields ,buffer ,ustream #\| ,eof)))
+ ((eq ,line ,eof) t)
+ ,@body)))))
(defun make-preparse-hash-table ()
(if sui-lrl-hash
- (clear-preparse-hash-tables)
+ (clear-preparse-hash-tables)
(setf
- pfstr-hash (make-hash-table :size 1500000)
- cui-lrl-hash (make-hash-table :size 1500000)
- lui-lrl-hash (make-hash-table :size 5000000)
- sui-lrl-hash (make-hash-table :size 6000000)
- cuisui-lrl-hash (make-hash-table :size 6000000)
- cui-lrlus-hash (make-hash-table :size 1500000)
- lui-lrlus-hash (make-hash-table :size 5000000)
- sui-lrlus-hash (make-hash-table :size 6000000)
- cuisui-lrlus-hash (make-hash-table :size 6000000)
- sab-srl-hash (make-hash-table :size 200 :test 'equal)
+ pfstr-hash (make-hash-table :size 1500000)
+ cui-lrl-hash (make-hash-table :size 1500000)
+ lui-lrl-hash (make-hash-table :size 5000000)
+ sui-lrl-hash (make-hash-table :size 6000000)
+ cuisui-lrl-hash (make-hash-table :size 6000000)
+ cui-lrlus-hash (make-hash-table :size 1500000)
+ lui-lrlus-hash (make-hash-table :size 5000000)
+ sui-lrlus-hash (make-hash-table :size 6000000)
+ cuisui-lrlus-hash (make-hash-table :size 6000000)
+ sab-srl-hash (make-hash-table :size 200 :test 'equal)
sab-srlus-hash (make-hash-table :size 200 :test 'equal))))
(defun ensure-preparse (&optional (force-read nil))
(when (and (string-equal (vff "MRCONSO.RRF" "LAT" line) "ENG")
(string-equal (vff "MRCONSO.RRF" "TS" line) "P")
(string-equal (vff "MRCONSO.RRF" "STT" line) "PF"))
- (setf (gethash cui pfstr-hash) (vff "MRCONSO.RRF" "STR" line))))
+ (setf (gethash cui pfstr-hash) (vff "MRCONSO.RRF" "STR" line))))
(set-lrl-hash cui srl cui-lrl-hash)
(set-lrl-hash lui srl lui-lrl-hash)
(set-lrl-hash sui srl sui-lrl-hash)
(declare (type (or null fixnum) hash-lrl)
(boolean found))
(if (or (not found) (< srl hash-lrl))
- (setf (gethash key hash) srl))))
+ (setf (gethash key hash) srl))))
;; UMLS file and column structures
;;; SQL datatypes symbols
(lambda (x) (write-to-string (cui-lrlus (parse-ui (vff "MRSTY.RRF" "CUI" x))))))
("MRCOC.RRF" "KLRL" "TINYINT" 0
(lambda (x) (write-to-string
- (max (cui-lrl (parse-ui (vff "MRCOC.RRF" "CUI1" x)))
- (kmrcl:aif (cui-lrl (parse-ui (vff "MRCOC.RRF" "CUI2" x))) kmrcl::it 0)))))
+ (max (cui-lrl (parse-ui (vff "MRCOC.RRF" "CUI1" x)))
+ (kmrcl:aif (cui-lrl (parse-ui (vff "MRCOC.RRF" "CUI2" x))) kmrcl::it 0)))))
("MRCOC.RRF" "KLRLUS" "TINYINT" 0
(lambda (x) (write-to-string
- (max (cui-lrlus (parse-ui (vff "MRCOC.RRF" "CUI1" x)))
- (kmrcl:aif (cui-lrl (parse-ui (vff "MRCOC.RRF" "CUI2" x))) kmrcl::it 0)))))
+ (max (cui-lrlus (parse-ui (vff "MRCOC.RRF" "CUI1" x)))
+ (kmrcl:aif (cui-lrl (parse-ui (vff "MRCOC.RRF" "CUI2" x))) kmrcl::it 0)))))
("MRSAT.RRF" "KSRL" "TINYINT" 0
(lambda (x) (write-to-string (sab-srl (vff "MRSAT.RRF" "SAB" x)))))
("MRSAT.RRF" "KSRLUS" "TINYINT" 0
(lambda (x) (write-to-string (sab-srlus (vff "MRDEF.RRF" "SAB" x)))))
("MRXW_ENG.RRF" "KLRL" "TINYINT" 0
(lambda (x) (write-to-string (cuisui-lrl (make-cuisui
- (parse-ui (vff "MRXW_ENG.RRF" "CUI" x))
- (parse-ui (vff "MRXW_ENG.RRF" "SUI" x)))))))
+ (parse-ui (vff "MRXW_ENG.RRF" "CUI" x))
+ (parse-ui (vff "MRXW_ENG.RRF" "SUI" x)))))))
("MRXW_ENG.RRF" "KLRLUS" "TINYINT" 0
(lambda (x) (write-to-string (cuisui-lrlus (make-cuisui
- (parse-ui (vff "MRXW_ENG.RRF" "CUI" x))
- (parse-ui (vff "MRXW_ENG.RRF" "SUI" x)))))))
+ (parse-ui (vff "MRXW_ENG.RRF" "CUI" x))
+ (parse-ui (vff "MRXW_ENG.RRF" "SUI" x)))))))
("MRXW_NONENG.RRF" "KLRL" "TINYINT" 0
(lambda (x) (write-to-string (cuisui-lrl (make-cuisui
- (parse-ui (vff "MRXW_NONENG.RRF" "CUI" x))
- (parse-ui (vff "MRXW_NONENG.RRF" "SUI" x)))))))
+ (parse-ui (vff "MRXW_NONENG.RRF" "CUI" x))
+ (parse-ui (vff "MRXW_NONENG.RRF" "SUI" x)))))))
("MRXW_NONENG.RRF" "KLRLUS" "TINYINT" 0
(lambda (x) (write-to-string (cuisui-lrlus (make-cuisui
- (parse-ui (vff "MRXW_NONENG.RRF" "CUI" x))
- (parse-ui (vff "MRXW_NONENG.RRF" "SUI" x)))))))
+ (parse-ui (vff "MRXW_NONENG.RRF" "CUI" x))
+ (parse-ui (vff "MRXW_NONENG.RRF" "SUI" x)))))))
("MRXNW_ENG.RRF" "KLRL" "TINYINT" 0
(lambda (x) (write-to-string (cuisui-lrl (make-cuisui
- (parse-ui (vff "MRXNW_ENG.RRF" "CUI" x))
- (parse-ui (vff "MRXNW_ENG.RRF" "SUI" x)))))))
+ (parse-ui (vff "MRXNW_ENG.RRF" "CUI" x))
+ (parse-ui (vff "MRXNW_ENG.RRF" "SUI" x)))))))
("MRXNW_ENG.RRF" "KLRLUS" "TINYINT" 0
(lambda (x) (write-to-string (cuisui-lrlus (make-cuisui
- (parse-ui (vff "MRXNW_ENG.RRF" "CUI" x))
- (parse-ui (vff "MRXNW_ENG.RRF" "SUI" x)))))))
+ (parse-ui (vff "MRXNW_ENG.RRF" "CUI" x))
+ (parse-ui (vff "MRXNW_ENG.RRF" "SUI" x)))))))
("MRXNS_ENG.RRF" "KLRL" "TINYINT" 0
(lambda (x) (write-to-string (cuisui-lrl (make-cuisui
- (parse-ui (vff "MRXNS_ENG.RRF" "CUI" x))
- (parse-ui (vff "MRXNS_ENG.RRF" "SUI" x)))))))
+ (parse-ui (vff "MRXNS_ENG.RRF" "CUI" x))
+ (parse-ui (vff "MRXNS_ENG.RRF" "SUI" x)))))))
("MRXNS_ENG.RRF" "KLRLUS" "TINYINT" 0
(lambda (x) (write-to-string (cuisui-lrlus (make-cuisui
- (parse-ui (vff "MRXNS_ENG.RRF" "CUI" x))
- (parse-ui (vff "MRXNS_ENG.RRF" "SUI" x)))))))
+ (parse-ui (vff "MRXNS_ENG.RRF" "CUI" x))
+ (parse-ui (vff "MRXNS_ENG.RRF" "SUI" x)))))))
#+nil ("MRREL.RRF" "KPFSTR2" "TEXT" 1024 (lambda (x) (pfstr-hash (parse-ui (vff "MRREL.RRF" "CUI2" x)))))
#+nil ("MRCOC.RRF" "KPFSTR2" "TEXT" 1024 (lambda (x) (pfstr-hash (parse-ui (vff "MRCOC.RRF" "CUI2" x)))))
(let ((cols '()))
(with-umls-file (line "MRCOLS.RRF")
(destructuring-bind (col des ref min av max fil dty) line
- (push (make-ucol col des ref (parse-integer min) (read-from-string av)
- (parse-integer max) fil dty)
- cols)))
+ (push (make-ucol col des ref (parse-integer min) (read-from-string av)
+ (parse-integer max) fil dty)
+ cols)))
(nreverse cols)))
(defun gen-ucols-custom ()
"Initialize umls columns for custom columns"
(loop for customcol in +custom-cols+
- collect
- (make-ucol (nth 1 customcol) "" 0 0 0 (eval (nth 3 customcol))
- (nth 0 customcol) nil :sqltype (canonicalize-column-type (nth 2 customcol))
- :custom-value-fun (compile nil (nth 4 customcol)))))
+ collect
+ (make-ucol (nth 1 customcol) "" 0 0 0 (eval (nth 3 customcol))
+ (nth 0 customcol) nil :sqltype (canonicalize-column-type (nth 2 customcol))
+ :custom-value-fun (compile nil (nth 4 customcol)))))
(defun gen-ucols-generic (col-filename)
"Initialize for generic (LEX/NET) columns"
(let ((cols '()))
(with-umls-file (line col-filename)
(destructuring-bind (nam des ref fil) line
- (setq nam (escape-column-name nam))
- (dolist (file (delimited-string-to-list fil #\,))
- (push
- (make-ucol nam des ref nil nil nil file nil)
- cols))))
+ (setq nam (escape-column-name nam))
+ (dolist (file (delimited-string-to-list fil #\,))
+ (push
+ (make-ucol nam des ref nil nil nil file nil)
+ cols))))
(nreverse cols)))
(let ((files '()))
(with-umls-file (line files-filename)
(destructuring-bind (fil des fmt cls rws bts) line
- (push (make-ufile
- dir fil des
- (parse-integer cls)
- (parse-integer rws) (parse-integer bts)
- (concatenate 'list (umls-field-string-to-list fmt)
- (custom-colnames-for-filename fil)))
- files)))
+ (push (make-ufile
+ dir fil des
+ (parse-integer cls)
+ (parse-integer rws) (parse-integer bts)
+ (concatenate 'list (umls-field-string-to-list fmt)
+ (custom-colnames-for-filename fil)))
+ files)))
(nreverse files)))
(defun gen-ufiles-custom ()
(make-ufile "META" "MRXW_NONENG.RRF" "Custom NonEnglish Index"
- 5 0 0 (fields (find-ufile "MRXW_ENG.RRF"))))
+ 5 0 0 (fields (find-ufile "MRXW_ENG.RRF"))))
(setq *current-srl* srl))
(defmacro query-string (table fields srl where-name where-value
- &key (lrl "KCUILRL") single distinct order like limit
+ &key (lrl "KCUILRL") single distinct order like limit
filter)
(let* ((%%fields (format nil "SELECT ~A~{~:@(~A~)~^,~} FROM ~:@(~A~)"
- (if distinct "DISTINCT " "") fields table))
- (%%order (if order (format nil " ORDER BY ~{~:@(~A~) ~(~A~)~^,~}"
- order)
- ""))
- (%%lrl (format nil " AND ~:@(~A~)<=" lrl))
- (%%where (when where-name
- (format nil " WHERE ~:@(~A~)~A" where-name
- (if like " like " ""))))
+ (if distinct "DISTINCT " "") fields table))
+ (%%order (if order (format nil " ORDER BY ~{~:@(~A~) ~(~A~)~^,~}"
+ order)
+ ""))
+ (%%lrl (format nil " AND ~:@(~A~)<=" lrl))
+ (%%where (when where-name
+ (format nil " WHERE ~:@(~A~)~A" where-name
+ (if like " like " ""))))
(%filter (gensym "FILTER-"))
(%single (gensym "SINGLE-"))
(%limit (gensym "LIMIT-")))
""))))))
(defun query-string-eval (table fields srl where-name where-value
- &key (lrl "KCUILRL") single distinct order like limit filter)
+ &key (lrl "KCUILRL") single distinct order like limit filter)
(when single (setq limit 1))
(concatenate
'string
(format nil "SELECT ~A~{~:@(~A~)~^,~} FROM ~:@(~A~)"
- (if distinct "DISTINCT " "") fields table)
+ (if distinct "DISTINCT " "") fields table)
(if where-name (format nil " WHERE ~:@(~A~)" where-name) "")
(if where-name
(format nil
- (typecase where-value
- (number "='~D'")
- (null " IS NULL")
- (t
- (if like " LINK '%~A%""='~A'")))
- where-value)
+ (typecase where-value
+ (number "='~D'")
+ (null " IS NULL")
+ (t
+ (if like " LINK '%~A%""='~A'")))
+ where-value)
"")
(if filter (concatenate 'string " AND " filter) nil)
(if srl (format nil " AND ~:@(~A~)<=~D" lrl srl) "")
(defmacro umlisp-query (table fields srl where-name where-value
- &key (lrl "KCUILRL") single distinct order like
+ &key (lrl "KCUILRL") single distinct order like
limit filter (query-cmd 'mutex-sql-query))
"Query the UMLisp database. Return a list of umlisp objects whose name
is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
:filter ,filter :limit ,limit)))
(defmacro umlisp-query-eval (table fields srl where-name where-value
- &key (lrl "KCUILRL") single distinct order like
+ &key (lrl "KCUILRL") single distinct order like
filter limit)
"Query the UMLisp database. Return a list of umlisp objects whose name
is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
;; only WHERE-VALUE and SRL are evaluated
(defmacro collect-umlisp-query ((table fields srl where-name where-value
- &key (lrl "KCUILRL") distinct single
- order like (query-cmd 'mutex-sql-query)
+ &key (lrl "KCUILRL") distinct single
+ order like (query-cmd 'mutex-sql-query)
filter limit)
- &body body)
+ &body body)
(let ((value (gensym))
- (r (gensym)))
+ (r (gensym)))
(if single
(if (and limit (> limit 1))
(error "Can't set limit along with single.")
(when tuple
(destructuring-bind ,fields tuple
,@body))))
- `(let ((,value ,where-value))
- ,@(unless where-name `((declare (ignore ,value))))
- (let ((,r '()))
- (dolist (tuple (umlisp-query ,table ,fields ,srl ,where-name ,value
- :lrl ,lrl :single ,single :distinct ,distinct
- :order ,order :filter ,filter :like ,like
+ `(let ((,value ,where-value))
+ ,@(unless where-name `((declare (ignore ,value))))
+ (let ((,r '()))
+ (dolist (tuple (umlisp-query ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :filter ,filter :like ,like
:limit ,limit))
- (push (destructuring-bind ,fields tuple ,@body) ,r))
- (nreverse ,r))
- #+ignore
- (loop for tuple in
- (umlisp-query ,table ,fields ,srl ,where-name ,value
- :lrl ,lrl :single ,single :distinct ,distinct
- :order ,order :like ,like :filter ,filter :limit ,limit)
- collect (destructuring-bind ,fields tuple ,@body))))))
+ (push (destructuring-bind ,fields tuple ,@body) ,r))
+ (nreverse ,r))
+ #+ignore
+ (loop for tuple in
+ (umlisp-query ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :like ,like :filter ,filter :limit ,limit)
+ collect (destructuring-bind ,fields tuple ,@body))))))
(defmacro collect-umlisp-query-eval ((table fields srl where-name where-value
- &key (lrl "KCUILRL") distinct single
- order like filter limit)
- &body body)
+ &key (lrl "KCUILRL") distinct single
+ order like filter limit)
+ &body body)
(let ((value (gensym))
- (r (gensym))
- (eval-fields (cadr fields)))
+ (r (gensym))
+ (eval-fields (cadr fields)))
(if single
- `(let* ((,value ,where-value)
- (tuple (car (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
- :lrl ,lrl :single ,single
- :distinct ,distinct :order ,order
- :like ,like :filter ,filter
+ `(let* ((,value ,where-value)
+ (tuple (car (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single
+ :distinct ,distinct :order ,order
+ :like ,like :filter ,filter
:limit ,limit))))
- (when tuple
- (destructuring-bind ,eval-fields tuple
- ,@body)))
- `(let ((,value ,where-value)
- (,r '()))
- (dolist (tuple (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
- :lrl ,lrl :single ,single :distinct ,distinct
- :order ,order :like ,like
+ (when tuple
+ (destructuring-bind ,eval-fields tuple
+ ,@body)))
+ `(let ((,value ,where-value)
+ (,r '()))
+ (dolist (tuple (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :like ,like
:filter ,filter :limit ,limit))
- (push (destructuring-bind ,eval-fields tuple ,@body) ,r))
- (nreverse ,r)
- #+ignore
- (loop for tuple in
- (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
- :lrl ,lrl :single ,single :distinct ,distinct
- :order ,order :like ,like :filter ,filter
+ (push (destructuring-bind ,eval-fields tuple ,@body) ,r))
+ (nreverse ,r)
+ #+ignore
+ (loop for tuple in
+ (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :like ,like :filter ,filter
:limit ,limit)
- collect (destructuring-bind ,eval-fields tuple ,@body))))))
+ collect (destructuring-bind ,eval-fields tuple ,@body))))))
;;;
;;; Read from SQL database
(ensure-sui-integer sui)
(collect-umlisp-query (mrconso (cui kcuilrl) srl sui sui :distinct t)
(make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui)
- :lrl (ensure-integer kcuilrl))))
+ :lrl (ensure-integer kcuilrl))))
(defun find-ucon-aui (aui &key (srl *current-srl*))
"Find list of ucon for aui"
(ensure-aui-integer aui)
(collect-umlisp-query (mrconso (cui kcuilrl) srl aui aui :distinct t)
(make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui)
- :lrl (ensure-integer kcuilrl))))
+ :lrl (ensure-integer kcuilrl))))
(defun find-ucon-cuisui (cui sui &key (srl *current-srl*))
"Find ucon for cui/sui"
(ensure-sui-integer sui)
(when (and cui sui)
(collect-umlisp-query (mrconso (kcuilrl) srl kcuisui
- (make-cuisui cui sui))
+ (make-cuisui cui sui))
(make-instance 'ucon :cui cui
- :pfstr (find-pfstr-cui cui)
- :lrl (ensure-integer kcuilrl)))))
+ :pfstr (find-pfstr-cui cui)
+ :lrl (ensure-integer kcuilrl)))))
(defun find-ucon-str (str &key (srl *current-srl*))
"Find ucon that are exact match for str"
(collect-umlisp-query (mrconso (cui kcuilrl) srl str str :distinct t)
(make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui)
- :lrl (ensure-integer kcuilrl))))
+ :lrl (ensure-integer kcuilrl))))
(defun find-ucon-all (&key (srl *current-srl*))
"Return list of all ucon's"
(clsql:map-query
'list
#'(lambda (tuple)
- (destructuring-bind (cui cuilrl) tuple
- (make-instance 'ucon :cui (ensure-integer cui)
- :pfstr (find-pfstr-cui cui)
+ (destructuring-bind (cui cuilrl) tuple
+ (make-instance 'ucon :cui (ensure-integer cui)
+ :pfstr (find-pfstr-cui cui)
:lrl (ensure-integer cuilrl))))
(query-string mrconso (cui kcuilrl) srl nil nil
- :order (cui asc) :distinct t)
+ :order (cui asc) :distinct t)
:database db)))
(defun find-ucon-all2 (&key (srl *current-srl*))
"Return list of all ucon's"
(collect-umlisp-query (mrconso (cui kcuilrl) srl nil nil :order (cui asc)
- :distinct t)
+ :distinct t)
(make-instance 'ucon :cui (ensure-integer cui)
- :pfstr (find-pfstr-cui cui)
- :lrl (ensure-integer kcuilrl))))
+ :pfstr (find-pfstr-cui cui)
+ :lrl (ensure-integer kcuilrl))))
(defun find-cui-ucon-all (&key (srl *current-srl*))
"Return list of CUIs for all ucons"
(collect-umlisp-query (mrconso (cui) srl nil nil :order (cui asc)
- :distinct t)
- cui))
+ :distinct t)
+ cui))
(defun map-ucon-all (fn &key (srl *current-srl*))
"Map a function over all ucon's"
(clsql:map-query
nil
#'(lambda (tuple)
- (destructuring-bind (cui cuilrl) tuple
- (funcall fn (make-instance 'ucon :cui (ensure-integer cui)
- :pfstr (find-pfstr-cui cui)
- :lrl (ensure-integer cuilrl)))))
+ (destructuring-bind (cui cuilrl) tuple
+ (funcall fn (make-instance 'ucon :cui (ensure-integer cui)
+ :pfstr (find-pfstr-cui cui)
+ :lrl (ensure-integer cuilrl)))))
(query-string mrconso (cui kcuilrl) srl nil nil :order (cui asc)
- :distinct t)
+ :distinct t)
:database db)))
(defun find-usty-word (word &key (srl *current-srl*))
"Return a list of usty that match word"
(collect-umlisp-query (mrsty (tui sty) srl sty word :lrl klrl :like t
- :distinct t)
+ :distinct t)
(make-instance 'usty :tui (ensure-integer tui) :sty sty)))
(defun find-urel-cui (cui &key (srl *current-srl*) filter without-pfstr2)
"Return a list of urel for cui"
(ensure-cui-integer cui)
(collect-umlisp-query (mrrel (aui1 rel stype1 cui2 aui2 stype2 rela rui srui sab sl rg dir suppress cvf)
- srl cui1 cui :lrl "KSRL" :filter filter)
+ srl cui1 cui :lrl "KSRL" :filter filter)
(let ((rel
(make-instance 'urel :cui1 cui :aui1 (ensure-integer aui1) :stype1 stype1 :rel rel
:cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2) :stype2 stype2
"Return the urel for a rui"
(ensure-rui-integer rui)
(collect-umlisp-query (mrrel (aui1 rel stype1 cui1 cui2 aui2 stype2 rela rui srui sab sl rg dir suppress cvf)
- srl rui rui :lrl "KSRL" :single t)
+ srl rui rui :lrl "KSRL" :single t)
(make-instance 'urel :cui1 cui1 :aui1 (ensure-integer aui1) :stype1 stype1 :rel rel
- :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2) :stype2 stype2
- :rui (ensure-integer rui) :srui srui :rela rela :sab sab :sl sl :rg rg :dir dir
- :suppress suppress :cvf cvf :pfstr2 (find-pfstr-cui cui2))))
+ :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2) :stype2 stype2
+ :rui (ensure-integer rui) :srui srui :rela rela :sab sab :sl sl :rg rg :dir dir
+ :suppress suppress :cvf cvf :pfstr2 (find-pfstr-cui cui2))))
(defun find-cui2-urel-cui (cui &key (srl *current-srl*))
"Return a list of urel for cui"
(ensure-cui-integer cui)
(collect-umlisp-query (mrrel (cui2) srl cui1
- cui :lrl "KSRL")
- cui2))
+ cui :lrl "KSRL")
+ cui2))
(defun find-urel-cui2 (cui2 &key (srl *current-srl*))
"Return a list of urel for cui2"
(ensure-cui-integer cui2)
(collect-umlisp-query (mrrel (rel cui1 aui1 stype1 aui2 stype2 rela rui srui sab sl rg dir suppress cvf)
- srl cui2 cui2 :lrl "KSRL")
+ srl cui2 cui2 :lrl "KSRL")
(make-instance 'urel :cui2 cui2 :rel rel :aui2 (ensure-integer aui2)
:stype2 stype2 :rui (ensure-integer rui) :srui srui
- :stype1 stype1 :cui1 (ensure-integer cui1)
+ :stype1 stype1 :cui1 (ensure-integer cui1)
:aui1 (ensure-integer aui1)
- :rela rela :sab sab :sl sl :rg rg :dir dir :suppress suppress :cvf cvf
- :pfstr2 (find-pfstr-cui cui2))))
+ :rela rela :sab sab :sl sl :rg rg :dir dir :suppress suppress :cvf cvf
+ :pfstr2 (find-pfstr-cui cui2))))
(defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*))
(ensure-cui-integer cui2)
(loop for cui in (remove-duplicates
- (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl)))
- collect (find-ucon-cui cui :srl srl)))
+ (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl)))
+ collect (find-ucon-cui cui :srl srl)))
(defun find-ucoc-cui (cui &key (srl *current-srl*))
"Return a list of ucoc for cui"
(ensure-cui-integer cui)
(collect-umlisp-query (mrcoc (aui1 cui2 aui2 sab cot cof coa) srl cui1
- cui :lrl klrl :order (cof asc))
+ cui :lrl klrl :order (cof asc))
(setq cui2 (ensure-integer cui2))
(when (eql 0 cui2) (setq cui2 nil))
(make-instance 'ucoc :cui1 cui :aui1 (ensure-integer aui1)
- :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2)
- :cot cot :cof (ensure-integer cof) :coa coa :sab sab
- :pfstr2 (find-pfstr-cui cui2))))
+ :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2)
+ :cot cot :cof (ensure-integer cof) :coa coa :sab sab
+ :pfstr2 (find-pfstr-cui cui2))))
(defun find-ucoc-cui2 (cui2 &key (srl *current-srl*))
"Return a list of ucoc for cui2"
(ensure-cui-integer cui2)
(collect-umlisp-query (mrcoc (cui1 aui1 aui2 sab cot cof coa) srl cui2
- cui2 :lrl klrl :order (cof asc))
+ cui2 :lrl klrl :order (cof asc))
(when (zerop cui2) (setq cui2 nil))
(make-instance 'ucoc :cui1 (ensure-integer cui1) :cui2 cui2
- :aui1 (ensure-integer aui1) :aui2 (ensure-integer aui2)
- :sab sab :cot cot :cof (ensure-integer cof) :coa coa
- :pfstr2 (find-pfstr-cui cui2))))
+ :aui1 (ensure-integer aui1) :aui2 (ensure-integer aui2)
+ :sab sab :cot cot :cof (ensure-integer cof) :coa coa
+ :pfstr2 (find-pfstr-cui cui2))))
(defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*))
"List of ucon with co-occurance cui2"
"Return a list of uterm for cui"
(ensure-cui-integer cui)
(collect-umlisp-query (mrconso (lui lat ts kluilrl) srl cui cui
- :lrl kluilrl :distinct t)
+ :lrl kluilrl :distinct t)
(make-instance 'uterm :lui (ensure-integer lui) :cui cui
- :lat lat :ts ts :lrl (ensure-integer kluilrl))))
+ :lat lat :ts ts :lrl (ensure-integer kluilrl))))
(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
- :lrl kluilrl :distinct t)
+ :lrl kluilrl :distinct t)
(make-instance 'uterm :cui (ensure-integer cui) :lui lui
- :lat lat :ts ts :lrl (ensure-integer kluilrl))))
+ :lat lat :ts ts :lrl (ensure-integer kluilrl))))
(defun find-uterm-cuilui (cui lui &key (srl *current-srl*))
"Return single uterm for cui/lui"
(ensure-cui-integer cui)
(ensure-lui-integer lui)
(collect-umlisp-query (mrconso (lat ts kluilrl) srl kcuilui
- (make-cuilui cui lui)
- :lrl kluilrl :single t)
+ (make-cuilui cui lui)
+ :lrl kluilrl :single t)
(make-instance 'uterm :cui cui :lui lui :lat lat :ts ts
- :lrl (ensure-integer kluilrl))))
+ :lrl (ensure-integer kluilrl))))
(defun find-ustr-cuilui (cui lui &key (srl *current-srl*))
"Return a list of ustr for cui/lui"
(ensure-cui-integer cui)
(ensure-lui-integer lui)
(collect-umlisp-query (mrconso (sui stt str suppress ksuilrl) srl kcuilui
- (make-cuilui cui lui) :lrl ksuilrl)
- (make-instance 'ustr :sui (ensure-integer sui) :cui cui :lui lui
- :cuisui (make-cuisui cui sui) :stt stt :str str :suppress suppress
- :lrl (ensure-integer ksuilrl))))
+ (make-cuilui cui lui) :lrl ksuilrl)
+ (make-instance 'ustr :sui (ensure-integer sui) :cui cui :lui lui
+ :cuisui (make-cuisui cui sui) :stt stt :str str :suppress suppress
+ :lrl (ensure-integer ksuilrl))))
(defun find-ustr-cuisui (cui sui &key (srl *current-srl*))
"Return the single ustr for cuisui"
(ensure-cui-integer cui)
(ensure-sui-integer sui)
(collect-umlisp-query (mrconso (lui stt str suppress ksuilrl) srl kcuisui
- (make-cuisui cui sui) :lrl lsuilrl :single t)
+ (make-cuisui cui sui) :lrl lsuilrl :single t)
(make-instance 'ustr :sui sui :cui cui :cuisui (make-cuisui cui sui)
- :lui (ensure-integer lui) :stt stt :str str :suppress suppress
- :lrl (ensure-integer ksuilrl))))
+ :lui (ensure-integer lui) :stt stt :str str :suppress suppress
+ :lrl (ensure-integer ksuilrl))))
(defun find-ustr-sui (sui &key (srl *current-srl*))
"Return the list of ustr for sui"
(ensure-sui-integer sui)
(collect-umlisp-query (mrconso (cui lui stt str suppress ksuilrl) srl sui sui
- :lrl ksuilrl)
+ :lrl ksuilrl)
(make-instance 'ustr :sui sui :cui cui :stt stt :str str
- :cuisui (make-cuisui (ensure-integer cui) sui)
- :suppress suppress
- :lui (ensure-integer lui) :lrl (ensure-integer ksuilrl))))
+ :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
- (append
- (multiple-value-list (decompose-cuisui cuisui))
- (list :srl srl))))))
+ (append
+ (multiple-value-list (decompose-cuisui cuisui))
+ (list :srl srl))))))
(defun find-ustr-all (&key (srl *current-srl*))
"Return list of all ustr's"
(clsql:map-query
'list
#'(lambda (tuple)
- (destructuring-bind (cui lui sui stt ksuilrl suppress) tuple
- (make-instance 'ustr :cui (ensure-integer cui)
- :lui (ensure-integer lui) :sui (ensure-integer sui)
- :stt stt :str (find-pfstr-cui cui)
- :cuisui (make-cuisui (ensure-integer cui)
- (ensure-integer sui))
- :suppress suppress
- :lrl (ensure-integer ksuilrl))))
+ (destructuring-bind (cui lui sui stt ksuilrl suppress) tuple
+ (make-instance 'ustr :cui (ensure-integer cui)
+ :lui (ensure-integer lui) :sui (ensure-integer sui)
+ :stt stt :str (find-pfstr-cui cui)
+ :cuisui (make-cuisui (ensure-integer cui)
+ (ensure-integer sui))
+ :suppress suppress
+ :lrl (ensure-integer ksuilrl))))
(query-string mrconso (cui lui sui stt ksuilrl) srl nil nil :lrl ksuilrl
- :distinct t
- :order (sui asc))
+ :distinct t
+ :order (sui asc))
:database db)))
(defun find-string-sui (sui &key (srl *current-srl*))
(collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui lat str)
srl kcuisui (make-cuisui cui sui) :lrl srl)
(make-instance 'uso :aui aui :sab sab :code code :srl srl :tty tty
- :cui cui :sui sui :saui saui :sdui sdui :scui scui
+ :cui cui :sui sui :saui saui :sdui sdui :scui scui
:lat lat :str str)))
(defun find-uso-cui (cui &key (srl *current-srl*) (english-only nil) limit)
(collect-umlisp-query (mrconso (sab cui sui code srl tty saui sdui scui lat
str) srl aui aui :lrl srl :single t)
(make-instance 'uso :aui aui :cui cui :sab sab :code code :srl srl :tty tty
- :sui sui :saui saui :sdui sdui :scui scui :lat lat
+ :sui sui :saui saui :sdui sdui :scui scui :lat lat
:str str)))
(defun find-uhier-cui (cui &key (srl *current-srl*))
(ensure-cui-integer cui)
(collect-umlisp-query (mrhier (aui cxn paui sab rela ptr hcd cvf)
- srl cui cui :lrl ksrl)
+ srl cui cui :lrl ksrl)
(make-instance 'uhier :cui cui :aui (ensure-integer aui)
- :cxn (ensure-integer cxn)
- :paui (ensure-integer paui)
- :sab sab :rela rela :ptr ptr :hcd hcd :cvf cvf)))
+ :cxn (ensure-integer cxn)
+ :paui (ensure-integer paui)
+ :sab sab :rela rela :ptr ptr :hcd hcd :cvf cvf)))
(defun find-uhier-all (&key (srl *current-srl*))
(collect-umlisp-query (mrhier (cui aui cxn paui sab rela ptr hcd cvf)
- srl nil nil :lrl ksrl)
+ srl nil nil :lrl ksrl)
(make-instance 'uhier :cui cui :aui (ensure-integer aui)
- :cxn (ensure-integer cxn)
- :paui (ensure-integer paui)
- :sab sab :rela rela :ptr ptr :hcd hcd :cvf cvf)))
+ :cxn (ensure-integer cxn)
+ :paui (ensure-integer paui)
+ :sab sab :rela rela :ptr ptr :hcd hcd :cvf cvf)))
(defun find-usat-ui (cui &optional lui sui &key (srl *current-srl*))
(ensure-cui-integer cui)
(let ((ls "SELECT CODE,ATN,SAB,ATV FROM MRSAT WHERE "))
(cond
(sui (string-append ls "KCUISUI='"
- (integer-string (make-cuisui cui sui) 14)
- "'"))
+ (integer-string (make-cuisui cui sui) 14)
+ "'"))
(lui (string-append ls "KCUILUI='"
- (integer-string (make-cuilui cui lui) 14)
- "' and sui='0'"))
+ (integer-string (make-cuilui cui lui) 14)
+ "' and sui='0'"))
(t (string-append ls "cui='" (prefixed-fixnum-string cui nil 7)
- "' and lui='0' and sui='0'")))
+ "' 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
- (destructuring-bind (code atn sab atv) tuple
- (make-instance 'usat :code code :atn atn :sab sab :atv atv)))))
+ (destructuring-bind (code atn sab atv) tuple
+ (make-instance 'usat :code code :atn atn :sab sab :atv atv)))))
(defun find-usty-tui (tui)
"Find usty for tui"
(defun find-usab-all ()
"Return all usab objects"
(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)
+ 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)
- :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)
- :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
- :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
- :curver curver :sabin sabin :ssn ssn :scit scit)))
+ :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)
+ :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
+ :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
+ :curver curver :sabin sabin :ssn ssn :scit scit)))
(defun find-usab-by-key (key-name key)
"Find usab for a key"
(collect-umlisp-query-eval ('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 key-name key :single t)
+ vend imeta rmeta slc scc srl tfr cfr cxty
+ ttyl atnl lat cenc curver sabin
+ ssn scit)
+ nil key-name key :single t)
(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)
- :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
- :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
- :curver curver :sabin sabin
- :ssn ssn :scit scit)))
+ :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)
+ :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
+ :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
+ :curver curver :sabin sabin
+ :ssn ssn :scit scit)))
(defun find-usab-rsab (rsab)
"Find usab for rsab"
(defun find-umap-cui (cui)
(ensure-cui-integer cui)
(collect-umlisp-query (mrmap (mapsetsab mapsubsetid maprank fromid fromsid fromexpr
- fromtype fromrule fromres rel rela toid tosid
- toexpr totype torule tores maprule maptype
- mapatn mapatv cvf)
- nil mapsetcui cui)
+ fromtype fromrule fromres rel rela toid tosid
+ toexpr totype torule tores maprule maptype
+ mapatn mapatv cvf)
+ nil mapsetcui cui)
(make-instance 'umap :mapsetcui cui :mapsetsab mapsetsab :mapsubsetid mapsubsetid
- :maprank (ensure-integer maprank) :fromid fromid :fromsid fromsid
- :fromexpr fromexpr :fromtype fromtype :fromrule fromrule :fromres fromres
- :rel rel :rela rela :toid toid :tosid tosid :toexpr toexpr :totype totype
- :torule torule :tores tores :maprule maprule :maptype maptype :mapatn mapatn
- :mapatv mapatv :cvf cvf)))
+ :maprank (ensure-integer maprank) :fromid fromid :fromsid fromsid
+ :fromexpr fromexpr :fromtype fromtype :fromrule fromrule :fromres fromres
+ :rel rel :rela rela :toid toid :tosid tosid :toexpr toexpr :totype totype
+ :torule torule :tores tores :maprule maprule :maptype maptype :mapatn mapatn
+ :mapatv mapatv :cvf cvf)))
(defun find-usmap-cui (cui)
(ensure-cui-integer cui)
(collect-umlisp-query (mrsmap (mapsetsab fromexpr fromtype rel rela toexpr totype cvf)
- nil mapsetcui cui)
+ nil mapsetcui cui)
(make-instance 'usmap :mapsetcui cui :mapsetsab mapsetsab
- :fromexpr fromexpr :fromtype fromtype
- :rel rel :rela rela :toexpr toexpr :totype totype
+ :fromexpr fromexpr :fromtype fromtype
+ :rel rel :rela rela :toexpr toexpr :totype totype
:cvf cvf)))
;;;; Cross table find functions
(defun find-ucon-normalized-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 ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t
- :lrl 'klrl :order '(cui asc))
+ :lrl 'klrl :order '(cui asc))
(find-ucon-cui cui :srl srl)))
(defun find-cui-normalized-word (word &key (srl *current-srl*) (like nil))
"Return list of cui that match word, optionally use SQL's LIKE syntax"
(collect-umlisp-query-eval ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t
- :lrl 'klrl :order '(cui asc))
- cui))
+ :lrl 'klrl :order '(cui asc))
+ cui))
(defun find-lui-normalized-word (word &key (srl *current-srl*) (like nil))
"Return list of cui that match word, optionally use SQL's LIKE syntax"
(collect-umlisp-query-eval ('mrxnw_eng '(lui) srl 'nwd word :like like :distinct t
- :lrl 'klrl :order '(cui asc))
- lui))
+ :lrl 'klrl :order '(cui asc))
+ lui))
(defun find-sui-normalized-word (word &key (srl *current-srl*) (like nil))
"Return list of cui that match word, optionally use SQL's LIKE syntax"
(collect-umlisp-query-eval ('mrxnw_eng '(sui) srl 'nwd word :like like :distinct t
- :lrl 'klrl :order '(cui asc))
- sui))
+ :lrl 'klrl :order '(cui asc))
+ sui))
(defun find-ustr-word (word &key sab (srl *current-srl*) (like nil))
"Return list of ustr that match word in matching SAB. Optionally, use SQL's LIKE syntax"
(defun find-ustr-normalized-word (word &key (srl *current-srl*))
"Return list of ustrs that match word"
(collect-umlisp-query (mrxnw_eng (cui sui) srl nwd word :lrl klrl
- :order (cui asc sui asc))
+ :order (cui asc sui asc))
(find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
(defun find-uterm-word (word &key (srl *current-srl*))
"Return list of uterms that match word"
(collect-umlisp-query (mrxw_eng (cui lui) srl wd word :lrl klrl
- :order (cui asc lui asc))
+ :order (cui asc lui asc))
(find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl)))
(defun find-uterm-normalized-word (word &key (srl *current-srl*))
"Return list of uterms that match word"
(collect-umlisp-query (mrxnw_eng (cui lui) srl nwd word :lrl klrl
- :order (cui asc lui asc))
+ :order (cui asc lui asc))
(find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl)))
(defun find-ucon-noneng-word (word &key (srl *current-srl*) (like nil))
"Return list of ucons that match non-english word"
(collect-umlisp-query-eval ('mrxw_noneng '(cui) srl 'wd word :like like
- :distinct t :lrl 'klrl :order '(cui asc))
+ :distinct t :lrl 'klrl :order '(cui asc))
(find-ucon-cui cui :srl srl)))
(defun find-ustr-noneng-word (word &key (srl *current-srl*))
"Return list of ustrs that match non-english word"
(collect-umlisp-query (mrxw_noneng (cui sui) srl wd word :lrl klrl
- :order (cui asc sui asc))
+ :order (cui asc sui asc))
(find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
;; Special tables
(dolist (word (delimited-string-to-list str #\space))
(setq uobjs (append uobjs (apply obj-lookup-fun word :srl srl extra-lookup-args))))
(let ((sorted
- (funcall sort-fun str
- (delete-duplicates uobjs :test #'= :key key))))
+ (funcall sort-fun str
+ (delete-duplicates uobjs :test #'= :key key))))
(let ((len (length sorted)))
(cond
((zerop len)
sorted))))))
(defun find-ucon-multiword (str &key (srl *current-srl*)
- (only-exact-if-match t)
+ (only-exact-if-match t)
limit
sab)
(find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str
:extra-lookup-args (list :sab sab)))
(defun find-uconso-multiword (str &key (srl *current-srl*)
- (only-exact-if-match t)
+ (only-exact-if-match t)
limit
sab)
(find-uobj-multiword str #'find-uconso-word #'sort-score-pfstr-str
:extra-lookup-args (list :sab sab)))
(defun find-uterm-multiword (str &key (srl *current-srl*)
- (only-exact-if-match t)
+ (only-exact-if-match t)
limit)
(find-uobj-multiword str #'find-uterm-word #'sort-score-pfstr-str
- #'lui srl only-exact-if-match limit))
+ #'lui srl only-exact-if-match limit))
(defun find-ustr-multiword (str &key (srl *current-srl*)
- (only-exact-if-match t)
+ (only-exact-if-match t)
limit
sab)
(find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str
(defun find-lexterm-word (wrd)
(collect-umlisp-query (lrwd (eui) nil wrd wrd)
(make-instance 'lexterm :eui (ensure-integer eui)
- :wrd (copy-seq wrd))))
+ :wrd (copy-seq wrd))))
;; LEX SQL Read functions
(ensure-eui-integer 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))))
+ :eui2 (ensure-integer eui2))))
(defun find-labr-bas (bas)
(collect-umlisp-query (labr (eui abr eui2 bas2) nil bas bas)
(make-instance 'labr :eui (ensure-integer eui) :abr abr :bas2 bas2
- :bas (copy-seq bas) :eui2 (ensure-integer eui2))))
+ :bas (copy-seq bas) :eui2 (ensure-integer eui2))))
(defun find-lagr-eui (eui)
(ensure-eui-integer eui)
(collect-umlisp-query (lragr (str sca agr cit bas) nil eui eui)
(make-instance 'lagr :eui eui :str str :sca sca :agr agr
- :cit cit :bas bas)))
+ :cit cit :bas bas)))
(defun find-lcmp-eui (eui)
(ensure-eui-integer eui)
(ensure-eui-integer eui)
(collect-umlisp-query (lrnom (bas sca eui2 bas2 sca2) nil eui eui)
(make-instance 'lnom :eui eui :bas bas :sca sca :bas2 bas2 :sca2 sca2
- :eui2 (ensure-integer eui2))))
+ :eui2 (ensure-integer eui2))))
(defun find-lprn-eui (eui)
(ensure-eui-integer eui)
(collect-umlisp-query (lrprn (bas num gnd cas pos qnt fea) nil eui eui)
(make-instance 'lprn :eui eui :bas bas :num num :gnd gnd
- :cas cas :pos pos :qnt qnt :fea fea)))
+ :cas cas :pos pos :qnt qnt :fea fea)))
(defun find-lprp-eui (eui)
(ensure-eui-integer eui)
(defun find-lwd-wrd (wrd)
(make-instance 'lwd :wrd wrd
- :euilist (collect-umlisp-query (lrwd (eui) nil wrd wrd)
- (ensure-integer eui))))
+ :euilist (collect-umlisp-query (lrwd (eui) nil wrd wrd)
+ (ensure-integer eui))))
;;; Semantic Network SQL access functions
(defun find-sdef-ui (ui)
(collect-umlisp-query (srdef (rt sty_rl stn_rtn def ex un rh abr rin)
- nil ui ui :single t)
+ nil ui ui :single t)
(make-instance 'sdef :rt rt :ui ui :styrl sty_rl :stnrtn stn_rtn
- :def def :ex ex :un un :rh rh :abr abr :rin rin)))
+ :def def :ex ex :un un :rh rh :abr abr :rin rin)))
(defun find-sstre1-ui (ui)
(collect-umlisp-query (srstre1 (ui2 ui3) nil ui ui)
(make-instance 'sstre1 :ui ui :ui2 (ensure-integer ui2)
- :ui3 (ensure-integer ui3))))
+ :ui3 (ensure-integer ui3))))
(defun find-sstre1-ui2 (ui2)
(collect-umlisp-query (srstre1 (ui ui3) nil ui2 ui2)
(make-instance 'sstre1 :ui (ensure-integer ui) :ui2 ui2
- :ui3 (ensure-integer ui3))))
+ :ui3 (ensure-integer ui3))))
(defun find-sstr-rl (rl)
(collect-umlisp-query (srstre (sty_rl sty_rl2 ls) nil rl rl)
((stringp srl-control)
(ensure-integer
(caar (sql-query (format nil "select count(~a) from ~a where ~a <= ~d"
- count-variable table srl-control srl)
- conn))))
+ count-variable table srl-control srl)
+ conn))))
((null srl-control)
(ensure-integer
(caar (sql-query (format nil "select count(~a) from ~a"
- count-variable table )
- conn))))
+ count-variable table )
+ conn))))
(t
(error "Unknown srl-control")
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))
- conn))
+ name count (if srl srl 3))
+ conn))
(defun find-ustats-all (&key (srl *current-srl*))
(if srl
(collect-umlisp-query (ustats (name count srl) nil srl srl
- :order (name asc))
- (make-instance 'ustats :name name
- :hits (ensure-integer count)
- :srl (ensure-integer srl)))
+ :order (name asc))
+ (make-instance 'ustats :name name
+ :hits (ensure-integer count)
+ :srl (ensure-integer srl)))
(collect-umlisp-query (ustats (name count srl) nil nil nil
- :order (name asc))
- (make-instance 'ustats :name name
- :hits (ensure-integer count)
- :srl (ensure-integer srl)))))
+ :order (name asc))
+ (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))))
+ (make-instance 'ustats :name name :hits (ensure-integer count))))
(defun sql-connect ()
"Connect to UMLS database, automatically used pooled connections"
(clsql:connect (umls-connection-spec)
- :database-type *umls-sql-type* :pool t))
+ :database-type *umls-sql-type* :pool t))
(defun sql-disconnect (conn)
"Disconnect from UMLS database, but put connection back into pool"
(defmacro with-sql-connection ((conn) &body body)
`(let ((,conn (sql-connect)))
(unwind-protect
- (progn ,@body)
+ (progn ,@body)
(when ,conn (clsql:disconnect :database ,conn)))))
(defun sql-query (cmd conn &key (result-types :auto))
(defmacro with-mutex-sql ((conn) &body body)
`(let ((,conn (sql-connect)))
(unwind-protect
- (progn ,@body)
+ (progn ,@body)
(when ,conn (sql-disconnect ,conn)))))
(defun mutex-sql-execute (cmd)
"SELECT SAB,DEF FROM MRDEF WHERE CUI='39' AND KSRL<=2 ORDER BY CUI asc")
(deftest :qrystr/8 (umlisp::query-string mrdef (sab def) 2 cui 39 :lrl ksrl
- :order (cui asc def desc))
+ :order (cui asc def desc))
"SELECT SAB,DEF FROM MRDEF WHERE CUI='39' AND KSRL<=2 ORDER BY CUI asc,DEF desc")
(deftest :qrystr/8e (umlisp::query-string-eval 'mrdef '(sab def) 2 'cui 39 :lrl 'ksrl
- :order '(cui asc def desc))
+ :order '(cui asc def desc))
"SELECT SAB,DEF FROM MRDEF WHERE CUI='39' AND KSRL<=2 ORDER BY CUI asc,DEF desc")
(deftest :ui/1 (umlisp::parse-cui "C0002341") 2341)
(setq *rt-parse*
'(
(deftest :parse/1
- (umlisp::decompose-fil "abc")
+ (umlisp::decompose-fil "abc")
"abc" nil)
(deftest :parse/2
- (umlisp::decompose-fil "dir/abc")
+ (umlisp::decompose-fil "dir/abc")
"abc" "dir")
(deftest :parse/3
- (umlisp::decompose-fil nil)
+ (umlisp::decompose-fil nil)
nil nil)
(deftest :parse/4
- (umlisp::filename-to-tablename "test")
+ (umlisp::filename-to-tablename "test")
"test")
(deftest :parse/5
- (umlisp::filename-to-tablename "TEST.AB.RRF")
+ (umlisp::filename-to-tablename "TEST.AB.RRF")
"TEST_AB")))
;; specific for UMLS2007AA
(deftest uparse.1 (length *umls-files*) 63)
(deftest uparse.2 (length *umls-cols*) 452)
(deftest uparse.3
- (sort (mapcar #'u::col (umlisp::ucols (umlisp::find-ufile "MRCONSO.RRF")))
- #'string<)
- ("AUI" "CODE" "CUI" "CVF" "ISPREF" "KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL"
+ (sort (mapcar #'u::col (umlisp::ucols (umlisp::find-ufile "MRCONSO.RRF")))
+ #'string<)
+ ("AUI" "CODE" "CUI" "CVF" "ISPREF" "KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL"
"KPFENG" "KSUILRL" "LAT" "LUI" "SAB" "SAUI" "SCUI" "SDUI" "SRL" "STR" "STT"
"SUI" "SUPPRESS" "TS" "TTY"))
(deftest uparse.4
- (equal
- (sort (mapcar #'u::col (umlisp::ucols (umlisp::find-ufile "MRCONSO.RRF")))
- #'string<)
- (sort (copy-seq (umlisp::fields (umlisp::find-ufile "MRCONSO.RRF")))
- #'string<))
- t)
+ (equal
+ (sort (mapcar #'u::col (umlisp::ucols (umlisp::find-ufile "MRCONSO.RRF")))
+ #'string<)
+ (sort (copy-seq (umlisp::fields (umlisp::find-ufile "MRCONSO.RRF")))
+ #'string<))
+ t)
(deftest uparse.5
- (sort
- (umlisp::custom-colnames-for-filename "MRCONSO.RRF")
- #'string<)
- ("KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFENG" "KSUILRL"))
+ (sort
+ (umlisp::custom-colnames-for-filename "MRCONSO.RRF")
+ #'string<)
+ ("KCUILRL" "KCUILUI" "KCUISUI" "KLUILRL" "KPFENG" "KSUILRL"))
(deftest uparse.6
- (compiled-function-p
- (umlisp::custom-value-fun
- (umlisp::find-ucol "KCUISUI" "MRCONSO.RRF")))
- t)
+ (compiled-function-p
+ (umlisp::custom-value-fun
+ (umlisp::find-ucol "KCUISUI" "MRCONSO.RRF")))
+ t)
))))
(declare (optimize (speed 3) (safety 0)))
(if (stringp cui)
(let ((ch (schar cui 0)))
- (if (char-equal ch #\C)
- (parse-ui cui)
- (nth-value 0 (parse-integer cui))))
+ (if (char-equal ch #\C)
+ (parse-ui cui)
+ (nth-value 0 (parse-integer cui))))
cui))
(defun parse-lui (lui)
(declare (optimize (speed 3) (safety 0)))
(if (stringp lui)
(let ((ch (schar lui 0)))
- (if (char-equal ch #\L)
- (parse-ui lui)
- (nth-value 0 (parse-integer lui))))
+ (if (char-equal ch #\L)
+ (parse-ui lui)
+ (nth-value 0 (parse-integer lui))))
lui))
(defun parse-sui (sui)
(declare (optimize (speed 3) (safety 0)))
(if (stringp sui)
(let ((ch (schar sui 0)))
- (if (char-equal ch #\S)
- (parse-ui sui)
- (nth-value 0 (parse-integer sui))))
+ (if (char-equal ch #\S)
+ (parse-ui sui)
+ (nth-value 0 (parse-integer sui))))
sui))
(defun parse-tui (tui)
(declare (optimize (speed 3) (safety 0)))
(if (stringp tui)
(let ((ch (schar tui 0)))
- (if (char-equal ch #\T)
- (parse-ui tui)
- (nth-value 0 (parse-integer tui))))
+ (if (char-equal ch #\T)
+ (parse-ui tui)
+ (nth-value 0 (parse-integer tui))))
tui))
(defun parse-aui (aui)
(declare (optimize (speed 3) (safety 0)))
(if (stringp aui)
(let ((ch (schar aui 0)))
- (if (char-equal ch #\A)
- (parse-ui aui)
- (nth-value 0 (parse-integer aui))))
+ (if (char-equal ch #\A)
+ (parse-ui aui)
+ (nth-value 0 (parse-integer aui))))
aui))
(defun parse-rui (rui)
(declare (optimize (speed 3) (safety 0)))
(if (stringp rui)
(let ((ch (schar rui 0)))
- (if (char-equal ch #\R)
- (parse-ui rui)
+ (if (char-equal ch #\R)
+ (parse-ui rui)
(nth-value 0 (parse-integer rui))))
rui))
(declare (optimize (speed 3) (safety 0)))
(if (stringp eui)
(let ((ch (schar eui 0)))
- (if (char-equal ch #\E)
- (parse-ui eui)
- (nth-value 0 (parse-integer eui))))
+ (if (char-equal ch #\E)
+ (parse-ui eui)
+ (nth-value 0 (parse-integer eui))))
eui))
(defconstant +cuisui-scale+ 10000000)
#-(or 64bit x86-64)
(defun make-cuilui (cui lui)
(declare (fixnum cui lui)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 0) (space 0)))
(+ (* +cuisui-scale+ cui) lui))
(defun decompose-cuisui (cuisui)
(dolist (uterm (s#term ucon))
(dolist (ustr (s#str uterm))
(when (string-equal sui (sui ustr))
- (return-from find-ustr-in-ucon ustr)))))
+ (return-from find-ustr-in-ucon ustr)))))
projects / umlisp.git / commitdiff