(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)))))
projects / umlisp-orf.git / commitdiff