--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: classes-support.lisp
+;;;; Purpose: Support for UMLisp classes
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package #:umlisp-orf)
+
+;;; Formatting routines
+
+(defgeneric fmt-cui (c))
+(defmethod fmt-cui ((c ucon))
+ (fmt-cui (cui c)))
+
+(defmethod fmt-cui ((c fixnum))
+ (prefixed-fixnum-string c #\C 7))
+
+(defmethod fmt-cui ((c string))
+ (if (eql (aref c 0) #\C)
+ c
+ (fmt-cui (parse-integer c))))
+
+(defmethod fmt-cui ((c null))
+ (format nil "nil"))
+
+(defgeneric fmt-lui (c))
+(defmethod fmt-lui ((l uterm))
+ (fmt-lui (lui l)))
+
+(defmethod fmt-lui ((l fixnum))
+ (prefixed-fixnum-string l #\L 7))
+
+(defmethod fmt-lui ((l string))
+ (if (eql (aref l 0) #\L)
+ l
+ (fmt-lui (parse-integer l))))
+
+(defgeneric fmt-sui (s))
+(defmethod fmt-sui ((s ustr))
+ (fmt-sui (sui s)))
+
+(defmethod fmt-sui ((s fixnum))
+ (prefixed-fixnum-string s #\S 7))
+
+(defmethod fmt-sui ((s string))
+ (if (eql (aref s 0) #\S)
+ s
+ (fmt-sui (parse-integer s))))
+
+(defgeneric fmt-tui (tui))
+(defmethod fmt-tui ((tui fixnum))
+ (prefixed-fixnum-string tui #\T 3))
+
+(defmethod fmt-tui ((tui string))
+ (if (eql (aref tui 0) #\T)
+ tui
+ (fmt-tui (parse-integer tui))))
+
+(defgeneric fmt-eui (e))
+(defmethod fmt-eui ((e fixnum))
+ (prefixed-fixnum-string e #\E 7))
+
+(defmethod fmt-eui ((e string))
+ (if (eql (aref e 0) #\E)
+ e
+ (fmt-eui (parse-integer e))))
+
+(defmethod fmt-eui ((e null))
+ (format nil "nil"))
+
+(defun cui-p (ui)
+ "Check if a string is a CUI"
+ (check-ui ui #\C 7))
+
+(defun lui-p (ui)
+ "Check if a string is a LUI"
+ (check-ui ui #\L 7))
+
+(defun sui-p (ui)
+ "Check if a string is a SUI"
+ (check-ui ui #\S 7))
+
+(defun tui-p (ui)
+ (check-ui ui #\T 3))
+
+(defun eui-p (ui)
+ (check-ui ui #\E 7))
+
+(defun check-ui (ui start-char len)
+ (when (and (stringp ui)
+ (= (length ui) (1+ len))
+ (char-equal start-char (schar ui 0))
+ (ignore-errors (parse-integer ui :start 1)))
+ t))
+
+
+;;; Generic display functions
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun english-term-p (obj)
+ "Returns two values: T/NIL if term is english and T/NIL if obj is a TERM"
+ (if (eq (hyperobject::class-name (hyperobject::class-of obj)) 'uterm)
+ (values (string-equal (lat obj) "ENG") t)
+ (values nil nil))))
+
+(defun english-term-filter (obj)
+ "Retrns NIL if object is a term and not english"
+ (multiple-value-bind (is-english is-term) (english-term-p obj)
+ (or (not is-term) is-english)))
+
+(defun print-umlsclass (obj &key (stream *standard-output*)
+ (vid :compact-text)
+ (file-wrapper nil) (english-only t) (subobjects nil)
+ (refvars nil) (link-printer nil))
+ (view obj :stream stream :vid vid :subobjects subobjects
+ :file-wrapper file-wrapper
+ :filter (if english-only nil #'english-term-filter)
+ :link-printer link-printer
+ :refvars refvars))
+
+(defmacro define-lookup-display (newfuncname lookup-func)
+ "Defines functions for looking up and displaying objects"
+ `(defun ,newfuncname (keyval &key (stream *standard-output*) (vid :compact-text)
+ (file-wrapper t) (english-only nil) (subobjects nil))
+ (let ((obj (funcall ,lookup-func keyval)))
+ (print-umlsclass obj :stream stream :vid vid
+ :file-wrapper file-wrapper :english-only english-only
+ :subobjects subobjects)
+ obj)))
+
+(define-lookup-display display-con #'find-ucon-cui)
+(define-lookup-display display-term #'find-uterm-lui)
+(define-lookup-display display-str #'find-ustr-sui)
+
+(defun ucon-has-tui (ucon tui)
+ "Returns T if UCON has a semantic type of TUI."
+ (some #'(lambda (usty) (= tui (tui usty))) (s#sty ucon)))
+
+(defgeneric suistr (lo))
+(defmethod suistr ((lo ulo))
+ "Return the string for a ulo object"
+ (find-string-sui (sui lo)))
+
+(defgeneric pf-ustr (obj))
+(defmethod pf-ustr ((ucon ucon))
+ "Return the preferred ustr for a ucon"
+ (pf-ustr
+ (find-if (lambda (uterm) (string= "P" (ts uterm))) (s#term ucon))))
+
+(defmethod pf-ustr ((uterm uterm))
+ "Return the preferred ustr for a uterm"
+ (find-if (lambda (ustr) (string= "PF" (stt ustr))) (s#str uterm)))
+
+(defgeneric mesh-number (obj))
+(defmethod mesh-number ((con ucon))
+ (mesh-number (pf-ustr con)))
+
+(defmethod mesh-number ((ustr ustr))
+ (let ((codes
+ (map-and-remove-nils
+ (lambda (sat)
+ (when (and (string-equal "MSH" (sab sat))
+ (string-equal "MN" (atn sat)))
+ (atv sat)))
+ (s#sat ustr))))
+ (if (= 1 (length codes))
+ (car codes)
+ codes)))
+
+(defun ucon-ustrs (ucon)
+ "Return lists of strings for a concept"
+ (let (res)
+ (dolist (term (s#term ucon) (nreverse res))
+ (dolist (str (s#str term))
+ (push str res)))))
+
+
+(defmethod pfstr ((uterm uterm))
+ "Return the preferred string for a uterm"
+ (dolist (ustr (s#str uterm))
+ (when (string= "PF" (stt ustr))
+ (return-from pfstr (str ustr)))))
+
+(defmethod pfstr ((ustr ustr))
+ "Return the preferred string for a ustr, which is the string itself"
+ (str ustr))
+
+(defun remove-non-english-terms (uterms)
+ (remove-if-not #'english-term-p uterms))
+
+(defun remove-english-terms (uterms)
+ (remove-if #'english-term-p uterms))
+
+
+(defvar +relationship-abbreviations+
+ '(("RB" "Broader" "has a broader relationship")
+ ("RN" "Narrower" "has a narrower relationship")
+ ("RO" "Other related" "has relationship other than synonymous, narrower, or broader")
+ ("RL" "Like" "the two concepts are similar or 'alike'. In the current edition of the Metathesaurus, most relationships with this attribute are mappings provided by a source")
+ ("RQ" "Unspecified" "unspecified source asserted relatedness, possibly synonymous")
+ ("SY" "Source Synonymy" "source asserted synonymy")
+ ("PAR" "Parent" "has parent relationship in a Metathesaurus source vocabulary")
+ ("CHD" "Child" "has child relationship in a Metathesaurus source vocabulary")
+ ("SIB" "Sibling" "has sibling relationship in a Metathesaurus source vocabulary")
+ ("AQ" "Allowed" "is an allowed qualifier for a concept in a Metathesaurus source vocabulary")
+ ("QB" "Qualified" "can be qualified by a concept in a Metathesaurus source vocabulary")))
+
+(defvar *rel-info-table* (make-hash-table :size 30 :test 'equal))
+(defvar *is-rel-table-init* nil)
+(unless *is-rel-table-init*
+ (dolist (relinfo +relationship-abbreviations+)
+ (setf (gethash (string-downcase (car relinfo)) *rel-info-table*)
+ (cdr relinfo)))
+ (setq *is-rel-table-init* t))
+
+(defun rel-abbr-info (rel)
+ (nth-value 0 (gethash (string-downcase rel) *rel-info-table*)))
+
+(defun filter-urels-by-rel (urels rel)
+ (remove-if-not (lambda (urel) (string-equal rel (rel urel))) urels))
+
+
+(defvar +language-abbreviations+
+ '(("BAQ" . "Basque")
+ ("DAN" . "Danish")
+ ("DUT" . "Dutch")
+ ("ENG" . "English")
+ ("FIN" . "Finnish")
+ ("FRE" . "French")
+ ("GER" . "German")
+ ("HEB" . "Hebrew")
+ ("HUN" . "Hungarian")
+ ("ITA" . "Italian")
+ ("NOR" . "Norwegian")
+ ("POR" . "Portuguese")
+ ("RUS" . "Russian")
+ ("SPA" . "Spanish")
+ ("SWE" . "Swedish")))
+
+(defvar *lat-info-table* (make-hash-table :size 30 :test 'equal))
+(defvar *is-lat-table-init* nil)
+(unless *is-lat-table-init*
+ (dolist (latinfo +language-abbreviations+)
+ (setf (gethash (string-downcase (car latinfo)) *lat-info-table*)
+ (cdr latinfo)))
+ (setq *is-lat-table-init* t))
+
+(defun lat-abbr-info (lat)
+ (nth-value 0 (gethash (string-downcase lat) *lat-info-table*)))
+
+
+(defun stt-abbr-info (stt)
+ (when (string-equal "PF" stt)
+ (return-from stt-abbr-info "Preferred"))
+ (when (char-equal #\V (schar stt 0))
+ (setq stt (subseq stt 1)))
+ (loop for c across stt
+ collect
+ (cond
+ ((char-equal #\C c)
+ "Upper/lower case")
+ ((char-equal #\W c)
+ "Word order")
+ ((char-equal #\S c)
+ "Singular")
+ ((char-equal #\P c)
+ "Plural")
+ ((char-equal #\O c)
+ "Other"))))
+
+
+(defun ucon-parents (con &optional sab)
+ (ucon-ancestors con sab t))
+
+(defun ucon-ancestors (ucon &optional sab single-level)
+ "Returns a list of ancestor lists for a concept"
+ (let* ((parent-rels (filter-urels-by-rel (s#rel ucon) "par"))
+ (anc nil))
+ (when sab
+ (setq parent-rels (delete-if-not
+ (lambda (rel) (string-equal sab (sab rel)))
+ parent-rels)))
+ (dolist (rel parent-rels (nreverse anc))
+ (let ((parent (find-ucon-cui (cui2 rel))))
+ (push
+ (if single-level
+ (list parent)
+ (list* parent (car (ucon-ancestors parent (sab rel) nil))))
+ anc)))))
+
+(defgeneric cxt-ancestors (obj))
+(defmethod cxt-ancestors ((con ucon))
+ (loop for term in (s#term con)
+ append (cxt-ancestors term)))
+
+
+(defmethod cxt-ancestors ((term uterm))
+ (loop for str in (s#str term)
+ append (cxt-ancestors str)))
+
+(defmethod cxt-ancestors ((str ustr))
+ "Return the ancestory contexts of a ustr"
+ (let* ((anc (remove-if-not
+ (lambda (cxt) (string-equal "ANC" (cxl cxt)))
+ (s#cxt str)))
+ (num-contexts (if anc
+ (apply #'max (mapcar (lambda (cxt) (cxn cxt)) anc))
+ 0))
+ (anc-lists '()))
+ (dotimes (i num-contexts (nreverse anc-lists))
+ (let* ((anc-this-cxn (remove-if-not
+ (lambda (cxt) (= (1+ i) (cxn cxt))) anc)))
+ (push
+ (sort anc-this-cxn (lambda (a b) (< (rnk a) (rnk b))))
+ anc-lists)))))
+
+
+#+scl
+(dolist (c '(urank udef usat uso ucxt ustr ulo uterm usty urel ucoc uatx ucon uxw uxnw uxns lexterm labr lagr lcmp lmod lnom lprn lprp lspl ltrm ltyp lwd sdef sstr sstre1 sstre2 usrl))
+ (let ((cl (find-class c)))
+ (clos:finalize-inheritance cl)))
+
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: classes.lisp
+;;;; Purpose: Class defintions for UMLisp
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package #:umlisp-orf)
+
+(defclass umlsclass (hyperobject)
+ ()
+ (:metaclass hyperobject-class)
+ (:description "Parent class of all UMLS objects. It is based on the HYPEROBJECT-CLASS metaclass that provides object printing functions."))
+
+
+(defclass usrl (umlsclass)
+ ((sab :value-type string :initarg :sab :reader sab)
+ (srl :value-type fixnum :initarg :srl :reader srl))
+ (:metaclass hyperobject-class)
+ (:user-name "Source Restriction Level")
+ (:default-print-slots sab srl)
+ (:description "Custom Table: Source Restriction Level"))
+
+
+(defclass urank (umlsclass)
+ ((rank :value-type fixnum :initarg :rank :reader rank)
+ (sab :value-type string :initarg :sab :reader sab)
+ (tty :value-type string :initarg :tty :reader tty)
+ (supres :value-type string :initarg :supres :reader supres))
+ (:metaclass hyperobject-class)
+ (:user-name "Rank")
+ (:default-print-slots rank sab tty supres))
+
+(defclass udef (umlsclass)
+ ((def :value-type cdata :initarg :def :reader def)
+ (sab :value-type string :initarg :sab :reader sab :hyperlink find-usab-rsab))
+ (:metaclass hyperobject-class)
+ (:user-name "Definition")
+ (:default-print-slots sab def))
+
+(defclass usat (umlsclass)
+ ((sab :value-type string :initarg :sab :reader sab :hyperlink find-usab-rsab)
+ (code :value-type string :initarg :code :reader code)
+ (atn :value-type string :initarg :atn :reader atn)
+ (atv :value-type cdata :initarg :atv :reader atv))
+ (:metaclass hyperobject-class)
+ (:user-name "Simple Attribute")
+ (:default-print-slots sab code atn atv))
+
+(defclass usab (umlsclass)
+ ((vcui :value-type fixnum :initarg :vcui :reader vcui :print-formatter fmt-cui)
+ (rcui :value-type fixnum :initarg :rcui :reader rcui :print-formatter fmt-cui)
+ (vsab :value-type string :initarg :vsab :reader vsab)
+ (rsab :value-type string :initarg :rsab :reader rsab :hyperlink find-ustr-sab
+ :hyperlink-parameters (("subobjects" . "no")))
+ (son :value-type string :initarg :son :reader son)
+ (sf :value-type string :initarg :sf :reader sf)
+ (sver :value-type string :initarg :sver :reader sver)
+ (vstart :value-type string :initarg :vstart :reader vstart)
+ (vend :value-type string :initarg :vend :reader vend)
+ (imeta :value-type string :initarg :imeta :reader imeta)
+ (rmeta :value-type string :initarg :rmeta :reader rmeta)
+ (slc :value-type cdata :initarg :slc :reader slc)
+ (scc :value-type cdata :initarg :scc :reader scc)
+ (srl :value-type fixnum :initarg :srl :reader srl)
+ (tfr :value-type fixnum :initarg :tfr :reader tfr :print-formatter fmt-comma-integer)
+ (cfr :value-type fixnum :initarg :cfr :reader cfr :print-formatter fmt-comma-integer)
+ (cxty :value-type string :initarg :cxty :reader cxty)
+ (ttyl :value-type string :initarg :ttyl :reader ttyl)
+ (atnl :value-type string :initarg :atnl :reader atnl)
+ (lat :value-type string :initarg :lat :reader lat)
+ (cenc :value-type string :initarg :cenc :reader cenc)
+ (curver :value-type string :initarg :curver :reader curver)
+ (sabin :value-type string :initarg :sabin :reader sabin))
+ (:metaclass hyperobject-class)
+ (:user-name "Source Abbreviation")
+ (:default-print-slots vcui rcui vsab rsab son sf sver vstart vend imeta
+ rmeta slc scc srl tfr cfr cxty ttyl atnl lat cenc
+ curver sabin))
+
+(defclass uso (umlsclass)
+ ((sab :value-type string :initarg :sab :reader sab :hyperlink find-usab-rsab)
+ (code :value-type string :initarg :code :reader code)
+ (tty :value-type string :initarg :tty :reader tty :hyperlink find-btty-tty)
+ (srl :value-type fixnum :initarg :srl :reader srl))
+ (:metaclass hyperobject-class)
+ (:user-name "Source")
+ (:default-print-slots sab code tty srl))
+
+(defclass ucxt (umlsclass)
+ ((sab :value-type string :initarg :sab :reader sab :hyperlink find-usab-rsab)
+ (code :value-type string :initarg :code :reader code)
+ (rnk :value-type fixnum :initarg :rnk :reader rnk)
+ (cxn :value-type fixnum :initarg :cxn :reader cxn)
+ (cxl :value-type string :initarg :cxl :reader cxl)
+ (cxs :value-type cdata :initarg :cxs :reader cxs)
+ (cui2 :value-type fixnum :initarg :cui2 :reader cui2 :hyperlink find-ucon-cui
+ :print-formatter fmt-cui)
+ (hcd :value-type string :initarg :hcd :reader hcd)
+ (rela :value-type string :initarg :rela :reader rela)
+ (xc :value-type string :initarg :xc :reader xc))
+ (:metaclass hyperobject-class)
+ (:user-name "Context")
+ (:default-print-slots sab code rnk cxn cxl hcd rela xc cui2 cxs))
+
+(defclass ustr (umlsclass)
+ ((sui :value-type fixnum :initarg :sui :reader sui :print-formatter fmt-sui
+ :hyperlink find-ustr-sui)
+ (cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui
+ :hyperlink find-ucon-cui)
+ (lui :value-type fixnum :initarg :lui :reader lui :print-formatter fmt-lui
+ :hyperlink find-uterm-lui)
+ (cuisui :value-type integer :initarg :cuisui :reader cuisui )
+ (str :value-type cdata :initarg :str :reader str)
+ (lrl :value-type fixnum :initarg :lrl :reader lrl)
+ (stt :value-type string :initarg :stt :reader stt)
+ (s#so :reader s#so :subobject (find-uso-cuisui cui sui))
+ (s#sat :reader s#sat :subobject (find-usat-ui cui lui sui))
+ (s#cxt :reader s#cxt :subobject (find-ucxt-cuisui cui sui)))
+ (:metaclass hyperobject-class)
+ (:user-name "String")
+ (:default-print-slots sui stt lrl str))
+
+(defclass ulo (umlsclass)
+ ((isn :value-type string :initarg :isn :reader isn)
+ (fr :value-type fixnum :initarg :fr :reader fr)
+ (un :value-type string :initarg :un :reader un)
+ (sui :value-type fixnum :initarg :sui :reader sui :print-formatter fmt-sui)
+ (sna :value-type string :initarg :sna :reader sna)
+ (soui :value-type string :initarg :soui :reader soui))
+ (:metaclass hyperobject-class)
+ (:user-name "Locator")
+ (:default-print-slots isn fr un sna soui sui))
+
+(defclass uterm (umlsclass)
+ ((lui :value-type fixnum :initarg :lui :reader lui :print-formatter fmt-lui
+ :hyperlink find-uterm-lui)
+ (cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui
+ :hyperlink find-ucon-cui)
+ (lat :value-type string :initarg :lat :reader lat)
+ (ts :value-type string :initarg :ts :reader ts)
+ (lrl :value-type fixnum :initarg :lrl :reader lrl)
+ (s#str :reader s#str :subobject (find-ustr-cuilui cui lui))
+ (s#sat :reader s#sat :subobject (find-usat-ui cui lui)))
+ (:metaclass hyperobject-class)
+ (:user-name "Term")
+ (:default-print-slots lui lat ts lrl))
+
+(defclass usty (umlsclass)
+ ((tui :value-type fixnum :initarg :tui :reader tui :print-formatter fmt-tui
+ :hyperlink find-ucon-tui
+ :hyperlink-parameters (("subobjects" . "no")))
+ (sty :value-type string :initarg :sty :reader sty))
+ (:metaclass hyperobject-class)
+ (:user-name "Semantic Type")
+ (:default-print-slots tui sty))
+
+(defclass urel (umlsclass)
+ ((rel :value-type string :initarg :rel :reader rel :hyperlink find-brel-rel)
+ (cui1 :value-type fixnum :initarg :cui1 :reader cui1 :print-formatter fmt-cui)
+ (cui2 :value-type fixnum :initarg :cui2 :reader cui2 :hyperlink find-ucon-sui
+ :print-formatter fmt-cui)
+ (pfstr2 :value-type cdata :initarg :pfstr2 :reader pfstr2)
+ (rela :value-type string :initarg :rela :reader rela)
+ (sab :value-type string :initarg :sab :reader sab :hyperlink find-usab-rsab)
+ (sl :value-type string :initarg :sl :reader sl)
+ (mg :value-type string :initarg :mg :reader mg))
+ (:metaclass hyperobject-class)
+ (:user-name "Relationship")
+ (:default-print-slots rel rela sab sl mg cui2 pfstr2))
+
+(defclass ucoc (umlsclass)
+ ((cui1 :value-type fixnum :initarg :cui1 :reader cui1 :print-formatter fmt-cui)
+ (cui2 :value-type fixnum :initarg :cui2 :reader cui2 :print-formatter fmt-cui
+ :hyperlink find-ucon-cui)
+ (pfstr2 :value-type cdata :initarg :pfstr2 :reader pfstr2)
+ (soc :value-type string :initarg :soc :reader soc)
+ (cot :value-type string :initarg :cot :reader cot)
+ (cof :value-type fixnum :initarg :cof :reader cof)
+ (coa :value-type cdata :initarg :coa :reader coa))
+ (:metaclass hyperobject-class)
+ (:user-name "Co-occuring Concept")
+ (:default-print-slots soc cot cof coa cui2 pfstr2))
+
+
+(defclass uatx (umlsclass)
+ ((sab :value-type string :initarg :sab :reader sab)
+ (rel :value-type string :initarg :rel :reader rel)
+ (atx :value-type cdata :initarg :atx :reader atx))
+ (:metaclass hyperobject-class)
+ (:user-name "Associated Expression")
+ (:default-print-slots sab rel atx))
+
+(defclass ucon (umlsclass)
+ ((cui :value-type fixnum :initarg :cui :reader cui :print-formatter fmt-cui
+ :hyperlink find-ucon-cui)
+ (lrl :value-type fixnum :initarg :lrl :reader lrl)
+ (pfstr :value-type cdata :initarg :pfstr :reader pfstr)
+ (s#def :reader s#def :subobject (find-udef-cui cui))
+ (s#sty :reader s#sty :subobject (find-usty-cui cui))
+ (s#atx :reader s#atx :subobject (find-uatx-cui cui))
+ (s#lo :reader s#lo :subobject (find-ulo-cui cui))
+ (s#term :reader s#term :subobject (find-uterm-cui cui))
+ (s#sat :reader s#sat :subobject (find-usat-ui cui))
+ (s#rel :reader s#rel :subobject (find-urel-cui cui))
+ (s#coc :reader s#coc :subobject (find-ucoc-cui cui)))
+ (:metaclass hyperobject-class)
+ (:user-name "Concept")
+ (:default-print-slots cui lrl pfstr))
+
+(defclass uxw (umlsclass)
+ ((wd :value-type string :initarg :wd :reader wd)
+ (cui :value-type fixnum :initform nil :initarg :cui :reader cui :print-formatter fmt-cui)
+ (lui :value-type fixnum :initform nil :initarg :lui :reader lui :print-formatter fmt-lui)
+ (sui :value-type fixnum :initform nil :initarg :sui :reader sui :print-formatter fmt-sui))
+ (:metaclass hyperobject-class)
+ (:user-name "XW Index" "XW Indices")
+ (:default-print-slots wd cui lui sui))
+
+(defclass uxw-noneng (umlsclass)
+ ((lat :value-type string :initarg :lat :reader lat)
+ (wd :value-type string :initarg :wd :reader wd)
+ (cui :value-type fixnum :initform nil :initarg :cui :reader cui :print-formatter fmt-cui)
+ (lui :value-type fixnum :initform nil :initarg :lui :reader lui :print-formatter fmt-lui)
+ (sui :value-type fixnum :initform nil :initarg :sui :reader sui :print-formatter fmt-sui)
+ (lrl :value-type fixnum :initform nil :initarg :lrl :reader lrl))
+ (:metaclass hyperobject-class)
+ (:user-name "XW Non-English Index" "XW Non-English Indices")
+ (:default-print-slots wd cui lui sui))
+
+(defclass uxnw (umlsclass)
+ ((lat :value-type string :initarg :lat :reader lat)
+ (nwd :value-type string :initarg :nwd :reader nwd)
+ (cuilist :value-type list :initarg :cuilist :reader uxnw-cuilist))
+ (:metaclass hyperobject-class)
+ (:user-name "XNW Index" "XNW Indices")
+ (:default-print-slots lat nwd cuilist))
+
+(defclass uxns (umlsclass)
+ ((lat :value-type string :initarg :lat :reader lat)
+ (nstr :value-type string :initarg :nstr :reader nstr)
+ (cuilist :value-type list :initarg :cuilist :reader cuilist))
+ (:metaclass hyperobject-class)
+ (:user-name "XNS Index" "XNS Indices")
+ (:default-print-slots lat nstr cuilist))
+
+
+;;; LEX objects
+
+(defclass lexterm (umlsclass)
+ ((eui :value-type fixnum :initarg :eui :reader eui :print-formatter fmt-eui
+ :hyperlink find-lexterm-eui)
+ (wrd :value-type string :initarg :wrd :reader wrd)
+ (s#abr :reader s#abr :subobject (find-labr-eui eui))
+ (s#agr :reader s#agr :subobject (find-lagr-eui eui))
+ (s#cmp :reader s#cmp :subobject (find-lcmp-eui eui))
+ (s#mod :reader s#mod :subobject (find-lmod-eui eui))
+ (s#nom :reader s#nom :subobject (find-lnom-eui eui))
+ (s#prn :reader s#prn :subobject (find-lprn-eui eui))
+ (s#prp :reader s#prp :subobject (find-lprp-eui eui))
+ (s#spl :reader s#spl :subobject (find-lspl-eui eui))
+ (s#trm :reader s#trm :subobject (find-ltrm-eui eui))
+ (s#typ :reader s#typ :subobject (find-ltyp-eui eui)))
+ (:metaclass hyperobject-class)
+ (:user-name "Lexical Term")
+ (:default-print-slots eui wrd))
+
+
+(defclass labr (umlsclass)
+ ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui)
+ (bas :value-type string :initarg :bas :reader bas)
+ (abr :value-type string :initarg :abr :reader abr)
+ (eui2 :value-type integer :initarg :eui2 :reader eui2 :print-formatter fmt-eui)
+ (bas2 :value-type string :initarg :bas2 :reader bas2))
+ (:metaclass hyperobject-class)
+ (:user-name "Abbreviations and Acronym")
+ (:default-print-slots eui bas abr eui2 bas2))
+
+(defclass lagr (umlsclass)
+ ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui)
+ (str :value-type string :initarg :str :reader str)
+ (sca :value-type string :initarg :sca :reader sca)
+ (agr :value-type string :initarg :agr :reader agr)
+ (cit :value-type string :initarg :cit :reader cit)
+ (bas :value-type string :initarg :bas :reader bas))
+ (:metaclass hyperobject-class)
+ (:user-name "Agreement and Inflection")
+ (:default-print-slots eui str sca agr cit bas))
+
+(defclass lcmp (umlsclass)
+ ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui)
+ (bas :value-type string :initarg :bas :reader bas)
+ (sca :value-type string :initarg :sca :reader sca)
+ (com :value-type string :initarg :com :reader com))
+ (:metaclass hyperobject-class)
+ (:user-name "Complementation")
+ (:default-print-slots eui bas sca com))
+
+(defclass lmod (umlsclass)
+ ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui)
+ (bas :value-type string :initarg :bas :reader bas)
+ (sca :value-type string :initarg :sca :reader sca)
+ (psnmod :value-type string :initarg :psnmod :reader psnmod)
+ (fea :value-type string :initarg :fea :reader fea))
+ (:metaclass hyperobject-class)
+ (:user-name "Modifier")
+ (:default-print-slots eui bas sca psnmod fea))
+
+(defclass lnom (umlsclass)
+ ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui)
+ (bas :value-type string :initarg :bas :reader bas)
+ (sca :value-type string :initarg :sca :reader sca)
+ (eui2 :value-type integer :initarg :eui2 :reader eui2 :print-formatter fmt-eui)
+ (bas2 :value-type string :initarg :bas2 :reader bas2)
+ (sca2 :value-type string :initarg :sca2 :reader sca2))
+ (:metaclass hyperobject-class)
+ (:user-name "Nominalization")
+ (:default-print-slots eui bas sca eui2 bas2 sca2))
+
+(defclass lprn (umlsclass)
+ ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui)
+ (bas :value-type string :initarg :bas :reader bas)
+ (num :value-type string :initarg :num :reader num)
+ (gnd :value-type string :initarg :gnd :reader gnd)
+ (cas :value-type string :initarg :cas :reader cas)
+ (pos :value-type string :initarg :pos :reader pos)
+ (qnt :value-type string :initarg :qnt :reader qnt)
+ (fea :value-type string :initarg :fea :reader fea))
+ (:metaclass hyperobject-class)
+ (:user-name "Pronoun")
+ (:default-print-slots eui bas num gnd cas pos qnt fea))
+
+(defclass lprp (umlsclass)
+ ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui)
+ (bas :value-type string :initarg :bas :reader bas)
+ (str :value-type string :initarg :str :reader str)
+ (sca :value-type string :initarg :sca :reader sca)
+ (fea :value-type string :initarg :fea :reader fea))
+ (:metaclass hyperobject-class)
+ (:user-name "Property" "Properties")
+ (:default-print-slots eui bas str sca fea))
+
+
+(defclass lspl (umlsclass)
+ ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui)
+ (spv :value-type string :initarg :spv :reader spv)
+ (bas :value-type string :initarg :bas :reader bas))
+ (:metaclass hyperobject-class)
+ (:user-name "Spelling Variant")
+ (:default-print-slots eui spv bas))
+
+
+(defclass ltrm (umlsclass)
+ ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui)
+ (bas :value-type string :initarg :bas :reader bas)
+ (gen :value-type string :initarg :gen :reader gen))
+ (:metaclass hyperobject-class)
+ (:user-name "Trade Mark")
+ (:default-print-slots eui bas gen))
+
+(defclass ltyp (umlsclass)
+ ((eui :value-type integer :initarg :eui :reader eui :print-formatter fmt-eui)
+ (bas :value-type string :initarg :bas :reader bas)
+ (sca :value-type string :initarg :sca :reader sca)
+ (typ :value-type string :initarg :typ :reader typ))
+ (:metaclass hyperobject-class)
+ (:user-name "Inflection Type")
+ (:default-print-slots eui bas sca typ))
+
+(defclass lwd (umlsclass)
+ ((wrd :value-type string :initarg :wrd :reader wrd)
+ (euilist :value-type list :initarg :euilist :reader euilist))
+ (:metaclass hyperobject-class)
+ (:user-name "Lexical Word Index" "Lexical Word Indices")
+ (:default-print-slots wrd euilist))
+
+;;; Semantic NET objects
+
+(defclass sdef (umlsclass)
+ ((rt :value-type string :initarg :rt :reader rt)
+ (ui :value-type integer :initarg :ui :reader ui :print-formatter fmt-tui)
+ (styrl :value-type string :initarg :styrl :reader styrl)
+ (stnrtn :value-type string :initarg :stnrtn :reader stnrtn)
+ (def :value-type string :initarg :def :reader def)
+ (ex :value-type string :initarg :ex :reader ex)
+ (un :value-type string :initarg :un :reader un)
+ (rh :value-type string :initarg :rh :reader rh)
+ (abr :value-type string :initarg :abr :reader abr)
+ (rin :value-type string :initarg :rin :reader rin))
+ (:metaclass hyperobject-class)
+ (:user-name "Basic information about Semantic Types and Relation")
+ (:default-print-slots rt ui styrl stnrtn def ex un rh abr rin))
+
+(defclass sstr (umlsclass)
+ ((styrl :value-type string :initarg :styrl :reader styrl)
+ (rl :value-type string :initarg :rl :reader rl)
+ (styrl2 :value-type string :initarg :styrl2 :reader styrl2)
+ (ls :value-type string :initarg :ls :reader ls))
+ (:metaclass hyperobject-class)
+ (:user-name "Structure of the Network")
+ (:default-print-slots styrl rl styrl2 ls))
+
+(defclass sstre1 (umlsclass)
+ ((ui :value-type integer :initarg :ui :reader ui :print-formatter fmt-tui)
+ (ui2 :value-type integer :initarg :ui2 :reader ui2 :print-formatter fmt-tui)
+ (ui3 :value-type integer :initarg :ui3 :reader ui3 :print-formatter fmt-tui))
+ (:metaclass hyperobject-class)
+ (:user-name "Fully Inherited Set of Relation (TUIs)"
+ "Fully Inherited Set of Relations (TUIs)")
+ (:default-print-slots ui ui2 ui3))
+
+(defclass sstre2 (umlsclass)
+ ((sty :value-type string :initarg :ui :reader sty)
+ (rl :value-type string :initarg :ui2 :reader rl)
+ (sty2 :value-type string :initarg :ui3 :reader sty2))
+ (:metaclass hyperobject-class)
+ (:user-name "Fully Inherited Set of Relation (strings)"
+ "Fully Inherited Set of Relations (strings)")
+ (:default-print-slots sty rl sty2))
+
+
+;;; **************************
+;;; Local Classes
+;;; **************************
+
+(defclass ustats (umlsclass)
+ ((name :value-type string :initarg :name :reader name)
+ (hits :value-type integer :initarg :hits :reader hits
+ :user-name "count"
+ :print-formatter fmt-comma-integer)
+ (srl :value-type fixnum :initarg :srl :reader srl))
+ (:metaclass hyperobject-class)
+ (:default-initargs :name nil :hits nil :srl nil)
+ (:user-name "UMLS Statistic")
+ (:default-print-slots name hits srl)
+ (:documentation "Custom Table: UMLS Database statistics."))
+
+
+(defclass bsab (umlsclass)
+ ((sab :value-type string :initarg :sab :reader sab
+ :hyperlink find-ustr-sab
+ :hyperlink-parameters (("subobjects" . "no")))
+ (name :value-type string :initarg :name :reader name)
+ (hits :value-type fixnum :initarg :hits :reader hits
+ :user-name "count"
+ :print-formatter fmt-comma-integer))
+ (:metaclass hyperobject-class)
+ (:default-initargs :sab nil :name nil :hits nil)
+ (:user-name "Source of Abbreviation")
+ (:default-print-slots sab name hits)
+ (:documentation "Bonus SAB file"))
+
+(defclass btty (umlsclass)
+ ((tty :value-type string :initarg :tty :reader tty)
+ (name :value-type string :initarg :name :reader name)
+ (hits :value-type fixnum :initarg :hits :reader hits
+ :user-name "count"
+ :print-formatter fmt-comma-integer))
+ (:metaclass hyperobject-class)
+ (:default-initargs :tty nil :name nil :hits nil)
+ (:user-name "Bonus TTY")
+ (:default-print-slots tty name hits)
+ (:documentation "Bonus TTY file"))
+
+(defclass brel (umlsclass)
+ ((sab :value-type string :initarg :sab :reader sab)
+ (sl :value-type string :initarg :sl :reader sl)
+ (rel :value-type string :initarg :rel :reader rel)
+ (rela :value-type string :initarg :rela :reader rela)
+ (hits :value-type fixnum :initarg :hits :reader hits
+ :user-name "count"
+ :print-formatter fmt-comma-integer))
+ (:metaclass hyperobject-class)
+ (:default-initargs :sab nil :sl nil :rel nil :rela nil :hits nil)
+ (:user-name "Bonus REL")
+ (:default-print-slots sab sl rel rela hits)
+ (:documentation "Bonus REL file"))
+
+(defclass batn (umlsclass)
+ ((sab :value-type string :initarg :sab :reader sab)
+ (atn :value-type string :initarg :atn :reader atn)
+ (hits :value-type fixnum :initarg :hits :reader hits
+ :user-name "count"
+ :print-formatter fmt-comma-intger))
+ (:metaclass hyperobject-class)
+ (:default-initargs :sab nil :atn nil)
+ (:user-name "Bonus ATN")
+ (:default-print-slots sab atn hits)
+ (:documentation "Bonus ATN file"))
--- /dev/null
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: composite.lisp
+;;;; Purpose: Composite Classes for UMLisp
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package #:umlisp-orf)
+
+;;; Semantic type constants
+
+(defun find-tui-word (words)
+ (aif (car (find-usty-word words))
+ (tui it)
+ nil))
+(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)
+ (aif (funcall cui2-func c)
+ (let ((ucon2 (find-ucon-cui it)))
+ (when (ucon-is-tui? ucon2 tui)
+ ucon2)) nil))
+ (funcall related-con-func ucon))
+ :key #'cui))
+
+(defun find-ucon2-coc-tui (ucon tui)
+ "Return list of ucon's that have co-occuring concepts of semantic type tui"
+ (find-ucon2-tui ucon tui #'cui2 #'s#coc))
+
+(defun find-ucon2-rel-tui (ucon tui)
+ "Return list of ucon's that have related concepts to ucon and semantic type tui"
+ (find-ucon2-tui ucon tui #'cui2 #'s#rel))
+
+;;; Composite Objects
+
+(defclass freq (hyperobject)
+ ((freq :value-type integer :initarg :freq :accessor freq
+ :print-formatter fmt-comma-integer))
+ (:metaclass hyperobject-class)
+ (:default-initargs :freq 0)
+ (:user-name "Frequency class" "Frequency classes")
+ (:default-print-slots freq)
+ (:description "Base class containing frequency slot, used for multi-inherited objects"))
+
+(defclass ucon_freq (ucon freq)
+ ()
+ (:metaclass hyperobject-class)
+ (:user-name "Concept and Count" "Concepts and Counts")
+ (:default-print-slots cui freq pfstr)
+ (:description "Composite object of ucon/freq"))
+
+(defclass ustr_freq (ustr freq)
+ ()
+ (:metaclass hyperobject-class)
+ (:user-name "String and Count" "Strings and Counts")
+ (:default-print-slots sui freq stt lrl str)
+ (:description "Composite object of ustr/freq"))
+
+(defclass usty_freq (usty freq)
+ ()
+ (:metaclass hyperobject-class)
+ (:user-name "Semantic Type and Count" "Semantic Types and Counts")
+ (:default-print-slots tui freq sty)
+ (:description "Composite object of usty/freq"))
+
+(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)))))
+ (usty (find-usty-tui tui)))
+ (push (make-instance 'usty_freq :sty (sty usty)
+ :tui (tui usty) :freq freq) usty_freqs)))
+ (sort usty_freqs #'> :key #'freq)))
+
+
+(defclass usrl_freq (usrl freq)
+ ()
+ (:metaclass hyperobject-class)
+ (:user-name "Source and Count" "Sources and Counts")
+ (:default-print-slots sab freq srl)
+ (:description "Composite object of usrl/freq"))
+
+;; Frequency finding functions
+
+(defun find-usrl_freq-all ()
+ (let ((freqs '()))
+ (dolist (usrl (find-usrl-all))
+ (let ((freq (ensure-integer
+ (caar (mutex-sql-query
+ (format nil "select count(*) from MRSO where SAB='~a'"
+ (sab usrl)))))))
+ (push (make-instance 'usrl_freq :sab (sab usrl) :srl (srl usrl)
+ :freq freq)
+ freqs)))
+ (sort freqs #'> :key #'freq)))
+
+(defun find-ucon2_freq-coc-tui (ucon tui)
+"Return sorted list of tuples with ucon and freq that have co-occuring concepts of semantic type tui"
+ (let ((ucon_freqs '()))
+ (dolist (ucoc (s#coc ucon))
+ (aif (cui2 ucoc)
+ (let ((ucon2 (find-ucon-cui it)))
+ (when (ucon-is-tui? ucon2 tui)
+ (push (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2)
+ :pfstr (pfstr ucon2) :freq (cof ucoc))
+ ucon_freqs)))))
+ (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
+ (aif (aref ucon_freqs (cui ucon2))
+ (setf (freq it) (1+ (freq it)))
+ (setf (aref ucon_freqs (cui ucon2))
+ (make-instance 'ucon_freq :cui (cui ucon2) :lrl (lrl ucon2)
+ :pfstr (pfstr ucon2) :freq 1)))))
+ (let ((ucon_freq-list '()))
+ (dotimes (i (find-cui-max))
+ (declare (fixnum i))
+ (awhen (aref ucon_freqs i)
+ (push it ucon_freq-list)))
+ (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))
+
+#+(or scl)
+(dolist (c '(ucon_freq ustr_freq usty_freq usrl_freq))
+ (let ((cl #+cmu (pcl:find-class c)
+ #+scl (find-class c)))
+ #+cmu (pcl:finalize-inheritance cl)
+ #+scl (clos:finalize-inheritance cl)))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: sql-create
+;;;; Purpose: Create SQL database for UMLisp
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package #:umlisp-orf)
+
+(defun create-table-cmd (file)
+ "Return sql command to create a table"
+ (let ((col-func
+ (lambda (c)
+ (let ((sqltype (sqltype c)))
+ (concatenate 'string
+ (col c)
+ " "
+ (if (or (string-equal sqltype "VARCHAR")
+ (string-equal sqltype "CHAR"))
+ (format nil "~a (~a)" sqltype (cmax c))
+ sqltype))))))
+ (format nil "CREATE TABLE ~a (~{~a~^,~})" (table file)
+ (mapcar col-func (ucols file)))))
+
+(defun create-custom-table-cmd (tablename sql-cmd)
+ "Return SQL command to create a custom table"
+ (format nil "CREATE TABLE ~a AS ~a;" tablename sql-cmd))
+
+(defun insert-col-value (col value)
+ (if (null (parse-fun col))
+ value
+ (format nil "~A" (funcall (parse-fun col) value))))
+
+(defun insert-values-cmd (file values)
+ "Return sql insert command for a row of values"
+ (let ((insert-func
+ (lambda (col value)
+ (concatenate 'string (quote-str col)
+ (insert-col-value col value)
+ (quote-str col)))))
+ (format
+ nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~A)"
+ (table file)
+ (fields file)
+ (concat-separated-strings
+ ","
+ (mapcar insert-func (remove-custom-cols (ucols file)) values)
+ (custom-col-values (custom-ucols-for-file file) values t)))))
+
+
+(defun custom-col-value (col values doquote)
+ (let ((custom-value (funcall (custom-value-fun col) values)))
+ (if custom-value
+ (if doquote
+ (concatenate 'string (quote-str col)
+ (escape-backslashes custom-value)
+ (quote-str col))
+ (escape-backslashes custom-value))
+ "")))
+
+(defun custom-col-values (ucols values doquote)
+ "Returns a list of string column values for SQL inserts for custom columns"
+ (loop for col in ucols collect (custom-col-value col values doquote)))
+
+(defun remove-custom-cols (cols)
+ "Remove custom cols from a list col umls-cols"
+ (remove-if #'custom-value-fun 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-ucols-for-file (file)
+ (remove-if-not #'custom-value-fun (ucols file)))
+
+(defun noneng-lang-index-files ()
+ (remove-if-not
+ (lambda (f) (and (> (length (fil f)) 4)
+ (string-equal (fil f) "MRXW." :end1 5)
+ (not (string-equal (fil f) "MRXW.ENG"))
+ (not (string-equal (fil f) "MRXW.NONENG"))))
+ *umls-files*))
+
+;;; SQL Command Functions
+
+(defun create-index-cmd (colname tablename length)
+ "Return sql create index command"
+ (format nil "CREATE INDEX ~a ON ~a (~a)"
+ (concatenate 'string tablename "_" colname "_X")
+ tablename
+ (case *umls-sql-type*
+ (:mysql
+ (concatenate 'string colname
+ (if (integerp length)
+ (format nil " (~d)" length)
+ "")))
+ ((:postgresql :postgresql-socket)
+ ;; FIXME: incorrect syntax
+ (if (integerp length)
+ (format nil "substr((~A)::text,1,~D)" colname length)
+ colname))
+ (t
+ colname))))
+
+(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"
+ (dolist (file *umls-files*)
+ (ignore-errors
+ (sql-execute (format nil "DROP TABLE ~a" (table file)) conn))))
+
+(defun sql-create-tables (conn)
+ "SQL Databases: create all tables"
+ (dolist (file *umls-files*)
+ (sql-execute (create-table-cmd file) conn)))
+
+(defun sql-create-custom-tables (conn)
+ "SQL Databases: create all custom tables"
+ (dolist (ct +custom-tables+)
+ (sql-execute (create-custom-table-cmd (car ct) (cadr ct)) conn)))
+
+(defun sql-insert-values (conn file)
+ "SQL Databases: inserts all values for a file"
+ (with-umls-file (line (fil file))
+ (sql-execute (insert-values-cmd file line) conn)))
+
+(defun sql-insert-all-values (conn)
+ "SQL Databases: inserts all values for all files"
+ (dolist (file *umls-files*)
+ (sql-insert-values conn file)))
+
+(defun drop-index-cmd (colname tablename)
+ "Return sql create index command"
+ (case *umls-sql-type*
+ (:mysql
+ (format nil "DROP INDEX ~a ON ~a"
+ (concatenate 'string tablename "_" colname "_X")
+ tablename))
+ (t
+ (format nil "DROP INDEX ~a"
+ (concatenate 'string tablename "_" colname "_X")))))
+
+(defun sql-create-indexes (conn &optional (indexes +index-cols+))
+ "SQL Databases: create all indexes"
+ (dolist (idx indexes)
+ (ignore-errors (sql-execute (drop-index-cmd (car idx) (cadr idx)) conn))
+ (sql-execute (create-index-cmd (car idx) (cadr idx) (caddr idx)) conn)))
+
+(defun make-usrl (conn)
+ (if (eql :mysql *umls-sql-type*)
+ (sql-execute "drop table if exists USRL" conn)
+ (ignore-errors (sql-execute "drop table USRL" conn)))
+ (sql-execute "create table USRL (sab varchar(80), srl integer)" conn)
+ (dolist (tuple (mutex-sql-query
+ "select distinct SAB,SRL from MRSO order by SAB asc"))
+ (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)"
+ (car tuple) (ensure-integer (cadr tuple)))
+ conn)))
+
+(defun sql-create-special-tables (conn)
+ (make-usrl conn)
+ (make-ustats))
+
+(defun create-umls-db-by-insert ()
+ "SQL Databases: initializes entire database via SQL insert commands"
+ (ensure-ucols+ufiles)
+ (ensure-preparse)
+ (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+)
+ (sql-create-special-tables conn)))
+
+(defun create-umls-db (&key (extension ".trans") (skip-translation nil))
+ "SQL Databases: initializes entire database via SQL copy commands.
+This is much faster that using create-umls-db-insert."
+ (ensure-ucols+ufiles)
+ (ensure-preparse)
+ (unless skip-translation
+ (translate-all-files extension))
+ (let ((copy-cmd
+ (ecase (umls-sql-type)
+ (:mysql #'mysql-copy-cmd)
+ (:postgresql #'pg-copy-cmd))))
+ (with-sql-connection (conn)
+ (clsql:truncate-database :database conn)
+ (sql-drop-tables conn)
+ (sql-create-tables conn)
+ (dolist (file *umls-files*)
+ (sql-execute (funcall copy-cmd file extension) conn))
+ (sql-create-indexes conn)
+ (sql-create-custom-tables conn)
+ (sql-create-indexes conn +custom-index-cols+)
+ (sql-create-special-tables conn))))
+
+(defun translate-all-files (&optional (extension ".trans"))
+ "Copy translated files and return postgresql copy commands to import"
+ (make-noneng-index-file extension)
+ (dolist (f (remove "MRXW.NONENG" *umls-files* :test #'string= :key #'fil))
+ (translate-umls-file f extension)))
+
+(defun translate-umls-file (file extension)
+ "Translate a umls file into a format suitable for sql copy cmd"
+ (translate-files file extension (list file)))
+
+(defun make-noneng-index-file (extension)
+ "Make non-english index file"
+ (translate-files (find-ufile "MRXW.NONENG")
+ extension (noneng-lang-index-files)))
+
+(defun translate-files (out-ufile extension input-ufiles)
+ "Translate a umls file into a format suitable for sql copy cmd"
+ (let ((output-path (umls-pathname (fil out-ufile) extension)))
+ (if (probe-file output-path)
+ (format t "File ~A already exists: skipping~%" output-path)
+ (with-open-file (ostream output-path :direction :output)
+ (dolist (input-ufile input-ufiles)
+ (with-umls-file (line (fil input-ufile))
+ (translate-line out-ufile line ostream)
+ (princ #\newline ostream)))))))
+
+(defun translate-line (file line strm)
+ "Translate a single line for sql output"
+ (flet ((col-value (col value)
+ (if (eq (datatype col) 'sql-u)
+ (let ((ui (parse-ui value "")))
+ (if (stringp ui)
+ ui
+ (write-to-string ui)))
+ (escape-backslashes value))))
+ (print-separated-strings
+ strm "|"
+ (mapcar #'col-value (remove-custom-cols (ucols file)) line)
+ (custom-col-values (custom-ucols-for-file file) line nil))))
+
+(defun pg-copy-cmd (file extension)
+ "Return postgresql copy statement for a file"
+ (format
+ nil "COPY ~a FROM '~a' using delimiters '|' with null as ''"
+ (table file) (umls-pathname (fil file) extension)))
+
+(defun mysql-copy-cmd (file extension &key local-file)
+ "Return mysql copy statement for a file"
+ (format
+ nil
+ "LOAD DATA ~AINFILE \"~a\" INTO TABLE ~a FIELDS TERMINATED BY \"|\""
+ (if local-file "LOCAL " "")
+ (umls-pathname (fil file) extension) (table file)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Routines for analyzing cost of fixed size storage
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun umls-fixed-size-waste ()
+ "Display storage waste if using all fixed size storage"
+ (let ((totalwaste 0)
+ (totalunavoidable 0)
+ (totalavoidable 0)
+ (unavoidable '())
+ (avoidable '()))
+ (dolist (file *umls-files*)
+ (dolist (col (ucols file))
+ (let* ((avwaste (- (cmax col) (av col)))
+ (cwaste (* avwaste (rws file))))
+ (when (plusp cwaste)
+ (if (<= avwaste 6)
+ (progn
+ (incf totalunavoidable cwaste)
+ (push (list (fil file) (col col)
+ avwaste cwaste)
+ unavoidable))
+ (progn
+ (incf totalavoidable cwaste)
+ (push (list (fil file) (col col)
+ avwaste cwaste)
+ avoidable)))
+ (incf totalwaste cwaste)))))
+ (values totalwaste totalavoidable totalunavoidable
+ (nreverse avoidable) (nreverse unavoidable))))
+
+(defun display-waste ()
+ (ensure-ucols+ufiles)
+ (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"
+ (declare (optimize (speed 3) (space 0)))
+ (ensure-ucols+ufiles)
+ (let ((max 0))
+ (declare (fixnum max))
+ (dolist (ucol *umls-cols*)
+ (when (> (cmax ucol) max)
+ (setq max (cmax ucol))))
+ max))
+
+(defun max-umls-row ()
+ "Return length of longest row"
+ (declare (optimize (speed 3) (space 0)))
+ (ensure-ucols+ufiles)
+ (let ((rowsizes '()))
+ (dolist (file *umls-files*)
+ (let ((row 0))
+ (dolist (ucol (ucols file))
+ (incf row (1+ (cmax ucol))))
+ (push row rowsizes)))
+ (car (sort rowsizes #'>))))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: data-structures.lisp
+;;;; Purpose: Basic data objects for UMLisp
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package #:umlisp-orf)
+
+;;; Paths for files
+
+(defvar *umls-path*
+ (make-pathname :directory '(:absolute "data" "umls" "2003AC"))
+ "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.")
+
+
+;; Preliminary objects to replace structures
+
+(defclass ufile ()
+ ((fil :initarg :fil :accessor fil)
+ (table :initarg :table :accessor table)
+ (des :initarg :des :accessor des)
+ (fmt :initarg :fmt :accessor fmt)
+ (cls :initarg :cls :accessor cls)
+ (rws :initarg :rws :accessor rws)
+ (bts :initarg :bts :accessor bts)
+ (fields :initarg :fields :accessor fields)
+ (ucols :initarg :ucols :accessor ucols))
+ (:default-initargs :fil nil :table nil :des nil :fmt nil :cls nil :rws nil :bts nil
+ :fields nil :ucols nil)
+ (:documentation "UMLS File"))
+
+(defclass ucol ()
+ ((col :initarg :col :accessor col)
+ (des :initarg :des :accessor des)
+ (ref :initarg :ref :accessor ref)
+ (min :initarg :min :accessor cmin)
+ (av :initarg :av :accessor av)
+ (max :initarg :max :accessor cmax)
+ (fil :initarg :fil :accessor fil)
+ (sqltype :initarg :sqltype :accessor sqltype)
+ (dty :initarg :dty :accessor dty :documentation "new in 2002: suggested SQL datatype")
+ (parse-fun :initarg :parse-fun :accessor parse-fun)
+ (quote-str :initarg :quote-str :accessor quote-str)
+ (datatype :initarg :datatype :accessor datatype)
+ (custom-value-fun :initarg :custom-value-fun :accessor custom-value-fun))
+ (:default-initargs :col nil :des nil :ref nil :min nil :av nil :max nil :fil nil
+ :sqltype nil :dty nil :parse-fun nil :datatype nil
+ :custom-value-fun nil)
+ (:documentation "UMLS column"))
+
+
+(defmethod print-object ((obj ufile) (s stream))
+ (print-unreadable-object (obj s :type t)
+ (format s "~A" (fil obj))))
+
+(defmethod print-object ((obj ucol) (s stream))
+ (print-unreadable-object (obj s :type t)
+ (format s "~A" (col obj))))
+
+
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: package.lisp
+;;;; Purpose: Package definition for UMLisp
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package #:cl-user)
+
+(eval-when (:compile-toplevel :load-toplevel :execute) ;; enclose reader macro
+ (defpackage #:umlisp-orf
+ (:nicknames #:u1)
+ (:use #:kmrcl #:common-lisp #:hyperobject)
+ (:export
+ #:dummy
+ .
+ ;; From classes.lisp
+ #1=(#:umlsclass
+ #:ucon #:uterm #:ustr #:usrl #:uso #:ucxt #:urank #:udef #:usat #:usab #:ulo
+ #:urel #:ucoc #:usty #:uatx #:uxw #:uxnw #:uxns
+ #:lexterm #:labr #:lagr #:lcmp #:lmod #:lnom #:lprn #:lprp #:lspl #:ltrm
+ #:ltyp #:lwd #:sdef #:sstr #:sstre1 #:sstre2
+ #:sty #:tui #:def #:sab #:srl #:tty #:rank #:supres #:atn #:atv #:vcui
+ #:rcui #:vsab
+ #:rl #:sty2 #:ui #:ui2 #:ui3 #:eui #:bas #:eui2 #:bas2
+ #:cui #:lui #:sui #:wd #:lat #:nstr :cuilist
+ #:rsab #:lat
+ #:s#def #:s#sty #:s#term #:s#str #:s#atx #:s#lo #:s#sat #:s#rel #:s#coc
+ #:s#so #:s#cxt
+ #:pfstr #:pfstr2 #:lrl #:def #:ts #:cui1 #:cui2 #:rela #:sl #:mg #:rel
+ #:soc #:cot #:cof #:coa #:isn #:fr #:un #:sna #:soui #:hcd #:stt #:str
+
+ ;; From class-support.lisp
+ #:ucon-has-tui
+ #:english-term-p #:remove-non-english-terms #:remove-english-terms
+ #:fmt-cui #:fmt-tui #:fmt-sui #:fmt-eui #:fmt-tui
+ #:display-con #:display-term #:display-str
+ #:pfstr #:pf-ustr
+ #:cui-p #:lui-p #:sui-p #:tui-p #:eui-p
+ #:rel-abbr-info #:filter-urels-by-rel
+ #:ucon-ancestors #:ucon-parents
+ #:mesh-number #:cxt-ancestors #:ucon-ustrs
+ #:lat-abbr-info #:stt-abbr-info
+
+ ;; From sql.lisp
+ #:*umls-sql-db*
+ #:umls-sql-user!
+ #:umls-sql-passwd!
+ #:umls-sql-db!
+ #:umls-sql-host!
+ #:umls-sql-type!
+ #:with-sql-connection
+ #:mutex-sql-execute
+ #:mutex-sql-query
+ #:with-mutex-sql
+ #:sql-query
+ #:sql-execute
+
+ ;; From utils.lisp
+ #:fmt-cui
+ #:fmt-lui
+ #:fmt-sui
+ #:fmt-tui
+ #:find-uterm-in-ucon
+ #:find-ustr-in-uterm
+ #:find-ustr-in-ucon
+ #:*current-srl*
+ #:parse-cui #:parse-lui #:parse-sui #:parse-tui #:parse-eui
+
+ ;; From sql-classes.lisp
+
+ #:find-udef-cui
+ #:find-usty-cui
+ #:find-usty-word
+ #:find-urel-cui
+ #:find-cui2-urel-cui
+ #:find-urel-cui2
+ #:find-ucon-rel-cui2
+ #:find-ucoc-cui
+ #:find-ucoc-cui2
+ #:find-ucon-coc-cui2
+ #:find-usty-sty
+ #:find-ulo-cui
+ #:suistr
+ #:find-uatx-cui
+ #:print-umlsclass
+ #:find-ucon-cui
+ #:find-ucon-cui-sans-pfstr
+ #:find-ucon-lui
+ #:find-ucon-sui
+ #:find-ucon-cuisui
+ #:find-ucon-str
+ #:find-ucon-all
+ #:find-cui-ucon-all
+ #:map-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-usab-all
+ #:find-usab-rsab
+ #:find-usab-vsab
+ #: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-cui-normalized-word
+ #:find-lui-normalized-word
+ #:find-sui-normalized-word
+ #:find-ustr-word
+ #:find-ustr-normalized-word
+ #:find-uterm-multiword
+ #:find-uterm-word
+ #:find-uterm-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
+ #:display-con
+ #:display-term
+ #:display-str
+ #:find-ustats-all
+ #:find-ustats-srl
+ #:find-bsab-sab
+ #:find-bsab-all
+ #:find-btty-all
+ #:find-btty-tty
+ #:find-brel-rel
+
+ ;; composite.lisp
+ #: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
+ )))
+
+(defpackage umlisp-user
+ (:use #:kmrcl #:common-lisp #:hyperobject)
+ (:import-from :umlisp . #1#)
+ (:export . #1#)
+ (:documentation "User package for UMLisp")))
+
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: parse-2002.lisp
+;;;; Purpose: Parsing and SQL insertion routines for UMLisp which may
+;;;; change from year to year
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package #:umlisp-orf)
+
+;;; Pre-read data for custom fields into hash tables
+(defvar *preparse-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-preparse-hash-table ()
+ (if pfstr-hash
+ (progn
+ (clrhash pfstr-hash)
+ (clrhash cui-lrl-hash)
+ (clrhash lui-lrl-hash)
+ (clrhash cuisui-lrl-hash)
+ (clrhash sab-srl-hash))
+ (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 buffered-ensure-preparse (&optional (force-read nil))
+ (when (or force-read (not *preparse-hash-init?*))
+ (make-preparse-hash-table)
+ (setq *preparse-hash-init?* t))
+ (with-buffered-umls-file (line "MRCON")
+ (let ((cui (parse-ui (aref line 0)))
+ (lui (parse-ui (aref line 3)))
+ (sui (parse-ui (aref line 5)))
+ (lrl (parse-integer (aref line 7))))
+ (unless (gethash cui pfstr-hash) ;; if haven't stored pfstr for cui
+ (if (and (string-equal (aref line 1) "ENG") ; LAT
+ (string-equal (aref line 2) "P") ; ts
+ (string-equal (aref line 4) "PF")) ; stt
+ (setf (gethash cui pfstr-hash) (aref line 6))))
+ (set-lrl-hash cui lrl cui-lrl-hash)
+ (set-lrl-hash lui lrl lui-lrl-hash)
+ (set-lrl-hash (make-cuisui cui sui) lrl cuisui-lrl-hash)))
+ (with-buffered-umls-file (line "MRSO")
+ (let ((sab (aref line 3)))
+ (unless (gethash sab sab-srl-hash) ;; if haven't stored
+ (setf (gethash sab sab-srl-hash) (aref line 6))))))
+
+ (defun ensure-preparse (&optional (force-read nil))
+ (when (or force-read (not *preparse-hash-init?*))
+ (make-preparse-hash-table)
+ (setq *preparse-hash-init?* t))
+ (with-umls-file (line "MRCON")
+ (let ((cui (parse-ui (nth 0 line)))
+ (lui (parse-ui (nth 3 line)))
+ (sui (parse-ui (nth 5 line)))
+ (lrl (parse-integer (nth 7 line))))
+ (unless (gethash cui pfstr-hash) ;; if haven't stored pfstr for cui
+ (if (and (string-equal (nth 1 line) "ENG") ; LAT
+ (string-equal (nth 2 line) "P") ; ts
+ (string-equal (nth 4 line) "PF")) ; stt
+ (setf (gethash cui pfstr-hash) (nth 6 line))))
+ (set-lrl-hash cui lrl cui-lrl-hash)
+ (set-lrl-hash lui lrl lui-lrl-hash)
+ (set-lrl-hash (make-cuisui cui sui) lrl cuisui-lrl-hash)))
+ (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)
+ (aif (gethash sab sab-srl-hash) 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
+;;; 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
+;;; sql-c - Character data
+
+(defparameter +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-c)
+ ("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)
+ ;; New fields for 2002AD
+ ("RCUI" sql-u) ("VCUI" sql-u) ("CFR" sql-i) ("TFR" sql-i)
+ )
+ "SQL data types for each non-string column")
+
+(defparameter +custom-tables+
+ 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")
+
+(defparameter +custom-cols+
+ '(("MRCON" "KPFSTR" "TEXT" 1024
+ (lambda (x) (pfstr-hash (parse-ui (nth 0 x)))))
+ ("MRCON" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 5 x))))))
+ ("MRCON" "KCUILUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 3 x))))))
+ ("MRCON" "KCUILRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cui-lrl (parse-ui (nth 0 x))))))
+ ("MRCON" "KLUILRL" "INTEGER" 0
+ (lambda (x) (write-to-string (lui-lrl (parse-ui (nth 3 x))))))
+ ("MRLO" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string
+ (if (zerop (length (nth 4 x)))
+ (cui-lrl (parse-ui (nth 0 x)))
+ (cuisui-lrl (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 4 x))))))))
+ ("MRSTY" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cui-lrl (parse-ui (nth 0 x))))))
+ ("MRCOC" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string
+ (max (cui-lrl (parse-ui (nth 0 x)))
+ (kmrcl:aif (cui-lrl (parse-ui (nth 1 x))) kmrcl::it 0)))))
+ ("MRSAT" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 5 x)))))
+ ("MRREL" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 4 x)))))
+ ("MRRANK" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 1 x)))))
+ ("MRDEF" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 1 x)))))
+ ("MRCXT" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 2 x)))))
+ ("MRATX" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 1 x)))))
+ ("MRXW.ENG" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
+ ("MRXW.NONENG" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
+ ("MRXNW.ENG" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
+ ("MRXNS.ENG" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
+ ("MRREL" "KPFSTR2" "TEXT" 1024
+ (lambda (x) (pfstr-hash (parse-ui (nth 2 x)))))
+ ("MRCOC" "KPFSTR2" "TEXT" 1024
+ (lambda (x) (pfstr-hash (parse-ui (nth 1 x)))))
+ ("MRCXT" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
+ ("MRSAT" "KCUILUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
+ ("MRSAT" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 2 x))))))
+ ("MRSO" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 2 x))))))
+ ("MRXW.ENG" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
+ ("MRXNW.ENG" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
+ ("MRXNS.ENG" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
+ ("MRXW.NONENG" "LAT" "VARCHAR" 3 (lambda (x) (nth 0 x)))
+ ("MRXW.NONENG" "WD" "VARCHAR" 200 (lambda (x) (nth 1 x)))
+ ("MRXW.NONENG" "CUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 2 x)))))
+ ("MRXW.NONENG" "LUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 3 x)))))
+ ("MRXW.NONENG" "SUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 4 x)))))
+ ("MRXW.NONENG" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x)))))))
+ "Custom columns to create.(filename, col, sqltype, value-func).")
+
+(defparameter +index-cols+
+ '(("CUI" "MRATX") ("CUI1" "MRCOC") ("CUI" "MRCON") ("LUI" "MRCON")
+ ("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")
+ #+ignore ("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")
+ ("SRL" "MRSAB") ("RSAB" "MRSAB") ("VSAB" "MRSAB") ("RCUI" "MRSAB")
+ ("VCUI" "MRSAB") ("LAT" "MRSAB"))
+ "Columns in files to index")
+
+
+(defparameter +custom-index-cols+
+ nil
+ #+ignore
+ '(("CUI" "MRCONFULL") ("SAB" "MRCONFULL") ("TUI" "MRCONFULL"))
+ "Indexes to custom tables")
+
+;; File & Column functions
+
+(defun gen-ucols ()
+ (add-ucols (gen-ucols-meta))
+ (add-ucols (gen-ucols-custom))
+ (add-ucols (gen-ucols-generic "LRFLD"))
+ (add-ucols (gen-ucols-generic "SRFLD")))
+
+(defun gen-ucols-meta ()
+"Initialize all umls columns"
+ (let ((cols '()))
+ (with-umls-file (line "MRCOLS")
+ (destructuring-bind (col des ref min av max fil dty) line
+ (push (make-ucol col des ref (parse-integer min) (read-from-string av)
+ (parse-integer max) fil dty)
+ cols)))
+ (nreverse cols)))
+
+(defun gen-ucols-custom ()
+"Initialize umls columns for custom columns"
+ (loop for customcol in +custom-cols+
+ collect
+ (make-ucol (nth 1 customcol) "" 0 0 0 (nth 3 customcol)
+ (nth 0 customcol) nil :sqltype (nth 2 customcol)
+ :custom-value-fun (nth 4 customcol))))
+
+(defun gen-ucols-generic (col-filename)
+"Initialize for generic (LEX/NET) columns"
+ (let ((cols '()))
+ (with-umls-file (line col-filename)
+ (destructuring-bind (nam des ref fil) line
+ (setq nam (escape-column-name nam))
+ (dolist (file (delimited-string-to-list fil #\,))
+ (push
+ (make-ucol nam des ref nil nil nil file nil)
+ cols))))
+ (nreverse cols)))
+
+
+(defun gen-ufiles ()
+ (add-ufiles (gen-ufiles-generic "MRFILES"))
+ (add-ufiles (gen-ufiles-generic "LRFIL"))
+ (add-ufiles (gen-ufiles-generic "SRFIL"))
+ ;; needs to come last
+ (add-ufiles (gen-ufiles-custom)))
+
+
+(defun gen-ufiles-generic (files-filename)
+"Initialize all LEX file structures"
+ (let ((files '()))
+ (with-umls-file (line files-filename)
+ (destructuring-bind (fil des fmt cls rws bts) line
+ (push (make-ufile
+ fil des (substitute #\_ #\. fil) (parse-integer cls)
+ (parse-integer rws) (parse-integer bts)
+ (concatenate 'list (umls-field-string-to-list fmt)
+ (custom-colnames-for-filename fil)))
+ files)))
+ (nreverse files)))
+
+(defun gen-ufiles-custom ()
+ (make-ufile "MRXW.NONENG" "Custom NonEnglish Index" "MRXW_NONENG"
+ 5 0 0 (fields (find-ufile "MRXW.ENG"))))
+
+
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: parse-common.lisp
+;;;; Purpose: Common, stable parsing routines for UMLisp
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package #:umlisp-orf)
+
+(defun ensure-ucols+ufiles (&optional (alwaysclear nil))
+"Initialize all UMLS file and column structures if not already initialized"
+ (when (or alwaysclear (null *umls-files*))
+ (gen-ucols)
+ (gen-ufiles)
+ (ensure-field-lengths)))
+
+(defun add-ucols (ucols)
+ "Adds a ucol or list of ucols to *umls-cols*. Returns input value."
+ (setq *umls-cols* (append (mklist ucols) *umls-cols*))
+ ucols)
+
+(defun add-ufiles (ufiles)
+ "Adds a ufile or list of ufiles to *umls-filess*. Returns input value."
+ (setq *umls-files* (append (mklist ufiles) *umls-files*))
+ ufiles)
+
+(defun umls-pathname (filename &optional (extension ""))
+"Return pathname for a umls filename with an optional extension"
+ (etypecase filename
+ (string
+ (merge-pathnames
+ (make-pathname :name (concatenate 'string filename extension))
+ (case (schar filename 0)
+ ((#\M #\m)
+ *meta-path*)
+ ((#\L #\l)
+ *lex-path*)
+ ((#\S #\s)
+ *net-path*)
+ (t
+ *umls-path*))))
+ (pathname
+ filename)))
+
+(defun read-umls-line (strm &optional (eof 'eof))
+ "Read a line from a UMLS stream, split into fields"
+ (let ((line (read-line strm nil eof)))
+ (if (eq line eof)
+ eof
+ (delimited-string-to-list line #\| t))))
+
+;;; Find field lengths for LEX and NET files
+
+(defun ensure-field-lengths ()
+ "Initial colstruct field lengths for files that don't have a measurement.
+Currently, these are the LEX and NET files."
+ (dolist (length-list (ufiles-field-lengths (ufiles-to-measure)))
+ (destructuring-bind (filename fields-max fields-av) length-list
+ (let ((file (find-ufile filename)))
+ (unless file
+ (error "Can't find ~A filename in ufiles" filename))
+ (unless (= (length fields-max) (length (fields file)))
+ (error
+ "Number of file fields ~A not equal to field count in ufile ~S"
+ fields-max file))
+ (dotimes (i (length (fields file)))
+ (declare (fixnum i))
+ (let* ((field (nth i (fields file)))
+ (col (find-ucol field filename)))
+ (unless col
+ (error "can't find column ~A" field))
+ (setf (cmax col) (aref fields-max i))
+ (setf (av col) (aref fields-av i))
+ (ensure-ucol-datatype col (datatype-for-colname (col col)))))))))
+
+(defun ufiles-to-measure ()
+ "Returns a list of ufiles to measure"
+ (loop for ufile in *umls-files*
+ unless (or (char= #\M (schar (fil ufile) 0))
+ (char= #\m (schar (fil ufile) 0)))
+ collect ufile))
+
+
+(defun ufiles-field-lengths (ufiles)
+ "Returns a list of lists of containing (FILE MAX AV)"
+ (loop for ufile in ufiles collect (file-field-lengths (fil ufile))))
+
+(defun file-field-lengths (filename)
+ "Returns a list of FILENAME MAX AV"
+ (declare (optimize (speed 3) (safety 0)))
+ (let (fields-max fields-av num-fields (count-lines 0))
+ (with-umls-file (line filename)
+ (unless num-fields
+ (setq num-fields (length line))
+ (setq fields-max (make-array num-fields :element-type 'fixnum
+ :initial-element 0))
+ (setq fields-av (make-array num-fields :element-type 'number
+ :initial-element 0)))
+ (dotimes (i num-fields)
+ (declare (fixnum i))
+ (let ((len (length (nth i line))))
+ (incf (aref fields-av i) len)
+ (when (> len (aref fields-max i))
+ (setf (aref fields-max i) len))))
+ (incf count-lines))
+ (dotimes (i num-fields)
+ (setf (aref fields-av i) (float (/ (aref fields-av i) count-lines))))
+ (list filename fields-max fields-av)))
+
+;;; UMLS column/file functions
+
+(defun find-ucol-of-colname (colname filename ucols)
+"Returns list of umls-col structure for a column name and a filename"
+ (dolist (ucol ucols nil)
+ (when (and (string-equal filename (fil ucol))
+ (string-equal colname (col ucol)))
+ (return-from find-ucol-of-colname ucol))))
+
+(defun ensure-col-in-columns (colname filename ucols)
+ (aif (find-ucol-of-colname colname filename ucols)
+ it
+ (add-ucols (make-ucol-for-column colname filename ucols))))
+
+(defun make-ucol-for-column (colname filename ucols)
+ ;; try to find column name without a terminal digit
+ (let* ((len (length colname))
+ (last-digit? (digit-char-p (schar colname (1- len))))
+ (base-colname (if last-digit?
+ (subseq colname 0 (1- len))
+ colname))
+ (ucol (when last-digit?
+ (find-ucol-of-colname base-colname filename ucols))))
+ (when (and last-digit? (null ucol))
+ (error "Couldn't find a base column for col ~A in file ~A"
+ colname filename))
+ (copy-or-new-ucol colname filename ucol)))
+
+(defun copy-or-new-ucol (colname filename ucol)
+ (if ucol
+ (make-instance
+ 'ucol
+ :col (copy-seq colname) :des (copy-seq (des ucol)) :ref (copy-seq (ref ucol))
+ :min (cmin ucol) :max (cmax ucol) :fil (copy-seq (fil ucol))
+ :sqltype (copy-seq (sqltype ucol)) :dty (copy-seq (dty ucol))
+ :parse-fun (parse-fun ucol) :quote-str (copy-seq (quote-str ucol))
+ :datatype (datatype ucol) :custom-value-fun (custom-value-fun ucol))
+ (make-empty-ucol colname filename)))
+
+(defun ensure-compiled-fun (fun)
+ "Ensure that a function is compiled"
+ (etypecase fun
+ (null
+ nil)
+ (function
+ (if (compiled-function-p fun)
+ fun
+ (compile nil fun)))
+ (list
+ (compile nil fun))))
+
+(defun make-ucol (col des ref min av max fil dty
+ &key (sqltype "VARCHAR") (parse-fun #'add-sql-quotes)
+ (quote-str "'") (custom-value-fun))
+ (let ((ucol (make-instance
+ 'ucol
+ :col col :des des :ref ref :min min :av av
+ :max (if (eql max 0) 1 max) ;; ensure at least one char wide
+ :fil fil
+ :dty dty :sqltype sqltype :quote-str quote-str
+ :parse-fun (ensure-compiled-fun parse-fun)
+ :custom-value-fun (ensure-compiled-fun custom-value-fun))))
+ (ensure-ucol-datatype ucol (datatype-for-colname col))
+ ucol))
+
+(defun make-empty-ucol (colname filename)
+ ;;(format "call in make-empty-ucol: ~A/~A" colname filename)
+ (make-ucol (copy-seq colname) "Unknown" "" nil nil nil filename nil))
+
+(defun find-ucol (colname filename)
+ "Returns list of umls-col structure for a column name and a filename"
+ (ensure-col-in-columns colname filename *umls-cols*))
+
+(defun find-ufile (filename)
+ "Returns umls-file structure for a filename"
+ (find-if #'(lambda (f) (string-equal filename (fil f))) *umls-files*))
+
+(defun find-ucols-for-ufile (ufile)
+ "Returns list of umls-cols for a file structure"
+ (loop for colname in (fields ufile)
+ collect (find-ucol colname (fil ufile))))
+
+(defun umls-field-string-to-list (fmt)
+ "Converts a comma delimited list of fields into a list of field names. Will
+append a unique number (starting at 2) onto a column name that is repeated in the list"
+ (let ((col-counts (make-hash-table :test 'equal)))
+ (loop for colname in (delimited-string-to-list (escape-column-name fmt) #\,)
+ collect
+ (multiple-value-bind (value found) (gethash colname col-counts)
+ (cond
+ (found
+ (incf (gethash colname col-counts))
+ (concatenate 'string colname (write-to-string (1+ value))))
+ (t
+ (setf (gethash colname col-counts) 1)
+ colname))))))
+
+(defun make-ufile (fil des table cls rws bts fields)
+ (let ((ufile (make-instance 'ufile :fil fil :des des :table table :cls cls
+ :rws rws :bts bts :fields fields)))
+ (setf (ucols ufile) (find-ucols-for-ufile ufile))
+ ufile))
+
+(defun datatype-for-colname (colname)
+"Return datatype for column name"
+ (second (find colname +col-datatypes+ :key #'car :test #'string-equal)))
+
+(defun ensure-ucol-datatype (col datatype)
+"Add data type information to column"
+ (setf (datatype col) datatype)
+ (case datatype
+ (sql-u (setf (sqltype col) "INTEGER"
+ (parse-fun col) #'parse-ui
+ (quote-str col) ""))
+ (sql-s (setf (sqltype col) "SMALLINT"
+ (parse-fun col) #'parse-integer
+ (quote-str col) ""))
+ (sql-l (setf (sqltype col) "BIGINT"
+ (parse-fun col) #'parse-integer
+ (quote-str col) ""))
+ (sql-i (setf (sqltype col) "INTEGER"
+ (parse-fun col) #'parse-integer
+ (quote-str col) ""))
+ (sql-f (setf (sqltype col) "NUMERIC"
+ (parse-fun col) #'read-from-string
+ (quote-str col) ""))
+ (t ; Default column type, optimized text storage
+ (setf (parse-fun col) #'add-sql-quotes
+ (quote-str col) "'")
+ (when (and (cmax col) (av col))
+ (if (> (cmax col) 255)
+ (setf (sqltype col) "TEXT")
+ (setf (sqltype col) "VARCHAR"))))))
+
+(defun escape-column-name (name)
+ (substitute #\_ #\/ name))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: parse-macros.lisp
+;;;; Purpose: Macros for UMLS file parsing
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package #:umlisp-orf)
+
+(defmacro with-umls-file ((line filename) &body body)
+"Opens a UMLS and processes each parsed line with (body) argument"
+ (let ((ustream (gensym "STRM-"))
+ (eof (gensym "EOF-")))
+ `(let ((,eof (gensym "EOFSYM-")))
+ (with-open-file
+ (,ustream (umls-pathname ,filename) :direction :input)
+ (do ((,line (read-umls-line ,ustream ,eof)
+ (read-umls-line ,ustream ,eof)))
+ ((eq ,line ,eof) t)
+ ,@body)))))
+
+(defmacro with-buffered-umls-file ((line filename) &body body)
+ "Opens a UMLS and processes each parsed line with (body) argument"
+ (let ((ustream (gensym "STRM-"))
+ (buffer (gensym "BUF-"))
+ (eof (gensym "EOF-")))
+ `(let ((,buffer (make-fields-buffer))
+ (,eof (gensym "EOFSYM-")))
+ (with-open-file
+ (,ustream (umls-pathname ,filename) :direction :input)
+ (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof)
+ (read-buffered-fields ,buffer ,ustream #\| ,eof)))
+ ((eq ,line ,eof) t)
+ ,@body)))))
+
+(defmacro with-buffered2-umls-file ((line filename) &body body)
+ "Opens a UMLS and processes each parsed line with (body) argument"
+ (let ((ustream (gensym "STRM-"))
+ (buffer (gensym "BUF-"))
+ (eof (gensym "EOF-")))
+ `(let ((,buffer (make-fields-buffer2))
+ (,eof (gensym "EOFSYM-")))
+ (with-open-file
+ (,ustream (umls-pathname ,filename)
+ :direction :input :if-exists :overwrite)
+ (do ((,line (read-buffered-fields ,buffer ,ustream #\| ,eof)
+ (read-buffered-fields ,buffer ,ustream #\| ,eof)))
+ ((eq ,line ,eof) t)
+ ,@body)))))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: parse-macros.lisp
+;;;; Purpose: Macros for UMLS file parsing
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+
+(defpackage #:run-tests (:use #:cl))
+(in-package #:run-tests)
+
+(require 'rt)
+(require 'kmrcl)
+(require 'clsql-mysql)
+(require 'clsql)
+(require 'hyperobject)
+(load "umlisp-orf.asd")
+(load "umlisp-orf-tests.asd")
+(asdf:operate 'asdf:test-op 'umlisp-orf)
+
+(defun quit (&optional (code 0))
+ "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function."
+ #+allegro (excl:exit code)
+ #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
+ #+(or cmu scl) (ext:quit code)
+ #+cormanlisp (win32:exitprocess code)
+ #+gcl (lisp:bye code)
+ #+lispworks (lw:quit :status code)
+ #+lucid (lcl:quit code)
+ #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
+ #+mcl (ccl:quit code)
+ #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
+ (error 'not-implemented :proc (list 'quit code)))
+
+(quit)
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: sql-classes.lisp
+;;;; Purpose: Routines for reading UMLS objects from SQL database
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package #:umlisp-orf)
+
+
+(defvar *current-srl* nil)
+(defun current-srl ()
+ *current-srl*)
+(defun current-srl! (srl)
+ (setq *current-srl* srl))
+
+(defmacro query-string (table fields &optional srl where-name where-value
+ &key (lrl "KCUILRL") single distinct order like)
+ (let* ((%%fields (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)"
+ (if distinct "distinct " "") fields table))
+ (%%order (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}"
+ order)
+ ""))
+ (%%lrl (format nil " and ~:@(~A~)<=" lrl))
+ (%%where (when where-name
+ (format nil " where ~:@(~A~)~A" where-name
+ (if like " like " "")))))
+ `(concatenate
+ 'string
+ ,%%fields
+ ,@(when %%where (list %%where))
+ ,@(when %%where
+ `((typecase ,where-value
+ (fixnum
+ (concatenate 'string "='" (prefixed-fixnum-string ,where-value #\0 10) "'"))
+ (number
+ (concatenate 'string "='" (write-to-string ,where-value) "'"))
+ (null
+ " is null")
+ (t
+ (format nil ,(if like "'%~A%'" "='~A'") ,where-value)))))
+ (if ,srl (concatenate 'string ,%%lrl (write-to-string ,srl)) "")
+ ,@(when %%order (list %%order))
+ ,@(when single (list " limit 1")))))
+
+(defun query-string-eval (table fields &optional srl where-name where-value
+ &key (lrl "KCUILRL") single distinct order like)
+ (concatenate
+ 'string
+ (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)"
+ (if distinct "distinct " "") fields table)
+ (if where-name (format nil " where ~:@(~A~)" where-name) "")
+ (if where-name
+ (format nil
+ (typecase where-value
+ (number "=~D")
+ (null " is null")
+ (t
+ (if like " like '%~A%""='~A'")))
+ where-value)
+ "")
+ (if srl (format nil " and ~:@(~A~)<=~D" lrl srl) "")
+ (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}" order) "")
+ (if single " limit 1" "")))
+
+
+(defmacro umlisp-query (table fields srl where-name where-value
+ &key (lrl "KCUILRL") single distinct order like
+ (query-cmd 'mutex-sql-query))
+ "Query the UMLisp database. Return a list of umlisp objects whose name
+is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
+ `(,query-cmd
+ (query-string ,table ,fields ,srl ,where-name ,where-value
+ :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like)))
+
+(defmacro umlisp-query-eval (table fields srl where-name where-value
+ &key (lrl "KCUILRL") single distinct order like)
+ "Query the UMLisp database. Return a list of umlisp objects whose name
+is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
+ `(mutex-sql-query
+ (query-string-eval ,table ,fields ,srl ,where-name ,where-value
+ :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like)))
+
+;; only WHERE-VALUE and SRL are evaluated
+(defmacro collect-umlisp-query ((table fields srl where-name where-value
+ &key (lrl "KCUILRL") distinct single
+ order like (query-cmd 'mutex-sql-query))
+ &body body)
+ (let ((value (gensym))
+ (r (gensym)))
+ (if single
+ `(let* ((,value ,where-value)
+ (tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single
+ :distinct ,distinct :order ,order
+ :like ,like
+ :query-cmd ,query-cmd))))
+ ,@(unless where-name `((declare (ignore ,value))))
+ (when tuple
+ (destructuring-bind ,fields tuple
+ ,@body)))
+ `(let ((,value ,where-value))
+ ,@(unless where-name `((declare (ignore ,value))))
+ (let ((,r '()))
+ (dolist (tuple (umlisp-query ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :like ,like))
+ (push (destructuring-bind ,fields tuple ,@body) ,r))
+ (nreverse ,r))
+ #+ignore
+ (loop for tuple in
+ (umlisp-query ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :like ,like)
+ collect (destructuring-bind ,fields tuple ,@body))))))
+
+(defmacro collect-umlisp-query-eval ((table fields srl where-name where-value
+ &key (lrl "KCUILRL") distinct single
+ order like)
+ &body body)
+ (let ((value (gensym))
+ (r (gensym))
+ (eval-fields (cadr fields)))
+ (if single
+ `(let* ((,value ,where-value)
+ (tuple (car (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single
+ :distinct ,distinct :order ,order
+ :like ,like))))
+ (when tuple
+ (destructuring-bind ,eval-fields tuple
+ ,@body)))
+ `(let ((,value ,where-value)
+ (,r '()))
+ (dolist (tuple (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :like ,like))
+ (push (destructuring-bind ,eval-fields tuple ,@body) ,r))
+ (nreverse ,r)
+ #+ignore
+ (loop for tuple in
+ (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
+ :lrl ,lrl :single ,single :distinct ,distinct
+ :order ,order :like ,like)
+ collect (destructuring-bind ,eval-fields tuple ,@body))))))
+
+;;;
+;;; Read from SQL database
+
+(defmacro ensure-cui-integer (cui)
+ `(if (stringp ,cui)
+ (setq ,cui (parse-cui ,cui))
+ ,cui))
+
+(defmacro ensure-lui-integer (lui)
+ `(if (stringp ,lui)
+ (setq ,lui (parse-lui ,lui))
+ ,lui))
+
+(defmacro ensure-sui-integer (sui)
+ `(if (stringp ,sui)
+ (setq ,sui (parse-sui ,sui))
+ ,sui))
+
+(defmacro ensure-tui-integer (tui)
+ `(if (stringp ,tui)
+ (setq ,tui (parse-tui ,tui))
+ ,tui))
+
+(defmacro ensure-eui-integer (eui)
+ `(if (stringp ,eui)
+ (setq ,eui (parse-eui ,eui))
+ ,eui))
+
+(defun find-ucon-cui (cui &key (srl *current-srl*))
+ "Find ucon for a cui"
+ (ensure-cui-integer cui)
+ (collect-umlisp-query (mrcon (kpfstr kcuilrl) srl cui cui :single t)
+ (make-instance 'ucon :cui cui :pfstr kpfstr
+ :lrl (ensure-integer kcuilrl))))
+
+(defun find-ucon-cui-sans-pfstr (cui &key (srl *current-srl*))
+ "Find ucon for a cui"
+ (ensure-cui-integer cui)
+ (collect-umlisp-query (mrcon (kcuilrl) srl cui cui :single t)
+ (make-instance 'ucon :cui cui :lrl (ensure-integer kcuilrl)
+ :pfstr nil)))
+
+(defun find-pfstr-cui (cui &key (srl *current-srl*))
+ "Find preferred string for a cui"
+ (ensure-cui-integer cui)
+ (collect-umlisp-query (mrcon (kpfstr) srl cui cui :single t)
+ kpfstr))
+
+(defun find-ucon-lui (lui &key (srl *current-srl*))
+ "Find list of ucon for lui"
+ (ensure-lui-integer lui)
+ (collect-umlisp-query (mrcon (cui kpfstr kcuilrl) srl lui lui
+ :distinct t)
+ (make-instance 'ucon :cui (ensure-integer cui) :pfstr kpfstr
+ :lrl (ensure-integer kcuilrl))))
+
+(defun find-ucon-sui (sui &key (srl *current-srl*))
+ "Find list of ucon for sui"
+ (ensure-sui-integer sui)
+ (collect-umlisp-query (mrcon (cui kpfstr kcuilrl) srl sui sui :distinct t)
+ (make-instance 'ucon :cui (ensure-integer cui) :pfstr kpfstr
+ :lrl (ensure-integer kcuilrl))))
+
+(defun find-ucon-cuisui (cui sui &key (srl *current-srl*))
+ "Find ucon for cui/sui"
+ (ensure-cui-integer cui)
+ (ensure-sui-integer sui)
+ (when (and cui sui)
+ (collect-umlisp-query (mrcon (kpfstr kcuilrl) srl kcuisui
+ (make-cuisui cui sui))
+ (make-instance 'ucon :cui cui
+ :pfstr kpfstr
+ :lrl (ensure-integer kcuilrl)))))
+
+(defun find-ucon-str (str &key (srl *current-srl*))
+ "Find ucon that are exact match for str"
+ (collect-umlisp-query (mrcon (cui kpfstr kcuilrl) srl str str :distinct t)
+ (make-instance 'ucon :cui (ensure-integer cui) :pfstr kpfstr
+ :lrl (ensure-integer kcuilrl))))
+
+(defun find-ucon-all (&key (srl *current-srl*))
+ "Return list of all ucon's"
+ (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)))
+ (query-string mrcon (cui kpfstr kcuilrl) srl nil nil
+ :order (cui asc) :distinct t)
+ :database db)))
+
+(defun find-ucon-all2 (&key (srl *current-srl*))
+ "Return list of all ucon's"
+ (collect-umlisp-query (mrcon (cui kpfstr kcuilrl) srl nil nil :order (cui asc)
+ :distinct t)
+ (make-instance 'ucon :cui (ensure-integer cui)
+ :pfstr kpfstr
+ :lrl (ensure-integer kcuilrl))))
+
+(defun find-cui-ucon-all (&key (srl *current-srl*))
+ "Return list of CUIs for all ucons"
+ (collect-umlisp-query (mrcon (cui) srl nil nil :order (cui asc)
+ :distinct t)
+ cui))
+
+(defun map-ucon-all (fn &key (srl *current-srl*))
+ "Map a function over all ucon's"
+ (with-sql-connection (db)
+ (clsql:map-query
+ nil
+ #'(lambda (cui pfstr cuilrl)
+ (funcall fn
+ (make-instance 'ucon :cui (ensure-integer cui)
+ :pfstr pfstr
+ :lrl (ensure-integer cuilrl))))
+ (query-string mrcon (cui kpfstr kcuilrl) srl nil nil :order (cui asc)
+ :distinct t)
+ :database db)))
+
+
+(defun find-udef-cui (cui &key (srl *current-srl*))
+ "Return a list of udefs for cui"
+ (ensure-cui-integer cui)
+ (collect-umlisp-query (mrdef (sab def) srl cui cui :lrl "KSRL")
+ (make-instance 'udef :sab sab :def def)))
+
+(defun find-usty-cui (cui &key (srl *current-srl*))
+ "Return a list of usty for cui"
+ (ensure-cui-integer cui)
+ (collect-umlisp-query (mrsty (tui sty) srl cui cui :lrl "KLRL")
+ (make-instance 'usty :tui (ensure-integer tui) :sty sty)))
+
+(defun find-usty-word (word &key (srl *current-srl*))
+ "Return a list of usty that match word"
+ (collect-umlisp-query (mrsty (tui sty) srl sty word :lrl klrl :like t
+ :distinct t)
+ (make-instance 'usty :tui (ensure-integer tui) :sty sty)))
+
+(defun find-urel-cui (cui &key (srl *current-srl*))
+ "Return a list of urel for cui"
+ (ensure-cui-integer cui)
+ (collect-umlisp-query (mrrel (rel cui2 rela sab sl mg kpfstr2) srl cui1
+ cui :lrl "KSRL")
+ (make-instance 'urel :cui1 cui :rel rel
+ :cui2 (ensure-integer cui2) :rela rela :sab sab :sl sl
+ :mg mg :pfstr2 kpfstr2)))
+
+(defun find-cui2-urel-cui (cui &key (srl *current-srl*))
+ "Return a list of urel for cui"
+ (ensure-cui-integer cui)
+ (collect-umlisp-query (mrrel (cui2) srl cui1
+ cui :lrl "KSRL")
+ cui2))
+
+(defun find-urel-cui2 (cui2 &key (srl *current-srl*))
+ "Return a list of urel for cui2"
+ (ensure-cui-integer cui2)
+ (collect-umlisp-query (mrrel (rel cui1 rela sab sl mg kpfstr2) srl cui2
+ cui2 :lrl "KSRL")
+ (make-instance 'urel :cui2 cui2 :rel rel
+ :cui1 (ensure-integer cui1) :rela rela :sab sab :sl sl
+ :mg mg :pfstr2 kpfstr2)))
+
+(defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*))
+ (ensure-cui-integer cui2)
+ (loop for cui in (remove-duplicates
+ (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl)))
+ collect (find-ucon-cui cui :srl srl)))
+
+(defun find-ucoc-cui (cui &key (srl *current-srl*))
+ "Return a list of ucoc for cui"
+ (ensure-cui-integer cui)
+ (collect-umlisp-query (mrcoc (cui2 soc cot cof coa kpfstr2) srl cui1
+ cui :lrl klrl :order (cof asc))
+ (setq cui2 (ensure-integer cui2))
+ (when (eql 0 cui2) (setq cui2 nil))
+ (make-instance 'ucoc :cui1 cui :cui2 (ensure-integer cui2)
+ :soc soc :cot cot :cof (ensure-integer cof) :coa coa
+ :pfstr2 kpfstr2)))
+
+(defun find-ucoc-cui2 (cui2 &key (srl *current-srl*))
+ "Return a list of ucoc for cui2"
+ (ensure-cui-integer cui2)
+ (collect-umlisp-query (mrcoc (cui1 soc cot cof coa kpfstr2) srl cui2
+ cui2 :lrl klrl :order (cof asc))
+ (when (zerop cui2) (setq cui2 nil))
+ (make-instance 'ucoc :cui1 (ensure-integer cui1) :cui2 cui2
+ :soc soc :cot cot :cof (ensure-integer cof) :coa coa
+ :pfstr2 kpfstr2)))
+
+(defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*))
+ "List of ucon with co-occurance cui2"
+ (ensure-cui-integer cui2)
+ (mapcar
+ #'(lambda (cui) (find-ucon-cui cui :srl srl))
+ (remove-duplicates (mapcar #'cui1 (find-ucoc-cui2 cui2 :srl srl)))))
+
+(defun find-ulo-cui (cui &key (srl *current-srl*))
+ "Return a list of ulo for cui"
+ (ensure-cui-integer cui)
+ (collect-umlisp-query (mrlo (isn fr un sui sna soui) srl cui cui
+ :lrl "KLRL")
+ (make-instance 'ulo :isn isn :fr (ensure-integer fr) :un un
+ :sui (ensure-integer sui) :sna sna :soui soui)))
+
+(defun find-uatx-cui (cui &key (srl *current-srl*))
+ "Return a list of uatx for cui"
+ (ensure-cui-integer cui)
+ (collect-umlisp-query (mratx (sab rel atx) srl cui cui :lrl ksrl)
+ (make-instance 'uatx :sab sab :rel rel :atx atx)))
+
+
+(defun find-uterm-cui (cui &key (srl *current-srl*))
+ "Return a list of uterm for cui"
+ (ensure-cui-integer cui)
+ (collect-umlisp-query (mrcon (lui lat ts kluilrl) srl cui cui
+ :lrl kluilrl :distinct t)
+ (make-instance 'uterm :lui (ensure-integer lui) :cui cui
+ :lat lat :ts ts :lrl (ensure-integer kluilrl))))
+
+(defun find-uterm-lui (lui &key (srl *current-srl*))
+ "Return a list of uterm for lui"
+ (ensure-lui-integer lui)
+ (collect-umlisp-query (mrcon (cui lat ts kluilrl) srl lui lui
+ :lrl kluilrl :distinct t)
+ (make-instance 'uterm :cui (ensure-integer cui) :lui lui
+ :lat lat :ts ts :lrl (ensure-integer kluilrl))))
+
+(defun find-uterm-cuilui (cui lui &key (srl *current-srl*))
+ "Return single uterm for cui/lui"
+ (ensure-cui-integer cui)
+ (ensure-lui-integer lui)
+ (collect-umlisp-query (mrcon (lat ts kluilrl) srl kcuilui
+ (make-cuilui cui lui)
+ :lrl kluilrl :single t)
+ (make-instance 'uterm :cui cui :lui lui :lat lat :ts ts
+ :lrl (ensure-integer kluilrl))))
+
+(defun find-ustr-cuilui (cui lui &key (srl *current-srl*))
+ "Return a list of ustr for cui/lui"
+ (ensure-cui-integer cui)
+ (ensure-lui-integer lui)
+ (collect-umlisp-query (mrcon (sui stt str lrl) srl kcuilui
+ (make-cuilui cui lui) :lrl lrl)
+ (make-instance 'ustr :sui (ensure-integer sui) :cui cui :lui lui
+ :cuisui (make-cuisui cui sui) :stt stt :str str
+ :lrl (ensure-integer lrl))))
+
+(defun find-ustr-cuisui (cui sui &key (srl *current-srl*))
+ "Return the single ustr for cuisui"
+ (ensure-cui-integer cui)
+ (ensure-sui-integer sui)
+ (collect-umlisp-query (mrcon (lui stt str lrl) srl kcuisui
+ (make-cuisui cui sui) :lrl lrl :single t)
+ (make-instance 'ustr :sui sui :cui cui :cuisui (make-cuisui cui sui)
+ :lui (ensure-integer lui) :stt stt :str str
+ :lrl (ensure-integer lrl))))
+
+(defun find-ustr-sui (sui &key (srl *current-srl*))
+ "Return the list of ustr for sui"
+ (ensure-sui-integer sui)
+ (collect-umlisp-query (mrcon (cui lui stt str lrl) srl sui sui
+ :lrl lrl)
+ (make-instance 'ustr :sui sui :cui cui :stt stt :str str
+ :cuisui (make-cuisui (ensure-integer cui) sui)
+ :lui (ensure-integer lui) :lrl (ensure-integer lrl))))
+
+(defun find-ustr-sab (sab &key (srl *current-srl*))
+ "Return the list of ustr for sab"
+ (collect-umlisp-query (mrso (kcuisui) srl sab sab :lrl srl)
+ (let ((cuisui (ensure-integer kcuisui)))
+ (apply #'find-ustr-cuisui
+ (append
+ (multiple-value-list (decompose-cuisui cuisui))
+ (list :srl srl))))))
+
+(defun find-ustr-all (&key (srl *current-srl*))
+ "Return list of all ustr's"
+ (with-sql-connection (db)
+ (clsql:map-query
+ 'list
+ #'(lambda (cui lui sui stt lrl pfstr)
+ (make-instance 'ustr :cui (ensure-integer cui)
+ :lui (ensure-integer lui) :sui (ensure-integer sui)
+ :stt stt :str pfstr
+ :cuisui (make-cuisui (ensure-integer cui)
+ (ensure-integer sui))
+ :lrl (ensure-integer lrl)))
+ (query-string mrcon (cui lui sui stt lrl kpfstr) srl nil nil :lrl lrl
+ :distinct t
+ :order (sui asc))
+ :database db)))
+
+(defun find-string-sui (sui &key (srl *current-srl*))
+ "Return the string associated with sui"
+ (ensure-sui-integer sui)
+ (collect-umlisp-query (mrcon (str) srl sui sui :lrl lrl :single t)
+ str))
+
+(defun find-uso-cuisui (cui sui &key (srl *current-srl*))
+ (ensure-sui-integer sui)
+ (ensure-cui-integer cui)
+ (collect-umlisp-query (mrso (sab code srl tty) srl kcuisui
+ (make-cuisui cui sui) :lrl srl)
+ (make-instance 'uso :sab sab :code code :srl srl :tty tty)))
+
+(defun find-ucxt-cuisui (cui sui &key (srl *current-srl*))
+ (ensure-cui-integer cui)
+ (ensure-sui-integer sui)
+ (collect-umlisp-query (mrcxt (sab code cxn cxl rnk cxs cui2 hcd rela xc)
+ srl kcuisui (make-cuisui cui sui) :lrl ksrl)
+ (make-instance 'ucxt :sab sab :code code
+ :cxn (ensure-integer cxn) :cxl cxl :cxs cxs :hcd hcd
+ :rela rela :xc xc :rnk (ensure-integer rnk)
+ :cui2 (ensure-integer cui2))))
+
+(defun find-usat-ui (cui &optional (lui nil) (sui nil) &key (srl *current-srl*))
+ (ensure-cui-integer cui)
+ (ensure-lui-integer lui)
+ (ensure-sui-integer sui)
+ (let ((ls "select CODE,ATN,SAB,ATV from MRSAT where "))
+ (cond
+ (sui (string-append ls "KCUISUI='"
+ (integer-string (make-cuisui cui sui) 14)
+ "'"))
+ (lui (string-append ls "KCUILUI='"
+ (integer-string (make-cuilui cui lui) 14)
+ "' and sui='0'"))
+ (t (string-append ls "cui='" (prefixed-fixnum-string cui nil 7)
+ "' and lui='0' and sui='0'")))
+ (when srl
+ (string-append ls " and KSRL<=" (prefixed-fixnum-string srl nil 3)))
+ (loop for tuple in (mutex-sql-query ls) collect
+ (destructuring-bind (code atn sab atv) tuple
+ (make-instance 'usat :code code :atn atn :sab sab :atv atv)))))
+
+(defun find-usty-tui (tui)
+ "Find usty for tui"
+ (ensure-tui-integer tui)
+ (collect-umlisp-query (mrsty (sty) nil tui tui :single t)
+ (make-instance 'usty :tui tui :sty sty)))
+
+(defun find-usty-sty (sty)
+ "Find usty for a sty"
+ (collect-umlisp-query (mrsty (tui) nil sty sty :single t)
+ (make-instance 'usty :tui (ensure-integer tui) :sty sty)))
+
+(defun find-usty-all ()
+ "Return list of usty's for all semantic types"
+ (collect-umlisp-query (mrsty (tui) nil nil nil :distinct t)
+ (find-usty-tui tui)))
+
+(defun find-usab-all ()
+ "Find usab for a key"
+ (collect-umlisp-query (mrsab (vcui rcui vsab rsab son sf sver vstart vend imeta
+ rmeta slc scc srl tfr cfr cxty ttyl atnl lat
+ cenc curver sabin) nil nil nil)
+ (make-instance 'usab :vcui (ensure-integer vcui)
+ :rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son
+ :sf sf :sver sver :vstart vstart :vend vend :imeta imeta
+ :rmeta rmeta :slc slc :scc scc :srl (ensure-integer srl)
+ :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
+ :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
+ :curver curver :sabin sabin)))
+
+(defun find-usab-by-key (key-name key)
+ "Find usab for a key"
+ (collect-umlisp-query-eval ('mrsab '(vcui rcui vsab rsab son sf sver vstart
+ vend imeta rmeta slc scc srl tfr cfr cxty
+ ttyl atnl lat cenc curver sabin)
+ nil key-name key :single t)
+ (make-instance 'usab :vcui (ensure-integer vcui)
+ :rcui (ensure-integer rcui) :vsab vsab :rsab rsab :son son
+ :sf sf :sver sver :vstart vstart :vend vend :imeta imeta
+ :rmeta rmeta :slc slc :scc scc :srl (ensure-integer srl)
+ :tfr (ensure-integer tfr) :cfr (ensure-integer cfr)
+ :cxty cxty :ttyl ttyl :atnl atnl :lat lat :cenc cenc
+ :curver curver :sabin sabin)))
+
+(defun find-usab-rsab (rsab)
+ "Find usab for rsab"
+ (find-usab-by-key 'rsab rsab))
+
+(defun find-usab-vsab (vsab)
+ "Find usab for vsab"
+ (find-usab-by-key 'vsab vsab))
+
+(defun find-cui-max ()
+ (ensure-integer (caar (mutex-sql-query "select max(CUI) from MRCON"))))
+
+;;;; Cross table find functions
+
+(defun find-ucon-tui (tui &key (srl *current-srl*))
+ "Find list of ucon for tui"
+ (ensure-tui-integer tui)
+ (collect-umlisp-query (mrsty (cui) srl tui tui :lrl klrl :order (cui asc))
+ (find-ucon-cui (ensure-integer cui) :srl srl)))
+
+(defun find-ucon-word (word &key (srl *current-srl*) (like nil))
+ "Return list of ucons that match word. Optionally, use SQL's LIKE syntax"
+ (collect-umlisp-query-eval ('mrxw_eng '(cui) srl 'wd word :like like :distinct t
+ :lrl 'klrl :order '(cui asc))
+ (find-ucon-cui cui :srl srl)))
+
+(defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil))
+ "Return list of ucons that match word, optionally use SQL's LIKE syntax"
+ (collect-umlisp-query-eval ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t
+ :lrl 'klrl :order '(cui asc))
+ (find-ucon-cui cui :srl srl)))
+
+(defun find-cui-normalized-word (word &key (srl *current-srl*) (like nil))
+ "Return list of cui that match word, optionally use SQL's LIKE syntax"
+ (collect-umlisp-query-eval ('mrxnw_eng '(cui) srl 'nwd word :like like :distinct t
+ :lrl 'klrl :order '(cui asc))
+ cui))
+
+(defun find-lui-normalized-word (word &key (srl *current-srl*) (like nil))
+ "Return list of cui that match word, optionally use SQL's LIKE syntax"
+ (collect-umlisp-query-eval ('mrxnw_eng '(lui) srl 'nwd word :like like :distinct t
+ :lrl 'klrl :order '(cui asc))
+ lui))
+
+(defun find-sui-normalized-word (word &key (srl *current-srl*) (like nil))
+ "Return list of cui that match word, optionally use SQL's LIKE syntax"
+ (collect-umlisp-query-eval ('mrxnw_eng '(sui) srl 'nwd word :like like :distinct t
+ :lrl 'klrl :order '(cui asc))
+ sui))
+
+(defun find-ustr-word (word &key (srl *current-srl*))
+ "Return list of ustrs that match word"
+ (collect-umlisp-query (mrxw_eng (cui sui) srl wd word :lrl klrl
+ :order (cui asc sui asc))
+ (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
+
+(defun find-ustr-normalized-word (word &key (srl *current-srl*))
+ "Return list of ustrs that match word"
+ (collect-umlisp-query (mrxnw_eng (cui sui) srl nwd word :lrl klrl
+ :order (cui asc sui asc))
+ (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
+
+(defun find-uterm-word (word &key (srl *current-srl*))
+ "Return list of uterms that match word"
+ (collect-umlisp-query (mrxw_eng (cui lui) srl wd word :lrl klrl
+ :order (cui asc lui asc))
+ (find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl)))
+
+(defun find-uterm-normalized-word (word &key (srl *current-srl*))
+ "Return list of uterms that match word"
+ (collect-umlisp-query (mrxnw_eng (cui lui) srl nwd word :lrl klrl
+ :order (cui asc lui asc))
+ (find-uterm-cuilui (ensure-integer cui) (ensure-integer lui) :srl srl)))
+
+(defun find-ucon-noneng-word (word &key (srl *current-srl*) (like nil))
+ "Return list of ucons that match non-english word"
+ (collect-umlisp-query-eval ('mrxw_noneng '(cui) srl 'wd word :like like
+ :distinct t :lrl 'klrl :order '(cui asc))
+ (find-ucon-cui cui :srl srl)))
+
+(defun find-ustr-noneng-word (word &key (srl *current-srl*))
+ "Return list of ustrs that match non-english word"
+ (collect-umlisp-query (mrxw_noneng (cui sui) srl wd word :lrl klrl
+ :order (cui asc sui asc))
+ (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl)))
+
+;; Special tables
+
+(defun find-usrl-all ()
+ (collect-umlisp-query (usrl (sab srl) nil nil nil :order (sab asc))
+ (make-instance 'usrl :sab sab :srl (ensure-integer srl))))
+
+;;; Multiword lookup and score functions
+
+(defun find-uobj-multiword (str obj-lookup-fun sort-fun key srl
+ only-exact-if-match)
+ (let ((uobjs '()))
+ (dolist (word (delimited-string-to-list str #\space))
+ (setq uobjs (append uobjs (funcall obj-lookup-fun word :srl srl))))
+ (let ((sorted
+ (funcall sort-fun str
+ (delete-duplicates uobjs :test #'= :key key))))
+ (if (and (plusp (length sorted))
+ only-exact-if-match
+ (multiword-match str (pfstr (first sorted))))
+ (first sorted)
+ sorted))))
+
+(defun find-ucon-multiword (str &key (srl *current-srl*)
+ (only-exact-if-match t))
+ (find-uobj-multiword str #'find-ucon-word #'sort-score-pfstr-str
+ #'cui srl only-exact-if-match))
+
+(defun find-uterm-multiword (str &key (srl *current-srl*)
+ (only-exact-if-match t))
+ (find-uobj-multiword str #'find-uterm-word #'sort-score-pfstr-str
+ #'lui srl only-exact-if-match))
+
+(defun find-ustr-multiword (str &key (srl *current-srl*)
+ (only-exact-if-match t))
+ (find-uobj-multiword str #'find-ustr-word #'sort-score-ustr-str
+ #'sui srl only-exact-if-match))
+
+(defun sort-score-pfstr-str (str uobjs)
+ "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr"
+ (sort-score-umlsclass-str uobjs str #'pfstr))
+
+(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))))
+
+
+;;; LEX SQL functions
+
+(defun find-lexterm-eui (eui)
+ (ensure-eui-integer eui)
+ (collect-umlisp-query (lrwd (wrd) nil eui eui :single t)
+ (make-instance 'lexterm :eui eui :wrd wrd)))
+
+(defun find-lexterm-word (wrd)
+ (collect-umlisp-query (lrwd (eui) nil wrd wrd)
+ (make-instance 'lexterm :eui (ensure-integer eui)
+ :wrd (copy-seq wrd))))
+
+;; LEX SQL Read functions
+
+(defun find-labr-eui (eui)
+ (ensure-eui-integer eui)
+ (collect-umlisp-query (lrabr (bas abr eui2 bas2) nil eui eui)
+ (make-instance 'labr :eui eui :bas bas :abr abr :bas2 bas2
+ :eui2 (ensure-integer eui2))))
+
+(defun find-labr-bas (bas)
+ (collect-umlisp-query (labr (eui abr eui2 bas2) nil bas bas)
+ (make-instance 'labr :eui (ensure-integer eui) :abr abr :bas2 bas2
+ :bas (copy-seq bas) :eui2 (ensure-integer eui2))))
+
+(defun find-lagr-eui (eui)
+ (ensure-eui-integer eui)
+ (collect-umlisp-query (lragr (str sca agr cit bas) nil eui eui)
+ (make-instance 'lagr :eui eui :str str :sca sca :agr agr
+ :cit cit :bas bas)))
+
+(defun find-lcmp-eui (eui)
+ (ensure-eui-integer eui)
+ (collect-umlisp-query (lrcmp (bas sca com) nil eui eui)
+ (make-instance 'lcmp :eui eui :bas bas :sca sca :com com)))
+
+(defun find-lmod-eui (eui)
+ (ensure-eui-integer eui)
+ (collect-umlisp-query (lrmod (bas sca psn_mod fea) nil eui eui)
+ (make-instance 'lmod :eui eui :bas bas :sca sca :psnmod psn_mod :fea fea)))
+
+(defun find-lnom-eui (eui)
+ (ensure-eui-integer eui)
+ (collect-umlisp-query (lrnom (bas sca eui2 bas2 sca2) nil eui eui)
+ (make-instance 'lnom :eui eui :bas bas :sca sca :bas2 bas2 :sca2 sca2
+ :eui2 (ensure-integer eui2))))
+
+(defun find-lprn-eui (eui)
+ (ensure-eui-integer eui)
+ (collect-umlisp-query (lrprn (bas num gnd cas pos qnt fea) nil eui eui)
+ (make-instance 'lprn :eui eui :bas bas :num num :gnd gnd
+ :cas cas :pos pos :qnt qnt :fea fea)))
+
+(defun find-lprp-eui (eui)
+ (ensure-eui-integer eui)
+ (collect-umlisp-query (lrprp (bas str sca fea) nil eui eui)
+ (make-instance 'lprp :eui eui :bas bas :str str :sca sca :fea fea)))
+
+(defun find-lspl-eui (eui)
+ (ensure-eui-integer eui)
+ (collect-umlisp-query (lrspl (spv bas) nil eui eui)
+ (make-instance 'lspl :eui eui :spv spv :bas bas)))
+
+(defun find-ltrm-eui (eui)
+ (ensure-eui-integer eui)
+ (collect-umlisp-query (lrtrm (bas gen) nil eui eui)
+ (make-instance 'ltrm :eui eui :bas bas :gen gen)))
+
+(defun find-ltyp-eui (eui)
+ (ensure-eui-integer eui)
+ (collect-umlisp-query (lrtyp (bas sca typ) nil eui eui)
+ (make-instance 'ltyp :eui eui :bas bas :sca sca :typ typ)))
+
+(defun find-lwd-wrd (wrd)
+ (make-instance 'lwd :wrd wrd
+ :euilist (collect-umlisp-query (lrwd (eui) nil wrd wrd)
+ (ensure-integer eui))))
+
+;;; Semantic Network SQL access functions
+
+(defun find-sdef-ui (ui)
+ (collect-umlisp-query (srdef (rt sty_rl stn_rtn def ex un rh abr rin)
+ nil ui ui :single t)
+ (make-instance 'sdef :rt rt :ui ui :styrl sty_rl :stnrtn stn_rtn
+ :def def :ex ex :un un :rh rh :abr abr :rin rin)))
+
+(defun find-sstre1-ui (ui)
+ (collect-umlisp-query (srstre1 (ui2 ui3) nil ui ui)
+ (make-instance 'sstre1 :ui ui :ui2 (ensure-integer ui2)
+ :ui3 (ensure-integer ui3))))
+
+(defun find-sstre1-ui2 (ui2)
+ (collect-umlisp-query (srstre1 (ui ui3) nil ui2 ui2)
+ (make-instance 'sstre1 :ui (ensure-integer ui) :ui2 ui2
+ :ui3 (ensure-integer ui3))))
+
+(defun find-sstr-rl (rl)
+ (collect-umlisp-query (srstre (sty_rl sty_rl2 ls) nil rl rl)
+ (make-instance 'sstr :rl rl :styrl sty_rl :styrl2 sty_rl2 :ls ls)))
+
+(defun find-sstre2-sty (sty)
+ (collect-umlisp-query (srstre2 (rl sty2) nil sty sty)
+ (make-instance 'sstre2 :sty (copy-seq sty) :rl rl :sty2 sty2)))
+
+(defun find-sstr-styrl (styrl)
+ (collect-umlisp-query (srstr (rl sty_rl2 ls) nil styrl styrl)
+ (make-instance 'sstr :styrl styrl :rl rl :styrl2 sty_rl2 :ls ls)))
+
+
+;;; **************************
+;;; Local Classes
+;;; **************************
+
+
+(defun make-ustats ()
+ (with-sql-connection (conn)
+ (ignore-errors (sql-execute "drop table USTATS" conn))
+ (sql-execute "create table USTATS (NAME varchar(160), COUNT bigint, SRL integer)" conn)
+
+ (dotimes (srl 4)
+ (insert-ustats-count conn "Concept Count" "MRCON" "distinct CUI" "KCUILRL" srl)
+ (insert-ustats-count conn "Term Count" "MRCON" "distinct KCUILUI" "KCUILRL" srl)
+ (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*))
+ (if srl
+ (collect-umlisp-query (ustats (name count srl) nil srl srl
+ :order (name asc))
+ (make-instance 'ustats :name name
+ :hits (ensure-integer count)
+ :srl (ensure-integer srl)))
+ (collect-umlisp-query (ustats (name count srl) nil nil nil
+ :order (name asc))
+ (make-instance 'ustats :name name
+ :hits (ensure-integer count)
+ :srl (ensure-integer srl)))))
+
+(defun find-ustats-srl (srl)
+ (collect-umlisp-query (ustats (name count) nil srl srl :order (name asc))
+ (make-instance 'ustats :name name :hits (ensure-integer count))))
+
+
+
+(defun find-bsab-sab (sab)
+ (collect-umlisp-query (bonus_sab (name count) nil sab sab :single t)
+ (make-instance 'bsab :sab sab :name name :hits (ensure-integer count))))
+
+(defun find-bsab-all ()
+ (collect-umlisp-query (bonus_sab (sab name count) nil nil nil :order (sab asc))
+ (make-instance 'bsab :sab sab :name name :hits (ensure-integer count))))
+
+(defun find-btty-tty (tty)
+ (collect-umlisp-query (bonus_tty (name count) nil tty tty :single t)
+ (make-instance 'btty :tty tty :name name :hits (ensure-integer count))))
+
+(defun find-btty-all ()
+ (collect-umlisp-query (bonus_tty (tty name count) nil nil nil :order (tty asc))
+ (make-instance 'btty :tty tty :name name :hits (ensure-integer count))))
+
+(defun find-brel-rel (rel)
+ (collect-umlisp-query (bonus_rel (sab sl rel rela count) nil rel rel)
+ (make-instance 'brel :sab sab :sl sl :rel rel :rela rela
+ :hits (ensure-integer count))))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: sql.lisp
+;;;; Purpose: Low-level SQL routines data for UMLisp
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package #:umlisp-orf)
+
+(defvar +umls-sql-map+
+ '((:2002AD . "KUMLS2002AD") (:2003AA . "KUMLS2003AA")
+ (:2003AB . "KUMLS2003AB") (:2003AC . "KUMLS2003AC")
+ (:2004AA . "KUMLS2004AA")))
+(defvar +default-umls-db+ :2003AC)
+
+
+(defun lookup-db-name (db)
+ (cdr (assoc (ensure-keyword db) +umls-sql-map+)))
+
+(defvar *umls-sql-db* +default-umls-db+)
+(defun umls-sql-db ()
+ *umls-sql-db*)
+
+(defun umls-sql-db! (db)
+ (setq *umls-sql-db* db))
+
+(defvar *umls-sql-user* "secret")
+(defun umls-sql-user ()
+ *umls-sql-user*)
+(defun umls-sql-user! (u)
+ (sql-disconnect-pooled)
+ (setq *umls-sql-user* u))
+
+(defvar *umls-sql-passwd* "secret")
+(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 (list *umls-sql-host* (lookup-db-name *umls-sql-db*)
+ *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 (result-types :auto))
+ (clsql:query cmd :database conn :result-types result-types :field-names nil))
+
+(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 (result-types :auto))
+ (with-mutex-sql (conn)
+ (sql-query cmd conn :result-types result-types)))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: umlisp-tests.asd
+;;;; Purpose: ASDF system definitionf for umlisp testing package
+;;;; Author: Kevin M. Rosenberg
+;;;; Date Started: Apr 2003
+;;;;
+;;;; $Id$
+;;;; *************************************************************************
+
+(defpackage #:umlisp-tests-system
+ (:use #:asdf #:cl))
+(in-package #:umlisp-tests-system)
+
+(defsystem umlisp-orf-tests
+ :depends-on (:rt :umlisp)
+ :components
+ ((:module tests
+ :components
+ ((:file "package")
+ (:file "basic" :depends-on ("package"))
+ (:file "parse" :depends-on ("package"))))))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'umlisp-orf-tests))))
+ (or (funcall (intern (symbol-name '#:do-tests)
+ (find-package '#:regression-test)))
+ (error "test-op failed")))
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: umlisp.asd
+;;;; Purpose: ASDF system definition file for UMLisp
+;;;; Author: Kevin M. Rosenberg
+;;;; Date Started: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(defpackage #:umlisp-system (:use #:asdf #:cl))
+(in-package #:umlisp-system)
+
+#+(or allegro lispworks cmu sbcl openmcl scl)
+(defsystem umlisp-orf
+ :components
+ ((:file "package")
+ (:file "data-structures" :depends-on ("package"))
+ (:file "utils" :depends-on ("data-structures"))
+ (:file "sql" :depends-on ("utils"))
+ (:file "parse-macros" :depends-on ("sql"))
+ (:file "parse-2002" :depends-on ("parse-macros"))
+ (:file "parse-common" :depends-on ("parse-2002"))
+ (:file "create-sql" :depends-on ("parse-common"))
+ (:file "sql-classes" :depends-on ("sql"))
+ (:file "classes" :depends-on ("sql-classes"))
+ (:file "class-support" :depends-on ("classes"))
+ (:file "composite" :depends-on ("sql-classes")))
+ :depends-on (clsql clsql-postgresql-socket kmrcl hyperobject))
+
+#+(or allegro lispworks cmu sbcl openmcl scl)
+(defmethod perform ((o test-op) (c (eql (find-system 'umlisp-orf))))
+ (oos 'load-op 'umlisp-orf-tests)
+ (oos 'test-op 'umlisp-orf-tests))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: utils.lisp
+;;;; Purpose: Low-level utility functions for UMLisp
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package #:umlisp-orf)
+
+(declaim (inline make-cuisui make-cuilui parse-ui parse-cui))
+
+(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."
+ (declare (simple-string s)
+ (optimize (speed 3) (safety 0)))
+ (if (< (length s) 2)
+ nullvalue
+ (nth-value 0 (parse-integer s :start 1))))
+
+(defun parse-cui (cui)
+ (declare (optimize (speed 3) (safety 0)))
+ (if (stringp cui)
+ (let ((ch (schar cui 0)))
+ (if (char-equal ch #\C)
+ (parse-ui cui)
+ (nth-value 0 (parse-integer cui))))
+ cui))
+
+(defun parse-lui (lui)
+ (declare (optimize (speed 3) (safety 0)))
+ (if (stringp lui)
+ (let ((ch (schar lui 0)))
+ (if (char-equal ch #\L)
+ (parse-ui lui)
+ (nth-value 0 (parse-integer lui))))
+ lui))
+
+(defun parse-sui (sui)
+ (declare (optimize (speed 3) (safety 0)))
+ (if (stringp sui)
+ (let ((ch (schar sui 0)))
+ (if (char-equal ch #\S)
+ (parse-ui sui)
+ (nth-value 0 (parse-integer sui))))
+ sui))
+
+(defun parse-tui (tui)
+ (declare (optimize (speed 3) (safety 0)))
+ (if (stringp tui)
+ (let ((ch (schar tui 0)))
+ (if (char-equal ch #\T)
+ (parse-ui tui)
+ (nth-value 0 (parse-integer tui))))
+ tui))
+
+(defun parse-eui (eui)
+ (declare (optimize (speed 3) (safety 0)))
+ (if (stringp eui)
+ (let ((ch (schar eui 0)))
+ (if (char-equal ch #\E)
+ (parse-ui eui)
+ (nth-value 0 (parse-integer eui))))
+ eui))
+
+(defconstant +cuisui-scale+ 10000000)
+(declaim (type fixnum +cuisui-scale+))
+
+(defun make-cuisui (cui sui)
+ (declare (fixnum cui sui)
+ (optimize (speed 3) (safety 0) (space 0)))
+ (+ (* +cuisui-scale+ cui) sui))
+
+(defun make-cuilui (cui lui)
+ (declare (fixnum cui lui)
+ (optimize (speed 3) (safety 0) (space 0)))
+ (+ (* +cuisui-scale+ cui) lui))
+
+(defun decompose-cuisui (cuisui)
+ "Returns the CUI and SUI of a cuisui number"
+ (floor cuisui +cuisui-scale+))
+
+;;; Lookup functions for uterms,ustr in ucons
+
+(defun find-uterm-in-ucon (ucon lui)
+ (find lui (s#term ucon) :key #'lui :test 'equal))
+
+(defun find-ustr-in-uterm (uterm sui)
+ (find sui (s#str uterm) :key #'sui :test 'equal))
+
+(defun find-ustr-in-ucon (ucon sui)
+ (dolist (uterm (s#term ucon))
+ (dolist (ustr (s#str uterm))
+ (when (string-equal sui (sui ustr))
+ (return-from find-ustr-in-ucon ustr)))))
projects / umlisp-orf.git / commitdiff