--- /dev/null
+;;;; $Id: data-structures.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $
+
+(in-package :umlisp)
+
+
+;;; Paths for files
+
+(defvar *umls-path*
+ (kboot:find-directory
+ '((nil (:absolute "data" "umls" "2002AC"))
+ (nil (:absolute "data" "umls" "2002AB"))
+ (nil (:absolute "data" "umls" "UMLS2001"))
+ #+mswindows ("F" (:absolute "umls" "2002ac"))
+ #+mswindows ("C" (:absolute "umls"))
+ #+mswindows ("F" (:absolute "umls" "UMLS2001"))
+ ))
+ "Path for base of UMLS data files")
+
+(defvar *meta-path*
+ (merge-pathnames
+ (make-pathname :directory '(:relative "META"))
+ *umls-path*))
+
+(defvar *lex-path*
+ (merge-pathnames
+ (make-pathname :directory '(:relative "LEX"))
+ *umls-path*))
+
+(defvar *net-path*
+ (merge-pathnames
+ (make-pathname :directory '(:relative "NET"))
+ *umls-path*))
+
+(defun umls-path! (p)
+ (setq *umls-path* p))
+
+
+;;; Structures for parsing UMLS text files
+
+(defparameter *umls-files* nil
+ "List of umls file structures. Used when parsing text files.")
+(defparameter *umls-cols* nil
+ "List of meta column structures. Used when parsing text files.")
+
--- /dev/null
+cl-umlisp (1.0-1) unstable; urgency=low
+
+ * Initial Release.
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Sat, 5 Oct 2002 12:52:28 -0600
+
--- /dev/null
+Source: cl-umlisp
+Section: contrib/devel
+Priority: optional
+Maintainer: Kevin M. Rosenberg <kmr@debian.org>
+Build-Depends-Indep: debhelper (>= 4.0.0)
+Standards-Version: 3.5.7.0
+
+Package: cl-umlisp
+Architecture: all
+Depends: ${shlibs:Depends}
+Description: Common Lisp interface for the Unified Medical Language System
+ The Unified Medical Language System is a multi-gigabyte database of
+ medical terminology. This a interface for Common Lisp programs that utilizes
+ the a SQL database engine and Common Lisp classes for efficient access.
+
--- /dev/null
+This package was debianized by Kevin M. Rosenberg <kmr@debian.org> on
+Sat, 5 Oct 2002 12:52:28 -0600.
+
+It was downloaded from ftp://umlisp.b9.com
+
+Upstream Author: Kevin M. Rosenberg <kevin@rosenberg.net>
+
+Copyright:
+
+UMLisp is Copyright (C) 2000-2002 by Kevin M. Rosenberg
+It is open-source software govened by the GNU GPL License.
+
+The GNU GPL License is in your Debian file system as
+/usr/share/common-licenses/GPL.
--- /dev/null
+#! /bin/sh
+#
+# see: dh_installdeb(1)
+
+set -e
+
+# package name according to lisp
+LISP_PKG=umlisp
+
+# summary of how this script can be called:
+# * <postinst> `configure' <most-recently-configured-version>
+# * <old-postinst> `abort-upgrade' <new version>
+# * <conflictor's-postinst> `abort-remove' `in-favour' <package>
+# <new-version>
+# * <deconfigured's-postinst> `abort-deconfigure' `in-favour'
+# <failed-install-package> <version> `removing'
+# <conflicting-package> <version>
+# for details, see http://www.debian.org/doc/debian-policy/ or
+# the debian-policy package
+#
+# quoting from the policy:
+# Any necessary prompting should almost always be confined to the
+# post-installation script, and should be protected with a conditional
+# so that unnecessary prompting doesn't happen if a package's
+# installation fails and the `postinst' is called with `abort-upgrade',
+# `abort-remove' or `abort-deconfigure'.
+
+case "$1" in
+ configure)
+ /usr/sbin/register-common-lisp-source ${LISP_PKG}
+ ;;
+ abort-upgrade|abort-remove|abort-deconfigure)
+ ;;
+ *)
+ echo "postinst called with unknown argument \`$1'" >&2
+ exit 1
+ ;;
+esac
+
+# dh_installdeb will replace this with shell code automatically
+# generated by other debhelper scripts.
+
+#DEBHELPER#
+
+exit 0
--- /dev/null
+#! /bin/sh
+#
+# see: dh_installdeb(1)
+
+set -e
+
+# package name according to lisp
+LISP_PKG=umlisp
+
+# summary of how this script can be called:
+# * <prerm> `remove'
+# * <old-prerm> `upgrade' <new-version>
+# * <new-prerm> `failed-upgrade' <old-version>
+# * <conflictor's-prerm> `remove' `in-favour' <package> <new-version>
+# * <deconfigured's-prerm> `deconfigure' `in-favour'
+# <package-being-installed> <version> `removing'
+# <conflicting-package> <version>
+# for details, see http://www.debian.org/doc/debian-policy/ or
+# the debian-policy package
+
+
+case "$1" in
+ remove|upgrade|deconfigure)
+ /usr/sbin/unregister-common-lisp-source ${LISP_PKG}
+ ;;
+ failed-upgrade)
+ ;;
+ *)
+ echo "prerm called with unknown argument \`$1'" >&2
+ exit 1
+ ;;
+esac
+
+# dh_installdeb will replace this with shell code automatically
+# generated by other debhelper scripts.
+
+#DEBHELPER#
+
+exit 0
+
+
--- /dev/null
+#!/usr/bin/make -f
+
+export DH_COMPAT=4
+
+pkg := umlisp
+debpkg := cl-umlisp
+
+
+clc-source := usr/share/common-lisp/source
+clc-systems := usr/share/common-lisp/systems
+clc-umlisp := $(clc-source)/$(pkg)
+
+doc-dir := usr/share/doc/$(debpkg)
+
+
+configure: configure-stamp
+configure-stamp:
+ dh_testdir
+ # Add here commands to configure the package.
+
+ touch configure-stamp
+
+
+build: build-stamp
+
+build-stamp: configure-stamp
+ dh_testdir
+ # Add here commands to compile the package.
+ touch build-stamp
+
+clean:
+ dh_testdir
+ dh_testroot
+ rm -f build-stamp configure-stamp
+ # Add here commands to clean up after the build process.
+ rm -f debian/cl-umlisp.postinst.* debian/cl-umlisp.prerm.*
+ dh_clean
+
+install: build
+ dh_testdir
+ dh_testroot
+ dh_clean -k
+ # Add here commands to install the package into debian/umlisp.
+ dh_installdirs $(clc-systems) $(clc-umlisp) $(doc-dir)
+ dh_install umlisp.asd $(shell echo *.lisp) $(clc-umlisp)
+ #dh_install $(shell echo *.html) $(doc-dir)
+ dh_link $(clc-umlisp)/umlisp.asd $(clc-systems)/umlisp.asd
+
+# Build architecture-independent files here.
+binary-indep: build install
+
+
+# Build architecture-dependent files here.
+binary-arch: build install
+ dh_testdir
+ dh_testroot
+# dh_installdebconf
+ dh_installdocs
+# dh_installmenu
+# dh_installlogrotate
+# dh_installemacsen
+# dh_installpam
+# dh_installmime
+# dh_installinit
+# dh_installcron
+# dh_installman
+# dh_installinfo
+# dh_undocumented
+ dh_installchangelogs
+ dh_strip
+ dh_compress
+ dh_fixperms
+# dh_makeshlibs
+ dh_installdeb
+# dh_perl
+ dh_shlibdeps
+ dh_gencontrol
+ dh_md5sums
+ dh_builddeb
+
+binary: binary-indep binary-arch
+.PHONY: build clean binary-indep binary-arch binary install configure
+
--- /dev/null
+;;;; $Id: obj-composite.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $
+
+(in-package :umlisp)
+
+
+;;; Semantic type constants
+
+(defun find-tui-word (words)
+ (gu:aif (car (find-usty-word words))
+ (tui gu::it)
+ nil))
+(gu:memoize 'find-tui-word)
+
+(defun tui-disease-or-syndrome ()
+ (find-tui-word "disease or syndrome"))
+(defun tui-sign-or-symptom ()
+ (find-tui-word "sign or symptom"))
+(defun tui-finding ()
+ (find-tui-word "finding"))
+
+
+;;;; Related concepts with specific tui lookup functions
+
+(defun ucon-is-tui? (ucon tui)
+ "Returns t if ucon has a semantic type of tui"
+ (find tui (s#sty ucon) :key #'tui))
+
+(defun find-ucon2-tui (ucon tui cui2-func related-con-func)
+ "Returns a list of related ucons that have specific tui"
+ (remove-duplicates
+ (filter
+ #'(lambda (c)
+ (gu:aif (funcall cui2-func c)
+ (let ((ucon2 (find-ucon-cui gu::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))
+
+;;; Composite Objects
+
+(defclass ucon_freq (umlsclass)
+ ((ucon :type ucon :initarg :ucon :reader ucon)
+ (freq :type fixnum :initarg :freq :accessor freq))
+ (:metaclass ml-class)
+ (:default-initargs :cui nil :pfstr nil :freq nil)
+ (:title "Concept and Count")
+ (:fields (cui :string fmt-cui) (freq :fixnum) (pfstr :cdata))
+ (:ref-fields (cui find-ucon-cui))
+ (:documentation "Composite object of ucon/freq"))
+
+(defun ucon_freq-cui (c)
+ (cui (ucon c)))
+
+(defun ucon_freq-pfstr (c)
+ (pfstr (ucon c)))
+
+(defclass ustr_freq (umlsclass)
+ ((ustr :type ustr :initarg :ustr :reader ustr)
+ (freq :type fixnum :initarg :freq :accessor freq))
+ (:metaclass ml-class)
+ (:default-initargs :cui nil :pfstr nil :freq nil)
+ (:title "String and Count")
+ (:fields (sui :string fmt-sui) (freq :fixnum) (stt :string) (lrl :fixnum) (str :cdata))
+ (:ref-fields (sui find-ustr-sui))
+ (:documentation "Composite object of ustr/freq"))
+
+(defun ustr_freq-sui (s)
+ (sui (ustr s)))
+
+(defun ustr_freq-str (s)
+ (str (ustr s)))
+
+(defun ustr_freq-lrl (s)
+ (lrl (ustr s)))
+
+(defun ustr_freq-stt (s)
+ (stt (ustr s)))
+
+(defclass usty_freq (umlsclass)
+ ((usty :type usty :initarg :usty :reader usty)
+ (freq :type fixnum :initarg :freq :accessor freq))
+ (:metaclass ml-class)
+ (:default-initargs :usty nil :freq nil)
+ (:title "Semantic Type and Count")
+ (:ref-fields (tui find-ucon-tui "subobjects=no"))
+ (:fields (tui :string fmt-tui) (freq :fixnum) (sty :string))
+ (:documentation "Composite object of usty/freq"))
+
+(defun usty_freq-tui (s)
+ (tui (usty s)))
+
+(defun usty_freq-sty (s)
+ (sty (usty s)))
+
+(defclass usrl_freq (umlsclass)
+ ((usrl :type usrl :initarg :usrl :reader usrl)
+ (freq :type fixnum :initarg :freq :accessor freq))
+ (:metaclass ml-class)
+ (:default-initargs :usrl nil :freq nil)
+ (:title "Source and Count")
+ (:ref-fields (sab find-ustr-sab))
+ (:fields (sab :string) (freq :commainteger) (srl :fixnum))
+ (:documentation "Composite object of usrl/freq"))
+
+(defun usrl_freq-sab (s)
+ (sab (usrl s)))
+
+(defun usrl_freq-srl (s)
+ (srl (usrl s)))
+
+
+;; Frequency finding functions
+(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))
+ (gu:aif (cui2 ucoc)
+ (let ((ucon2 (find-ucon-cui gu::it)))
+ (when (ucon-is-tui? ucon2 tui)
+ (push (make-instance 'ucon_freq :ucon 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))))
+ (if (and ucon 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"
+ (find-ucon2-str&sty str sty #'find-ucon2-coc-tui))
+
+(defun find-ucon2-rel-str&sty (str sty)
+ "Find all ucons that are a relationship to concept named str
+ and that have semantic type of sty"
+ (find-ucon2-str&sty str sty #'find-ucon2-rel-tui))
+
+;;; Most common relationships, co-occurances
+
+(defun find-ucon2_freq-tui-all (tui ucon2-tui-func)
+ "Return sorted list of all ucon2 that have a semantic type tui with ucon that is also has sty of tui"
+ (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
+ (gu:aif (aref ucon_freqs (cui ucon2))
+ (setf (freq gu::it) (1+ (freq gu::it)))
+ (setf (aref ucon_freqs (cui ucon2))
+ (make-instance 'ucon_freq :ucon ucon2 :freq 1)))))
+ (let ((ucon_freq-list '()))
+ (dotimes (i (find-cui-max))
+ (declare (fixnum i))
+ (gu:awhen (aref ucon_freqs i)
+ (push gu::it ucon_freq-list)))
+ (sort ucon_freq-list #'> :key #'freq))))
+
+(defun find-ucon2_freq-rel-tui-all (tui)
+ "Sorted list of ucon_freq with semantic type tui that are rel's of ucons with semantic type tui"
+ (find-ucon2_freq-tui-all tui #'find-ucon2-rel-tui))
+
+(defun find-ucon2_freq-coc-tui-all (tui)
+ (find-ucon2_freq-tui-all tui #'find-ucon2-coc-tui))
+
--- /dev/null
+;;; $Id: obj-sql.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $
+
+(in-package :umlisp)
+
+(declaim (optimize (speed 3) (safety 1)))
+
+(defvar *current-srl* nil)
+(defun current-srl ()
+ *current-srl*)
+(defun current-srl! (srl)
+ (setq *current-srl* srl))
+
+;;; Initializers
+
+(defun post-import-sql ()
+ (make-ustats)
+ (make-usrl)
+ (make-user-table)
+ #+pubmed (create-pmsearch-table))
+
+;;; Accessors (read on demand)
+
+;; defines a slot-unbound method for class and slot-name, fills
+;; the slot by calling reader function with the slot values of
+;; the instance's reader-keys
+(defmacro def-lazy-reader (class slot-name reader &rest reader-keys)
+ (let* ((the-slot-name (gensym))
+ (the-class (gensym))
+ (the-instance (gensym))
+ (keys '()))
+ (dolist (key reader-keys)
+ (push (list 'slot-value the-instance (list 'quote key)) keys))
+ (setq keys (nreverse keys))
+ `(defmethod slot-unbound (,the-class (,the-instance ,class)
+ (,the-slot-name (eql ',slot-name)))
+ (declare (ignore ,the-class))
+ (setf (slot-value ,the-instance ,the-slot-name)
+ (,reader ,@keys)))))
+
+(def-lazy-reader ucon s#term find-uterm-cui cui)
+(def-lazy-reader ucon s#def find-udef-cui cui)
+(def-lazy-reader ucon s#sty find-usty-cui cui)
+(def-lazy-reader ucon s#rel find-urel-cui cui)
+(def-lazy-reader ucon s#coc find-ucoc-cui cui)
+(def-lazy-reader ucon s#lo find-ulo-cui cui)
+(def-lazy-reader ucon s#atx find-uatx-cui cui)
+(def-lazy-reader ucon s#sat find-usat-ui cui)
+
+;; For uterms
+(def-lazy-reader uterm s#str find-ustr-cuilui cui lui)
+(def-lazy-reader uterm s#sat find-usat-ui cui lui)
+
+;; For ustrs
+(def-lazy-reader ustr s#sat find-usat-ui cui lui sui)
+(def-lazy-reader ustr s#cxt find-ucxt-cuisui cui sui)
+(def-lazy-reader ustr s#so find-uso-cuisui cui sui)
+
+;;; Object lookups
+
+;;; Lookup functions for uterms,ustr in ucons
+
+(defun find-uterm-in-ucon (ucon lui)
+ (find lui (s#term ucon) :key #'uterm-lui :test 'equal))
+
+(defun find-ustr-in-uterm (uterm sui)
+ (find sui (s#str uterm) :key #'ustr-sui :test 'equal))
+
+(defun find-ustr-in-ucon (ucon sui)
+ (let ((found-ustr nil))
+ (dolist (uterm (s#term ucon))
+ (unless found-ustr
+ (dolist (ustr (s#str uterm))
+ (unless found-ustr
+ (when (string-equal sui (sui ustr))
+ (setq found-ustr ustr))))))
+ found-ustr))
+
+
+(defun find-ucon-cui (cui &key (srl *current-srl*))
+ "Find ucon for a cui"
+ (if (stringp cui)
+ (setq cui (parse-cui cui)))
+ (if cui
+ (let ((ls (format nil "select KPFSTR,KCUILRL from MRCON where CUI=~d"
+ cui)))
+ (if srl
+ (string-append ls (format nil " and KCUILRL <= ~d limit 1" srl))
+ (string-append ls " limit 1"))
+ (gu:awhen (car (mutex-sql-query ls))
+ (make-instance 'ucon :cui cui :pfstr (car gu::it)
+ :lrl (ensure-integer (cadr gu::it)))))
+ nil))
+
+(defun find-ucon-lui (lui &key (srl *current-srl*))
+ "Find list of ucon for lui"
+ (if (stringp lui)
+ (setq lui (parse-lui lui)))
+ (if lui
+ (let ((ucons '())
+ (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where LUI=~d" lui)))
+ (if srl
+ (string-append ls (format nil " and KCUILRL <= ~d" srl)))
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple))
+ :pfstr (nth 1 tuple)
+ :lrl (ensure-integer (nth 2 tuple)))
+ ucons))
+ (nreverse ucons))
+ nil))
+
+(defun find-ucon-sui (sui &key (srl *current-srl*))
+ "Find list of ucon for sui"
+ (if (stringp sui)
+ (setq sui (parse-sui sui)))
+ (if sui
+ (let ((ucons '())
+ (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where SUI=~d" sui)))
+ (when srl
+ (string-append ls (format nil " and KCUILRL <= ~d" srl)))
+ (let ((tuples (mutex-sql-query ls)))
+ (dolist (tuple tuples)
+ (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple))
+ :pfstr (nth 1 tuple)
+ :lrl (ensure-integer (nth 2 tuple)))
+ ucons)))
+ (nreverse ucons))
+ nil))
+
+(defun find-ucon-cuisui (cui sui &key (srl *current-srl*))
+ "Find ucon for cui/sui"
+ (if (stringp cui)
+ (setq cui (parse-cui cui)))
+ (if (stringp sui)
+ (setq sui (parse-sui sui)))
+ (if (and cui sui)
+ (let ((ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where KCUISUI=~d"
+ (make-cuisui cui sui))))
+ (when srl
+ (string-append ls (format nil " and KCUILRL <= ~d" srl)))
+ (gu:aif (car (mutex-sql-query ls))
+ (make-instance 'ucon :cui (ensure-integer (nth 0 gu::it))
+ :pfstr (nth 1 gu::it)
+ :lrl (ensure-integer (nth 2 gu::it)))
+ nil))
+ nil))
+
+(defun find-ucon-str (str &key (srl *current-srl*))
+ "Find ucon that are exact match for str"
+ (if str
+ (let ((ucons '())
+ (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where STR='~a'" str)))
+ (when srl
+ (string-append ls " and KCUILRL <= ~d" srl))
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple))
+ :pfstr (nth 1 tuple)
+ :lrl (ensure-integer (nth 2 tuple))) ucons))
+ (nreverse ucons))
+ nil))
+
+(defun find-ucon-all (&key (srl *current-srl*))
+ "Return list of all ucon's"
+ (let ((ls "select distinct CUI,KPFSTR,KCUILRL from MRCON"))
+ (when srl
+ (string-append ls (format nil " where KCUILRL <= ~d" srl)))
+ (string-append ls " order by CUI asc")
+ (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)))
+ ls
+ :database db))))
+
+
+
+(defun find-udef-cui (cui &key (srl *current-srl*))
+ "Return a list of udefs for cui"
+ (let ((udefs '())
+ (ls (format nil "select SAB,DEF from MRDEF where CUI=~d" cui)))
+ (when srl
+ (string-append ls (format nil " and KSRL <= ~d" srl)))
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'udef :sab (car tuple) :def (cadr tuple)) udefs))
+ (nreverse udefs)))
+
+(defun find-usty-cui (cui &key (srl *current-srl*))
+ "Return a list of usty for cui"
+ (let ((ustys '())
+ (ls (format nil "select TUI,STY from MRSTY where CUI=~d" cui)))
+ (when srl
+ (string-append ls (format nil " and KLRL <= ~d" srl)))
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'usty :tui (ensure-integer (car tuple)) :sty (cadr tuple)) ustys))
+ ustys))
+
+(defun find-usty-word (word &key (srl *current-srl*))
+ "Return a list of usty that match word"
+ (let ((ustys '())
+ (ls (format nil "select distinct TUI,STY from MRSTY where STY like '%~a%'" word)))
+ (when srl
+ (string-append ls (format nil " and KLRL <= ~d" srl)))
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'usty :tui (ensure-integer (car tuple)) :sty (cadr tuple)) ustys))
+ ustys))
+
+(defun find-urel-cui (cui &key (srl *current-srl*))
+ "Return a list of urel for cui"
+ (let ((urels '())
+ (ls (format nil "select REL,CUI2,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI1=~d" cui)))
+ (when srl
+ (string-append ls (format nil " and KSRL <= ~d" srl)))
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'urel
+ :cui1 cui
+ :rel (nth 0 tuple)
+ :cui2 (ensure-integer (nth 1 tuple))
+ :rela (nth 2 tuple)
+ :sab (nth 3 tuple)
+ :sl (nth 4 tuple)
+ :mg (nth 5 tuple)
+ :pfstr2 (nth 6 tuple))
+ urels))
+ (nreverse urels)))
+
+(defun find-urel-cui2 (cui2 &key (srl *current-srl*))
+ "Return a list of urel for cui2"
+ (let ((urels '())
+ (ls (format nil "select REL,CUI1,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI2=~d" cui2)))
+ (when srl
+ (string-append ls (format nil " and SRL <= ~d" srl)))
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'urel
+ :cui2 cui2
+ :rel (nth 0 tuple)
+ :cui1 (ensure-integer (nth 1 tuple))
+ :rela (nth 2 tuple)
+ :sab (nth 3 tuple)
+ :sl (nth 4 tuple)
+ :mg (nth 5 tuple)
+ :pfstr2 (nth 6 tuple))
+ urels))
+ (nreverse urels)))
+
+(defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*))
+ (mapcar
+ #'(lambda (cui) (find-ucon-cui cui :key srl))
+ (remove-duplicates (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl)))))
+
+(defun find-ucoc-cui (cui &key (srl *current-srl*))
+ "Return a list of ucoc for cui"
+ (let ((ucocs '())
+ (ls (format nil "select CUI2,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI1=~d" cui)))
+ (when srl
+ (string-append ls (format nil " and KLRL <= ~d" srl)))
+ (string-append ls " order by COF asc")
+ (dolist (tuple (mutex-sql-query ls))
+ (let ((cui2 (ensure-integer (nth 0 tuple))))
+ (when (zerop cui2)
+ (setq cui2 nil))
+ (push (make-instance 'ucoc :cui1 cui
+ :cui2 cui2
+ :soc (nth 1 tuple)
+ :cot (nth 2 tuple)
+ :cof (ensure-integer (nth 3 tuple))
+ :coa (nth 4 tuple)
+ :pfstr2 (nth 5 tuple))
+ ucocs)))
+ ucocs)) ;; akready ordered by SQL select
+
+(defun find-ucoc-cui2 (cui2 &key (srl *current-srl*))
+ "Return a list of ucoc for cui2"
+ (let ((ucocs '())
+ (ls (format nil "select CUI1,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI2=~d" cui2)))
+ (when srl
+ (string-append ls (format nil " and KSRL <= ~d" srl)))
+ (string-append ls " order by COF asc")
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'ucoc :cui1 (ensure-integer (nth 0 tuple))
+ :cui2 cui2
+ :soc (nth 1 tuple)
+ :cot (nth 2 tuple)
+ :cof (ensure-integer (nth 3 tuple))
+ :coa (nth 4 tuple)
+ :pfstr2 (nth 5 tuple))
+ ucocs))
+ ucocs)) ;; already ordered by SQL select
+
+(defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*))
+ "List of ucon with co-occurance cui2"
+ (mapcar
+ #'(lambda (cui) (find-ucon-cui cui :key srl))
+ (remove-duplicates (mapcar #'cui1 (find-ucoc-cui2 cui2 :srl srl)))))
+
+(defun find-ulo-cui (cui &key (srl *current-srl*))
+ "Return a list of ulo for cui"
+ (let ((ulos '())
+ (ls (format nil "select ISN,FR,UN,SUI,SNA,SOUI from MRLO where CUI=~d" cui)))
+ (when srl
+ (string-append ls (format nil " and KLRL <= ~d" srl)))
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'ulo :isn (nth 0 tuple)
+ :fr (ensure-integer (nth 1 tuple))
+ :un (nth 2 tuple)
+ :sui (ensure-integer (nth 3 tuple))
+ :sna (nth 4 tuple)
+ :soui (nth 5 tuple))
+ ulos))
+ (nreverse ulos)))
+
+(defmethod suistr ((lo ulo))
+ "Return the string for a ulo object"
+ (find-string-sui (sui lo)))
+
+(defun find-uatx-cui (cui &key (srl *current-srl*))
+ "Return a list of uatx for cui"
+ (let ((uatxs '())
+ (ls (format nil "select SAB,REL,ATX from MRATX where CUI=~d" cui)))
+ (when srl
+ (string-append ls (format nil " and KSRL <= ~d" srl)))
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'uatx :sab (nth 0 tuple)
+ :rel (nth 1 tuple)
+ :atx (nth 2 tuple))
+ uatxs))
+ (nreverse uatxs)))
+
+
+(defun find-uterm-cui (cui &key (srl *current-srl*))
+ "Return a list of uterm for cui"
+ (let ((uterms '())
+ (ls (format nil "select distinct LUI,LAT,TS,KLUILRL from MRCON where CUI=~d" cui)))
+ (when srl
+ (string-append ls (format nil " and KLUILRL <= ~d" srl)))
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'uterm :lui (ensure-integer (nth 0 tuple))
+ :cui cui
+ :lat (nth 1 tuple)
+ :ts (nth 2 tuple)
+ :lrl (ensure-integer (nth 3 tuple)))
+ uterms))
+ (nreverse uterms)))
+
+(defun find-uterm-lui (lui &key (srl *current-srl*))
+ "Return a list of uterm for lui"
+ (if (stringp lui)
+ (setq lui (parse-lui lui)))
+ (let ((uterms '())
+ (ls (format nil "select distinct CUI,LAT,TS,KLUILRL from MRCON where LUI=~d" lui)))
+ (when srl
+ (string-append ls (format nil " and KLUILRL <= ~d" srl)))
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'uterm :cui (ensure-integer (nth 0 tuple))
+ :lui lui
+ :lat (nth 1 tuple)
+ :ts (nth 2 tuple)
+ :lrl (ensure-integer (nth 3 tuple)))
+ uterms))
+ (nreverse uterms)))
+
+(defun find-uterm-cuilui (cui lui &key (srl *current-srl*))
+ "Return single uterm for cui/lui"
+ (let ((ls (format nil "select LAT,TS,KLUILRL from MRCON where KCUILUI=~d limit 1" (make-cuilui cui lui))))
+ (when srl
+ (string-append ls (format nil " and KLUILRL <= ~d" srl)))
+ (gu:aif (car (mutex-sql-query ls))
+ (make-instance 'uterm :cui cui
+ :lui lui
+ :lat (nth 0 gu::it)
+ :ts (nth 1 gu::it)
+ :lrl (ensure-integer (nth 2 gu::it)))
+ nil)))
+
+(defun find-ustr-cuilui (cui lui &key (srl *current-srl*))
+ "Return a list of ustr for cui/lui"
+ (declare (fixnum cui lui))
+ (let ((ustrs '())
+ (ls (format nil "select SUI,STT,STR,LRL from MRCON where KCUILUI=~d" (make-cuilui cui lui))))
+ (when srl
+ (string-append ls (format nil " and LRL <= ~d" srl)))
+ (dolist (tuple (mutex-sql-query ls))
+ (let* ((sui (ensure-integer (car tuple)))
+ (ustr (make-instance 'ustr :sui sui
+ :cui cui
+ :cuisui (make-cuisui cui sui)
+ :lui lui
+ :stt (nth 1 tuple)
+ :str (nth 2 tuple)
+ :lrl (ensure-integer (nth 3 tuple)))))
+ (push ustr ustrs)))
+ (nreverse ustrs)))
+
+(defun find-ustr-cuisui (cui sui &key (srl *current-srl*))
+ "Return the single ustr for cuisui"
+ (let ((ls (format nil "select LUI,STT,STR,LRL from MRCON where KCUISUI=~d"
+ (make-cuisui cui sui))))
+ (when srl
+ (string-append ls (format nil " and LRL <= ~d" srl)))
+ (gu:aif (car (mutex-sql-query ls))
+ (make-instance 'ustr :sui sui
+ :cui cui
+ :cuisui (make-cuisui cui sui)
+ :lui (ensure-integer (nth 0 gu::it))
+ :stt (nth 1 gu::it)
+ :str (nth 2 gu::it)
+ :lrl (ensure-integer (nth 3 gu::it)))
+ nil)))
+
+(defun find-ustr-sui (sui &key (srl *current-srl*))
+ "Return the list of ustr for sui"
+ (if (stringp sui)
+ (setq sui (parse-sui sui)))
+ (let ((ustrs '())
+ (ls (format nil "select CUI,LUI,STT,STR,LRL from MRCON where SUI=~d" sui)))
+ (when srl
+ (string-append ls (format nil " and LRL <= ~d" srl)))
+ (dolist (tuple (mutex-sql-query ls))
+ (let ((cui (ensure-integer (car tuple))))
+ (push (make-instance 'ustr :sui sui
+ :cui cui
+ :cuisui (make-cuisui cui sui)
+ :lui (ensure-integer (nth 1 tuple))
+ :stt (nth 2 tuple)
+ :str (nth 3 tuple)
+ :lrl (ensure-integer (nth 4 tuple)))
+ ustrs)))
+ (nreverse ustrs)))
+
+(defun find-ustr-sab (sab &key (srl *current-srl*))
+ "Return the list of ustr for sab"
+ (let ((ustrs '())
+ (ls (format nil "select KCUISUI from MRSO where SAB='~a'" sab)))
+ (when srl
+ (string-append ls (format nil " and SRL <= ~d" srl)))
+ (dolist (tuple (mutex-sql-query ls))
+ (let ((cuisui (ensure-integer (car tuple))))
+ (push (apply #'find-ustr-cuisui
+ (append
+ (multiple-value-list (decompose-cuisui cuisui))
+ (list :srl srl)))
+ ustrs)))
+ (nreverse ustrs)))
+
+(defun find-ustr-all (&key (srl *current-srl*))
+ "Return list of all ustr's"
+ (let ((ls "select distinct CUI,LUI,SUI,STT,LRL,KPFSTR from MRCON"))
+ (when srl
+ (string-append ls (format nil " where LRL <= ~d" srl)))
+ (string-append ls " order by SUI asc")
+ (with-sql-connection (db)
+ (clsql:map-query
+ 'list
+ #'(lambda (cui lui sui stt lrl pfstr)
+ (setq cui (ensure-integer cui))
+ (setq lui (ensure-integer lui))
+ (setq sui (ensure-integer sui))
+ (setq lrl (ensure-integer lrl))
+ (make-instance 'ustr :cui cui
+ :lui lui
+ :sui sui
+ :cuisui (make-cuisui cui sui)
+ :stt stt
+ :lrl lrl
+ :str pfstr))
+ ls
+ :database db))))
+
+(defun find-string-sui (sui &key (srl *current-srl*))
+ "Return the string associated with sui"
+ (let ((ls (format nil "select STR from MRCON where SUI=~d" sui)))
+ (when srl
+ (string-append ls (format nil " and LRL <= ~d" srl)))
+ (string-append ls " limit 1")
+ (caar (mutex-sql-query ls))))
+
+(defun find-uso-cuisui (cui sui &key (srl *current-srl*))
+ (declare (fixnum cui sui))
+ (let ((usos '())
+ (ls (format nil "select SAB,CODE,SRL,TTY from MRSO where KCUISUI=~d"
+ (make-cuisui cui sui))))
+ (when srl
+ (string-append ls (format nil " and SRL <= ~d" srl)))
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'uso :sab (nth 0 tuple) :code (nth 1 tuple)
+ :srl (nth 2 tuple) :tty (nth 3 tuple))
+ usos))
+ (nreverse usos)))
+
+(defun find-ucxt-cuisui (cui sui &key (srl *current-srl*))
+ (declare (fixnum cui sui))
+ (let ((ucxts '())
+ (ls (format nil "select SAB,CODE,CXN,CXL,RNK,CXS,CUI2,HCD,RELA,XC from MRCXT where KCUISUI=~d"
+ (make-cuisui cui sui))))
+ (when srl
+ (string-append ls (format nil " and KSRL <= ~d" srl)))
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'ucxt :sab (nth 0 tuple)
+ :code (nth 1 tuple)
+ :cxn (ensure-integer (nth 2 tuple))
+ :cxl (nth 3 tuple)
+ :rnk (ensure-integer (nth 4 tuple))
+ :cxs (nth 5 tuple)
+ :cui2 (ensure-integer (nth 6 tuple))
+ :hcd (nth 7 tuple)
+ :rela (nth 8 tuple)
+ :xc (nth 9 tuple))
+ ucxts))
+ (nreverse ucxts)))
+
+(defun find-usat-ui (cui &optional (lui nil) (sui nil) &key (srl *current-srl*))
+ (let ((ls (format nil "select CODE,ATN,SAB,ATV from MRSAT where ")))
+ (cond
+ (sui (string-append ls (format nil "KCUISUI=~d" (make-cuisui cui sui))))
+ (lui (string-append ls (format nil "KCUILUI=~d and sui=0" (make-cuilui cui lui))))
+ (t (string-append ls (format nil "cui=~d and lui=0 and sui=0" cui))))
+ (when srl
+ (string-append ls (format nil " and KSRL <= ~d" srl)))
+ (let ((usats '()))
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'usat :code (nth 0 tuple)
+ :atn (nth 1 tuple)
+ :sab (nth 2 tuple)
+ :atv (nth 3 tuple))
+ usats))
+ (nreverse usats))))
+
+(defun find-bsab-sab (sab)
+ (gu:aif (car (mutex-sql-query
+ (format nil "select NAME,COUNT from BONUS_SAB where SAB='~a'" sab)))
+ (make-instance 'bsab :sab sab :name (nth 0 gu::it)
+ :hits (ensure-integer (nth 1 gu::it)))
+ nil))
+
+(defun find-bsab-all ()
+ (let ((usabs '()))
+ (dolist (tuple (mutex-sql-query "select SAB,NAME,COUNT from BONUS_SAB"))
+ (push
+ (make-instance 'bsab :sab (nth 0 tuple) :name (nth 1 tuple)
+ :hits (ensure-integer (nth 2 tuple)))
+ usabs))
+ (nreverse usabs)))
+
+(defun find-btty-tty (tty)
+ (gu:aif (car (mutex-sql-query
+ (format nil "select NAME from BONUS_TTY where TTY='~a'" tty)))
+ (make-instance 'btty :tty tty :name (nth 0 gu::it))
+ nil))
+
+(defun find-btty-all ()
+ (let ((uttys '()))
+ (dolist (tuple (mutex-sql-query "select TTY,NAME from BONUS_TTY"))
+ (push
+ (make-instance 'btty :tty (nth 0 tuple) :name (nth 1 tuple))
+ uttys))
+ (nreverse uttys)))
+
+(defun find-brel-rel (rel)
+ (let ((brels '()))
+ (dolist (tuple (mutex-sql-query
+ (format nil "select SAB,SL,REL,RELA,COUNT from BONUS_REL where REL='~a'" rel)))
+ (push
+ (make-instance 'brel :sab (nth 0 tuple) :sl (nth 1 tuple) :rel (nth 2 tuple)
+ :rela (nth 3 tuple) :hits (ensure-integer (nth 4 tuple)))
+ brels))
+ (nreverse brels)))
+
+(defun find-pfstr-cui (cui)
+ (caar (mutex-sql-query (format nil "select KPFSTR from MRCON where CUI=~d limit 1" cui))))
+
+(defun find-usty-tui (tui)
+ "Find usty for tui"
+ (setq tui (parse-tui tui))
+ (gu:aif (car (mutex-sql-query
+ (format nil "select STY from MRSTY where TUI=~d limit 1" tui)))
+ (make-instance 'usty :tui tui :sty (nth 0 gu::it))
+ nil))
+
+(defun find-usty-sty (sty)
+ "Find usty for a sty"
+ (gu:aif (car (mutex-sql-query
+ (format nil "select TUI from MRSTY where STY='~a' limit 1" sty)))
+ (make-instance 'usty :tui (ensure-integer (nth 0 gu::it)) :sty sty)
+ nil))
+
+(defun find-usty-all ()
+ "Return list of usty's for all semantic types"
+ (let ((ustys '()))
+ (dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY"))
+ (push (find-usty-tui (nth 0 tuple)) ustys))
+ (nreverse ustys)))
+
+(defun find-usty_freq-all ()
+ (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))))))
+ (push (make-instance 'usty_freq :usty (find-usty-tui tui) :freq freq) usty_freqs)))
+ (sort usty_freqs #'> :key #'usty_freq-freq)))
+
+
+(defun make-user-table ()
+ (mutex-sql-execute "create table UMLISP_USERS (ID integer UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY,FIRST_NAME varchar(20),LAST_NAME varchar(20),ORGANIZATION varchar(80),ADDRESS1 varchar(60),ADDRESS2 varchar(60),CITY varchar(30),STATE char(2),ZIP char(10),COUNTRY varchar(40),OCCUPATION varchar(120),EMAIL varchar(80),PASSWD varchar(20),MAILLIST char(1),LICENSED char(1),SRL integer,TIMEOUT integer,DATETIME_CREATED datetime,DATETIME_MODIFIED datetime)"))
+
+(defun find-umlisp-user-email (email)
+ (let ((tuple (car (mutex-sql-query
+ (format nil "select ID,FIRST_NAME,LAST_NAME,ORGANIZATION,ADDRESS1,ADDRESS2,CITY,STATE,ZIP,COUNTRY,OCCUPATION,LICENSED,MAILLIST,PASSWD,SRL,TIMEOUT,DATETIME_CREATED,DATETIME_MODIFIED from UMLISP_USERS where EMAIL='~a'" email)))))
+ (when tuple
+ (make-instance 'umlisp-user :email email
+ :id (ensure-integer (nth 0 tuple))
+ :first-name (nth 1 tuple)
+ :last-name (nth 2 tuple)
+ :organization (nth 3 tuple)
+ :address1 (nth 4 tuple)
+ :address2 (nth 5 tuple)
+ :city (nth 6 tuple)
+ :state (nth 7 tuple)
+ :zip (nth 8 tuple)
+ :country (nth 9 tuple)
+ :occupation (nth 10 tuple)
+ :licensed (if (string-equal "Y" (nth 11 tuple)) t nil)
+ :maillist (if (string-equal "Y" (nth 12 tuple)) t nil)
+ :passwd (nth 13 tuple)
+ :srl (ensure-integer (nth 14 tuple))
+ :timeout (ensure-integer (nth 15 tuple))
+ :datetime-created (nth 16 tuple)
+ :datetime-modified (nth 17 tuple)))))
+
+(defun find-umlisp-user-all ()
+ (let ((users '()))
+ (dolist (email (find-umlisp-user-all-email))
+ (push (find-umlisp-user-email email) users))
+ (nreverse users)))
+
+(defun find-umlisp-user-all-email ()
+ (let ((emails '()))
+ (dolist (tuple (mutex-sql-query "select EMAIL from UMLISP_USERS"))
+ (push (car tuple) emails))
+ (nreverse emails)))
+
+(defun find-umlisp-user-announce-email ()
+ (let ((emails '()))
+ (dolist (tuple (mutex-sql-query
+ "select EMAIL from UMLISP_USERS where MAILLIST='Y'"))
+ (push (car tuple) emails))
+ (nreverse emails)))
+
+(defun add-umlisp-user (user)
+ (if (typep user 'umlisp-user)
+ (progn
+ (mutex-sql-execute
+ (format nil "insert into UMLISP_USERS (FIRST_NAME,LAST_NAME,ORGANIZATION,ADDRESS1,ADDRESS2,CITY,STATE,ZIP,COUNTRY,OCCUPATION,LICENSED,MAILLIST,EMAIL,PASSWD,SRL,TIMEOUT,DATETIME_CREATED,DATETIME_MODIFIED) values ('~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a',~d,~d,NOW(),NOW())"
+ (first-name user) (last-name user)
+ (organization user)
+ (address1 user) (address2 user)
+ (city user) (state user)
+ (zip user) (country user) (occupation user)
+ (if (licensed user) #\Y #\N)
+ (if (maillist user) #\Y #\N)
+ (email user)
+ (passwd user) (srl user)
+ (timeout user)))
+ (let ((read-user (find-umlisp-user-email (email user))))
+ (setf (slot-value user 'id) (id read-user)
+ (slot-value user 'datetime-created) (datetime-created read-user)
+ (slot-value user 'datetime-modified) (datetime-modified read-user)))
+ t)
+ nil))
+
+(defun umlisp-user-verify-passwd (user passwd)
+ (when user
+ (string-equal passwd (passwd user))))
+
+(defun umlisp-user-set-srl (email srl)
+ (when (and (integerp srl) (find-umlisp-user-email email))
+ (mutex-sql-execute
+ (format nil "update UMLISP_USERS set SRL=~d,DATETIME_MODIFIED=NOW() where EMAIL='~a'" srl email))
+ srl))
+
+(defun make-ustats ()
+ (with-sql-connection (conn)
+ (sql-execute "drop table if exists 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)
+ (insert-ustats-count conn "Distinct Term Count" "MRCON" "distinct LUI" "KLUILRL" srl)
+ (insert-ustats-count conn "String Count" "MRCON" "*" "LRL" srl)
+ (insert-ustats-count conn "Distinct String Count" "MRCON" "distinct SUI" "LRL" srl)
+ (insert-ustats-count conn "Associated Expression Count" "MRATX" "*" "KSRL" srl)
+ (insert-ustats-count conn "Context Count" "MRCXT" "*" "KSRL" srl)
+ (insert-ustats-count conn "Co-occuring Concept Count" "MRCOC" "*" "KLRL" srl)
+ (insert-ustats-count conn "Definition Count" "MRDEF" "*" "KSRL" srl)
+ (insert-ustats-count conn "Locator Count" "MRLO" "*" "KLRL" srl)
+ (insert-ustats-count conn "Rank Count" "MRRANK" "*" "KSRL" srl)
+ (insert-ustats-count conn "Relationship Count" "MRREL" "*" "KSRL" srl)
+ (insert-ustats-count conn "Semantic Type Count" "MRSTY" "*" "KLRL" srl)
+ (insert-ustats-count conn "Simple Attribute Count" "MRSAT" "*" "KSRL" srl)
+ (insert-ustats-count conn "Source Count" "MRSO" "*" "SRL" srl)
+ (insert-ustats-count conn "Word Index Count" "MRXW_ENG" "*" "KLRL" srl)
+ (insert-ustats-count conn "Normalized Word Index Count" "MRXNW_ENG" "*" "KLRL" srl)
+ (insert-ustats-count conn "Normalized String Index Count" "MRXNS_ENG" "*" "KLRL" srl)
+ (insert-ustats-count conn "Bonus Attribute Name Count" "BONUS_ATN" "*" nil srl)
+ (insert-ustats-count conn "Bonus Relationship Count" "BONUS_REL" "*" nil srl)
+ (insert-ustats-count conn "Bonus Source Abbreviation Count" "BONUS_SAB" "*" nil srl)
+ (insert-ustats-count conn "Bonus Term Type Count" "BONUS_TTY" "*" nil srl))
+ (sql-execute "create index USTATS_SRL on USTATS (SRL)" conn))
+ (find-ustats-all))
+
+(defun insert-ustats-count (conn name table count-variable srl-control srl)
+ (insert-ustats conn name (find-count-table conn table srl count-variable srl-control) 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))))
+ ((null srl-control)
+ (ensure-integer
+ (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))
+
+(defun find-ustats-all (&key (srl *current-srl*))
+ (let ((ustats '())
+ (ls "select NAME,COUNT,SRL from USTATS"))
+ (when srl
+ (string-append ls (format nil " where SRL=~d" srl)))
+ (string-append ls " order by NAME asc")
+ (dolist (tuple (mutex-sql-query ls))
+ (push (make-instance 'ustats :name (nth 0 tuple)
+ :hits (ensure-integer (nth 1 tuple))
+ :srl (ensure-integer (nth 2 tuple)))
+ ustats))
+ (nreverse ustats)))
+
+(defun find-ustats-srl (srl)
+ (let ((ustats '()))
+ (dolist (tuple (mutex-sql-query
+ (format nil "select NAME,COUNT from USTATS where SRL=~d order by NAME asc" srl)))
+ (push (make-instance 'ustats :name (nth 0 tuple)
+ :hits (ensure-integer (nth 1 tuple))
+ :srl srl)
+ ustats))
+ (nreverse ustats)))
+
+(defun make-usrl ()
+ (with-sql-connection (conn)
+ (sql-execute "drop table if exists 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)))
+ (find-usrl-all))
+
+(defun find-usrl-all ()
+ (let ((usrls '())
+ (tuples (mutex-sql-query "select SAB,SRL from USRL order by SAB desc")))
+ (dolist (tuple tuples)
+ (push (make-instance 'usrl :sab (nth 0 tuple)
+ :srl (ensure-integer (nth 1 tuple))) usrls))
+ usrls)) ;; already reversed by sql
+
+(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 :usrl usrl :freq freq) freqs)))
+ (sort freqs #'> :key #'usrl_freq-freq)))
+
+(defun find-cui-max ()
+ (let ((cui (caar (mutex-sql-query "select max(CUI) from MRCON"))))
+ (ensure-integer cui)))
+
+;;;; Cross table find functions
+
+(defun find-ucon-tui (tui &key (srl *current-srl*))
+ "Find list of ucon for tui"
+ (when (stringp tui)
+ (setq tui (parse-tui tui)))
+ (let ((ucons '())
+ (ls (format nil "select CUI from MRSTY where TUI=~d" tui)))
+ (when srl
+ (string-append ls (format nil " and KLRL <= ~d" srl)))
+ (string-append ls " order by cui desc")
+ (dolist (tuple (mutex-sql-query ls))
+ (push (find-ucon-cui (ensure-integer (car tuple)) :srl srl) ucons))
+ ucons))
+
+(defun find-ucon-word (word &key (srl *current-srl*) (like nil))
+ "Return list of ucons that match word. Optionally, use SQL's LIKE syntax"
+ (let ((ucons '())
+ (ls (format nil "select distinct cui from MRXW_ENG where wd~A'~A'"
+ (if like " LIKE " "=")
+ word)))
+ (when srl
+ (string-append ls (format nil " and KLRL <= ~d" srl)))
+ (string-append ls " order by cui desc")
+ (dolist (tuple (mutex-sql-query ls))
+ (push (find-ucon-cui (car tuple) :srl srl) ucons))
+ ucons))
+
+(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"
+ (let ((ucons '())
+ (ls (format nil "select distinct cui from MRXNW_ENG where nwd~A'~A'"
+ (if like " LIKE " "=")
+ word)))
+ (when srl
+ (string-append ls (format nil " and KLRL <= ~d" srl)))
+ (string-append ls " order by cui desc")
+ (dolist (tuple (mutex-sql-query ls))
+ (push (find-ucon-cui (car tuple) :srl srl) ucons))
+ ucons))
+
+(defun find-ustr-word (word &key (srl *current-srl*))
+ "Return list of ustrs that match word"
+ (let ((ustrs '())
+ (ls (format nil "select cui,sui from MRXW_ENG where wd='~a'" word)))
+ (when srl
+ (string-append ls (format nil " and KLRL <= ~d" srl)))
+ (string-append ls " order by cui desc,sui desc")
+ (dolist (tuple (mutex-sql-query ls))
+ (push (find-ustr-cuisui (ensure-integer (car tuple)) (ensure-integer (cadr tuple)) :srl srl)
+ ustrs))
+ ustrs))
+
+(defun find-ustr-normalized-word (word &key (srl *current-srl*))
+ "Return list of ustrs that match word"
+ (let ((ustrs '())
+ (ls (format nil "select cui,sui from MRXNW_ENG where nwd='~a'" word)))
+ (when srl
+ (string-append ls (format nil " and KLRL <= ~d" srl)))
+ (string-append ls " order by cui desc,sui desc")
+ (dolist (tuple (mutex-sql-query ls))
+ (push (find-ustr-cuisui (ensure-integer (car tuple)) (ensure-integer (cadr tuple)) :srl srl)
+ ustrs))
+ ustrs))
+
+
+;;; Multiword lookup and score functions
+
+(defun find-ucon-multiword (str &key (srl *current-srl*))
+ "Return sorted list of ucon's that match a multiword string"
+ (let* ((words (delimited-string-to-list str #\space))
+ (ucons '()))
+ (dolist (word words)
+ (setq ucons (append ucons (find-ucon-word word :srl srl))))
+ (sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui))))
+
+(defun find-ucon-normalized-multiword (str &key (srl *current-srl*))
+ "Return sorted list of ucon's that match a multiword string"
+ (let* ((words (delimited-string-to-list str #\space))
+ (ucons '())
+ (nwords '()))
+ (dolist (word words)
+ (let ((nws (lvg:process-terms word)))
+ (dolist (nword nws)
+ (push nword nwords))))
+ (dolist (word nwords)
+ (setq ucons (append ucons (find-ucon-word word :srl srl))))
+ (sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui))))
+
+(defun find-ustr-multiword (str &key (srl *current-srl*))
+ "Return sorted list of ustr's that match a multiword string"
+ (let* ((words (delimited-string-to-list str #\space))
+ (ustrs '()))
+ (dolist (word words)
+ (setq ustrs (append ustrs (find-ustr-word word :srl srl))))
+ (sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'cui))))
+
+(defun find-ustr-normalized-multiword (str &key (srl *current-srl*))
+ "Return sorted list of ustr's that match a multiword string"
+ (let* ((words (delimited-string-to-list str #\space))
+ (ustrs '())
+ (nwords '()))
+ (dolist (word words)
+ (let ((nws (lvg:process-terms word)))
+ (dolist (nword nws)
+ (push nword nwords))))
+ (dolist (word nwords)
+ (setq ustrs (append ustrs (find-ustr-word word :srl srl))))
+ (sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'ustr-cui))))
+
+(defun a (str)
+ (find-normalized-matches-for-str str #'find-ustr-normalized-word #'ustr-sui))
+
+(defun find-normalized-matches-for-str (str lookup-func key-func)
+ "Return list of objects that normalize match for words in string,
+eliminate duplicates."
+ (let ((objs '())
+ (nwords '()))
+ (dolist (word (delimited-string-to-list str #\space))
+ (dolist (nword (lvg:process-terms word))
+ (unless (member nword nwords :test #'string-equal)
+ (push nword nwords))))
+ (dolist (nw nwords)
+ (setq objs (append objs (funcall lookup-func nw))))
+ (delete-duplicates objs :key key-func :test #'eql)))
+
+(defun sort-score-ucon-str (str ucons)
+ "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
+ (sort-score-umlsclass-str ucons str #'pfstr))
+
+(defun sort-score-ustr-str (str ustrs)
+ "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
+ (sort-score-umlsclass-str ustrs str #'str))
+
+(defun sort-score-umlsclass-str (objs str lookup-func)
+ "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)))
+ scored))
+ (mapcar #'car (sort scored #'> :key #'cadr))))
+
+(defun score-multiword-match (s1 s2)
+ "Score a match between two strings with s1 being reference string"
+ (let* ((word-list-1 (delimited-string-to-list s1 #\space))
+ (word-list-2 (delimited-string-to-list s2 #\space))
+ (n1 (length word-list-1))
+ (n2 (length word-list-2))
+ (unmatched n1)
+ (score 0)
+ (nlong 0)
+ (nshort 0)
+ short-list long-list)
+ (declare (fixnum n1 n2 nshort nlong score unmatched))
+ (if (> n1 n2)
+ (progn
+ (setq nlong n1)
+ (setq nshort n2)
+ (setq long-list word-list-1)
+ (setq short-list word-list-2))
+ (progn
+ (setq nlong n2)
+ (setq nshort n1)
+ (setq long-list word-list-2)
+ (setq short-list word-list-1)))
+ (decf score (- nlong nshort)) ;; reduce score for extra words
+ (dotimes (iword nshort)
+ (declare (fixnum iword))
+ (gu:aif (position (nth iword short-list) long-list :test #'string-equal)
+ (progn
+ (incf score (- 10 (abs (- gu::it iword))))
+ (decf unmatched))))
+ (decf score (* 2 unmatched))
+ score))
+
+
+;;; LEX SQL functions
+
+(defun find-lexterm-eui (eui)
+ (gu:awhen (car (mutex-sql-query
+ (format nil "select WRD from LRWD where EUI=~d" eui)))
+ (make-instance 'lexterm :eui eui :wrd (nth 0 gu:it))))
+
+(defun find-lexterm-word (wrd)
+ (gu:awhen (mutex-sql-query
+ (format nil "select EUI from LRWD where WRD='~a'" wrd))
+ (let ((terms '()))
+ (dolist (tuple gu:it)
+ (let ((eui (ensure-integer (nth 0 tuple))))
+ (push
+ (make-instance 'lexterm :eui eui :wrd (copy-seq wrd))
+ terms)))
+ (nreverse terms))))
+
+;; LEXTERM accessors, read on demand
+
+(def-lazy-reader lexterm s#abr find-labr-eui eui)
+(def-lazy-reader lexterm s#agr find-lagr-eui eui)
+(def-lazy-reader lexterm s#cmp find-lcmp-eui eui)
+(def-lazy-reader lexterm s#mod find-lmod-eui eui)
+(def-lazy-reader lexterm s#nom find-lnom-eui eui)
+(def-lazy-reader lexterm s#prn find-lprn-eui eui)
+(def-lazy-reader lexterm s#prp find-lprp-eui eui)
+(def-lazy-reader lexterm s#spl find-lspl-eui eui)
+(def-lazy-reader lexterm s#trm find-ltrm-eui eui)
+(def-lazy-reader lexterm s#typ find-ltyp-eui eui)
+
+;; LEX SQL Read functions
+
+(defun find-labr-eui (eui)
+ (gu:awhen (mutex-sql-query
+ (format nil "select BAS,ABR,EUI2,BAS2 from LRABR where EUI=~d" eui))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'labr :eui eui
+ :bas (nth 0 tuple)
+ :abr (nth 1 tuple)
+ :eui2 (ensure-integer (nth 2 tuple))
+ :bas2 (nth 3 tuple))
+ results))
+ (nreverse results))))
+
+(defun find-labr-bas (bas)
+ (gu:awhen (mutex-sql-query
+ (format nil "select EUI,ABR,EUI2,BAS2 from LRABR where BAS='~a'" bas))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'labr :eui (ensure-integer (nth 0 tuple))
+ :bas (copy-seq bas)
+ :abr (nth 1 tuple)
+ :eui2 (ensure-integer (nth 2 tuple))
+ :bas2 (nth 3 tuple))
+ results))
+ (nreverse results))))
+
+(defun find-lagr-eui (eui)
+ (gu:awhen (mutex-sql-query
+ (format nil "select STR,SCA,AGR,CIT,BAS from LRAGR where EUI=~d" eui))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'lagr
+ :eui eui
+ :str (nth 0 tuple)
+ :sca (nth 1 tuple)
+ :agr (nth 2 tuple)
+ :cit (nth 3 tuple)
+ :bas (nth 4 tuple))
+ results))
+ (nreverse results))))
+
+(defun find-lcmp-eui (eui)
+ (gu:awhen (mutex-sql-query
+ (format nil "select BAS,SCA,COM from LRCMP where EUI=~d" eui))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'lcmp
+ :eui eui
+ :bas (nth 0 tuple)
+ :sca (nth 1 tuple)
+ :com (nth 2 tuple))
+ results))
+ (nreverse results))))
+
+(defun find-lmod-eui (eui)
+ (gu:awhen (mutex-sql-query
+ (format nil "select BAS,SCA,PSN_MOD,FEA from LRMOD where EUI=~d" eui))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'lmod
+ :eui eui
+ :bas (nth 0 tuple)
+ :sca (nth 1 tuple)
+ :psnmod (nth 2 tuple)
+ :fea (nth 3 tuple))
+ results))
+ (nreverse results))))
+
+(defun find-lnom-eui (eui)
+ (gu:awhen (mutex-sql-query
+ (format nil "select BAS,SCA,EUI2,BAS2,SCA2 from LRNOM where EUI=~d" eui))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'lnom
+ :eui eui
+ :bas (nth 0 tuple)
+ :sca (nth 1 tuple)
+ :eui2 (ensure-integer (nth 2 tuple))
+ :bas2 (nth 3 tuple)
+ :sca2 (nth 4 tuple))
+ results))
+ (nreverse results))))
+
+(defun find-lprn-eui (eui)
+ (gu:awhen (mutex-sql-query
+ (format nil "select BAS,NUM,GND,CAS,POS,QNT,FEA from LRPRN where EUI=~d" eui))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'lprn
+ :eui eui
+ :bas (nth 0 tuple)
+ :num (nth 1 tuple)
+ :gnd (nth 2 tuple)
+ :cas (nth 3 tuple)
+ :pos (nth 4 tuple)
+ :qnt (nth 5 tuple)
+ :fea (nth 6 tuple))
+ results))
+ (nreverse results))))
+
+(defun find-lprp-eui (eui)
+ (gu:awhen (mutex-sql-query
+ (format nil "select BAS,STR,SCA,FEA from LRPRP where EUI=~d" eui))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'lprp
+ :eui eui
+ :bas (nth 0 tuple)
+ :str (nth 1 tuple)
+ :sca (nth 2 tuple)
+ :fea (nth 3 tuple))
+ results))
+ (nreverse results))))
+
+(defun find-lspl-eui (eui)
+ (gu:awhen (mutex-sql-query
+ (format nil "select SPV,BAS from LRSPL where EUI=~d" eui))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'lspl
+ :eui eui
+ :spv (nth 0 tuple)
+ :bas (nth 1 tuple))
+ results))
+ (nreverse results))))
+
+
+(defun find-ltrm-eui (eui)
+ (gu:awhen (mutex-sql-query
+ (format nil "select BAS,GEN from LRTRM where EUI=~d" eui))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'ltrm
+ :eui eui
+ :bas (nth 0 tuple)
+ :gen (nth 1 tuple))
+ results))
+ (nreverse results))))
+
+(defun find-ltyp-eui (eui)
+ (gu:awhen (mutex-sql-query
+ (format nil "select BAS,SCA,TYP from LRTYP where EUI=~d" eui))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'ltyp
+ :eui eui
+ :bas (nth 0 tuple)
+ :sca (nth 1 tuple)
+ :typ (nth 2 tuple))
+ results))
+ (nreverse results))))
+
+(defun find-lwd-wrd (wrd)
+ (gu:awhen (mutex-sql-query
+ (format nil "select EUI from LRWD where WRD='~a'" wrd))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push (ensure-integer (nth 0 tuple)) results))
+ (make-instance 'lwd :wrd wrd
+ :euilist (nreverse results)))))
+
+;;; Semantic Network SQL access functions
+
+(defun find-sdef-ui (ui)
+ (gu:awhen (car (mutex-sql-query
+ (format nil "select RT,STY_RL,STN_RTN,DEF,EX,UN,RH,ABR,RIN from SRDEF where UI=~d" ui)))
+ (make-instance 'sdef :rt (nth 0 gu::it)
+ :ui ui
+ :styrl (nth 1 gu::it)
+ :stnrtn (nth 2 gu::it)
+ :def (nth 3 gu::it)
+ :ex (nth 4 gu::it)
+ :un (nth 5 gu::it)
+ :rh (nth 6 gu::it)
+ :abr (nth 7 gu::it)
+ :rin (nth 8 gu::it))))
+
+(defun find-sstre1-ui (ui)
+ (gu:awhen (mutex-sql-query
+ (format nil "select UI2,UI3 from SRSTRE1 where UI=~d" ui))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'sstre1 :ui ui
+ :ui2 (ensure-integer (nth 0 tuple))
+ :ui3 (ensure-integer (nth 1 tuple)))
+ results))
+ (nreverse results))))
+
+(defun find-sstre1-ui2 (ui2)
+ (gu:awhen (mutex-sql-query
+ (format nil "select UI,UI3 from SRSTRE1 where UI2=~d" ui2))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'sstre1 :ui (ensure-integer (nth 0 tuple))
+ :ui2 ui2
+ :ui3 (ensure-integer (nth 1 tuple)))
+ results))
+ (nreverse results))))
+
+(defun find-sstr-rl (rl)
+ (gu:awhen (mutex-sql-query
+ (format nil "select STY_RL,STY_RL2,LS from SRSTRE where RL='~a'" rl))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'sstr
+ :rl rl
+ :styrl (nth 0 tuple)
+ :styrl2 (nth 1 tuple)
+ :ls (nth 2 tuple))
+ results))
+ (nreverse results))))
+
+
+(defun find-sstre2-sty (sty)
+ (gu:awhen (mutex-sql-query
+ (format nil "select RL,STY2 from SRSTRE2 where STY='~a'" sty))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'sstre2
+ :sty (copy-seq sty)
+ :rl (nth 0 tuple)
+ :sty2 (nth 1 tuple))
+ results))
+ (nreverse results))))
+
+(defun find-sstr-styrl (styrl)
+ (gu:awhen (mutex-sql-query
+ (format nil "select RL,STY_RL2,LS from SRSTR where RL='~a'" styrl))
+ (let ((results '()))
+ (dolist (tuple gu::it)
+ (push
+ (make-instance 'sstr :styrl styrl
+ :rl (nth 0 tuple)
+ :styrl2 (nth 1 tuple)
+ :ls (nth 2 tuple))
+ results))
+ (nreverse results))))
+
+
--- /dev/null
+;;; $Id: obj.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $
+;;;
+;;; UMLS object defintions and printing routines
+
+(in-package :umlisp)
+(declaim (optimize (speed 3) (safety 1)))
+
+(defclass umlsclass ()
+ ()
+ (:metaclass ml-class)
+ (:documentation "Parent class of all UMLS objects"))
+
+
+(defmethod print-object ((obj umlsclass) (s stream))
+ (print-unreadable-object (obj s :type t :identity t)
+ (let ((fmt (make-instance 'gu.ml::textformat)))
+ (apply #'format
+ s (funcall (gu.ml::obj-data-fmtstr fmt) obj)
+ (multiple-value-list
+ (funcall (funcall (gu.ml::obj-data-value-func fmt) obj) obj))))))
+
+
+(defclass umlisp-user (umlsclass)
+ ((id :type fixnum :initarg :id :reader id)
+ (first-name :type string :initarg :first-name :reader first-name)
+ (last-name :type string :initarg :last-name :reader last-name)
+ (organization :type string :initarg :organization :reader organization)
+ (address1 :type string :initarg :address1 :reader address1)
+ (address2 :type string :initarg :address2 :reader address2)
+ (city :type string :initarg :city :reader city)
+ (state :type string :initarg :state :reader state)
+ (zip :type string :initarg :zip :reader zip)
+ (country :type string :initarg :country :reader country)
+ (licensed :type boolean :initarg :licensed :reader licensed)
+ (occupation :type string :initarg :occupation :reader occupation)
+ (email :type string :initarg :email :reader email)
+ (passwd :type string :initarg :passwd :reader passwd)
+ (srl :type fixnum :initarg :srl :reader srl)
+ (timeout :type fixnum :initarg :timeout :reader timeout)
+ (maillist :type boolean :initarg :maillist :reader maillist)
+ (datetime-created :type string :initarg :datetime-created
+ :reader datetime-created)
+ (datetime-modified :type string :initarg :datetime-modified
+ :reader datetime-modified))
+ (:default-initargs
+ :id nil :first-name nil :last-name nil :email nil :passwd nil :srl nil
+ :organization nil :address1 nil :address2 nil :city nil :state nil
+ :zip nil :country nil :licensed nil :occupation nil :maillist nil
+ :timeout nil :datetime-created nil :datetime-modified nil)
+ (:metaclass ml-class)
+ (:title "UMLisp User")
+ (:fields
+ (id :fixnum) (first-name :string) (last-name :string) (email :string)
+ (occupation :string) (organization :string) (address1 :string)
+ (address2 :string) (city :string) (state :string) (zip :string)
+ (country :string) (licensed :boolean) (maillist :boolean) (srl :fixnum)
+ (timeout :fixnum) (datetime-created :string) (datetime-modified :string))
+ (:documentation "Class for UMLisp user database"))
+
+(defclass ustats (umlsclass)
+ ((name :type string :initarg :name :reader name)
+ (hits :type integer :initarg :hits :reader hits)
+ (srl :type fixnum :initarg :srl :reader srl))
+ (:metaclass ml-class)
+ (:default-initargs :name nil :hits nil :srl nil)
+ (:title "UMLS Statistic")
+ (:fields (name :string) (hits :commainteger) (srl :fixnum))
+ (:documentation "Custom Table: UMLS Database statistics."))
+
+(defclass usrl (umlsclass)
+ ((sab :type string :initarg :sab :reader sab)
+ (srl :type integer :initarg :srl :reader srl))
+ (:metaclass ml-class)
+ (:default-initargs :sab nil :srl nil)
+ (:title "Source Restriction Level")
+ (:fields (sab :string) (srl :fixnum))
+ (:documentation "Custom Table: Source Restriction Level"))
+
+(defclass bsab (umlsclass)
+ ((sab :type string :initarg :sab :reader sab)
+ (name :type string :initarg :name :reader name)
+ (hits :type fixnum :initarg :hits :reader hits))
+ (:metaclass ml-class)
+ (:default-initargs :sab nil :name nil :hits nil)
+ (:title "Source of Abbreviation")
+ (:fields (sab :string) (name :string) (hits :commainteger))
+ (:ref-fields (sab find-ustr-sab (("subobjects" "no"))))
+ (:documentation "Bonus SAB file"))
+
+(defclass btty (umlsclass)
+ ((tty :type string :initarg :tty :reader tty)
+ (name :type string :initarg :name :reader name))
+ (:metaclass ml-class)
+ (:default-initargs :tty nil :name nil)
+ (:title "Bonus TTY")
+ (:fields (tty :string) (name :fixnum))
+ (:documentation "Bonus TTY file"))
+
+(defclass brel (umlsclass)
+ ((sab :type string :initarg :sab :reader sab)
+ (sl :type string :initarg :sl :reader sl)
+ (rel :type string :initarg :rel :reader rel)
+ (rela :type string :initarg :rela :reader rela)
+ (hits :type fixnum :initarg :hits :reader hits))
+ (:metaclass ml-class)
+ (:default-initargs :sab nil :sl nil :rel nil :rela nil :hits nil)
+ (:title "Bonus REL")
+ (:fields
+ (sab :string) (sl :string) (rel :string) (rela :string) (hits :commainteger))
+ (:documentation "Bonus REL file"))
+
+(defclass batn (umlsclass)
+ ((sab :type string :initarg :sab :reader sab)
+ (atn :type string :initarg :atn :reader atn)
+ (hits :type fixnum :initarg :hits :reader hits))
+ (:metaclass ml-class)
+ (:default-initargs :sab nil :atn nil)
+ (:title "Bonus ATN")
+ (:fields (sab :string) (atn :string) (hits :commaninteger))
+ (:documentation "Bonus ATN file"))
+
+(defclass urank (umlsclass)
+ ((rank :type fixnum :initarg :rank :reader rank)
+ (sab :type string :initarg :sab :reader sab)
+ (tty :type string :initarg :tty :reader tty)
+ (supres :type string :initarg :supres :reader supres))
+ (:metaclass ml-class)
+ (:default-initargs :rank nil :sab nil :tty nil :supres nil)
+ (:title "Rank")
+ (:fields (rank :fixnum) (sab :string) (tty :string) (supres :string)))
+
+(defclass udef (umlsclass)
+ ((def :type string :initarg :def :reader def)
+ (sab :type string :initarg :sab :reader sab))
+ (:metaclass ml-class)
+ (:default-initargs :def nil :sab nil)
+ (:title "Definition")
+ (:ref-fields (sab find-bsab-sab))
+ (:fields (sab :string) (def :cdata)))
+
+(defclass usat (umlsclass)
+ ((sab :type string :initarg :sab :reader sab)
+ (code :type string :initarg :code :reader code)
+ (atn :type string :initarg :atn :reader atn)
+ (atv :type string :initarg :atv :reader atv))
+ (:metaclass ml-class)
+ (:default-initargs :sab nil :code nil :atn nil :atv nil)
+ (:title "Simple Attribute")
+ (:ref-fields (sab find-bsab-sab))
+ (:fields (sab :string) (code :string) (atn :string) (atv :cdata)))
+
+(defclass uso (umlsclass)
+ ((sab :type string :initarg :sab :reader sab)
+ (code :type string :initarg :code :reader code)
+ (tty :type string :initarg :tty :reader tty)
+ (srl :type fixnum :initarg :srl :reader srl))
+ (:metaclass ml-class)
+ (:default-initargs :sab nil :code nil :tty nil :srl nil)
+ (:title "Source")
+ (:ref-fields (sab find-bsab-sab) (tty find-btty-tty))
+ (:fields (sab :string) (code :string) (tty :string) (srl :fixnum)))
+
+(defclass ucxt (umlsclass)
+ ((sab :type string :initarg :sab :reader sab)
+ (code :type string :initarg :code :reader code)
+ (rnk :type fixnum :initarg :rnk :reader rnk)
+ (cxn :type fixnum :initarg :cxn :reader cxn)
+ (cxl :type string :initarg :cxl :reader cxl)
+ (cxs :type string :initarg :cxs :reader cxs)
+ (cui2 :type fixnum :initarg :cui2 :reader cui2)
+ (hcd :type string :initarg :hcd :reader hcd)
+ (rela :type string :initarg :rela :reader rela)
+ (xc :type string :initarg :xc :reader xc))
+ (:metaclass ml-class)
+ (:default-initargs :sab nil :code nil :rnk nil :cxn nil :cxl nil :cxs nil
+ :cui2 nil :hcd nil :rela nil :xc nil)
+ (:title "Context")
+ (:ref-fields (sab find-bsab-sab) (cui2 find-ucon-cui))
+ (:fields
+ (sab :string) (code :string) (rnk :fixnum) (cxn :fixnum) (cxl :string)
+ (hcd :string) (rela :string) (xc :string) (cui2 :string fmt-cui)
+ (cxs :cdata)))
+
+(defclass ustr (umlsclass)
+ ((sui :type fixnum :initarg :sui :reader sui)
+ (cui :type fixnum :initarg :cui :reader cui)
+ (lui :type fixnum :initarg :lui :reader lui)
+ (cuisui :type integer :initarg :cuisui :reader cuisui )
+ (str :type string :initarg :str :reader str)
+ (lrl :type fixnum :initarg :lrl :reader lrl)
+ (stt :type string :initarg :stt :reader stt)
+ (s#sat :reader s#sat)
+ (s#so :reader s#so)
+ (s#cxt :reader s#cxt))
+ (:metaclass ml-class)
+ (:default-initargs
+ :sui nil :cui nil :lui nil :cuisui nil :str nil :lrl nil :stt nil)
+ (:title "String")
+ (:subobjects-lists (s#sat usat) (s#so uso) (s#cxt ucxt))
+ (:fields (sui :string fmt-sui) (stt :string) (lrl :fixnum) (str :cdata))
+ (:ref-fields (sui find-ustr-sui)))
+
+(defclass ulo (umlsclass)
+ ((isn :type string :initarg :isn :reader isn)
+ (fr :type fixnum :initarg :fr :reader fr)
+ (un :type string :initarg :un :reader un)
+ (sui :type fixnum :initarg :sui :reader sui)
+ (sna :type string :initarg :sna :reader sna)
+ (soui :type string :initarg :soui :reader soui))
+ (:metaclass ml-class)
+ (:default-initargs :isn nil :fr nil :un nil :sui nil :sna nil :soui nil)
+ (:title "Locator")
+ (:fields (isn :string) (fr :fixnum) (un :string) (sna :string)
+ (soui :string) (sui :string fmt-sui) (suistr :string)))
+
+(defclass uterm (umlsclass)
+ ((lui :type fixnum :initarg :lui :reader lui)
+ (cui :type fixnum :initarg :cui :reader cui)
+ (lat :type string :initarg :lat :reader lat)
+ (ts :type string :initarg :ts :reader ts)
+ (lrl :type fixnum :initarg :lrl :reader lrl)
+ (s#str :reader s#str)
+ (s#sat :reader s#sat))
+ (:metaclass ml-class)
+ (:default-initargs :lui nil :cui nil :lat nil :ts nil :lrl nil)
+ (:title "Term")
+ (:subobjects-lists (s#sat usat) (s#str ustr))
+ (:fields (lui :string fmt-lui) (lat :string) (ts :string) (lrl :fixnum))
+ (:ref-fields (lui find-uterm-lui)))
+
+(defclass usty (umlsclass)
+ ((tui :type fixnum :initarg :tui :reader tui)
+ (sty :type string :initarg :sty :reader sty))
+ (:metaclass ml-class)
+ (:default-initargs :tui nil :sty nil)
+ (:title "Semantic Type")
+ (:ref-fields (tui find-ucon-tui (("subobjects" "no"))))
+ (:fields (tui :string fmt-tui) (sty :string)))
+
+(defclass urel (umlsclass)
+ ((rel :type string :initarg :rel :reader rel)
+ (cui1 :type fixnum :initarg :cui1 :reader cui1)
+ (cui2 :type fixnum :initarg :cui2 :reader cui2)
+ (pfstr2 :type string :initarg :pfstr2 :reader pfstr2)
+ (rela :type string :initarg :rela :reader rela)
+ (sab :type string :initarg :sab :reader sab)
+ (sl :type string :initarg :sl :reader sl)
+ (mg :type string :initarg :mg :reader mg))
+ (:metaclass ml-class)
+ (:default-initargs
+ :rel nil :cui1 nil :cui2 nil :pfstr2 nil :rela nil :sab nil :sl nil :mg nil)
+ (:title "Relationship")
+ (:ref-fields (rel find-brel-rel) (sab find-bsab-sab) (cui2 find-ucon-cui))
+ (:fields (rel :string) (rela :string) (sab :string) (sl :string)
+ (mg :string) (cui2 :string fmt-cui) (pfstr2 :cdata)))
+
+(defclass ucoc (umlsclass)
+ ((cui1 :type fixnum :initarg :cui1 :reader cui1)
+ (cui2 :type fixnum :initarg :cui2 :reader cui2)
+ (pfstr2 :type string :initarg :pfstr2 :reader pfstr2)
+ (soc :type string :initarg :soc :reader soc)
+ (cot :type string :initarg :cot :reader cot)
+ (cof :type fixnum :initarg :cof :reader cof)
+ (coa :type string :initarg :coa :reader coa))
+ (:metaclass ml-class)
+ (:default-initargs
+ :cui1 nil :cui2 nil :pfstr2 nil :soc nil :cot nil :cof nil :coa nil)
+ (:title "Co-occuring Concept")
+ (:ref-fields (cui2 find-ucon-cui))
+ (:fields (soc :string) (cot :string) (cof :fixnum) (coa :cdata)
+ (cui2 :string fmt-cui) (pfstr2 :cdata)))
+
+
+(defclass uatx (umlsclass)
+ ((sab :type string :initarg :sab :reader sab)
+ (rel :type string :initarg :rel :reader rel)
+ (atx :type string :initarg :atx :reader atx))
+ (:metaclass ml-class)
+ (:default-initargs :sab nil :rel nil :atx nil)
+ (:title "Associated Expression")
+ (:fields (sab :string) (rel :string) (atx :cdata)))
+
+(defclass ucon (umlsclass)
+ ((cui :type fixnum :initarg :cui :reader cui )
+ (pfstr :initarg :pfstr :reader pfstr)
+ (lrl :initarg :lrl :reader lrl)
+ (s#term :reader s#term)
+ (s#def :reader s#def)
+ (s#lo :reader s#lo)
+ (s#rel :reader s#rel)
+ (s#coc :reader s#coc)
+ (s#sat :reader s#sat)
+ (s#atx :reader s#atx)
+ (s#sty :reader s#sty))
+ (:metaclass ml-class)
+ (:default-initargs :cui nil :pfstr nil :lrl nil)
+ (:title "Concept")
+ (:subobjects-lists
+ (s#def udef) (s#sty usty) (s#lo ulo) (s#atx uatx) (s#sat usat) (s#rel urel)
+ (s#coc ucoc) (s#term uterm))
+ (:fields (cui :string fmt-cui) (lrl :fixum) (pfstr :cdata))
+ (:ref-fields (cui find-ucon-cui)))
+
+(defclass uxw (umlsclass)
+ ((wd :type string :initarg :wd :reader wd)
+ (cui :type fixnum :initform nil :initarg :cui :reader cui)
+ (lui :type fixnum :initform nil :initarg :lui :reader lui)
+ (sui :type fixnum :initform nil :initarg :sui :reader sui))
+ (:metaclass ml-class)
+ (:default-initargs :wd nil :cui nil :lui nil :sui nil)
+ (:title "XW Index")
+ (:fields (wd :string) (cui :string fmt-cui) (lui :string fmt-lui)
+ (sui :string fmt-sui)))
+
+(defclass uxnw (umlsclass)
+ ((lat :type string :initarg :lat :reader lat)
+ (nwd :type string :initarg :nwd :reader nwd)
+ (cuilist :type list :initarg :cuilist :reader uxnw-cuilist))
+ (:metaclass ml-class)
+ (:default-initargs :lat nil :nwd nil :cuilist nil)
+ (:title "XNW Index")
+ (:fields (lat :string) (nwd :string) (cuilist :string)))
+
+(defclass uxns (umlsclass)
+ ((lat :type string :initarg :lat :reader lat)
+ (nstr :type string :initarg :nstr :reader nstr)
+ (cuilist :type list :initarg :cuilist :reader cuilist))
+ (:metaclass ml-class)
+ (:default-initargs :lat nil :nstr nil :cuilist nil)
+ (:title "XNS Index")
+ (:fields (lat :string) (nstr :string) (cuilist :string)))
+
+
+;;; LEX objects
+
+(defclass lexterm (umlsclass)
+ ((eui :type fixnum :initarg :eui :reader eui)
+ (wrd :type string :initarg :wrd :reader wrd)
+ (s#abr :reader s#abr)
+ (s#agr :reader s#agr)
+ (s#cmp :reader s#cmp)
+ (s#mod :reader s#mod)
+ (s#nom :reader s#nom)
+ (s#prn :reader s#prn)
+ (s#prp :reader s#prp)
+ (s#spl :reader s#spl)
+ (s#trm :reader s#trm)
+ (s#typ :reader s#typ))
+ (:metaclass ml-class)
+ (:default-initargs :eui nil :wrd nil)
+ (:title "Lexical Term")
+ (:subobjects-lists
+ (s#abr labr) (s#agr lagr) (s#cmp lcmp) (s#mod lmod) (s#nom unom)
+ (s#prn lprn) (s#prp lprp) (s#spl lspl) (s#trm ltrm) (s#typ ltyp))
+ (:fields (eui :string fmt-eui) (wrd :string))
+ (:ref-fields (eui find-lexterm-eui)))
+
+
+(defclass labr (umlsclass)
+ ((eui :type integer :initarg :eui :reader eui)
+ (bas :type string :initarg :bas :reader bas)
+ (abr :type string :initarg :abr :reader abr)
+ (eui2 :type integer :initarg :eui2 :reader eui2)
+ (bas2 :type string :initarg :bas2 :reader bas2))
+ (:metaclass ml-class)
+ (:default-initargs :eui nil :bas nil :abr nil :eui2 nil :bas2 nil)
+ (:title "Abbreviations and Acronyms")
+ (:fields (eui :string fmt-eui) (bas :string) (abr :string)
+ (eui2 :string fmt-eui) (bas2 :string )))
+
+(defclass lagr (umlsclass)
+ ((eui :type integer :initarg :eui :reader eui)
+ (str :type string :initarg :str :reader str)
+ (sca :type string :initarg :sca :reader sca)
+ (agr :type string :initarg :agr :reader agr)
+ (cit :type string :initarg :cit :reader cit)
+ (bas :type string :initarg :bas :reader bas))
+ (:metaclass ml-class)
+ (:default-initargs :eui nil :str nil :sca nil :agr nil :cit nil :bas nil)
+ (:title "Agreement and Inflection")
+ (:fields (eui :string fmt-eui) (str :string) (sca :string) (agr :string)
+ (cit :string) (bas :string)))
+
+(defclass lcmp (umlsclass)
+ ((eui :type integer :initarg :eui :reader eui)
+ (bas :type string :initarg :bas :reader bas)
+ (sca :type string :initarg :sca :reader sca)
+ (com :type string :initarg :com :reader com))
+ (:metaclass ml-class)
+ (:default-initargs :eui nil :bas nil :sca nil :com nil)
+ (:title "Complementation")
+ (:fields (eui :string fmt-eui) (bas :string) (sca :string) (com :string)))
+
+(defclass lmod (umlsclass)
+ ((eui :type integer :initarg :eui :reader eui)
+ (bas :type string :initarg :bas :reader bas)
+ (sca :type string :initarg :sca :reader sca)
+ (psnmod :type string :initarg :psnmod :reader psnmod)
+ (fea :type string :initarg :fea :reader fea))
+ (:metaclass ml-class)
+ (:default-initargs :eui nil :bas nil :sca nil :psnmod nil :fea nil)
+ (:title "Modifiers")
+ (:fields (eui :string fmt-eui) (bas :string) (sca :string) (psnmod :string)
+ (fea :string)))
+
+(defclass lnom (umlsclass)
+ ((eui :type integer :initarg :eui :reader eui)
+ (bas :type string :initarg :bas :reader bas)
+ (sca :type string :initarg :sca :reader sca)
+ (eui2 :type integer :initarg :eui2 :reader eui2)
+ (bas2 :type string :initarg :bas2 :reader bas2)
+ (sca2 :type string :initarg :sca2 :reader sca2))
+ (:metaclass ml-class)
+ (:default-initargs :eui nil :bas nil :sca nil :eui2 nil :bas2 nil :sca2 nil)
+ (:title "Nominalizations")
+ (:fields (eui :string fmt-eui) (bas :string) (sca :string)
+ (eui2 :string fmt-eui) (bas2 :string) (sca2 :string)))
+
+(defclass lprn (umlsclass)
+ ((eui :type integer :initarg :eui :reader eui)
+ (bas :type string :initarg :bas :reader bas)
+ (num :type string :initarg :num :reader num)
+ (gnd :type string :initarg :gnd :reader gnd)
+ (cas :type string :initarg :cas :reader cas)
+ (pos :type string :initarg :pos :reader pos)
+ (qnt :type string :initarg :qnt :reader qnt)
+ (fea :type string :initarg :fea :reader fea))
+ (:metaclass ml-class)
+ (:default-initargs :eui nil :bas nil :num nil :gnd nil :cas nil
+ :pos nil :qnt nil :fea nil)
+ (:title "Pronouns")
+ (:fields (eui :string fmt-eui) (bas :string) (num :string) (gnd :string)
+ (cas :string) (pos :string) (qnt :string) (fea :string)))
+
+(defclass lprp (umlsclass)
+ ((eui :type integer :initarg :eui :reader eui)
+ (bas :type string :initarg :bas :reader bas)
+ (str :type string :initarg :str :reader str)
+ (sca :type string :initarg :sca :reader sca)
+ (fea :type string :initarg :fea :reader fea))
+ (:metaclass ml-class)
+ (:default-initargs :eui nil :bas nil :str nil :sca nil :fea nil)
+ (:title "Properties")
+ (:fields (eui :string fmt-eui) (bas :string) (str :string) (sca :string)
+ (fea :string)))
+
+
+(defclass lspl (umlsclass)
+ ((eui :type integer :initarg :eui :reader eui)
+ (spv :type string :initarg :spv :reader spv)
+ (bas :type string :initarg :bas :reader bas))
+ (:metaclass ml-class)
+ (:default-initargs :eui nil :spv nil :bas nil)
+ (:title "Spelling Variants")
+ (:fields (eui :string fmt-eui) (spv :string) (bas :string)))
+
+
+
+(defclass ltrm (umlsclass)
+ ((eui :type integer :initarg :eui :reader eui)
+ (bas :type string :initarg :bas :reader bas)
+ (gen :type string :initarg :gen :reader gen))
+ (:metaclass ml-class)
+ (:default-initargs :eui nil :bas nil :gen nil)
+ (:title "Trade Marks")
+ (:fields (eui :string fmt-eui) (bas :string) (gen :string)))
+
+(defclass ltyp (umlsclass)
+ ((eui :type integer :initarg :eui :reader eui)
+ (bas :type string :initarg :bas :reader bas)
+ (sca :type string :initarg :sca :reader sca)
+ (typ :type string :initarg :typ :reader typ))
+ (:metaclass ml-class)
+ (:default-initargs :eui nil :bas nil :sca nil :typ nil)
+ (:title "Inflection Type")
+ (:fields (eui :string fmt-eui) (bas :string) (sca :string) (typ :string)))
+
+(defclass lwd (umlsclass)
+ ((wrd :type string :initarg :wrd :reader wrd)
+ (euilist :type list :initarg :euilist :reader euilist))
+ (:metaclass ml-class)
+ (:default-initargs :wrd nil :euilist nil)
+ (:title "Lexical Word Index")
+ (:fields (wrd :string) (euilist :string)))
+
+;;; Semantic NET objects
+
+(defclass sdef (umlsclass)
+ ((rt :type string :initarg :rt :reader rt)
+ (ui :type integer :initarg :ui :reader ui)
+ (styrl :type string :initarg :styrl :reader styrl)
+ (stnrtn :type string :initarg :stnrtn :reader stnrtn)
+ (def :type string :initarg :def :reader def)
+ (ex :type string :initarg :ex :reader ex)
+ (un :type string :initarg :un :reader un)
+ (rh :type string :initarg :rh :reader rh)
+ (abr :type string :initarg :abr :reader abr)
+ (rin :type string :initarg :rin :reader rin))
+ (:metaclass ml-class)
+ (:default-initargs
+ :rt nil :ui nil :styrl nil :stnrtn nil :def nil :ex nil :un nil :rh nil
+ :abr nil :rin nil)
+ (:title "Basic information about Semantic Types and Relations")
+ (:fields
+ (rt :string) (ui :string fmt-tui) (styrl :string) (stnrtn :string-tui)
+ (def :string) (ex :string) (un :string) (rh :string) (abr :string)
+ (rin :string)))
+
+(defclass sstr (umlsclass)
+ ((styrl :type string :initarg :styrl :reader styrl)
+ (rl :type string :initarg :rl :reader rl)
+ (styrl2 :type string :initarg :styrl2 :reader styrl2)
+ (ls :type string :initarg :ls :reader ls))
+ (:metaclass ml-class)
+ (:default-initargs :styrl nil :rl nil :styrl2 nil :ls nil)
+ (:title "Structure of the Network")
+ (:fields (styrl :string) (rl :string) (styrl2 :string) (ls :string)))
+
+(defclass sstre1 (umlsclass)
+ ((ui :type integer :initarg :ui :reader ui)
+ (ui2 :type integer :initarg :ui2 :reader ui2)
+ (ui3 :type integer :initarg :ui3 :reader ui3))
+ (:metaclass ml-class)
+ (:default-initargs :ui nil :ui2 nil :ui3 nil)
+ (:title "Fully Inherited Set of Releatons (TUI's)")
+ (:fields (ui :string fmt-tui) (ui2 :string fmt-tui) (ui3 :string fmt-tui)))
+
+(defclass sstre2 (umlsclass)
+ ((sty :type string :initarg :ui :reader sty)
+ (rl :type string :initarg :ui2 :reader rl)
+ (sty2 :type string :initarg :ui3 :reader sty2))
+ (:metaclass ml-class)
+ (:default-initargs :sty nil :rl nil :sty2 nil)
+ (:title "Fully Inherited Set of Releatons (strings)")
+ (:fields (sty :string) (rl :string) (sty2 :string)))
+
+;;; Formatting routines
+
+(defmethod fmt-cui ((c ucon))
+ (format nil "C~7,'0d" (cui c)))
+
+(defmethod fmt-cui ((c fixnum))
+ (format nil "C~7,'0d" c))
+
+(defmethod fmt-cui ((c string))
+ (if (eql (aref c 0) #\C)
+ c
+ (format nil "C~7,'0d" (parse-integer c))))
+
+(defmethod fmt-cui ((c null))
+ (format nil "nil"))
+
+(defmethod fmt-lui ((l uterm))
+ (format nil "L~7,'0d" (lui l)))
+
+(defmethod fmt-lui ((l fixnum))
+ (format nil "L~7,'0d" l))
+
+(defmethod fmt-lui ((l string))
+ (if (eql (aref l 0) #\L)
+ l
+ (format nil "L~7,'0d" (parse-integer l))))
+
+(defmethod fmt-sui ((s ustr))
+ (format nil "S~7,'0d" (sui s)))
+
+(defmethod fmt-sui ((s fixnum))
+ (format nil "S~7,'0d" s))
+
+(defmethod fmt-sui ((s string))
+ (if (eql (aref s 0) #\S)
+ s
+ (format nil "S~7,'0d" (parse-integer s))))
+
+(defmethod fmt-tui ((s fixnum))
+ (format nil "T~3,'0d" s))
+
+(defmethod fmt-tui ((s string))
+ (if (eql (aref s 0) #\T)
+ s
+ (format nil "T~3,'0d" (parse-integer s))))
+
+(defmethod fmt-eui ((e fixnum))
+ (format nil "E~7,'0d" e))
+
+(defmethod fmt-eui ((e string))
+ (if (eql (aref e 0) #\E)
+ e
+ (format nil "E~7,'0d" (parse-integer e))))
+
+(defmethod fmt-eui ((e null))
+ (format nil "nil"))
+
+;;; Generic display functions
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun english-term-p (obj)
+ (and (eq (class-name (class-of obj)) 'uterm)
+ (string-equal (lat obj) "ENG"))))
+
+(defun display-umls-obj
+ (obj &key (os *standard-output*) (format :text) (label nil)
+ (file-wrapper t) (english-only nil) (subobjects nil)
+ (refvars nil))
+ (display-ml-class
+ obj :os os :format format :label label :subobjects subobjects
+ :file-wrapper file-wrapper
+ :english-only-function (if english-only #'english-term-p nil)
+ :refvars refvars))
+
+(defmacro defludisp-ml-class (newfuncname lookup-func)
+ "Defines functions for looking up and displaying objects"
+ `(defun ,newfuncname
+ (keyval &key (os *standard-output*) (format :text) (label nil)
+ (file-wrapper t) (english-only nil) (subobjects nil))
+ (let ((obj (funcall ,lookup-func keyval)))
+ (display-umls-obj obj :os os :format format :label label
+ :file-wrapper file-wrapper :english-only english-only
+ :subobjects subobjects))))
+
+(defludisp-ml-class disp-con #'find-ucon-cui)
+(defludisp-ml-class disp-term #'find-uterm-lui)
+(defludisp-ml-class disp-str #'find-ustr-sui)
+
--- /dev/null
+;;;; $Id: package.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $
+;;;;
+;;;; Package definition for UMLisp
+
+(in-package :cl-user)
+
+(defpackage umlisp
+ (:nicknames :u)
+ (:export
+ #:ucon
+ #:uterm
+ #:ustr
+ #:find-udef-cui
+ #:find-usty-cui
+ #:find-usty-word
+ #:find-urel-cui
+ #:find-urel-cui2
+ #:find-ucon-rel-cui2
+ #:find-ucoc-cui
+ #:find-ucoc-cui2
+ #:find-ucon-coc-cui2
+ #:find-ulo-cui
+ #:suistr
+ #:find-uatx-cui
+ #:display-umls-obj
+ #:find-ucon-cui
+ #:find-ucon-lui
+ #:find-ucon-sui
+ #:find-ucon-cuisui
+ #:find-ucon-str
+ #:find-ucon-all
+ #:find-uterm-cui
+ #:find-uterm-lui
+ #:find-uterm-cuilui
+ #:find-uterm-in-ucon
+ #:find-ustr-cuilui
+ #:find-ustr-cuisui
+ #:find-ustr-sui
+ #:find-ustr-sab
+ #:find-ustr-all
+ #:find-string-sui
+ #:find-uso-cuisui
+ #:find-ucxt-cuisui
+ #:find-usat-ui
+ #:find-bsab-sab
+ #:find-bsab-all
+ #:find-btty-tty
+ #:find-btty-all
+ #:find-brel-rel
+ #:find-pfstr-cui
+ #:find-ustr-in-uterm
+ #:find-usty-tui
+ #:find-usty-all
+ #:find-usty_freq-all
+ #:find-usrl-all
+ #:find-usrl_freq-all
+ #:find-cui-max
+ #:find-ucon-tui
+ #:find-ucon-word
+ #:find-ucon-normalized-word
+ #:find-ustr-word
+ #:find-ustr-normalized-word
+ #:find-ucon-multiword
+ #:find-ucon-normalized-multiword
+ #:find-ustr-multiword
+ #:find-ustr-normalized-multiword
+ #:find-lexterm-eui
+ #:find-lexterm-word
+ #:find-labr-eui
+ #:find-labr-bas
+ #:find-lagr-eui
+ #:find-lcmp-eui
+ #:find-lmod-eui
+ #:find-lnom-eui
+ #:find-lprn-eui
+ #:find-lprp-eui
+ #:find-lspl-eui
+ #:find-ltrm-eui
+ #:find-ltyp-eui
+ #:find-lwd-wrd
+ #:find-sdef-ui
+ #:find-sstre1-ui
+ #:find-sstre1-ui2
+ #:find-sstr2-sty
+ #:find-sstr-rl
+ #:find-sstr-styrl
+ #:disp-con
+ #:disp-term
+ #:disp-str
+
+ ;; composite.cl
+ #:tui-finding
+ #:tui-sign-or-symptom
+ #:tui-disease-or-syndrome
+ #:ucon-is-tui?
+ #:find-ucon2-tui
+ #:find-ucon2-coc-tui
+ #:find-ucon2-rel-tui
+ #:find-ucon2_freq-coc-tui
+ #:find-ucon2-str&sty
+ #:find-ucon2-coc-str&sty
+ #:find-ucon2-rel-str&sty
+ #:find-ucon2_freq-tui-all
+ #:find-ucon2_freq-rel-tui-all
+ #:find-ucon2_freq-coc-tui-all
+ #:ucon_freq
+ #:ustr_freq
+ #:usty_freq
+ #:usrl_freq
+
+ #:umlisp-user
+ #:ustats
+ #:usrl
+ #:bsab
+ #:btty
+ #:brel
+ #:batn
+ #:urank
+ #:urel
+ #:usat
+ #:uso
+ #:ucxt
+ #:ustr
+ #:ulo
+ #:uterm
+ #:usty
+ #:urel
+ #:ucoc
+ #:uatx
+ #:ucon
+ #:uxw
+ #:uxnw
+ #:uxns
+ #:lexterm
+ #:labr
+ #:lagr
+ #:lcmp
+ #:lmod
+ #:lmod
+ #:lprn
+ #:prp
+ #:lspl
+ #:ltrm
+ #:ltyp
+ #:sdef
+ #:sstr
+ #:sstre1
+ #:sstre2
+ ))
+
+
+
+
--- /dev/null
+ ;;; UMLS-Parse
+;;; Lisp Routines for parsing UMLS files
+;;; and inserting into SQL databases
+;;;
+;;; Copyright (c) 2001 Kevin M. Rosenberg, M.D.
+;;; $Id: parse-2002.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $
+
+(in-package :umlisp)
+
+;;; Pre-read data for custom fields into hash tables
+(defvar *parse-hash-init?* nil)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(let ((pfstr-hash nil) ;;; Preferred concept strings by CUI
+ (cui-lrl-hash nil) ;;; LRL by CUI
+ (lui-lrl-hash nil) ;;; LRL by LUI
+ (cuisui-lrl-hash nil) ;;; LRL by CUISUI
+ (sab-srl-hash nil)) ;;; SRL by SAB
+
+ (defun make-parse-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))
+ (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))))
+
+ (defun binit-hash-table (&optional (force-read nil))
+ (when (or force-read (not *parse-hash-init?*))
+ (make-parse-hash-table)
+ (setq *parse-hash-init?* t))
+ (with-buffered-umls-file (line "MRCON")
+ (let ((cui (parse-ui (aref line 0)))
+ (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 (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 3 line)))
+ (unless (gethash sab sab-srl-hash) ;; if haven't stored
+ (setf (gethash sab sab-srl-hash) (aref 6 line))))))
+
+ (defun init-hash-table (&optional (force-read nil))
+ (when (or force-read (not *parse-hash-init?*))
+ (make-parse-hash-table)
+ (setq *parse-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)))
+ (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))))))))
+
+ (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)
+ (gu:aif (gethash sab sab-srl-hash) gu::it 0))
+)) ;; closure
+
+(defun set-lrl-hash (key lrl hash)
+ "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))))
+
+;; UMLS file and column structures
+
+(defstruct (umls-file)
+ "Record for each UMLS File"
+ fil table des fmt cls rws bts fields colstructs)
+
+(defstruct (umls-col)
+ "Record for each UMLS Column in each file"
+ col des ref min av max fil sqltype
+ dty ;; new in 2002 umls: suggested SQL datatype
+ parsefunc quotechar datatype custom-value-func)
+
+;;; SQL datatypes symbols
+;;; sql-u - Unique identifier
+;;; sql-s - Small integer (16-bit)
+;;; sql-i - Integer (32-bit)
+;;; sql-l - Big integer (64-bit)
+;;; sql-f - Floating point
+
+(defconstant +col-datatypes+
+ '(("AV" sql-f) ("BTS" sql-i) ("CLS" sql-i) ("COF" sql-i) ("CUI1" sql-u)
+ ("CUI2" sql-u) ("CUI" sql-u) ("CXN" sql-s) ("FR" sql-i) ("LRL" sql-s)
+ ("LUI" sql-u) ("MAX" sql-s) ("MIN" sql-s) ("RANK" sql-s) ("REF" sql-s)
+ ("RNK" sql-s) ("RWS" sql-i) ("SRL" sql-s) ("SUI" sql-u) ("TUI" sql-u)
+ ;;; Custom columns
+ ("KCUISUI" sql-l) ("KCUILUI" sql-l) ("KCUILRL" sql-i) ("KLUILRL" sql-i)
+ ("KSRL" sql-i) ("KLRL" sql-i)
+ ;;; LEX columns
+ ("EUI" sql-u) ("EUI2" sql-u)
+ ;;; Semantic net columns
+ ("UI" sql-u) ("UI2" sql-u) ("UI3" sql-u))
+ "SQL data types for each non-string column")
+
+(defconstant +custom-tables+
+ nil
+ #+ignore
+ '(("MRCONSO" "SELECT m.CUI, m.LAT, m.TS, m.LUI, m.STT, m.SUI, m.STR, m.LRL, s.SAB, s.TTY, s.SCD, s.SRL FROM MRCON m, MRSO s WHERE m.CUI=s.CUI AND m.LUI=s.LUI AND m.SUI=s.SUI")
+ ("MRCONFULL" "SELECT m.CUI, m.LAT, m.TS, m.LUI, m.STT, m.SUI, m.STR, m.LRL, s.SAB, s.TTY, s.SCD, s.SRL, t.TUI FROM MRCON m, MRSO s, MRSTY t WHERE m.CUI=s.CUI AND m.LUI=s.LUI AND m.SUI=s.SUI AND m.CUI=t.CUI AND s.CUI=t.CUI"))
+ "Custom tables to create")
+
+(defconstant +custom-cols+
+ '(("MRCON" "KPFSTR" "TEXT" 1024
+ (lambda (x) (pfstr-hash (parse-ui (nth 0 x)))))
+ ("MRCON" "KCUISUI" "BIGINT" 0
+ (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 5 x))))))
+ ("MRCON" "KCUILUI" "BIGINT" 0
+ (lambda (x) (format nil "~d" (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 3 x))))))
+ ("MRCON" "KCUILRL" "INTEGER" 0
+ (lambda (x) (format nil "~d" (cui-lrl (parse-ui (nth 0 x))))))
+ ("MRCON" "KLUILRL" "INTEGER" 0
+ (lambda (x) (format nil "~d" (lui-lrl (parse-ui (nth 3 x))))))
+ ("MRLO" "KLRL" "INTEGER" 0
+ (lambda (x) (format nil "~d"
+ (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) (format nil "~d" (cui-lrl (parse-ui (nth 0 x))))))
+ ("MRCOC" "KLRL" "INTEGER" 0
+ (lambda (x) (format nil "~d"
+ (max (cui-lrl (parse-ui (nth 0 x)))
+ (gu:aif (cui-lrl (parse-ui (nth 1 x))) gu::it 0)))))
+ ("MRSAT" "KSRL" "INTEGER" 0
+ (lambda (x) (format nil "~d" (sab-srl (nth 5 x)))))
+ ("MRREL" "KSRL" "INTEGER" 0
+ (lambda (x) (format nil "~d" (sab-srl (nth 4 x)))))
+ ("MRRANK" "KSRL" "INTEGER" 0
+ (lambda (x) (format nil "~d" (sab-srl (nth 1 x)))))
+ ("MRDEF" "KSRL" "INTEGER" 0
+ (lambda (x) (format nil "~d" (sab-srl (nth 1 x)))))
+ ("MRCXT" "KSRL" "INTEGER" 0
+ (lambda (x) (format nil "~d" (sab-srl (nth 2 x)))))
+ ("MRATX" "KSRL" "INTEGER" 0
+ (lambda (x) (format nil "~d" (sab-srl (nth 1 x)))))
+ ("MRXW.ENG" "KLRL" "INTEGER" 0
+ (lambda (x) (format nil "~d" (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
+ ("MRXW.NONENG" "KLRL" "INTEGER" 0
+ (lambda (x) (format nil "~d" (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
+ ("MRXNW.ENG" "KLRL" "INTEGER" 0
+ (lambda (x) (format nil "~d" (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
+ ("MRXNS.ENG" "KLRL" "INTEGER" 0
+ (lambda (x) (format nil "~d" (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
+ (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
+ ("MRSAT" "KCUILUI" "BIGINT" 0
+ (lambda (x) (format nil "~d" (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
+ ("MRSAT" "KCUISUI" "BIGINT" 0
+ (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 2 x))))))
+ ("MRSO" "KCUISUI" "BIGINT" 0
+ (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 2 x))))))
+ ("MRXW.ENG" "KCUISUI" "BIGINT" 0
+ (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
+ ("MRXNW.ENG" "KCUISUI" "BIGINT" 0
+ (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
+ ("MRXNS.ENG" "KCUISUI" "BIGINT" 0
+ (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
+ ("MRXW.NONENG" "LAT" "CHAR" 3 (lambda (x) (nth 0 x)))
+ ("MRXW.NONENG" "WD" "CHAR" 200 (lambda (x) (nth 1 x)))
+ ("MRXW.NONENG" "CUI" "INTEGER" 0 (lambda (x) (nth 2 x)))
+ ("MRXW.NONENG" "LUI" "INTEGER" 0 (lambda (x) (nth 3 x)))
+ ("MRXW.NONENG" "SUI" "INTEGER" 0 (lambda (x) (nth 4 x)))
+ ("MRXW.NONENG" "KCUISUI" "BIGINT" 0
+ (lambda (x) (format nil "~d" (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x)))))))
+ "Custom columns to create.(filename, col, sqltype, value-func).")
+
+(defconstant +index-cols+
+ '(("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") ("NSTR" "MRXNS_ENG" 10)
+ ("CUI" "MRXNW_ENG") ("NWD" "MRXNW_ENG") ("WD" "MRXW_ENG")
+ ("KCUISUI" "MRCON") ("KCUILUI" "MRCON") ("KCUILRL" "MRCON")
+ ("KLUILRL" "MRCON") ("KCUISUI" "MRCXT")
+ ("KCUISUI" "MRSO") ("KCUISUI" "MRSAT") ("KCUILUI" "MRSAT")
+ ("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")
+ ("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")
+ ;; Semantic NET indices
+ ("UI" "SRSTRE1") ("UI2" "SRSTRE1") ("UI3" "SRSTRE1")
+ ("STY_RL" "SRDEF") ("RT" "SRDEF") ("STY_RL" "SRSTR") ("STY_RL2" "SRSTR")
+ ("RL" "SRSTR"))
+ "Columns in files to index")
+
+
+(defconstant +custom-index-cols+
+ nil
+ #+ignore
+ '(("CUI" "MRCONFULL") ("SAB" "MRCONFULL") ("TUI" "MRCONFULL"))
+ "Indexes to custom tables")
+
+;; File & Column functions
+
+(defun init-umls (&optional (alwaysclear nil))
+"Initialize all UMLS file and column structures if not already initialized"
+ (when (or alwaysclear (null *umls-files*))
+ (init-umls-cols)
+ (init-umls-files)
+ (init-field-lengths)))
+
+(defun init-umls-cols ()
+ (setq *umls-cols* (append
+ (init-meta-cols)
+ (init-custom-cols)
+ (init-generic-cols "LRFLD")
+ (init-generic-cols "SRFLD"))))
+
+(defun init-meta-cols ()
+"Initialize all umls columns"
+ (let ((cols '()))
+ (with-umls-file (line "MRCOLS")
+ (destructuring-bind (col des ref min av max fil dty) line
+ (let ((c (make-umls-col
+ :col col
+ :des des
+ :ref ref
+ :min (parse-integer min)
+ :av (read-from-string av)
+ :max (parse-integer max)
+ :fil fil
+ :dty dty ;; new in 2002 UMLS
+ :sqltype "VARCHAR" ; default data type
+ :parsefunc #'add-sql-quotes
+ :custom-value-func nil
+ :quotechar "'")))
+ (add-datatype-to-col c (datatype-for-col col))
+ (push c cols))))
+ (nreverse cols)))
+
+(defun init-custom-cols ()
+"Initialize umls columns for custom columns"
+ (let ((cols '()))
+ (dolist (customcol +custom-cols+)
+ (let ((c (make-umls-col :col (nth 1 customcol)
+ :des ""
+ :ref 0
+ :min 0
+ :max (nth 3 customcol)
+ :av 0
+ :dty nil
+ :fil (nth 0 customcol)
+ :sqltype (nth 2 customcol)
+ :parsefunc #'add-sql-quotes
+ :custom-value-func (nth 4 customcol)
+ :quotechar "'")))
+ (add-datatype-to-col c (datatype-for-col (nth 1 customcol)))
+ (push c cols)))
+ (nreverse cols)))
+
+(defun escape-column-name (name)
+ (substitute #\_ #\/ name))
+
+(defun init-generic-cols (col-filename)
+"Initialize for generic (LEX/NET) columns"
+ (let ((cols '()))
+ (with-umls-file (line col-filename)
+ (destructuring-bind (nam des ref fil) line
+ (setq nam (escape-column-name nam))
+ (dolist (file (delimited-string-to-list fil #\,))
+ (let ((c (make-umls-col
+ :col nam
+ :des des
+ :ref ref
+ :min nil
+ :av nil
+ :max nil
+ :fil file
+ :dty nil
+ :sqltype "VARCHAR" ; default data type
+ :parsefunc #'add-sql-quotes
+ :custom-value-func nil
+ :quotechar "'")))
+ (add-datatype-to-col c (datatype-for-col nam))
+ (push c cols)))))
+ (nreverse cols)))
+
+(defun init-umls-files ()
+ (setq *umls-files* (append
+ (init-generic-files "MRFILES")
+ (init-generic-files "LRFIL")
+ (init-generic-files "SRFIL")))
+ ;; need to separate this since init-custom-files depends on *umls-files*
+ (setq *umls-files* (append *umls-files* (init-custom-files))))
+
+
+(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 ((field-list (delimited-string-to-list (escape-column-name fmt) #\,))
+ (col-count (make-hash-table :test 'equal)))
+ (dotimes (i (length field-list))
+ (declare (fixnum i))
+ (let ((col (nth i field-list)))
+ (multiple-value-bind (key found) (gethash col col-count)
+ (if found
+ (let ((next-id (1+ key)))
+ (setf (nth i field-list) (concatenate 'string
+ col
+ (format nil "~D" next-id)))
+ (setf (gethash col col-count) next-id))
+ (setf (gethash col col-count) 1)))))
+ field-list))
+
+(defun init-generic-files (files-filename)
+"Initialize all LEX file structures"
+ (let ((files '()))
+ (with-umls-file (line files-filename)
+ (destructuring-bind (fil des fmt cls rws bts) line
+ (let ((f (make-umls-file
+ :fil fil
+ :table (substitute #\_ #\. fil)
+ :des des
+ :fmt (escape-column-name fmt)
+ :cls (parse-integer cls)
+ :rws (parse-integer rws)
+ :bts (parse-integer bts)
+ :fields (concatenate 'list
+ (umls-field-string-to-list fmt)
+ (custom-colnames-for-filename fil)))))
+ (setf (umls-file-colstructs f) (umls-cols-for-umls-file f))
+ (push f files))))
+ (nreverse files)))
+
+(defun init-custom-files ()
+ (let ((ffile (make-umls-file :fil "MRXW.NONENG"
+ :des "Custom NonEnglish Index"
+ :table "MRXW_NONENG"
+ :cls 5
+ :rws 0
+ :bts 0
+ :fields (umls-file-fields (find-umls-file "MRXW.ENG")))))
+ (setf (umls-file-colstructs ffile)
+ (umls-cols-for-umls-file ffile))
+ (list ffile)))
+
+(defun datatype-for-col (colname)
+"Return datatype for column name"
+ (car (cdr (find colname +col-datatypes+ :key #'car :test #'string-equal))))
+
+(defun add-datatype-to-col (col datatype)
+"Add data type information to column"
+ (setf (umls-col-datatype col) datatype)
+ (case datatype
+ (sql-u (setf (umls-col-sqltype col) "INTEGER"
+ (umls-col-parsefunc col) #'parse-ui
+ (umls-col-quotechar col) ""))
+ (sql-s (setf (umls-col-sqltype col) "SMALLINT"
+ (umls-col-parsefunc col) #'parse-integer
+ (umls-col-quotechar col) ""))
+ (sql-l (setf (umls-col-sqltype col) "BIGINT"
+ (umls-col-parsefunc col) #'parse-integer
+ (umls-col-quotechar col) ""))
+ (sql-i (setf (umls-col-sqltype col) "INTEGER"
+ (umls-col-parsefunc col) #'parse-integer
+ (umls-col-quotechar col) ""))
+ (sql-f (setf (umls-col-sqltype col) "NUMERIC"
+ (umls-col-parsefunc col) #'read-from-string
+ (umls-col-quotechar col) ""))
+ (t ; Default column type, optimized text storage
+ (setf (umls-col-parsefunc col) #'add-sql-quotes
+ (umls-col-quotechar col) "'")
+ (when (and (umls-col-max col) (umls-col-av col))
+ (if (> (umls-col-max col) 255)
+ (setf (umls-col-sqltype col) "TEXT")
+ (if (< (- (umls-col-max col) (umls-col-av col)) 4)
+ (setf (umls-col-sqltype col) "CHAR") ; if average bytes wasted < 4
+ (setf (umls-col-sqltype col) "VARCHAR")))))))
+
+
+
--- /dev/null
+;;; UMLS-Parse General
+;;; General purpose Lisp Routines for parsing UMLS files
+;;; and inserting into SQL databases
+;;;
+;;; Copyright (c) 2001 Kevin M. Rosenberg, M.D.
+;;; $Id: parse-common.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $
+
+(in-package :umlisp)
+
+(defun umls-pathname (filename &optional (extension ""))
+"Return pathname for a umls filename"
+ (etypecase filename
+ (string
+ (merge-pathnames
+ (make-pathname :name (concatenate 'string filename extension))
+ (case (char filename 0)
+ ((#\M #\m)
+ *meta-path*)
+ ((#\L #\l)
+ *lex-path*)
+ ((#\S #\s)
+ *net-path*)
+ (t
+ *umls-path*))))
+ (pathname
+ filename)))
+
+(defun read-umls-line (strm)
+ "Read a line from a UMLS stream, split into fields"
+ (let ((line (read-line strm nil 'eof)))
+ (if (stringp line) ;; ensure not 'eof
+ (let* ((len (length line))
+ (maybe-remove-terminal ;; LRWD doesn't have '|' at end of line
+ (if (char= #\| (char line (1- len)))
+ (subseq line 0 (1- len))
+ line)))
+ (declare (fixnum len))
+ (delimited-string-to-list maybe-remove-terminal #\|))
+ line)))
+
+
+;;; Find field lengths for LEX and NET files
+
+(defun file-field-lengths (files)
+ (let ((lengths '()))
+ (dolist (file files)
+ (setq file (umls-file-fil file))
+ (let (max-field count-field num-fields (count-lines 0))
+ (with-umls-file (fields file)
+ (unless num-fields
+ (setq num-fields (length fields))
+ (setq max-field (make-array num-fields :element-type 'fixnum
+ :initial-element 0))
+ (setq count-field (make-array num-fields :element-type 'number
+ :initial-element 0)))
+ (dotimes (i (length fields))
+ (declare (fixnum i))
+ (let ((len (length (nth i fields))))
+ (incf (aref count-field i) len)
+ (when (> len (aref max-field i))
+ (setf (aref max-field i) len))))
+ (incf count-lines))
+ (dotimes (i num-fields)
+ (setf (aref count-field i) (float (/ (aref count-field i) count-lines))))
+ (push (list file max-field count-field) lengths)))
+ (nreverse lengths)))
+
+(defun init-field-lengths ()
+ "Initial colstruct field lengths for files that don't have a measurement.
+Currently, these are the LEX and NET files."
+ (let ((measure-files '()))
+ (dolist (file *umls-files*)
+ (let ((filename (umls-file-fil file)))
+ (unless (or (char= #\M (char filename 0))
+ (char= #\m (char filename 0)))
+ (push file measure-files))))
+ (let ((length-lists (file-field-lengths measure-files)))
+ (dolist (length-list length-lists)
+ (let* ((filename (car length-list))
+ (max-field (cadr length-list))
+ (av-field (caddr length-list))
+ (file (find-umls-file filename)))
+ (when file
+ (if (/= (length max-field) (length (umls-file-fields file)))
+ (format t "Warning: Number of file fields ~A doesn't match length of fields in file structure ~S"
+ max-field file)
+ (dotimes (i (max (length max-field) (length (umls-file-fields file))))
+ (declare (fixnum i))
+ (let* ((field (nth i (umls-file-fields file)))
+ (col (find-umls-col field filename)))
+ (if col
+ (progn
+ (setf (umls-col-max col) (aref max-field i))
+ (setf (umls-col-av col) (aref av-field i))
+ (add-datatype-to-col col (datatype-for-col (umls-col-col col))))
+ (error "can't find column ~A" field)))))))))))
+
+
+
+;;; UMLS column/file functions
+
+(defun find-col-in-columns (colname filename cols)
+"Returns list of umls-col structure for a column name and a filename"
+ (dolist (col cols)
+ (when (and (string-equal filename (umls-col-fil col))
+ (string-equal colname (umls-col-col col)))
+ (return-from find-col-in-columns col)))
+ nil)
+
+(defun find-or-make-col-in-columns (colname filename cols)
+ (let ((col (find-col-in-columns colname filename cols)))
+ (if col
+ col
+ ;; try to find column name without a terminal digit
+ (let* ((last-char (char colname (1- (length colname))))
+ (digit (- (char-code last-char) (char-code #\0))))
+ (if (and (>= digit 0) (<= digit 9))
+ (let ((base-colname (subseq colname 0 (1- (length colname)))))
+ (setq col (find-col-in-columns base-colname filename cols))
+ (if col
+ (let ((new-col (make-umls-col
+ :col (copy-seq colname)
+ :des (copy-seq (umls-col-des col))
+ :ref (copy-seq (umls-col-ref col))
+ :min (umls-col-min col)
+ :max (umls-col-max col)
+ :fil (copy-seq (umls-col-fil col))
+ :sqltype (copy-seq (umls-col-sqltype col))
+ :dty (copy-seq (umls-col-dty col))
+ :parsefunc (umls-col-parsefunc col)
+ :quotechar (copy-seq (umls-col-quotechar col))
+ :datatype (umls-col-datatype col)
+ :custom-value-func (umls-col-custom-value-func col))))
+ (push new-col *umls-cols*)
+ new-col)
+ (error "Couldn't find a base column for col ~A in file ~A"
+ colname filename)))
+ (let ((new-col (make-umls-col
+ :col (copy-seq colname)
+ :des "Unknown"
+ :ref ""
+ :min nil
+ :max nil
+ :fil filename
+ :sqltype "VARCHAR"
+ :dty nil
+ :parsefunc #'add-sql-quotes
+ :quotechar "'"
+ :datatype nil
+ :custom-value-func nil)))
+ (push new-col *umls-cols*)
+ new-col))))))
+
+(defun find-umls-col (colname filename)
+ "Returns list of umls-col structure for a column name and a filename"
+ (find-or-make-col-in-columns colname filename *umls-cols*))
+
+(defun find-umls-file (filename)
+ "Returns umls-file structure for a filename"
+ (find-if (lambda (f) (string-equal filename (umls-file-fil f))) *umls-files*))
+
+(defun umls-cols-for-umls-file (file)
+ "Returns list of umls-cols for a file structure"
+ (let ((filename (umls-file-fil file)))
+ (mapcar (lambda (col) (find-umls-col col filename))
+ (umls-file-fields file))))
+
+
+;; SQL command functions
+
+(defun create-table-cmd (file)
+"Return sql command to create a table"
+ (let ((col-func
+ (lambda (c)
+ (let ((sqltype (umls-col-sqltype c)))
+ (concatenate 'string (umls-col-col c)
+ " "
+ (if (or (string-equal sqltype "VARCHAR")
+ (string-equal sqltype "CHAR"))
+ (format nil "~a (~a)" sqltype (umls-col-max c))
+ sqltype)
+ ",")))))
+ (format nil "CREATE TABLE ~a (~a)" (umls-file-table file)
+ (string-trim-last-character
+ (mapcar-append-string col-func (umls-cols-for-umls-file 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-values-cmd (file values)
+"Return sql insert command for a row of values"
+ (let ((insert-func
+ (lambda (col value)
+ (concatenate
+ 'string
+ (umls-col-quotechar col)
+ (if (null (umls-col-parsefunc col))
+ value
+ (format nil "~A" (funcall (umls-col-parsefunc col) value)))
+ (umls-col-quotechar col)
+ ","))))
+ (format
+ nil "INSERT INTO ~a (~a) VALUES (~a)"
+ (umls-file-table file)
+ (string-trim-last-character
+ (mapcar-append-string (lambda (c) (concatenate 'string c ","))
+ (umls-file-fields file)))
+ (string-trim-last-character
+ (concatenate 'string
+ (mapcar2-append-string insert-func
+ (remove-custom-cols (umls-file-colstructs file))
+ values)
+ (custom-col-values (custom-colstructs-for-file file) values "," t)))
+ )))
+
+(defun custom-col-values (colstructs values delim doquote)
+ "Returns string of column values for SQL inserts for custom columns"
+ (let ((result ""))
+ (dolist (col colstructs)
+ (let* ((func (umls-col-custom-value-func col))
+ (custom-value (funcall func values)))
+ (string-append result
+ (if doquote (umls-col-quotechar col))
+ (escape-backslashes custom-value)
+ (if doquote (umls-col-quotechar col))
+ delim)))
+ result))
+
+(defun remove-custom-cols (cols)
+ "Remove custom cols from a list col umls-cols"
+ (remove-if #'umls-col-custom-value-func cols))
+
+(defun find-custom-cols-for-filename (filename)
+ (remove-if-not (lambda (x) (string-equal filename (car x))) +custom-cols+))
+
+(defun find-custom-col (filename col)
+ (find-if (lambda (x) (and (string-equal filename (car x))
+ (string-equal col (cadr x)))) +custom-cols+))
+
+
+(defun custom-colnames-for-filename (filename)
+ (mapcar #'cadr (find-custom-cols-for-filename filename)))
+
+(defun custom-colstructs-for-file (file)
+ (remove-if-not #'umls-col-custom-value-func (umls-file-colstructs file)))
+
+(defun noneng-lang-index-files ()
+ (remove-if-not (lambda (f) (and (> (length (umls-file-fil f)) 4)
+ (string-equal (umls-file-fil f) "MRXW." :end1 5)
+ (not (string-equal (umls-file-fil f) "MRXW.ENG"))
+ (not (string-equal (umls-file-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 ~a)"
+ (concatenate 'string tablename "_" colname "_X") tablename colname
+ (if (integerp length)
+ (format nil "(~d)" length)
+ "")))
+
+(defun create-all-tables-cmdfile ()
+"Return sql commands to create all tables. Not need for automated SQL import"
+ (mapcar (lambda (f) (format nil "~a~%~%" (create-table-cmd f))) *umls-files*))
+
+
+;; SQL Execution functions
+
+(defun sql-drop-tables (conn)
+"SQL Databases: drop all tables"
+ (mapcar
+ (lambda (file)
+ (ignore-errors
+ (sql-execute (format nil "DROP TABLE ~a" (umls-file-table file)) conn)))
+ *umls-files*))
+
+(defun sql-create-tables (conn)
+"SQL Databases: create all tables"
+ (mapcar (lambda (file) (sql-execute (create-table-cmd file) conn)) *umls-files*))
+
+(defun sql-create-custom-tables (conn)
+"SQL Databases: create all custom tables"
+ (mapcar (lambda (ct)
+ (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn))
+ +custom-tables+))
+
+(defun sql-insert-values (conn file)
+"SQL Databases: inserts all values for a file"
+ (with-umls-file (line (umls-file-fil file))
+ (sql-execute (insert-values-cmd file line) conn)))
+
+(defun sql-insert-all-values (conn)
+"SQL Databases: inserts all values for all files"
+ (mapcar (lambda (file) (sql-insert-values conn file)) *umls-files*))
+
+(defun sql-create-indexes (conn &optional (indexes +index-cols+))
+"SQL Databases: create all indexes"
+(mapcar
+ (lambda (idx)
+ (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn))
+ indexes))
+
+(defun create-umls-db-by-insert ()
+"SQL Databases: initializes entire database via SQL insert commands"
+ (init-umls)
+ (init-hash-table)
+ (with-sql-connection (conn)
+;; (sql-drop-tables conn)
+;; (sql-create-tables conn)
+;; (sql-insert-all-values conn)
+ (sql-create-indexes conn)
+ (sql-create-custom-tables conn)
+ (sql-create-indexes conn +custom-index-cols+)))
+
+(defun create-umls-db (&optional (extension ".trans")
+ (copy-cmd #'mysql-copy-cmd))
+ "SQL Databases: initializes entire database via SQL copy commands"
+ (init-umls)
+ (init-hash-table)
+ (translate-all-files extension)
+ (with-sql-connection (conn)
+ (sql-drop-tables conn)
+ (sql-create-tables conn)
+ (mapcar
+ #'(lambda (file) (sql-execute (funcall copy-cmd file extension) conn))
+ *umls-files*)
+ (sql-create-indexes conn)
+ (sql-create-custom-tables conn)
+ (sql-create-indexes conn +custom-index-cols+)))
+
+(defun translate-all-files (&optional (extension ".trans"))
+"Copy translated files and return postgresql copy commands to import"
+ (make-noneng-index-file extension)
+ (mapcar (lambda (f) (translate-file f extension)) *umls-files*))
+
+(defun translate-file (file extension)
+ "Translate a umls file into a format suitable for sql copy cmd"
+ (let ((path (umls-pathname (umls-file-fil file) extension)))
+ (if (probe-file path)
+ (progn
+ (format t "File ~A already exists: skipping~%" path)
+ nil)
+ (with-open-file (ostream path :direction :output)
+ (with-umls-file (line (umls-file-fil file))
+ (princ (umls-translate file line) ostream)
+ (princ #\newline ostream))
+ t))))
+
+(defun make-noneng-index-file (extension)
+ "Make non-english index file"
+ (let* ((outfile (find-umls-file "MRXW.NONENG"))
+ (path (umls-pathname (umls-file-fil outfile) extension)))
+
+ (if (probe-file path)
+ (progn
+ (format t "File ~A already exists: skipping~%" path)
+ nil)
+ (progn
+ (with-open-file (ostream path :direction :output)
+ (dolist (inputfile (noneng-lang-index-files))
+ (with-umls-file (line (umls-file-fil inputfile))
+ (princ (umls-translate outfile line) ostream) ;; use outfile for custom cols
+ (princ #\newline ostream))))
+ t))))
+
+(defun pg-copy-cmd (file extension)
+"Return postgresql copy statement for a file"
+ (format nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
+ (umls-file-table file) (umls-pathname (umls-file-fil file) extension)))
+
+(defun mysql-copy-cmd (file extension)
+"Return mysql copy statement for a file"
+ (format nil "LOAD DATA LOCAL INFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\""
+ (umls-pathname (umls-file-fil file) extension) (umls-file-table file)))
+
+(defun umls-translate (file line)
+"Translate a single line for sql output"
+(string-trim-last-character
+ (concatenate 'string
+ (mapcar2-append-string
+ (lambda (col value)
+ (concatenate
+ 'string
+ (if (eq (umls-col-datatype col) 'sql-u)
+ (format nil "~d" (parse-ui value ""))
+ (escape-backslashes value))
+ "|"))
+ (remove-custom-cols (umls-file-colstructs file))
+ line)
+ (custom-col-values (custom-colstructs-for-file file) line "|" nil))))
+
+
+(defun umls-fixed-size-waste ()
+ "Display storage waste if using all fixed size storage"
+ (let ((totalwaste 0)
+ (totalunavoidable 0)
+ (totalavoidable 0)
+ (unavoidable '())
+ (avoidable '()))
+ (dolist (file *umls-files*)
+ (dolist (col (umls-file-colstructs file))
+ (let* ((avwaste (- (umls-col-max col) (umls-col-av col)))
+ (cwaste (* avwaste (umls-file-rws file))))
+ (unless (zerop cwaste)
+ (if (<= avwaste 6)
+ (progn
+ (incf totalunavoidable cwaste)
+ (setq unavoidable (append unavoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste)))))
+ (progn
+ (incf totalavoidable cwaste)
+ (setq avoidable (append avoidable (list (list (umls-file-fil file) (umls-col-col col) avwaste cwaste))))))
+ (incf totalwaste cwaste)))))
+ (values totalwaste totalavoidable totalunavoidable avoidable unavoidable)))
+
+(defun display-waste ()
+ (unless *umls-files*
+ (init-umls))
+ (multiple-value-bind (tw ta tu al ul) (umls-fixed-size-waste)
+ (format t "Total waste: ~d~%" tw)
+ (format t "Total avoidable: ~d~%" ta)
+ (format t "Total unavoidable: ~d~%" tu)
+ (format t "Avoidable:~%")
+ (dolist (w al)
+ (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
+ (format t "Unavoidable:~%")
+ (dolist (w ul)
+ (format t " (~a,~a): ~a,~a~%" (car w) (cadr w) (caddr w) (cadddr w)))
+ ))
+
+(defun max-umls-field ()
+ "Return length of longest field"
+ (unless *umls-files*
+ (init-umls))
+ (let ((max 0))
+ (declare (fixnum max))
+ (dolist (col *umls-cols*)
+ (when (> (umls-col-max col) max)
+ (setq max (umls-col-max col))))
+ max))
+
+(defun max-umls-row ()
+ "Return length of longest row"
+ (if t
+ 6000 ;;; hack to use on systems without MRCOLS/MRFILES -- ok for UMLS2001
+ (progn
+ (unless *umls-files*
+ (init-umls))
+ (let ((rowsizes '()))
+ (dolist (file *umls-files*)
+ (let ((row 0)
+ (fields (umls-file-colstructs file)))
+ (dolist (field fields)
+ (incf row (1+ (umls-col-max field))))
+ (push row rowsizes)))
+ (car (sort rowsizes #'>))))))
--- /dev/null
+;;; UMLS-Parse General
+;;; General purpose Lisp Routines for parsing UMLS files
+;;; and inserting into SQL databases
+;;;
+;;; Copyright (c) 2001 Kevin M. Rosenberg, M.D.
+;;; $Id: parse-macros.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $
+
+(in-package :umlisp)
+
+
+(defmacro with-umls-file ((line filename) &body body)
+"Opens a UMLS and processes each parsed line with (body) argument"
+ (let ((ustream (gensym)))
+ `(with-open-file
+ (,ustream (umls-pathname ,filename)
+ :direction :input :if-exists :overwrite)
+ (do ((,line (read-umls-line ,ustream) (read-umls-line ,ustream)))
+ ((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))
+ (buffer (gensym)))
+ `(let ((,buffer (make-fields-buffer)))
+ (with-open-file
+ (,ustream (umls-pathname ,filename)
+ :direction :input :if-exists :overwrite)
+ (do ((,line (read-buffered-fields ,buffer ,ustream) (read-buffered-fields ,buffer ,ustream)))
+ ((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))
+ (buffer (gensym)))
+ `(let ((,buffer (make-fields-buffer2)))
+ (with-open-file
+ (,ustream (umls-pathname ,filename)
+ :direction :input :if-exists :overwrite)
+ (do ((,line (read-buffered-fields2 ,buffer ,ustream) (read-buffered-fields2 ,buffer ,ustream)))
+ ((eq ,line 'eof) t)
+ ,@body)))))
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Pkg: umlisp -*-
+;; SQL/UMLS database Layer over database backend
+;; Copyright (c) 2001 Kevin M. Rosenberg, M.D.
+;; $Id: sql.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $
+
+(in-package :umlisp)
+
+(declaim (optimize (speed 1) (safety 3)))
+
+(defvar *umls-sql-dsn* "KUMLS2002AC")
+(defun umls-sql-dsn ()
+ *umls-sql-dsn*)
+(defun umls-sql-dsn! (dbname)
+ (sql-disconnect-pooled)
+ (setq *umls-sql-dsn* dbname))
+
+(defvar *umls-sql-user* "webumls")
+(defun umls-sql-user ()
+ *umls-sql-user*)
+(defun umls-sql-user! (u)
+ (sql-disconnect-pooled)
+ (setq *umls-sql-user* u))
+
+(defvar *umls-sql-passwd* "webumls")
+(defun umls-sql-passwd ()
+ *umls-sql-passwd*)
+(defun umls-sql-passwd! (p)
+ (sql-disconnect-pooled)
+ (setq *umls-sql-passwd* p))
+
+(defvar *umls-sql-host* "localhost")
+(defun umls-sql-host ()
+ *umls-sql-host*)
+(defun umls-sql-host! (h)
+ (sql-disconnect-pooled)
+ (setq *umls-sql-host* h))
+
+(defvar *umls-sql-type* :mysql)
+(defun umls-sql-type ()
+ *umls-sql-type*)
+(defun umls-sql-type! (h)
+ (sql-disconnect-pooled)
+ (setq *umls-sql-type* h))
+
+(defun sql-connect ()
+ "Connect to UMLS database, automatically used pooled connections"
+ (clsql:connect `(,(umls-sql-host) ,(umls-sql-dsn) ,(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"
+ (clsql:disconnect :database conn))
+
+(defun sql-disconnect-pooled ()
+ (clsql:disconnect-pooled))
+
+(defmacro with-sql-connection ((conn) &body body)
+ `(let ((,conn (sql-connect)))
+ (unwind-protect
+ (progn ,@body)
+ (when ,conn (clsql:disconnect :database ,conn)))))
+
+(defun sql (stmt conn)
+ (if (string-equal "SELECT" (subseq stmt 0 6))
+ (sql-query stmt conn)
+ (sql-execute stmt conn)))
+
+(defun sql-query (cmd conn &key (types :auto))
+ (clsql:query cmd :database conn :types types))
+
+(defun sql-execute (cmd conn)
+ (clsql:execute-command cmd :database conn))
+
+(defun umls-sql (stmt)
+ (check-type stmt string)
+ (with-sql-connection (conn)
+ (sql stmt conn)))
+
+;;; Pool of open connections
+
+(defmacro with-mutex-sql ((conn) &body body)
+ `(let ((,conn (sql-connect)))
+ (unwind-protect
+ (progn ,@body)
+ (when ,conn (sql-disconnect ,conn)))))
+
+(defun mutex-sql-execute (cmd)
+ (with-mutex-sql (conn)
+ (sql-execute cmd conn)))
+
+(defun mutex-sql-query (cmd &key (types :auto))
+ (with-mutex-sql (conn)
+ (sql-query cmd conn :types types)))
+
+
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; $Id: umlisp.asd,v 1.1 2002/10/05 20:17:14 kevin Exp $
+
+(in-package :asdf)
+
+(defsystem umlisp
+ :components
+ ((:file "package")
+ (:file "data-structures" :depends-on ("package"))
+ (:file "sql" :depends-on ("data-structures"))
+ (:file "utils" :depends-on ("data-structures"))
+ (:file "parse-macros" :depends-on ("sql"))
+ (:file "parse-2002" :depends-on ("parse-macros"))
+ (:file "parse-common" :depends-on ("parse-2002"))
+ (:file "obj" :depends-on ("utils"))
+ (:file "obj-sql" :depends-on ("obj" "sql"))
+ (:file "obj-composite" :depends-on ("obj-sql"))))
+
--- /dev/null
+;;;; $Id: utils.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $
+
+(in-package :umlisp)
+
+(declaim (inline xml-cdata make-cuisui make-cuilui parse-ui parse-cui))
+(declaim (optimize (speed 3) (safety 1)))
+
+(defmacro def-metaclass-reader (field)
+ "Create function for reading slot of metaclass"
+ `(defun ,field (cl)
+ (car (slot-value (class-of cl) ',field))))
+
+(defmacro def-metaclass-reader-car (field)
+ "Create function for reading slot of metaclass"
+ `(defun ,field (cl)
+ (car (slot-value (class-of cl) ',field))))
+
+;;; Field transformations
+
+(defun parse-ui (s &optional (nullvalue 0))
+ "Return integer value for a UMLS unique identifier."
+ (if (< (length s) 2)
+ nullvalue
+ (parse-integer s :start 1)))
+
+(defun parse-cui (cui)
+ (if (stringp cui)
+ (let ((ch (aref cui 0)))
+ (if (eql ch #\C)
+ (parse-ui cui)
+ (parse-integer cui)))
+ cui))
+
+(defun parse-lui (lui)
+ (if (stringp lui)
+ (let ((ch (aref lui 0)))
+ (if (eql ch #\L)
+ (parse-ui lui)
+ (parse-integer lui)))
+ lui))
+
+(defun parse-sui (sui)
+ (if (stringp sui)
+ (let ((ch (aref sui 0)))
+ (if (eql ch #\S)
+ (parse-ui sui)
+ (parse-integer sui)))
+ sui))
+
+(defun parse-tui (tui)
+ (if (stringp tui)
+ (let ((ch (aref tui 0)))
+ (if (eql ch #\T)
+ (parse-ui tui)
+ (parse-integer tui)))
+ tui))
+
+(defun parse-eui (eui)
+ (if (stringp eui)
+ (let ((ch (aref eui 0)))
+ (if (eql ch #\E)
+ (parse-ui eui)
+ (parse-integer eui)))
+ eui))
+
+(defun xml-cdata (str)
+ (concatenate 'string "<![CDATA[" str "]]>"))
+
+(defconstant +cuisui-scale+ 10000000)
+
+(defun make-cuisui (cui sui)
+ (declare (fixnum cui sui))
+ (the integer (+ (* +cuisui-scale+ cui) sui)))
+
+(defun make-cuilui (cui lui)
+ (declare (fixnum cui lui))
+ (the integer (+ (* +cuisui-scale+ cui) lui)))
+
+(defun decompose-cuisui (cuisui)
+ (declare (integer cuisui))
+ (let* ((cui (the fixnum (truncate (/ cuisui +cuisui-scale+))))
+ (sui (the fixnum (- cuisui (* cui +cuisui-scale+)))))
+ (values cui sui)))