From: Kevin M. Rosenberg Date: Tue, 8 Oct 2002 22:13:41 +0000 (+0000) Subject: r2952: *** empty log message *** X-Git-Tag: v2006ac.2~334 X-Git-Url: http://git.kpe.io/?p=umlisp.git;a=commitdiff_plain;h=cd8b476663925be5a1ebbeb569a056e2e5b93aba r2952: *** empty log message *** --- diff --git a/README b/README new file mode 100644 index 0000000..9b75514 --- /dev/null +++ b/README @@ -0,0 +1,13 @@ +This is UMLisp - An object-oriented, SQL-based interface library to the +Unified Medical Language System. + +This is open-source software governed by the GNU General Public +License included with the software in the file COPYING. It is +Copyright (C) 2000-2002 by Kevin M. Rosenberg. + +No documentation is included with this product. Available +documentation and support options are listed on the UMLisp support web +site: http://umlisp.med-info.com/support/ + + + diff --git a/classes.lisp b/classes.lisp new file mode 100644 index 0000000..9a180ef --- /dev/null +++ b/classes.lisp @@ -0,0 +1,527 @@ +;;; $Id: classes.lisp,v 1.1 2002/10/08 22:08:56 kevin Exp $ +;;; +;;; UMLS object defintions and printing routines + +(in-package :umlisp) +(declaim (optimize (speed 3) (safety 1))) + +(defclass umlsclass () + () + (:metaclass ml-class) + (:documentation "Parent class of all UMLS objects")) + + +(defmethod print-object ((obj umlsclass) (s stream)) + (print-unreadable-object (obj s :type t :identity t) + (let ((fmt (make-instance 'gu.ml::textformat))) + (apply #'format + s (funcall (gu.ml::obj-data-fmtstr fmt) obj) + (multiple-value-list + (funcall (funcall (gu.ml::obj-data-value-func fmt) obj) obj)))))) + + + + +(defclass urank (umlsclass) + ((rank :type fixnum :initarg :rank :reader rank) + (sab :type string :initarg :sab :reader sab) + (tty :type string :initarg :tty :reader tty) + (supres :type string :initarg :supres :reader supres)) + (:metaclass ml-class) + (:default-initargs :rank nil :sab nil :tty nil :supres nil) + (:title "Rank") + (:fields (rank :fixnum) (sab :string) (tty :string) (supres :string))) + +(defclass udef (umlsclass) + ((def :type string :initarg :def :reader def) + (sab :type string :initarg :sab :reader sab)) + (:metaclass ml-class) + (:default-initargs :def nil :sab nil) + (:title "Definition") + (:ref-fields (sab find-bsab-sab)) + (:fields (sab :string) (def :cdata))) + +(defclass usat (umlsclass) + ((sab :type string :initarg :sab :reader sab) + (code :type string :initarg :code :reader code) + (atn :type string :initarg :atn :reader atn) + (atv :type string :initarg :atv :reader atv)) + (:metaclass ml-class) + (:default-initargs :sab nil :code nil :atn nil :atv nil) + (:title "Simple Attribute") + (:ref-fields (sab find-bsab-sab)) + (:fields (sab :string) (code :string) (atn :string) (atv :cdata))) + +(defclass uso (umlsclass) + ((sab :type string :initarg :sab :reader sab) + (code :type string :initarg :code :reader code) + (tty :type string :initarg :tty :reader tty) + (srl :type fixnum :initarg :srl :reader srl)) + (:metaclass ml-class) + (:default-initargs :sab nil :code nil :tty nil :srl nil) + (:title "Source") + (:ref-fields (sab find-bsab-sab) (tty find-btty-tty)) + (:fields (sab :string) (code :string) (tty :string) (srl :fixnum))) + +(defclass ucxt (umlsclass) + ((sab :type string :initarg :sab :reader sab) + (code :type string :initarg :code :reader code) + (rnk :type fixnum :initarg :rnk :reader rnk) + (cxn :type fixnum :initarg :cxn :reader cxn) + (cxl :type string :initarg :cxl :reader cxl) + (cxs :type string :initarg :cxs :reader cxs) + (cui2 :type fixnum :initarg :cui2 :reader cui2) + (hcd :type string :initarg :hcd :reader hcd) + (rela :type string :initarg :rela :reader rela) + (xc :type string :initarg :xc :reader xc)) + (:metaclass ml-class) + (:default-initargs :sab nil :code nil :rnk nil :cxn nil :cxl nil :cxs nil + :cui2 nil :hcd nil :rela nil :xc nil) + (:title "Context") + (:ref-fields (sab find-bsab-sab) (cui2 find-ucon-cui)) + (:fields + (sab :string) (code :string) (rnk :fixnum) (cxn :fixnum) (cxl :string) + (hcd :string) (rela :string) (xc :string) (cui2 :string fmt-cui) + (cxs :cdata))) + +(defclass ustr (umlsclass) + ((sui :type fixnum :initarg :sui :reader sui) + (cui :type fixnum :initarg :cui :reader cui) + (lui :type fixnum :initarg :lui :reader lui) + (cuisui :type integer :initarg :cuisui :reader cuisui ) + (str :type string :initarg :str :reader str) + (lrl :type fixnum :initarg :lrl :reader lrl) + (stt :type string :initarg :stt :reader stt) + (s#sat :reader s#sat) + (s#so :reader s#so) + (s#cxt :reader s#cxt)) + (:metaclass ml-class) + (:default-initargs + :sui nil :cui nil :lui nil :cuisui nil :str nil :lrl nil :stt nil) + (:title "String") + (:subobjects-lists (s#sat usat) (s#so uso) (s#cxt ucxt)) + (:fields (sui :string fmt-sui) (stt :string) (lrl :fixnum) (str :cdata)) + (:ref-fields (sui find-ustr-sui))) + +(defclass ulo (umlsclass) + ((isn :type string :initarg :isn :reader isn) + (fr :type fixnum :initarg :fr :reader fr) + (un :type string :initarg :un :reader un) + (sui :type fixnum :initarg :sui :reader sui) + (sna :type string :initarg :sna :reader sna) + (soui :type string :initarg :soui :reader soui)) + (:metaclass ml-class) + (:default-initargs :isn nil :fr nil :un nil :sui nil :sna nil :soui nil) + (:title "Locator") + (:fields (isn :string) (fr :fixnum) (un :string) (sna :string) + (soui :string) (sui :string fmt-sui) (suistr :string))) + +(defclass uterm (umlsclass) + ((lui :type fixnum :initarg :lui :reader lui) + (cui :type fixnum :initarg :cui :reader cui) + (lat :type string :initarg :lat :reader lat) + (ts :type string :initarg :ts :reader ts) + (lrl :type fixnum :initarg :lrl :reader lrl) + (s#str :reader s#str) + (s#sat :reader s#sat)) + (:metaclass ml-class) + (:default-initargs :lui nil :cui nil :lat nil :ts nil :lrl nil) + (:title "Term") + (:subobjects-lists (s#sat usat) (s#str ustr)) + (:fields (lui :string fmt-lui) (lat :string) (ts :string) (lrl :fixnum)) + (:ref-fields (lui find-uterm-lui))) + +(defclass usty (umlsclass) + ((tui :type fixnum :initarg :tui :reader tui) + (sty :type string :initarg :sty :reader sty)) + (:metaclass ml-class) + (:default-initargs :tui nil :sty nil) + (:title "Semantic Type") + (:ref-fields (tui find-ucon-tui (("subobjects" "no")))) + (:fields (tui :string fmt-tui) (sty :string))) + +(defclass urel (umlsclass) + ((rel :type string :initarg :rel :reader rel) + (cui1 :type fixnum :initarg :cui1 :reader cui1) + (cui2 :type fixnum :initarg :cui2 :reader cui2) + (pfstr2 :type string :initarg :pfstr2 :reader pfstr2) + (rela :type string :initarg :rela :reader rela) + (sab :type string :initarg :sab :reader sab) + (sl :type string :initarg :sl :reader sl) + (mg :type string :initarg :mg :reader mg)) + (:metaclass ml-class) + (:default-initargs + :rel nil :cui1 nil :cui2 nil :pfstr2 nil :rela nil :sab nil :sl nil :mg nil) + (:title "Relationship") + (:ref-fields (rel find-brel-rel) (sab find-bsab-sab) (cui2 find-ucon-cui)) + (:fields (rel :string) (rela :string) (sab :string) (sl :string) + (mg :string) (cui2 :string fmt-cui) (pfstr2 :cdata))) + +(defclass ucoc (umlsclass) + ((cui1 :type fixnum :initarg :cui1 :reader cui1) + (cui2 :type fixnum :initarg :cui2 :reader cui2) + (pfstr2 :type string :initarg :pfstr2 :reader pfstr2) + (soc :type string :initarg :soc :reader soc) + (cot :type string :initarg :cot :reader cot) + (cof :type fixnum :initarg :cof :reader cof) + (coa :type string :initarg :coa :reader coa)) + (:metaclass ml-class) + (:default-initargs + :cui1 nil :cui2 nil :pfstr2 nil :soc nil :cot nil :cof nil :coa nil) + (:title "Co-occuring Concept") + (:ref-fields (cui2 find-ucon-cui)) + (:fields (soc :string) (cot :string) (cof :fixnum) (coa :cdata) + (cui2 :string fmt-cui) (pfstr2 :cdata))) + + +(defclass uatx (umlsclass) + ((sab :type string :initarg :sab :reader sab) + (rel :type string :initarg :rel :reader rel) + (atx :type string :initarg :atx :reader atx)) + (:metaclass ml-class) + (:default-initargs :sab nil :rel nil :atx nil) + (:title "Associated Expression") + (:fields (sab :string) (rel :string) (atx :cdata))) + +(defclass ucon (umlsclass) + ((cui :type fixnum :initarg :cui :reader cui ) + (pfstr :initarg :pfstr :reader pfstr) + (lrl :initarg :lrl :reader lrl) + (s#term :reader s#term) + (s#def :reader s#def) + (s#lo :reader s#lo) + (s#rel :reader s#rel) + (s#coc :reader s#coc) + (s#sat :reader s#sat) + (s#atx :reader s#atx) + (s#sty :reader s#sty)) + (:metaclass ml-class) + (:default-initargs :cui nil :pfstr nil :lrl nil) + (:title "Concept") + (:subobjects-lists + (s#def udef) (s#sty usty) (s#lo ulo) (s#atx uatx) (s#sat usat) (s#rel urel) + (s#coc ucoc) (s#term uterm)) + (:fields (cui :string fmt-cui) (lrl :fixum) (pfstr :cdata)) + (:ref-fields (cui find-ucon-cui))) + +(defclass uxw (umlsclass) + ((wd :type string :initarg :wd :reader wd) + (cui :type fixnum :initform nil :initarg :cui :reader cui) + (lui :type fixnum :initform nil :initarg :lui :reader lui) + (sui :type fixnum :initform nil :initarg :sui :reader sui)) + (:metaclass ml-class) + (:default-initargs :wd nil :cui nil :lui nil :sui nil) + (:title "XW Index") + (:fields (wd :string) (cui :string fmt-cui) (lui :string fmt-lui) + (sui :string fmt-sui))) + +(defclass uxnw (umlsclass) + ((lat :type string :initarg :lat :reader lat) + (nwd :type string :initarg :nwd :reader nwd) + (cuilist :type list :initarg :cuilist :reader uxnw-cuilist)) + (:metaclass ml-class) + (:default-initargs :lat nil :nwd nil :cuilist nil) + (:title "XNW Index") + (:fields (lat :string) (nwd :string) (cuilist :string))) + +(defclass uxns (umlsclass) + ((lat :type string :initarg :lat :reader lat) + (nstr :type string :initarg :nstr :reader nstr) + (cuilist :type list :initarg :cuilist :reader cuilist)) + (:metaclass ml-class) + (:default-initargs :lat nil :nstr nil :cuilist nil) + (:title "XNS Index") + (:fields (lat :string) (nstr :string) (cuilist :string))) + + +;;; LEX objects + +(defclass lexterm (umlsclass) + ((eui :type fixnum :initarg :eui :reader eui) + (wrd :type string :initarg :wrd :reader wrd) + (s#abr :reader s#abr) + (s#agr :reader s#agr) + (s#cmp :reader s#cmp) + (s#mod :reader s#mod) + (s#nom :reader s#nom) + (s#prn :reader s#prn) + (s#prp :reader s#prp) + (s#spl :reader s#spl) + (s#trm :reader s#trm) + (s#typ :reader s#typ)) + (:metaclass ml-class) + (:default-initargs :eui nil :wrd nil) + (:title "Lexical Term") + (:subobjects-lists + (s#abr labr) (s#agr lagr) (s#cmp lcmp) (s#mod lmod) (s#nom unom) + (s#prn lprn) (s#prp lprp) (s#spl lspl) (s#trm ltrm) (s#typ ltyp)) + (:fields (eui :string fmt-eui) (wrd :string)) + (:ref-fields (eui find-lexterm-eui))) + + +(defclass labr (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (abr :type string :initarg :abr :reader abr) + (eui2 :type integer :initarg :eui2 :reader eui2) + (bas2 :type string :initarg :bas2 :reader bas2)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :abr nil :eui2 nil :bas2 nil) + (:title "Abbreviations and Acronyms") + (:fields (eui :string fmt-eui) (bas :string) (abr :string) + (eui2 :string fmt-eui) (bas2 :string ))) + +(defclass lagr (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (str :type string :initarg :str :reader str) + (sca :type string :initarg :sca :reader sca) + (agr :type string :initarg :agr :reader agr) + (cit :type string :initarg :cit :reader cit) + (bas :type string :initarg :bas :reader bas)) + (:metaclass ml-class) + (:default-initargs :eui nil :str nil :sca nil :agr nil :cit nil :bas nil) + (:title "Agreement and Inflection") + (:fields (eui :string fmt-eui) (str :string) (sca :string) (agr :string) + (cit :string) (bas :string))) + +(defclass lcmp (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (sca :type string :initarg :sca :reader sca) + (com :type string :initarg :com :reader com)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :sca nil :com nil) + (:title "Complementation") + (:fields (eui :string fmt-eui) (bas :string) (sca :string) (com :string))) + +(defclass lmod (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (sca :type string :initarg :sca :reader sca) + (psnmod :type string :initarg :psnmod :reader psnmod) + (fea :type string :initarg :fea :reader fea)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :sca nil :psnmod nil :fea nil) + (:title "Modifiers") + (:fields (eui :string fmt-eui) (bas :string) (sca :string) (psnmod :string) + (fea :string))) + +(defclass lnom (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (sca :type string :initarg :sca :reader sca) + (eui2 :type integer :initarg :eui2 :reader eui2) + (bas2 :type string :initarg :bas2 :reader bas2) + (sca2 :type string :initarg :sca2 :reader sca2)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :sca nil :eui2 nil :bas2 nil :sca2 nil) + (:title "Nominalizations") + (:fields (eui :string fmt-eui) (bas :string) (sca :string) + (eui2 :string fmt-eui) (bas2 :string) (sca2 :string))) + +(defclass lprn (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (num :type string :initarg :num :reader num) + (gnd :type string :initarg :gnd :reader gnd) + (cas :type string :initarg :cas :reader cas) + (pos :type string :initarg :pos :reader pos) + (qnt :type string :initarg :qnt :reader qnt) + (fea :type string :initarg :fea :reader fea)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :num nil :gnd nil :cas nil + :pos nil :qnt nil :fea nil) + (:title "Pronouns") + (:fields (eui :string fmt-eui) (bas :string) (num :string) (gnd :string) + (cas :string) (pos :string) (qnt :string) (fea :string))) + +(defclass lprp (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (str :type string :initarg :str :reader str) + (sca :type string :initarg :sca :reader sca) + (fea :type string :initarg :fea :reader fea)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :str nil :sca nil :fea nil) + (:title "Properties") + (:fields (eui :string fmt-eui) (bas :string) (str :string) (sca :string) + (fea :string))) + + +(defclass lspl (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (spv :type string :initarg :spv :reader spv) + (bas :type string :initarg :bas :reader bas)) + (:metaclass ml-class) + (:default-initargs :eui nil :spv nil :bas nil) + (:title "Spelling Variants") + (:fields (eui :string fmt-eui) (spv :string) (bas :string))) + + + +(defclass ltrm (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (gen :type string :initarg :gen :reader gen)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :gen nil) + (:title "Trade Marks") + (:fields (eui :string fmt-eui) (bas :string) (gen :string))) + +(defclass ltyp (umlsclass) + ((eui :type integer :initarg :eui :reader eui) + (bas :type string :initarg :bas :reader bas) + (sca :type string :initarg :sca :reader sca) + (typ :type string :initarg :typ :reader typ)) + (:metaclass ml-class) + (:default-initargs :eui nil :bas nil :sca nil :typ nil) + (:title "Inflection Type") + (:fields (eui :string fmt-eui) (bas :string) (sca :string) (typ :string))) + +(defclass lwd (umlsclass) + ((wrd :type string :initarg :wrd :reader wrd) + (euilist :type list :initarg :euilist :reader euilist)) + (:metaclass ml-class) + (:default-initargs :wrd nil :euilist nil) + (:title "Lexical Word Index") + (:fields (wrd :string) (euilist :string))) + +;;; Semantic NET objects + +(defclass sdef (umlsclass) + ((rt :type string :initarg :rt :reader rt) + (ui :type integer :initarg :ui :reader ui) + (styrl :type string :initarg :styrl :reader styrl) + (stnrtn :type string :initarg :stnrtn :reader stnrtn) + (def :type string :initarg :def :reader def) + (ex :type string :initarg :ex :reader ex) + (un :type string :initarg :un :reader un) + (rh :type string :initarg :rh :reader rh) + (abr :type string :initarg :abr :reader abr) + (rin :type string :initarg :rin :reader rin)) + (:metaclass ml-class) + (:default-initargs + :rt nil :ui nil :styrl nil :stnrtn nil :def nil :ex nil :un nil :rh nil + :abr nil :rin nil) + (:title "Basic information about Semantic Types and Relations") + (:fields + (rt :string) (ui :string fmt-tui) (styrl :string) (stnrtn :string-tui) + (def :string) (ex :string) (un :string) (rh :string) (abr :string) + (rin :string))) + +(defclass sstr (umlsclass) + ((styrl :type string :initarg :styrl :reader styrl) + (rl :type string :initarg :rl :reader rl) + (styrl2 :type string :initarg :styrl2 :reader styrl2) + (ls :type string :initarg :ls :reader ls)) + (:metaclass ml-class) + (:default-initargs :styrl nil :rl nil :styrl2 nil :ls nil) + (:title "Structure of the Network") + (:fields (styrl :string) (rl :string) (styrl2 :string) (ls :string))) + +(defclass sstre1 (umlsclass) + ((ui :type integer :initarg :ui :reader ui) + (ui2 :type integer :initarg :ui2 :reader ui2) + (ui3 :type integer :initarg :ui3 :reader ui3)) + (:metaclass ml-class) + (:default-initargs :ui nil :ui2 nil :ui3 nil) + (:title "Fully Inherited Set of Releatons (TUI's)") + (:fields (ui :string fmt-tui) (ui2 :string fmt-tui) (ui3 :string fmt-tui))) + +(defclass sstre2 (umlsclass) + ((sty :type string :initarg :ui :reader sty) + (rl :type string :initarg :ui2 :reader rl) + (sty2 :type string :initarg :ui3 :reader sty2)) + (:metaclass ml-class) + (:default-initargs :sty nil :rl nil :sty2 nil) + (:title "Fully Inherited Set of Releatons (strings)") + (:fields (sty :string) (rl :string) (sty2 :string))) + +;;; Formatting routines + +(defmethod fmt-cui ((c ucon)) + (format nil "C~7,'0d" (cui c))) + +(defmethod fmt-cui ((c fixnum)) + (format nil "C~7,'0d" c)) + +(defmethod fmt-cui ((c string)) + (if (eql (aref c 0) #\C) + c + (format nil "C~7,'0d" (parse-integer c)))) + +(defmethod fmt-cui ((c null)) + (format nil "nil")) + +(defmethod fmt-lui ((l uterm)) + (format nil "L~7,'0d" (lui l))) + +(defmethod fmt-lui ((l fixnum)) + (format nil "L~7,'0d" l)) + +(defmethod fmt-lui ((l string)) + (if (eql (aref l 0) #\L) + l + (format nil "L~7,'0d" (parse-integer l)))) + +(defmethod fmt-sui ((s ustr)) + (format nil "S~7,'0d" (sui s))) + +(defmethod fmt-sui ((s fixnum)) + (format nil "S~7,'0d" s)) + +(defmethod fmt-sui ((s string)) + (if (eql (aref s 0) #\S) + s + (format nil "S~7,'0d" (parse-integer s)))) + +(defmethod fmt-tui ((s fixnum)) + (format nil "T~3,'0d" s)) + +(defmethod fmt-tui ((s string)) + (if (eql (aref s 0) #\T) + s + (format nil "T~3,'0d" (parse-integer s)))) + +(defmethod fmt-eui ((e fixnum)) + (format nil "E~7,'0d" e)) + +(defmethod fmt-eui ((e string)) + (if (eql (aref e 0) #\E) + e + (format nil "E~7,'0d" (parse-integer e)))) + +(defmethod fmt-eui ((e null)) + (format nil "nil")) + +;;; Generic display functions + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun english-term-p (obj) + (and (eq (class-name (class-of obj)) 'uterm) + (string-equal (lat obj) "ENG")))) + +(defun display-umls-obj + (obj &key (os *standard-output*) (format :text) (label nil) + (file-wrapper t) (english-only nil) (subobjects nil) + (refvars nil)) + (display-ml-class + obj :os os :format format :label label :subobjects subobjects + :file-wrapper file-wrapper + :english-only-function (if english-only #'english-term-p nil) + :refvars refvars)) + +(defmacro defludisp-ml-class (newfuncname lookup-func) + "Defines functions for looking up and displaying objects" + `(defun ,newfuncname + (keyval &key (os *standard-output*) (format :text) (label nil) + (file-wrapper t) (english-only nil) (subobjects nil)) + (let ((obj (funcall ,lookup-func keyval))) + (display-umls-obj obj :os os :format format :label label + :file-wrapper file-wrapper :english-only english-only + :subobjects subobjects)))) + +(defludisp-ml-class disp-con #'find-ucon-cui) +(defludisp-ml-class disp-term #'find-uterm-lui) +(defludisp-ml-class disp-str #'find-ustr-sui) + diff --git a/composite.lisp b/composite.lisp new file mode 100644 index 0000000..d31c513 --- /dev/null +++ b/composite.lisp @@ -0,0 +1,177 @@ +;;;; $Id: composite.lisp,v 1.1 2002/10/08 22:08:56 kevin Exp $ + +(in-package :umlisp) + + +;;; Semantic type constants + +(defun find-tui-word (words) + (gu:aif (car (find-usty-word words)) + (tui gu::it) + nil)) +(gu:memoize 'find-tui-word) + +(defun tui-disease-or-syndrome () + (find-tui-word "disease or syndrome")) +(defun tui-sign-or-symptom () + (find-tui-word "sign or symptom")) +(defun tui-finding () + (find-tui-word "finding")) + + +;;;; Related concepts with specific tui lookup functions + +(defun ucon-is-tui? (ucon tui) + "Returns t if ucon has a semantic type of tui" + (find tui (s#sty ucon) :key #'tui)) + +(defun find-ucon2-tui (ucon tui cui2-func related-con-func) + "Returns a list of related ucons that have specific tui" + (remove-duplicates + (filter + #'(lambda (c) + (gu:aif (funcall cui2-func c) + (let ((ucon2 (find-ucon-cui gu::it))) + (when (ucon-is-tui? ucon2 tui) + ucon2)) + nil)) + (funcall related-con-func ucon)) + :key #'cui)) + +(defun find-ucon2-coc-tui (ucon tui) + "Return list of ucon's that have co-occuring concepts of semantic type tui" + (find-ucon2-tui ucon tui #'cui2 #'s#coc)) + +(defun find-ucon2-rel-tui (ucon tui) + "Return list of ucon's that have related concepts to ucon and semantic type tui" + (find-ucon2-tui ucon tui #'cui2 #'s#rel)) + +;;; Composite Objects + +(defclass ucon_freq (umlsclass) + ((ucon :type ucon :initarg :ucon :reader ucon) + (freq :type fixnum :initarg :freq :accessor freq)) + (:metaclass ml-class) + (:default-initargs :cui nil :pfstr nil :freq nil) + (:title "Concept and Count") + (:fields (cui :string fmt-cui) (freq :fixnum) (pfstr :cdata)) + (:ref-fields (cui find-ucon-cui)) + (:documentation "Composite object of ucon/freq")) + +(defun ucon_freq-cui (c) + (cui (ucon c))) + +(defun ucon_freq-pfstr (c) + (pfstr (ucon c))) + +(defclass ustr_freq (umlsclass) + ((ustr :type ustr :initarg :ustr :reader ustr) + (freq :type fixnum :initarg :freq :accessor freq)) + (:metaclass ml-class) + (:default-initargs :cui nil :pfstr nil :freq nil) + (:title "String and Count") + (:fields (sui :string fmt-sui) (freq :fixnum) (stt :string) (lrl :fixnum) (str :cdata)) + (:ref-fields (sui find-ustr-sui)) + (:documentation "Composite object of ustr/freq")) + +(defun ustr_freq-sui (s) + (sui (ustr s))) + +(defun ustr_freq-str (s) + (str (ustr s))) + +(defun ustr_freq-lrl (s) + (lrl (ustr s))) + +(defun ustr_freq-stt (s) + (stt (ustr s))) + +(defclass usty_freq (umlsclass) + ((usty :type usty :initarg :usty :reader usty) + (freq :type fixnum :initarg :freq :accessor freq)) + (:metaclass ml-class) + (:default-initargs :usty nil :freq nil) + (:title "Semantic Type and Count") + (:ref-fields (tui find-ucon-tui "subobjects=no")) + (:fields (tui :string fmt-tui) (freq :fixnum) (sty :string)) + (:documentation "Composite object of usty/freq")) + +(defun usty_freq-tui (s) + (tui (usty s))) + +(defun usty_freq-sty (s) + (sty (usty s))) + +(defclass usrl_freq (umlsclass) + ((usrl :type usrl :initarg :usrl :reader usrl) + (freq :type fixnum :initarg :freq :accessor freq)) + (:metaclass ml-class) + (:default-initargs :usrl nil :freq nil) + (:title "Source and Count") + (:ref-fields (sab find-ustr-sab)) + (:fields (sab :string) (freq :commainteger) (srl :fixnum)) + (:documentation "Composite object of usrl/freq")) + +(defun usrl_freq-sab (s) + (sab (usrl s))) + +(defun usrl_freq-srl (s) + (srl (usrl s))) + + +;; Frequency finding functions +(defun find-ucon2_freq-coc-tui (ucon tui) +"Return sorted list of tuples with ucon and freq that have co-occuring concepts of semantic type tui" + (let ((ucon_freqs '())) + (dolist (ucoc (s#coc ucon)) + (gu:aif (cui2 ucoc) + (let ((ucon2 (find-ucon-cui gu::it))) + (when (ucon-is-tui? ucon2 tui) + (push (make-instance 'ucon_freq :ucon ucon2 :freq (cof ucoc)) + ucon_freqs))))) + (setq ucon_freqs (delete-duplicates ucon_freqs :key #'cui)) + (sort ucon_freqs #'> :key #'freq))) + +(defun find-ucon2-str&sty (str sty lookup-func) + "Call lookup-func for ucon and usty for given str and sty" + (let ((ucon (car (find-ucon-str str))) + (usty (car (find-usty-word sty)))) + (if (and ucon usty) + (funcall lookup-func ucon (tui usty)) + nil))) + +(defun find-ucon2-coc-str&sty (str sty) + "Find all ucons that are a co-occuring concept for concept named str + and that have semantic type of sty" + (find-ucon2-str&sty str sty #'find-ucon2-coc-tui)) + +(defun find-ucon2-rel-str&sty (str sty) + "Find all ucons that are a relationship to concept named str + and that have semantic type of sty" + (find-ucon2-str&sty str sty #'find-ucon2-rel-tui)) + +;;; Most common relationships, co-occurances + +(defun find-ucon2_freq-tui-all (tui ucon2-tui-func) + "Return sorted list of all ucon2 that have a semantic type tui with ucon that is also has sty of tui" + (let ((ucon_freqs (make-array (1+ (find-cui-max)) :initial-element nil))) + (dolist (ucon (find-ucon-tui tui)) ;; for all disease-or-syn + (dolist (ucon2 (funcall ucon2-tui-func ucon tui)) ;; for each related disease + (gu:aif (aref ucon_freqs (cui ucon2)) + (setf (freq gu::it) (1+ (freq gu::it))) + (setf (aref ucon_freqs (cui ucon2)) + (make-instance 'ucon_freq :ucon ucon2 :freq 1))))) + (let ((ucon_freq-list '())) + (dotimes (i (find-cui-max)) + (declare (fixnum i)) + (gu:awhen (aref ucon_freqs i) + (push gu::it ucon_freq-list))) + (sort ucon_freq-list #'> :key #'freq)))) + +(defun find-ucon2_freq-rel-tui-all (tui) + "Sorted list of ucon_freq with semantic type tui that are rel's of ucons with semantic type tui" + (find-ucon2_freq-tui-all tui #'find-ucon2-rel-tui)) + +(defun find-ucon2_freq-coc-tui-all (tui) + (find-ucon2_freq-tui-all tui #'find-ucon2-coc-tui)) + diff --git a/debian/docs b/debian/docs new file mode 100644 index 0000000..e845566 --- /dev/null +++ b/debian/docs @@ -0,0 +1 @@ +README diff --git a/obj-composite.lisp b/obj-composite.lisp deleted file mode 100644 index 61f62d5..0000000 --- a/obj-composite.lisp +++ /dev/null @@ -1,177 +0,0 @@ -;;;; $Id: obj-composite.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $ - -(in-package :umlisp) - - -;;; Semantic type constants - -(defun find-tui-word (words) - (gu:aif (car (find-usty-word words)) - (tui gu::it) - nil)) -(gu:memoize 'find-tui-word) - -(defun tui-disease-or-syndrome () - (find-tui-word "disease or syndrome")) -(defun tui-sign-or-symptom () - (find-tui-word "sign or symptom")) -(defun tui-finding () - (find-tui-word "finding")) - - -;;;; Related concepts with specific tui lookup functions - -(defun ucon-is-tui? (ucon tui) - "Returns t if ucon has a semantic type of tui" - (find tui (s#sty ucon) :key #'tui)) - -(defun find-ucon2-tui (ucon tui cui2-func related-con-func) - "Returns a list of related ucons that have specific tui" - (remove-duplicates - (filter - #'(lambda (c) - (gu:aif (funcall cui2-func c) - (let ((ucon2 (find-ucon-cui gu::it))) - (when (ucon-is-tui? ucon2 tui) - ucon2)) - nil)) - (funcall related-con-func ucon)) - :key #'cui)) - -(defun find-ucon2-coc-tui (ucon tui) - "Return list of ucon's that have co-occuring concepts of semantic type tui" - (find-ucon2-tui ucon tui #'cui2 #'s#coc)) - -(defun find-ucon2-rel-tui (ucon tui) - "Return list of ucon's that have related concepts to ucon and semantic type tui" - (find-ucon2-tui ucon tui #'cui2 #'s#rel)) - -;;; Composite Objects - -(defclass ucon_freq (umlsclass) - ((ucon :type ucon :initarg :ucon :reader ucon) - (freq :type fixnum :initarg :freq :accessor freq)) - (:metaclass ml-class) - (:default-initargs :cui nil :pfstr nil :freq nil) - (:title "Concept and Count") - (:fields (cui :string fmt-cui) (freq :fixnum) (pfstr :cdata)) - (:ref-fields (cui find-ucon-cui)) - (:documentation "Composite object of ucon/freq")) - -(defun ucon_freq-cui (c) - (cui (ucon c))) - -(defun ucon_freq-pfstr (c) - (pfstr (ucon c))) - -(defclass ustr_freq (umlsclass) - ((ustr :type ustr :initarg :ustr :reader ustr) - (freq :type fixnum :initarg :freq :accessor freq)) - (:metaclass ml-class) - (:default-initargs :cui nil :pfstr nil :freq nil) - (:title "String and Count") - (:fields (sui :string fmt-sui) (freq :fixnum) (stt :string) (lrl :fixnum) (str :cdata)) - (:ref-fields (sui find-ustr-sui)) - (:documentation "Composite object of ustr/freq")) - -(defun ustr_freq-sui (s) - (sui (ustr s))) - -(defun ustr_freq-str (s) - (str (ustr s))) - -(defun ustr_freq-lrl (s) - (lrl (ustr s))) - -(defun ustr_freq-stt (s) - (stt (ustr s))) - -(defclass usty_freq (umlsclass) - ((usty :type usty :initarg :usty :reader usty) - (freq :type fixnum :initarg :freq :accessor freq)) - (:metaclass ml-class) - (:default-initargs :usty nil :freq nil) - (:title "Semantic Type and Count") - (:ref-fields (tui find-ucon-tui "subobjects=no")) - (:fields (tui :string fmt-tui) (freq :fixnum) (sty :string)) - (:documentation "Composite object of usty/freq")) - -(defun usty_freq-tui (s) - (tui (usty s))) - -(defun usty_freq-sty (s) - (sty (usty s))) - -(defclass usrl_freq (umlsclass) - ((usrl :type usrl :initarg :usrl :reader usrl) - (freq :type fixnum :initarg :freq :accessor freq)) - (:metaclass ml-class) - (:default-initargs :usrl nil :freq nil) - (:title "Source and Count") - (:ref-fields (sab find-ustr-sab)) - (:fields (sab :string) (freq :commainteger) (srl :fixnum)) - (:documentation "Composite object of usrl/freq")) - -(defun usrl_freq-sab (s) - (sab (usrl s))) - -(defun usrl_freq-srl (s) - (srl (usrl s))) - - -;; Frequency finding functions -(defun find-ucon2_freq-coc-tui (ucon tui) -"Return sorted list of tuples with ucon and freq that have co-occuring concepts of semantic type tui" - (let ((ucon_freqs '())) - (dolist (ucoc (s#coc ucon)) - (gu:aif (cui2 ucoc) - (let ((ucon2 (find-ucon-cui gu::it))) - (when (ucon-is-tui? ucon2 tui) - (push (make-instance 'ucon_freq :ucon ucon2 :freq (cof ucoc)) - ucon_freqs))))) - (setq ucon_freqs (delete-duplicates ucon_freqs :key #'cui)) - (sort ucon_freqs #'> :key #'freq))) - -(defun find-ucon2-str&sty (str sty lookup-func) - "Call lookup-func for ucon and usty for given str and sty" - (let ((ucon (car (find-ucon-str str))) - (usty (car (find-usty-word sty)))) - (if (and ucon usty) - (funcall lookup-func ucon (tui usty)) - nil))) - -(defun find-ucon2-coc-str&sty (str sty) - "Find all ucons that are a co-occuring concept for concept named str - and that have semantic type of sty" - (find-ucon2-str&sty str sty #'find-ucon2-coc-tui)) - -(defun find-ucon2-rel-str&sty (str sty) - "Find all ucons that are a relationship to concept named str - and that have semantic type of sty" - (find-ucon2-str&sty str sty #'find-ucon2-rel-tui)) - -;;; Most common relationships, co-occurances - -(defun find-ucon2_freq-tui-all (tui ucon2-tui-func) - "Return sorted list of all ucon2 that have a semantic type tui with ucon that is also has sty of tui" - (let ((ucon_freqs (make-array (1+ (find-cui-max)) :initial-element nil))) - (dolist (ucon (find-ucon-tui tui)) ;; for all disease-or-syn - (dolist (ucon2 (funcall ucon2-tui-func ucon tui)) ;; for each related disease - (gu:aif (aref ucon_freqs (cui ucon2)) - (setf (freq gu::it) (1+ (freq gu::it))) - (setf (aref ucon_freqs (cui ucon2)) - (make-instance 'ucon_freq :ucon ucon2 :freq 1))))) - (let ((ucon_freq-list '())) - (dotimes (i (find-cui-max)) - (declare (fixnum i)) - (gu:awhen (aref ucon_freqs i) - (push gu::it ucon_freq-list))) - (sort ucon_freq-list #'> :key #'freq)))) - -(defun find-ucon2_freq-rel-tui-all (tui) - "Sorted list of ucon_freq with semantic type tui that are rel's of ucons with semantic type tui" - (find-ucon2_freq-tui-all tui #'find-ucon2-rel-tui)) - -(defun find-ucon2_freq-coc-tui-all (tui) - (find-ucon2_freq-tui-all tui #'find-ucon2-coc-tui)) - diff --git a/obj-sql.lisp b/obj-sql.lisp deleted file mode 100644 index e05e096..0000000 --- a/obj-sql.lisp +++ /dev/null @@ -1,1257 +0,0 @@ -;;; $Id: obj-sql.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $ - -(in-package :umlisp) - -(declaim (optimize (speed 3) (safety 1))) - -(defvar *current-srl* nil) -(defun current-srl () - *current-srl*) -(defun current-srl! (srl) - (setq *current-srl* srl)) - -;;; Initializers - -(defun post-import-sql () - (make-ustats) - (make-usrl) - (make-user-table) - #+pubmed (create-pmsearch-table)) - -;;; Accessors (read on demand) - -;; defines a slot-unbound method for class and slot-name, fills -;; the slot by calling reader function with the slot values of -;; the instance's reader-keys -(defmacro def-lazy-reader (class slot-name reader &rest reader-keys) - (let* ((the-slot-name (gensym)) - (the-class (gensym)) - (the-instance (gensym)) - (keys '())) - (dolist (key reader-keys) - (push (list 'slot-value the-instance (list 'quote key)) keys)) - (setq keys (nreverse keys)) - `(defmethod slot-unbound (,the-class (,the-instance ,class) - (,the-slot-name (eql ',slot-name))) - (declare (ignore ,the-class)) - (setf (slot-value ,the-instance ,the-slot-name) - (,reader ,@keys))))) - -(def-lazy-reader ucon s#term find-uterm-cui cui) -(def-lazy-reader ucon s#def find-udef-cui cui) -(def-lazy-reader ucon s#sty find-usty-cui cui) -(def-lazy-reader ucon s#rel find-urel-cui cui) -(def-lazy-reader ucon s#coc find-ucoc-cui cui) -(def-lazy-reader ucon s#lo find-ulo-cui cui) -(def-lazy-reader ucon s#atx find-uatx-cui cui) -(def-lazy-reader ucon s#sat find-usat-ui cui) - -;; For uterms -(def-lazy-reader uterm s#str find-ustr-cuilui cui lui) -(def-lazy-reader uterm s#sat find-usat-ui cui lui) - -;; For ustrs -(def-lazy-reader ustr s#sat find-usat-ui cui lui sui) -(def-lazy-reader ustr s#cxt find-ucxt-cuisui cui sui) -(def-lazy-reader ustr s#so find-uso-cuisui cui sui) - -;;; Object lookups - -;;; Lookup functions for uterms,ustr in ucons - -(defun find-uterm-in-ucon (ucon lui) - (find lui (s#term ucon) :key #'uterm-lui :test 'equal)) - -(defun find-ustr-in-uterm (uterm sui) - (find sui (s#str uterm) :key #'ustr-sui :test 'equal)) - -(defun find-ustr-in-ucon (ucon sui) - (let ((found-ustr nil)) - (dolist (uterm (s#term ucon)) - (unless found-ustr - (dolist (ustr (s#str uterm)) - (unless found-ustr - (when (string-equal sui (sui ustr)) - (setq found-ustr ustr)))))) - found-ustr)) - - -(defun find-ucon-cui (cui &key (srl *current-srl*)) - "Find ucon for a cui" - (if (stringp cui) - (setq cui (parse-cui cui))) - (if cui - (let ((ls (format nil "select KPFSTR,KCUILRL from MRCON where CUI=~d" - cui))) - (if srl - (string-append ls (format nil " and KCUILRL <= ~d limit 1" srl)) - (string-append ls " limit 1")) - (gu:awhen (car (mutex-sql-query ls)) - (make-instance 'ucon :cui cui :pfstr (car gu::it) - :lrl (ensure-integer (cadr gu::it))))) - nil)) - -(defun find-ucon-lui (lui &key (srl *current-srl*)) - "Find list of ucon for lui" - (if (stringp lui) - (setq lui (parse-lui lui))) - (if lui - (let ((ucons '()) - (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where LUI=~d" lui))) - (if srl - (string-append ls (format nil " and KCUILRL <= ~d" srl))) - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple)) - :pfstr (nth 1 tuple) - :lrl (ensure-integer (nth 2 tuple))) - ucons)) - (nreverse ucons)) - nil)) - -(defun find-ucon-sui (sui &key (srl *current-srl*)) - "Find list of ucon for sui" - (if (stringp sui) - (setq sui (parse-sui sui))) - (if sui - (let ((ucons '()) - (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where SUI=~d" sui))) - (when srl - (string-append ls (format nil " and KCUILRL <= ~d" srl))) - (let ((tuples (mutex-sql-query ls))) - (dolist (tuple tuples) - (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple)) - :pfstr (nth 1 tuple) - :lrl (ensure-integer (nth 2 tuple))) - ucons))) - (nreverse ucons)) - nil)) - -(defun find-ucon-cuisui (cui sui &key (srl *current-srl*)) - "Find ucon for cui/sui" - (if (stringp cui) - (setq cui (parse-cui cui))) - (if (stringp sui) - (setq sui (parse-sui sui))) - (if (and cui sui) - (let ((ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where KCUISUI=~d" - (make-cuisui cui sui)))) - (when srl - (string-append ls (format nil " and KCUILRL <= ~d" srl))) - (gu:aif (car (mutex-sql-query ls)) - (make-instance 'ucon :cui (ensure-integer (nth 0 gu::it)) - :pfstr (nth 1 gu::it) - :lrl (ensure-integer (nth 2 gu::it))) - nil)) - nil)) - -(defun find-ucon-str (str &key (srl *current-srl*)) - "Find ucon that are exact match for str" - (if str - (let ((ucons '()) - (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where STR='~a'" str))) - (when srl - (string-append ls " and KCUILRL <= ~d" srl)) - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple)) - :pfstr (nth 1 tuple) - :lrl (ensure-integer (nth 2 tuple))) ucons)) - (nreverse ucons)) - nil)) - -(defun find-ucon-all (&key (srl *current-srl*)) - "Return list of all ucon's" - (let ((ls "select distinct CUI,KPFSTR,KCUILRL from MRCON")) - (when srl - (string-append ls (format nil " where KCUILRL <= ~d" srl))) - (string-append ls " order by CUI asc") - (with-sql-connection (db) - (clsql:map-query - 'list - #'(lambda (cui pfstr cuilrl) - (make-instance 'ucon :cui (ensure-integer cui) - :pfstr pfstr - :lrl (ensure-integer cuilrl))) - ls - :database db)))) - - - -(defun find-udef-cui (cui &key (srl *current-srl*)) - "Return a list of udefs for cui" - (let ((udefs '()) - (ls (format nil "select SAB,DEF from MRDEF where CUI=~d" cui))) - (when srl - (string-append ls (format nil " and KSRL <= ~d" srl))) - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'udef :sab (car tuple) :def (cadr tuple)) udefs)) - (nreverse udefs))) - -(defun find-usty-cui (cui &key (srl *current-srl*)) - "Return a list of usty for cui" - (let ((ustys '()) - (ls (format nil "select TUI,STY from MRSTY where CUI=~d" cui))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'usty :tui (ensure-integer (car tuple)) :sty (cadr tuple)) ustys)) - ustys)) - -(defun find-usty-word (word &key (srl *current-srl*)) - "Return a list of usty that match word" - (let ((ustys '()) - (ls (format nil "select distinct TUI,STY from MRSTY where STY like '%~a%'" word))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'usty :tui (ensure-integer (car tuple)) :sty (cadr tuple)) ustys)) - ustys)) - -(defun find-urel-cui (cui &key (srl *current-srl*)) - "Return a list of urel for cui" - (let ((urels '()) - (ls (format nil "select REL,CUI2,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI1=~d" cui))) - (when srl - (string-append ls (format nil " and KSRL <= ~d" srl))) - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'urel - :cui1 cui - :rel (nth 0 tuple) - :cui2 (ensure-integer (nth 1 tuple)) - :rela (nth 2 tuple) - :sab (nth 3 tuple) - :sl (nth 4 tuple) - :mg (nth 5 tuple) - :pfstr2 (nth 6 tuple)) - urels)) - (nreverse urels))) - -(defun find-urel-cui2 (cui2 &key (srl *current-srl*)) - "Return a list of urel for cui2" - (let ((urels '()) - (ls (format nil "select REL,CUI1,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI2=~d" cui2))) - (when srl - (string-append ls (format nil " and SRL <= ~d" srl))) - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'urel - :cui2 cui2 - :rel (nth 0 tuple) - :cui1 (ensure-integer (nth 1 tuple)) - :rela (nth 2 tuple) - :sab (nth 3 tuple) - :sl (nth 4 tuple) - :mg (nth 5 tuple) - :pfstr2 (nth 6 tuple)) - urels)) - (nreverse urels))) - -(defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*)) - (mapcar - #'(lambda (cui) (find-ucon-cui cui :key srl)) - (remove-duplicates (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl))))) - -(defun find-ucoc-cui (cui &key (srl *current-srl*)) - "Return a list of ucoc for cui" - (let ((ucocs '()) - (ls (format nil "select CUI2,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI1=~d" cui))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) - (string-append ls " order by COF asc") - (dolist (tuple (mutex-sql-query ls)) - (let ((cui2 (ensure-integer (nth 0 tuple)))) - (when (zerop cui2) - (setq cui2 nil)) - (push (make-instance 'ucoc :cui1 cui - :cui2 cui2 - :soc (nth 1 tuple) - :cot (nth 2 tuple) - :cof (ensure-integer (nth 3 tuple)) - :coa (nth 4 tuple) - :pfstr2 (nth 5 tuple)) - ucocs))) - ucocs)) ;; akready ordered by SQL select - -(defun find-ucoc-cui2 (cui2 &key (srl *current-srl*)) - "Return a list of ucoc for cui2" - (let ((ucocs '()) - (ls (format nil "select CUI1,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI2=~d" cui2))) - (when srl - (string-append ls (format nil " and KSRL <= ~d" srl))) - (string-append ls " order by COF asc") - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'ucoc :cui1 (ensure-integer (nth 0 tuple)) - :cui2 cui2 - :soc (nth 1 tuple) - :cot (nth 2 tuple) - :cof (ensure-integer (nth 3 tuple)) - :coa (nth 4 tuple) - :pfstr2 (nth 5 tuple)) - ucocs)) - ucocs)) ;; already ordered by SQL select - -(defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*)) - "List of ucon with co-occurance cui2" - (mapcar - #'(lambda (cui) (find-ucon-cui cui :key srl)) - (remove-duplicates (mapcar #'cui1 (find-ucoc-cui2 cui2 :srl srl))))) - -(defun find-ulo-cui (cui &key (srl *current-srl*)) - "Return a list of ulo for cui" - (let ((ulos '()) - (ls (format nil "select ISN,FR,UN,SUI,SNA,SOUI from MRLO where CUI=~d" cui))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'ulo :isn (nth 0 tuple) - :fr (ensure-integer (nth 1 tuple)) - :un (nth 2 tuple) - :sui (ensure-integer (nth 3 tuple)) - :sna (nth 4 tuple) - :soui (nth 5 tuple)) - ulos)) - (nreverse ulos))) - -(defmethod suistr ((lo ulo)) - "Return the string for a ulo object" - (find-string-sui (sui lo))) - -(defun find-uatx-cui (cui &key (srl *current-srl*)) - "Return a list of uatx for cui" - (let ((uatxs '()) - (ls (format nil "select SAB,REL,ATX from MRATX where CUI=~d" cui))) - (when srl - (string-append ls (format nil " and KSRL <= ~d" srl))) - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'uatx :sab (nth 0 tuple) - :rel (nth 1 tuple) - :atx (nth 2 tuple)) - uatxs)) - (nreverse uatxs))) - - -(defun find-uterm-cui (cui &key (srl *current-srl*)) - "Return a list of uterm for cui" - (let ((uterms '()) - (ls (format nil "select distinct LUI,LAT,TS,KLUILRL from MRCON where CUI=~d" cui))) - (when srl - (string-append ls (format nil " and KLUILRL <= ~d" srl))) - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'uterm :lui (ensure-integer (nth 0 tuple)) - :cui cui - :lat (nth 1 tuple) - :ts (nth 2 tuple) - :lrl (ensure-integer (nth 3 tuple))) - uterms)) - (nreverse uterms))) - -(defun find-uterm-lui (lui &key (srl *current-srl*)) - "Return a list of uterm for lui" - (if (stringp lui) - (setq lui (parse-lui lui))) - (let ((uterms '()) - (ls (format nil "select distinct CUI,LAT,TS,KLUILRL from MRCON where LUI=~d" lui))) - (when srl - (string-append ls (format nil " and KLUILRL <= ~d" srl))) - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'uterm :cui (ensure-integer (nth 0 tuple)) - :lui lui - :lat (nth 1 tuple) - :ts (nth 2 tuple) - :lrl (ensure-integer (nth 3 tuple))) - uterms)) - (nreverse uterms))) - -(defun find-uterm-cuilui (cui lui &key (srl *current-srl*)) - "Return single uterm for cui/lui" - (let ((ls (format nil "select LAT,TS,KLUILRL from MRCON where KCUILUI=~d limit 1" (make-cuilui cui lui)))) - (when srl - (string-append ls (format nil " and KLUILRL <= ~d" srl))) - (gu:aif (car (mutex-sql-query ls)) - (make-instance 'uterm :cui cui - :lui lui - :lat (nth 0 gu::it) - :ts (nth 1 gu::it) - :lrl (ensure-integer (nth 2 gu::it))) - nil))) - -(defun find-ustr-cuilui (cui lui &key (srl *current-srl*)) - "Return a list of ustr for cui/lui" - (declare (fixnum cui lui)) - (let ((ustrs '()) - (ls (format nil "select SUI,STT,STR,LRL from MRCON where KCUILUI=~d" (make-cuilui cui lui)))) - (when srl - (string-append ls (format nil " and LRL <= ~d" srl))) - (dolist (tuple (mutex-sql-query ls)) - (let* ((sui (ensure-integer (car tuple))) - (ustr (make-instance 'ustr :sui sui - :cui cui - :cuisui (make-cuisui cui sui) - :lui lui - :stt (nth 1 tuple) - :str (nth 2 tuple) - :lrl (ensure-integer (nth 3 tuple))))) - (push ustr ustrs))) - (nreverse ustrs))) - -(defun find-ustr-cuisui (cui sui &key (srl *current-srl*)) - "Return the single ustr for cuisui" - (let ((ls (format nil "select LUI,STT,STR,LRL from MRCON where KCUISUI=~d" - (make-cuisui cui sui)))) - (when srl - (string-append ls (format nil " and LRL <= ~d" srl))) - (gu:aif (car (mutex-sql-query ls)) - (make-instance 'ustr :sui sui - :cui cui - :cuisui (make-cuisui cui sui) - :lui (ensure-integer (nth 0 gu::it)) - :stt (nth 1 gu::it) - :str (nth 2 gu::it) - :lrl (ensure-integer (nth 3 gu::it))) - nil))) - -(defun find-ustr-sui (sui &key (srl *current-srl*)) - "Return the list of ustr for sui" - (if (stringp sui) - (setq sui (parse-sui sui))) - (let ((ustrs '()) - (ls (format nil "select CUI,LUI,STT,STR,LRL from MRCON where SUI=~d" sui))) - (when srl - (string-append ls (format nil " and LRL <= ~d" srl))) - (dolist (tuple (mutex-sql-query ls)) - (let ((cui (ensure-integer (car tuple)))) - (push (make-instance 'ustr :sui sui - :cui cui - :cuisui (make-cuisui cui sui) - :lui (ensure-integer (nth 1 tuple)) - :stt (nth 2 tuple) - :str (nth 3 tuple) - :lrl (ensure-integer (nth 4 tuple))) - ustrs))) - (nreverse ustrs))) - -(defun find-ustr-sab (sab &key (srl *current-srl*)) - "Return the list of ustr for sab" - (let ((ustrs '()) - (ls (format nil "select KCUISUI from MRSO where SAB='~a'" sab))) - (when srl - (string-append ls (format nil " and SRL <= ~d" srl))) - (dolist (tuple (mutex-sql-query ls)) - (let ((cuisui (ensure-integer (car tuple)))) - (push (apply #'find-ustr-cuisui - (append - (multiple-value-list (decompose-cuisui cuisui)) - (list :srl srl))) - ustrs))) - (nreverse ustrs))) - -(defun find-ustr-all (&key (srl *current-srl*)) - "Return list of all ustr's" - (let ((ls "select distinct CUI,LUI,SUI,STT,LRL,KPFSTR from MRCON")) - (when srl - (string-append ls (format nil " where LRL <= ~d" srl))) - (string-append ls " order by SUI asc") - (with-sql-connection (db) - (clsql:map-query - 'list - #'(lambda (cui lui sui stt lrl pfstr) - (setq cui (ensure-integer cui)) - (setq lui (ensure-integer lui)) - (setq sui (ensure-integer sui)) - (setq lrl (ensure-integer lrl)) - (make-instance 'ustr :cui cui - :lui lui - :sui sui - :cuisui (make-cuisui cui sui) - :stt stt - :lrl lrl - :str pfstr)) - ls - :database db)))) - -(defun find-string-sui (sui &key (srl *current-srl*)) - "Return the string associated with sui" - (let ((ls (format nil "select STR from MRCON where SUI=~d" sui))) - (when srl - (string-append ls (format nil " and LRL <= ~d" srl))) - (string-append ls " limit 1") - (caar (mutex-sql-query ls)))) - -(defun find-uso-cuisui (cui sui &key (srl *current-srl*)) - (declare (fixnum cui sui)) - (let ((usos '()) - (ls (format nil "select SAB,CODE,SRL,TTY from MRSO where KCUISUI=~d" - (make-cuisui cui sui)))) - (when srl - (string-append ls (format nil " and SRL <= ~d" srl))) - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'uso :sab (nth 0 tuple) :code (nth 1 tuple) - :srl (nth 2 tuple) :tty (nth 3 tuple)) - usos)) - (nreverse usos))) - -(defun find-ucxt-cuisui (cui sui &key (srl *current-srl*)) - (declare (fixnum cui sui)) - (let ((ucxts '()) - (ls (format nil "select SAB,CODE,CXN,CXL,RNK,CXS,CUI2,HCD,RELA,XC from MRCXT where KCUISUI=~d" - (make-cuisui cui sui)))) - (when srl - (string-append ls (format nil " and KSRL <= ~d" srl))) - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'ucxt :sab (nth 0 tuple) - :code (nth 1 tuple) - :cxn (ensure-integer (nth 2 tuple)) - :cxl (nth 3 tuple) - :rnk (ensure-integer (nth 4 tuple)) - :cxs (nth 5 tuple) - :cui2 (ensure-integer (nth 6 tuple)) - :hcd (nth 7 tuple) - :rela (nth 8 tuple) - :xc (nth 9 tuple)) - ucxts)) - (nreverse ucxts))) - -(defun find-usat-ui (cui &optional (lui nil) (sui nil) &key (srl *current-srl*)) - (let ((ls (format nil "select CODE,ATN,SAB,ATV from MRSAT where "))) - (cond - (sui (string-append ls (format nil "KCUISUI=~d" (make-cuisui cui sui)))) - (lui (string-append ls (format nil "KCUILUI=~d and sui=0" (make-cuilui cui lui)))) - (t (string-append ls (format nil "cui=~d and lui=0 and sui=0" cui)))) - (when srl - (string-append ls (format nil " and KSRL <= ~d" srl))) - (let ((usats '())) - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'usat :code (nth 0 tuple) - :atn (nth 1 tuple) - :sab (nth 2 tuple) - :atv (nth 3 tuple)) - usats)) - (nreverse usats)))) - -(defun find-bsab-sab (sab) - (gu:aif (car (mutex-sql-query - (format nil "select NAME,COUNT from BONUS_SAB where SAB='~a'" sab))) - (make-instance 'bsab :sab sab :name (nth 0 gu::it) - :hits (ensure-integer (nth 1 gu::it))) - nil)) - -(defun find-bsab-all () - (let ((usabs '())) - (dolist (tuple (mutex-sql-query "select SAB,NAME,COUNT from BONUS_SAB")) - (push - (make-instance 'bsab :sab (nth 0 tuple) :name (nth 1 tuple) - :hits (ensure-integer (nth 2 tuple))) - usabs)) - (nreverse usabs))) - -(defun find-btty-tty (tty) - (gu:aif (car (mutex-sql-query - (format nil "select NAME from BONUS_TTY where TTY='~a'" tty))) - (make-instance 'btty :tty tty :name (nth 0 gu::it)) - nil)) - -(defun find-btty-all () - (let ((uttys '())) - (dolist (tuple (mutex-sql-query "select TTY,NAME from BONUS_TTY")) - (push - (make-instance 'btty :tty (nth 0 tuple) :name (nth 1 tuple)) - uttys)) - (nreverse uttys))) - -(defun find-brel-rel (rel) - (let ((brels '())) - (dolist (tuple (mutex-sql-query - (format nil "select SAB,SL,REL,RELA,COUNT from BONUS_REL where REL='~a'" rel))) - (push - (make-instance 'brel :sab (nth 0 tuple) :sl (nth 1 tuple) :rel (nth 2 tuple) - :rela (nth 3 tuple) :hits (ensure-integer (nth 4 tuple))) - brels)) - (nreverse brels))) - -(defun find-pfstr-cui (cui) - (caar (mutex-sql-query (format nil "select KPFSTR from MRCON where CUI=~d limit 1" cui)))) - -(defun find-usty-tui (tui) - "Find usty for tui" - (setq tui (parse-tui tui)) - (gu:aif (car (mutex-sql-query - (format nil "select STY from MRSTY where TUI=~d limit 1" tui))) - (make-instance 'usty :tui tui :sty (nth 0 gu::it)) - nil)) - -(defun find-usty-sty (sty) - "Find usty for a sty" - (gu:aif (car (mutex-sql-query - (format nil "select TUI from MRSTY where STY='~a' limit 1" sty))) - (make-instance 'usty :tui (ensure-integer (nth 0 gu::it)) :sty sty) - nil)) - -(defun find-usty-all () - "Return list of usty's for all semantic types" - (let ((ustys '())) - (dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY")) - (push (find-usty-tui (nth 0 tuple)) ustys)) - (nreverse ustys))) - -(defun find-usty_freq-all () - (let ((usty_freqs '())) - (dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY")) - (let* ((tui (car tuple)) - (freq (ensure-integer - (caar (mutex-sql-query - (format nil "select count(*) from MRSTY where TUI=~a" tui)))))) - (push (make-instance 'usty_freq :usty (find-usty-tui tui) :freq freq) usty_freqs))) - (sort usty_freqs #'> :key #'usty_freq-freq))) - - -(defun make-user-table () - (mutex-sql-execute "create table UMLISP_USERS (ID integer UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY,FIRST_NAME varchar(20),LAST_NAME varchar(20),ORGANIZATION varchar(80),ADDRESS1 varchar(60),ADDRESS2 varchar(60),CITY varchar(30),STATE char(2),ZIP char(10),COUNTRY varchar(40),OCCUPATION varchar(120),EMAIL varchar(80),PASSWD varchar(20),MAILLIST char(1),LICENSED char(1),SRL integer,TIMEOUT integer,DATETIME_CREATED datetime,DATETIME_MODIFIED datetime)")) - -(defun find-umlisp-user-email (email) - (let ((tuple (car (mutex-sql-query - (format nil "select ID,FIRST_NAME,LAST_NAME,ORGANIZATION,ADDRESS1,ADDRESS2,CITY,STATE,ZIP,COUNTRY,OCCUPATION,LICENSED,MAILLIST,PASSWD,SRL,TIMEOUT,DATETIME_CREATED,DATETIME_MODIFIED from UMLISP_USERS where EMAIL='~a'" email))))) - (when tuple - (make-instance 'umlisp-user :email email - :id (ensure-integer (nth 0 tuple)) - :first-name (nth 1 tuple) - :last-name (nth 2 tuple) - :organization (nth 3 tuple) - :address1 (nth 4 tuple) - :address2 (nth 5 tuple) - :city (nth 6 tuple) - :state (nth 7 tuple) - :zip (nth 8 tuple) - :country (nth 9 tuple) - :occupation (nth 10 tuple) - :licensed (if (string-equal "Y" (nth 11 tuple)) t nil) - :maillist (if (string-equal "Y" (nth 12 tuple)) t nil) - :passwd (nth 13 tuple) - :srl (ensure-integer (nth 14 tuple)) - :timeout (ensure-integer (nth 15 tuple)) - :datetime-created (nth 16 tuple) - :datetime-modified (nth 17 tuple))))) - -(defun find-umlisp-user-all () - (let ((users '())) - (dolist (email (find-umlisp-user-all-email)) - (push (find-umlisp-user-email email) users)) - (nreverse users))) - -(defun find-umlisp-user-all-email () - (let ((emails '())) - (dolist (tuple (mutex-sql-query "select EMAIL from UMLISP_USERS")) - (push (car tuple) emails)) - (nreverse emails))) - -(defun find-umlisp-user-announce-email () - (let ((emails '())) - (dolist (tuple (mutex-sql-query - "select EMAIL from UMLISP_USERS where MAILLIST='Y'")) - (push (car tuple) emails)) - (nreverse emails))) - -(defun add-umlisp-user (user) - (if (typep user 'umlisp-user) - (progn - (mutex-sql-execute - (format nil "insert into UMLISP_USERS (FIRST_NAME,LAST_NAME,ORGANIZATION,ADDRESS1,ADDRESS2,CITY,STATE,ZIP,COUNTRY,OCCUPATION,LICENSED,MAILLIST,EMAIL,PASSWD,SRL,TIMEOUT,DATETIME_CREATED,DATETIME_MODIFIED) values ('~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a','~a',~d,~d,NOW(),NOW())" - (first-name user) (last-name user) - (organization user) - (address1 user) (address2 user) - (city user) (state user) - (zip user) (country user) (occupation user) - (if (licensed user) #\Y #\N) - (if (maillist user) #\Y #\N) - (email user) - (passwd user) (srl user) - (timeout user))) - (let ((read-user (find-umlisp-user-email (email user)))) - (setf (slot-value user 'id) (id read-user) - (slot-value user 'datetime-created) (datetime-created read-user) - (slot-value user 'datetime-modified) (datetime-modified read-user))) - t) - nil)) - -(defun umlisp-user-verify-passwd (user passwd) - (when user - (string-equal passwd (passwd user)))) - -(defun umlisp-user-set-srl (email srl) - (when (and (integerp srl) (find-umlisp-user-email email)) - (mutex-sql-execute - (format nil "update UMLISP_USERS set SRL=~d,DATETIME_MODIFIED=NOW() where EMAIL='~a'" srl email)) - srl)) - -(defun make-ustats () - (with-sql-connection (conn) - (sql-execute "drop table if exists USTATS" conn) - (sql-execute "create table USTATS (NAME varchar(160), COUNT bigint, SRL integer)" conn) - - (dotimes (srl 4) - (insert-ustats-count conn "Concept Count" "MRCON" "distinct CUI" "KCUILRL" srl) - (insert-ustats-count conn "Term Count" "MRCON" "distinct KCUILUI" "KCUILRL" srl) - (insert-ustats-count conn "Distinct Term Count" "MRCON" "distinct LUI" "KLUILRL" srl) - (insert-ustats-count conn "String Count" "MRCON" "*" "LRL" srl) - (insert-ustats-count conn "Distinct String Count" "MRCON" "distinct SUI" "LRL" srl) - (insert-ustats-count conn "Associated Expression Count" "MRATX" "*" "KSRL" srl) - (insert-ustats-count conn "Context Count" "MRCXT" "*" "KSRL" srl) - (insert-ustats-count conn "Co-occuring Concept Count" "MRCOC" "*" "KLRL" srl) - (insert-ustats-count conn "Definition Count" "MRDEF" "*" "KSRL" srl) - (insert-ustats-count conn "Locator Count" "MRLO" "*" "KLRL" srl) - (insert-ustats-count conn "Rank Count" "MRRANK" "*" "KSRL" srl) - (insert-ustats-count conn "Relationship Count" "MRREL" "*" "KSRL" srl) - (insert-ustats-count conn "Semantic Type Count" "MRSTY" "*" "KLRL" srl) - (insert-ustats-count conn "Simple Attribute Count" "MRSAT" "*" "KSRL" srl) - (insert-ustats-count conn "Source Count" "MRSO" "*" "SRL" srl) - (insert-ustats-count conn "Word Index Count" "MRXW_ENG" "*" "KLRL" srl) - (insert-ustats-count conn "Normalized Word Index Count" "MRXNW_ENG" "*" "KLRL" srl) - (insert-ustats-count conn "Normalized String Index Count" "MRXNS_ENG" "*" "KLRL" srl) - (insert-ustats-count conn "Bonus Attribute Name Count" "BONUS_ATN" "*" nil srl) - (insert-ustats-count conn "Bonus Relationship Count" "BONUS_REL" "*" nil srl) - (insert-ustats-count conn "Bonus Source Abbreviation Count" "BONUS_SAB" "*" nil srl) - (insert-ustats-count conn "Bonus Term Type Count" "BONUS_TTY" "*" nil srl)) - (sql-execute "create index USTATS_SRL on USTATS (SRL)" conn)) - (find-ustats-all)) - -(defun insert-ustats-count (conn name table count-variable srl-control srl) - (insert-ustats conn name (find-count-table conn table srl count-variable srl-control) srl)) - -(defun find-count-table (conn table srl count-variable srl-control) - (cond - ((stringp srl-control) - (ensure-integer - (caar (sql-query (format nil "select count(~a) from ~a where ~a <= ~d" - count-variable table srl-control srl) - conn)))) - ((null srl-control) - (ensure-integer - (caar (sql-query (format nil "select count(~a) from ~a" - count-variable table ) - conn)))) - (t - (error "Unknown srl-control") - 0))) - -(defun insert-ustats (conn name count srl) - (sql-execute (format nil "insert into USTATS (name,count,srl) values ('~a',~d,~d)" - name count (if srl srl 3)) - conn)) - -(defun find-ustats-all (&key (srl *current-srl*)) - (let ((ustats '()) - (ls "select NAME,COUNT,SRL from USTATS")) - (when srl - (string-append ls (format nil " where SRL=~d" srl))) - (string-append ls " order by NAME asc") - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'ustats :name (nth 0 tuple) - :hits (ensure-integer (nth 1 tuple)) - :srl (ensure-integer (nth 2 tuple))) - ustats)) - (nreverse ustats))) - -(defun find-ustats-srl (srl) - (let ((ustats '())) - (dolist (tuple (mutex-sql-query - (format nil "select NAME,COUNT from USTATS where SRL=~d order by NAME asc" srl))) - (push (make-instance 'ustats :name (nth 0 tuple) - :hits (ensure-integer (nth 1 tuple)) - :srl srl) - ustats)) - (nreverse ustats))) - -(defun make-usrl () - (with-sql-connection (conn) - (sql-execute "drop table if exists USRL" conn) - (sql-execute "create table USRL (sab varchar(80), srl integer)" conn) - (dolist (tuple (mutex-sql-query "select distinct SAB,SRL from MRSO order by SAB asc")) - (sql-execute (format nil "insert into USRL (sab,srl) values ('~a',~d)" - (car tuple) (ensure-integer (cadr tuple))) - conn))) - (find-usrl-all)) - -(defun find-usrl-all () - (let ((usrls '()) - (tuples (mutex-sql-query "select SAB,SRL from USRL order by SAB desc"))) - (dolist (tuple tuples) - (push (make-instance 'usrl :sab (nth 0 tuple) - :srl (ensure-integer (nth 1 tuple))) usrls)) - usrls)) ;; already reversed by sql - -(defun find-usrl_freq-all () - (let ((freqs '())) - (dolist (usrl (find-usrl-all)) - (let ((freq (ensure-integer - (caar (mutex-sql-query - (format nil "select count(*) from MRSO where SAB='~a'" - (sab usrl))))))) - (push (make-instance 'usrl_freq :usrl usrl :freq freq) freqs))) - (sort freqs #'> :key #'usrl_freq-freq))) - -(defun find-cui-max () - (let ((cui (caar (mutex-sql-query "select max(CUI) from MRCON")))) - (ensure-integer cui))) - -;;;; Cross table find functions - -(defun find-ucon-tui (tui &key (srl *current-srl*)) - "Find list of ucon for tui" - (when (stringp tui) - (setq tui (parse-tui tui))) - (let ((ucons '()) - (ls (format nil "select CUI from MRSTY where TUI=~d" tui))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) - (string-append ls " order by cui desc") - (dolist (tuple (mutex-sql-query ls)) - (push (find-ucon-cui (ensure-integer (car tuple)) :srl srl) ucons)) - ucons)) - -(defun find-ucon-word (word &key (srl *current-srl*) (like nil)) - "Return list of ucons that match word. Optionally, use SQL's LIKE syntax" - (let ((ucons '()) - (ls (format nil "select distinct cui from MRXW_ENG where wd~A'~A'" - (if like " LIKE " "=") - word))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) - (string-append ls " order by cui desc") - (dolist (tuple (mutex-sql-query ls)) - (push (find-ucon-cui (car tuple) :srl srl) ucons)) - ucons)) - -(defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil)) - "Return list of ucons that match word, optionally use SQL's LIKE syntax" - (let ((ucons '()) - (ls (format nil "select distinct cui from MRXNW_ENG where nwd~A'~A'" - (if like " LIKE " "=") - word))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) - (string-append ls " order by cui desc") - (dolist (tuple (mutex-sql-query ls)) - (push (find-ucon-cui (car tuple) :srl srl) ucons)) - ucons)) - -(defun find-ustr-word (word &key (srl *current-srl*)) - "Return list of ustrs that match word" - (let ((ustrs '()) - (ls (format nil "select cui,sui from MRXW_ENG where wd='~a'" word))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) - (string-append ls " order by cui desc,sui desc") - (dolist (tuple (mutex-sql-query ls)) - (push (find-ustr-cuisui (ensure-integer (car tuple)) (ensure-integer (cadr tuple)) :srl srl) - ustrs)) - ustrs)) - -(defun find-ustr-normalized-word (word &key (srl *current-srl*)) - "Return list of ustrs that match word" - (let ((ustrs '()) - (ls (format nil "select cui,sui from MRXNW_ENG where nwd='~a'" word))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) - (string-append ls " order by cui desc,sui desc") - (dolist (tuple (mutex-sql-query ls)) - (push (find-ustr-cuisui (ensure-integer (car tuple)) (ensure-integer (cadr tuple)) :srl srl) - ustrs)) - ustrs)) - - -;;; Multiword lookup and score functions - -(defun find-ucon-multiword (str &key (srl *current-srl*)) - "Return sorted list of ucon's that match a multiword string" - (let* ((words (delimited-string-to-list str #\space)) - (ucons '())) - (dolist (word words) - (setq ucons (append ucons (find-ucon-word word :srl srl)))) - (sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui)))) - -(defun find-ucon-normalized-multiword (str &key (srl *current-srl*)) - "Return sorted list of ucon's that match a multiword string" - (let* ((words (delimited-string-to-list str #\space)) - (ucons '()) - (nwords '())) - (dolist (word words) - (let ((nws (lvg:process-terms word))) - (dolist (nword nws) - (push nword nwords)))) - (dolist (word nwords) - (setq ucons (append ucons (find-ucon-word word :srl srl)))) - (sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui)))) - -(defun find-ustr-multiword (str &key (srl *current-srl*)) - "Return sorted list of ustr's that match a multiword string" - (let* ((words (delimited-string-to-list str #\space)) - (ustrs '())) - (dolist (word words) - (setq ustrs (append ustrs (find-ustr-word word :srl srl)))) - (sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'cui)))) - -(defun find-ustr-normalized-multiword (str &key (srl *current-srl*)) - "Return sorted list of ustr's that match a multiword string" - (let* ((words (delimited-string-to-list str #\space)) - (ustrs '()) - (nwords '())) - (dolist (word words) - (let ((nws (lvg:process-terms word))) - (dolist (nword nws) - (push nword nwords)))) - (dolist (word nwords) - (setq ustrs (append ustrs (find-ustr-word word :srl srl)))) - (sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'ustr-cui)))) - -(defun a (str) - (find-normalized-matches-for-str str #'find-ustr-normalized-word #'ustr-sui)) - -(defun find-normalized-matches-for-str (str lookup-func key-func) - "Return list of objects that normalize match for words in string, -eliminate duplicates." - (let ((objs '()) - (nwords '())) - (dolist (word (delimited-string-to-list str #\space)) - (dolist (nword (lvg:process-terms word)) - (unless (member nword nwords :test #'string-equal) - (push nword nwords)))) - (dolist (nw nwords) - (setq objs (append objs (funcall lookup-func nw)))) - (delete-duplicates objs :key key-func :test #'eql))) - -(defun sort-score-ucon-str (str ucons) - "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr" - (sort-score-umlsclass-str ucons str #'pfstr)) - -(defun sort-score-ustr-str (str ustrs) - "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr" - (sort-score-umlsclass-str ustrs str #'str)) - -(defun sort-score-umlsclass-str (objs str lookup-func) - "Sort a list of objects based on scoring to a string" - (let ((scored '())) - (dolist (obj objs) - (push - (list obj - (score-multiword-match str (funcall lookup-func obj))) - scored)) - (mapcar #'car (sort scored #'> :key #'cadr)))) - -(defun score-multiword-match (s1 s2) - "Score a match between two strings with s1 being reference string" - (let* ((word-list-1 (delimited-string-to-list s1 #\space)) - (word-list-2 (delimited-string-to-list s2 #\space)) - (n1 (length word-list-1)) - (n2 (length word-list-2)) - (unmatched n1) - (score 0) - (nlong 0) - (nshort 0) - short-list long-list) - (declare (fixnum n1 n2 nshort nlong score unmatched)) - (if (> n1 n2) - (progn - (setq nlong n1) - (setq nshort n2) - (setq long-list word-list-1) - (setq short-list word-list-2)) - (progn - (setq nlong n2) - (setq nshort n1) - (setq long-list word-list-2) - (setq short-list word-list-1))) - (decf score (- nlong nshort)) ;; reduce score for extra words - (dotimes (iword nshort) - (declare (fixnum iword)) - (gu:aif (position (nth iword short-list) long-list :test #'string-equal) - (progn - (incf score (- 10 (abs (- gu::it iword)))) - (decf unmatched)))) - (decf score (* 2 unmatched)) - score)) - - -;;; LEX SQL functions - -(defun find-lexterm-eui (eui) - (gu:awhen (car (mutex-sql-query - (format nil "select WRD from LRWD where EUI=~d" eui))) - (make-instance 'lexterm :eui eui :wrd (nth 0 gu:it)))) - -(defun find-lexterm-word (wrd) - (gu:awhen (mutex-sql-query - (format nil "select EUI from LRWD where WRD='~a'" wrd)) - (let ((terms '())) - (dolist (tuple gu:it) - (let ((eui (ensure-integer (nth 0 tuple)))) - (push - (make-instance 'lexterm :eui eui :wrd (copy-seq wrd)) - terms))) - (nreverse terms)))) - -;; LEXTERM accessors, read on demand - -(def-lazy-reader lexterm s#abr find-labr-eui eui) -(def-lazy-reader lexterm s#agr find-lagr-eui eui) -(def-lazy-reader lexterm s#cmp find-lcmp-eui eui) -(def-lazy-reader lexterm s#mod find-lmod-eui eui) -(def-lazy-reader lexterm s#nom find-lnom-eui eui) -(def-lazy-reader lexterm s#prn find-lprn-eui eui) -(def-lazy-reader lexterm s#prp find-lprp-eui eui) -(def-lazy-reader lexterm s#spl find-lspl-eui eui) -(def-lazy-reader lexterm s#trm find-ltrm-eui eui) -(def-lazy-reader lexterm s#typ find-ltyp-eui eui) - -;; LEX SQL Read functions - -(defun find-labr-eui (eui) - (gu:awhen (mutex-sql-query - (format nil "select BAS,ABR,EUI2,BAS2 from LRABR where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'labr :eui eui - :bas (nth 0 tuple) - :abr (nth 1 tuple) - :eui2 (ensure-integer (nth 2 tuple)) - :bas2 (nth 3 tuple)) - results)) - (nreverse results)))) - -(defun find-labr-bas (bas) - (gu:awhen (mutex-sql-query - (format nil "select EUI,ABR,EUI2,BAS2 from LRABR where BAS='~a'" bas)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'labr :eui (ensure-integer (nth 0 tuple)) - :bas (copy-seq bas) - :abr (nth 1 tuple) - :eui2 (ensure-integer (nth 2 tuple)) - :bas2 (nth 3 tuple)) - results)) - (nreverse results)))) - -(defun find-lagr-eui (eui) - (gu:awhen (mutex-sql-query - (format nil "select STR,SCA,AGR,CIT,BAS from LRAGR where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'lagr - :eui eui - :str (nth 0 tuple) - :sca (nth 1 tuple) - :agr (nth 2 tuple) - :cit (nth 3 tuple) - :bas (nth 4 tuple)) - results)) - (nreverse results)))) - -(defun find-lcmp-eui (eui) - (gu:awhen (mutex-sql-query - (format nil "select BAS,SCA,COM from LRCMP where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'lcmp - :eui eui - :bas (nth 0 tuple) - :sca (nth 1 tuple) - :com (nth 2 tuple)) - results)) - (nreverse results)))) - -(defun find-lmod-eui (eui) - (gu:awhen (mutex-sql-query - (format nil "select BAS,SCA,PSN_MOD,FEA from LRMOD where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'lmod - :eui eui - :bas (nth 0 tuple) - :sca (nth 1 tuple) - :psnmod (nth 2 tuple) - :fea (nth 3 tuple)) - results)) - (nreverse results)))) - -(defun find-lnom-eui (eui) - (gu:awhen (mutex-sql-query - (format nil "select BAS,SCA,EUI2,BAS2,SCA2 from LRNOM where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'lnom - :eui eui - :bas (nth 0 tuple) - :sca (nth 1 tuple) - :eui2 (ensure-integer (nth 2 tuple)) - :bas2 (nth 3 tuple) - :sca2 (nth 4 tuple)) - results)) - (nreverse results)))) - -(defun find-lprn-eui (eui) - (gu:awhen (mutex-sql-query - (format nil "select BAS,NUM,GND,CAS,POS,QNT,FEA from LRPRN where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'lprn - :eui eui - :bas (nth 0 tuple) - :num (nth 1 tuple) - :gnd (nth 2 tuple) - :cas (nth 3 tuple) - :pos (nth 4 tuple) - :qnt (nth 5 tuple) - :fea (nth 6 tuple)) - results)) - (nreverse results)))) - -(defun find-lprp-eui (eui) - (gu:awhen (mutex-sql-query - (format nil "select BAS,STR,SCA,FEA from LRPRP where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'lprp - :eui eui - :bas (nth 0 tuple) - :str (nth 1 tuple) - :sca (nth 2 tuple) - :fea (nth 3 tuple)) - results)) - (nreverse results)))) - -(defun find-lspl-eui (eui) - (gu:awhen (mutex-sql-query - (format nil "select SPV,BAS from LRSPL where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'lspl - :eui eui - :spv (nth 0 tuple) - :bas (nth 1 tuple)) - results)) - (nreverse results)))) - - -(defun find-ltrm-eui (eui) - (gu:awhen (mutex-sql-query - (format nil "select BAS,GEN from LRTRM where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'ltrm - :eui eui - :bas (nth 0 tuple) - :gen (nth 1 tuple)) - results)) - (nreverse results)))) - -(defun find-ltyp-eui (eui) - (gu:awhen (mutex-sql-query - (format nil "select BAS,SCA,TYP from LRTYP where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'ltyp - :eui eui - :bas (nth 0 tuple) - :sca (nth 1 tuple) - :typ (nth 2 tuple)) - results)) - (nreverse results)))) - -(defun find-lwd-wrd (wrd) - (gu:awhen (mutex-sql-query - (format nil "select EUI from LRWD where WRD='~a'" wrd)) - (let ((results '())) - (dolist (tuple gu::it) - (push (ensure-integer (nth 0 tuple)) results)) - (make-instance 'lwd :wrd wrd - :euilist (nreverse results))))) - -;;; Semantic Network SQL access functions - -(defun find-sdef-ui (ui) - (gu:awhen (car (mutex-sql-query - (format nil "select RT,STY_RL,STN_RTN,DEF,EX,UN,RH,ABR,RIN from SRDEF where UI=~d" ui))) - (make-instance 'sdef :rt (nth 0 gu::it) - :ui ui - :styrl (nth 1 gu::it) - :stnrtn (nth 2 gu::it) - :def (nth 3 gu::it) - :ex (nth 4 gu::it) - :un (nth 5 gu::it) - :rh (nth 6 gu::it) - :abr (nth 7 gu::it) - :rin (nth 8 gu::it)))) - -(defun find-sstre1-ui (ui) - (gu:awhen (mutex-sql-query - (format nil "select UI2,UI3 from SRSTRE1 where UI=~d" ui)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'sstre1 :ui ui - :ui2 (ensure-integer (nth 0 tuple)) - :ui3 (ensure-integer (nth 1 tuple))) - results)) - (nreverse results)))) - -(defun find-sstre1-ui2 (ui2) - (gu:awhen (mutex-sql-query - (format nil "select UI,UI3 from SRSTRE1 where UI2=~d" ui2)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'sstre1 :ui (ensure-integer (nth 0 tuple)) - :ui2 ui2 - :ui3 (ensure-integer (nth 1 tuple))) - results)) - (nreverse results)))) - -(defun find-sstr-rl (rl) - (gu:awhen (mutex-sql-query - (format nil "select STY_RL,STY_RL2,LS from SRSTRE where RL='~a'" rl)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'sstr - :rl rl - :styrl (nth 0 tuple) - :styrl2 (nth 1 tuple) - :ls (nth 2 tuple)) - results)) - (nreverse results)))) - - -(defun find-sstre2-sty (sty) - (gu:awhen (mutex-sql-query - (format nil "select RL,STY2 from SRSTRE2 where STY='~a'" sty)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'sstre2 - :sty (copy-seq sty) - :rl (nth 0 tuple) - :sty2 (nth 1 tuple)) - results)) - (nreverse results)))) - -(defun find-sstr-styrl (styrl) - (gu:awhen (mutex-sql-query - (format nil "select RL,STY_RL2,LS from SRSTR where RL='~a'" styrl)) - (let ((results '())) - (dolist (tuple gu::it) - (push - (make-instance 'sstr :styrl styrl - :rl (nth 0 tuple) - :styrl2 (nth 1 tuple) - :ls (nth 2 tuple)) - results)) - (nreverse results)))) - - diff --git a/obj.lisp b/obj.lisp deleted file mode 100644 index f52a2b6..0000000 --- a/obj.lisp +++ /dev/null @@ -1,624 +0,0 @@ -;;; $Id: obj.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $ -;;; -;;; UMLS object defintions and printing routines - -(in-package :umlisp) -(declaim (optimize (speed 3) (safety 1))) - -(defclass umlsclass () - () - (:metaclass ml-class) - (:documentation "Parent class of all UMLS objects")) - - -(defmethod print-object ((obj umlsclass) (s stream)) - (print-unreadable-object (obj s :type t :identity t) - (let ((fmt (make-instance 'gu.ml::textformat))) - (apply #'format - s (funcall (gu.ml::obj-data-fmtstr fmt) obj) - (multiple-value-list - (funcall (funcall (gu.ml::obj-data-value-func fmt) obj) obj)))))) - - -(defclass umlisp-user (umlsclass) - ((id :type fixnum :initarg :id :reader id) - (first-name :type string :initarg :first-name :reader first-name) - (last-name :type string :initarg :last-name :reader last-name) - (organization :type string :initarg :organization :reader organization) - (address1 :type string :initarg :address1 :reader address1) - (address2 :type string :initarg :address2 :reader address2) - (city :type string :initarg :city :reader city) - (state :type string :initarg :state :reader state) - (zip :type string :initarg :zip :reader zip) - (country :type string :initarg :country :reader country) - (licensed :type boolean :initarg :licensed :reader licensed) - (occupation :type string :initarg :occupation :reader occupation) - (email :type string :initarg :email :reader email) - (passwd :type string :initarg :passwd :reader passwd) - (srl :type fixnum :initarg :srl :reader srl) - (timeout :type fixnum :initarg :timeout :reader timeout) - (maillist :type boolean :initarg :maillist :reader maillist) - (datetime-created :type string :initarg :datetime-created - :reader datetime-created) - (datetime-modified :type string :initarg :datetime-modified - :reader datetime-modified)) - (:default-initargs - :id nil :first-name nil :last-name nil :email nil :passwd nil :srl nil - :organization nil :address1 nil :address2 nil :city nil :state nil - :zip nil :country nil :licensed nil :occupation nil :maillist nil - :timeout nil :datetime-created nil :datetime-modified nil) - (:metaclass ml-class) - (:title "UMLisp User") - (:fields - (id :fixnum) (first-name :string) (last-name :string) (email :string) - (occupation :string) (organization :string) (address1 :string) - (address2 :string) (city :string) (state :string) (zip :string) - (country :string) (licensed :boolean) (maillist :boolean) (srl :fixnum) - (timeout :fixnum) (datetime-created :string) (datetime-modified :string)) - (:documentation "Class for UMLisp user database")) - -(defclass ustats (umlsclass) - ((name :type string :initarg :name :reader name) - (hits :type integer :initarg :hits :reader hits) - (srl :type fixnum :initarg :srl :reader srl)) - (:metaclass ml-class) - (:default-initargs :name nil :hits nil :srl nil) - (:title "UMLS Statistic") - (:fields (name :string) (hits :commainteger) (srl :fixnum)) - (:documentation "Custom Table: UMLS Database statistics.")) - -(defclass usrl (umlsclass) - ((sab :type string :initarg :sab :reader sab) - (srl :type integer :initarg :srl :reader srl)) - (:metaclass ml-class) - (:default-initargs :sab nil :srl nil) - (:title "Source Restriction Level") - (:fields (sab :string) (srl :fixnum)) - (:documentation "Custom Table: Source Restriction Level")) - -(defclass bsab (umlsclass) - ((sab :type string :initarg :sab :reader sab) - (name :type string :initarg :name :reader name) - (hits :type fixnum :initarg :hits :reader hits)) - (:metaclass ml-class) - (:default-initargs :sab nil :name nil :hits nil) - (:title "Source of Abbreviation") - (:fields (sab :string) (name :string) (hits :commainteger)) - (:ref-fields (sab find-ustr-sab (("subobjects" "no")))) - (:documentation "Bonus SAB file")) - -(defclass btty (umlsclass) - ((tty :type string :initarg :tty :reader tty) - (name :type string :initarg :name :reader name)) - (:metaclass ml-class) - (:default-initargs :tty nil :name nil) - (:title "Bonus TTY") - (:fields (tty :string) (name :fixnum)) - (:documentation "Bonus TTY file")) - -(defclass brel (umlsclass) - ((sab :type string :initarg :sab :reader sab) - (sl :type string :initarg :sl :reader sl) - (rel :type string :initarg :rel :reader rel) - (rela :type string :initarg :rela :reader rela) - (hits :type fixnum :initarg :hits :reader hits)) - (:metaclass ml-class) - (:default-initargs :sab nil :sl nil :rel nil :rela nil :hits nil) - (:title "Bonus REL") - (:fields - (sab :string) (sl :string) (rel :string) (rela :string) (hits :commainteger)) - (:documentation "Bonus REL file")) - -(defclass batn (umlsclass) - ((sab :type string :initarg :sab :reader sab) - (atn :type string :initarg :atn :reader atn) - (hits :type fixnum :initarg :hits :reader hits)) - (:metaclass ml-class) - (:default-initargs :sab nil :atn nil) - (:title "Bonus ATN") - (:fields (sab :string) (atn :string) (hits :commaninteger)) - (:documentation "Bonus ATN file")) - -(defclass urank (umlsclass) - ((rank :type fixnum :initarg :rank :reader rank) - (sab :type string :initarg :sab :reader sab) - (tty :type string :initarg :tty :reader tty) - (supres :type string :initarg :supres :reader supres)) - (:metaclass ml-class) - (:default-initargs :rank nil :sab nil :tty nil :supres nil) - (:title "Rank") - (:fields (rank :fixnum) (sab :string) (tty :string) (supres :string))) - -(defclass udef (umlsclass) - ((def :type string :initarg :def :reader def) - (sab :type string :initarg :sab :reader sab)) - (:metaclass ml-class) - (:default-initargs :def nil :sab nil) - (:title "Definition") - (:ref-fields (sab find-bsab-sab)) - (:fields (sab :string) (def :cdata))) - -(defclass usat (umlsclass) - ((sab :type string :initarg :sab :reader sab) - (code :type string :initarg :code :reader code) - (atn :type string :initarg :atn :reader atn) - (atv :type string :initarg :atv :reader atv)) - (:metaclass ml-class) - (:default-initargs :sab nil :code nil :atn nil :atv nil) - (:title "Simple Attribute") - (:ref-fields (sab find-bsab-sab)) - (:fields (sab :string) (code :string) (atn :string) (atv :cdata))) - -(defclass uso (umlsclass) - ((sab :type string :initarg :sab :reader sab) - (code :type string :initarg :code :reader code) - (tty :type string :initarg :tty :reader tty) - (srl :type fixnum :initarg :srl :reader srl)) - (:metaclass ml-class) - (:default-initargs :sab nil :code nil :tty nil :srl nil) - (:title "Source") - (:ref-fields (sab find-bsab-sab) (tty find-btty-tty)) - (:fields (sab :string) (code :string) (tty :string) (srl :fixnum))) - -(defclass ucxt (umlsclass) - ((sab :type string :initarg :sab :reader sab) - (code :type string :initarg :code :reader code) - (rnk :type fixnum :initarg :rnk :reader rnk) - (cxn :type fixnum :initarg :cxn :reader cxn) - (cxl :type string :initarg :cxl :reader cxl) - (cxs :type string :initarg :cxs :reader cxs) - (cui2 :type fixnum :initarg :cui2 :reader cui2) - (hcd :type string :initarg :hcd :reader hcd) - (rela :type string :initarg :rela :reader rela) - (xc :type string :initarg :xc :reader xc)) - (:metaclass ml-class) - (:default-initargs :sab nil :code nil :rnk nil :cxn nil :cxl nil :cxs nil - :cui2 nil :hcd nil :rela nil :xc nil) - (:title "Context") - (:ref-fields (sab find-bsab-sab) (cui2 find-ucon-cui)) - (:fields - (sab :string) (code :string) (rnk :fixnum) (cxn :fixnum) (cxl :string) - (hcd :string) (rela :string) (xc :string) (cui2 :string fmt-cui) - (cxs :cdata))) - -(defclass ustr (umlsclass) - ((sui :type fixnum :initarg :sui :reader sui) - (cui :type fixnum :initarg :cui :reader cui) - (lui :type fixnum :initarg :lui :reader lui) - (cuisui :type integer :initarg :cuisui :reader cuisui ) - (str :type string :initarg :str :reader str) - (lrl :type fixnum :initarg :lrl :reader lrl) - (stt :type string :initarg :stt :reader stt) - (s#sat :reader s#sat) - (s#so :reader s#so) - (s#cxt :reader s#cxt)) - (:metaclass ml-class) - (:default-initargs - :sui nil :cui nil :lui nil :cuisui nil :str nil :lrl nil :stt nil) - (:title "String") - (:subobjects-lists (s#sat usat) (s#so uso) (s#cxt ucxt)) - (:fields (sui :string fmt-sui) (stt :string) (lrl :fixnum) (str :cdata)) - (:ref-fields (sui find-ustr-sui))) - -(defclass ulo (umlsclass) - ((isn :type string :initarg :isn :reader isn) - (fr :type fixnum :initarg :fr :reader fr) - (un :type string :initarg :un :reader un) - (sui :type fixnum :initarg :sui :reader sui) - (sna :type string :initarg :sna :reader sna) - (soui :type string :initarg :soui :reader soui)) - (:metaclass ml-class) - (:default-initargs :isn nil :fr nil :un nil :sui nil :sna nil :soui nil) - (:title "Locator") - (:fields (isn :string) (fr :fixnum) (un :string) (sna :string) - (soui :string) (sui :string fmt-sui) (suistr :string))) - -(defclass uterm (umlsclass) - ((lui :type fixnum :initarg :lui :reader lui) - (cui :type fixnum :initarg :cui :reader cui) - (lat :type string :initarg :lat :reader lat) - (ts :type string :initarg :ts :reader ts) - (lrl :type fixnum :initarg :lrl :reader lrl) - (s#str :reader s#str) - (s#sat :reader s#sat)) - (:metaclass ml-class) - (:default-initargs :lui nil :cui nil :lat nil :ts nil :lrl nil) - (:title "Term") - (:subobjects-lists (s#sat usat) (s#str ustr)) - (:fields (lui :string fmt-lui) (lat :string) (ts :string) (lrl :fixnum)) - (:ref-fields (lui find-uterm-lui))) - -(defclass usty (umlsclass) - ((tui :type fixnum :initarg :tui :reader tui) - (sty :type string :initarg :sty :reader sty)) - (:metaclass ml-class) - (:default-initargs :tui nil :sty nil) - (:title "Semantic Type") - (:ref-fields (tui find-ucon-tui (("subobjects" "no")))) - (:fields (tui :string fmt-tui) (sty :string))) - -(defclass urel (umlsclass) - ((rel :type string :initarg :rel :reader rel) - (cui1 :type fixnum :initarg :cui1 :reader cui1) - (cui2 :type fixnum :initarg :cui2 :reader cui2) - (pfstr2 :type string :initarg :pfstr2 :reader pfstr2) - (rela :type string :initarg :rela :reader rela) - (sab :type string :initarg :sab :reader sab) - (sl :type string :initarg :sl :reader sl) - (mg :type string :initarg :mg :reader mg)) - (:metaclass ml-class) - (:default-initargs - :rel nil :cui1 nil :cui2 nil :pfstr2 nil :rela nil :sab nil :sl nil :mg nil) - (:title "Relationship") - (:ref-fields (rel find-brel-rel) (sab find-bsab-sab) (cui2 find-ucon-cui)) - (:fields (rel :string) (rela :string) (sab :string) (sl :string) - (mg :string) (cui2 :string fmt-cui) (pfstr2 :cdata))) - -(defclass ucoc (umlsclass) - ((cui1 :type fixnum :initarg :cui1 :reader cui1) - (cui2 :type fixnum :initarg :cui2 :reader cui2) - (pfstr2 :type string :initarg :pfstr2 :reader pfstr2) - (soc :type string :initarg :soc :reader soc) - (cot :type string :initarg :cot :reader cot) - (cof :type fixnum :initarg :cof :reader cof) - (coa :type string :initarg :coa :reader coa)) - (:metaclass ml-class) - (:default-initargs - :cui1 nil :cui2 nil :pfstr2 nil :soc nil :cot nil :cof nil :coa nil) - (:title "Co-occuring Concept") - (:ref-fields (cui2 find-ucon-cui)) - (:fields (soc :string) (cot :string) (cof :fixnum) (coa :cdata) - (cui2 :string fmt-cui) (pfstr2 :cdata))) - - -(defclass uatx (umlsclass) - ((sab :type string :initarg :sab :reader sab) - (rel :type string :initarg :rel :reader rel) - (atx :type string :initarg :atx :reader atx)) - (:metaclass ml-class) - (:default-initargs :sab nil :rel nil :atx nil) - (:title "Associated Expression") - (:fields (sab :string) (rel :string) (atx :cdata))) - -(defclass ucon (umlsclass) - ((cui :type fixnum :initarg :cui :reader cui ) - (pfstr :initarg :pfstr :reader pfstr) - (lrl :initarg :lrl :reader lrl) - (s#term :reader s#term) - (s#def :reader s#def) - (s#lo :reader s#lo) - (s#rel :reader s#rel) - (s#coc :reader s#coc) - (s#sat :reader s#sat) - (s#atx :reader s#atx) - (s#sty :reader s#sty)) - (:metaclass ml-class) - (:default-initargs :cui nil :pfstr nil :lrl nil) - (:title "Concept") - (:subobjects-lists - (s#def udef) (s#sty usty) (s#lo ulo) (s#atx uatx) (s#sat usat) (s#rel urel) - (s#coc ucoc) (s#term uterm)) - (:fields (cui :string fmt-cui) (lrl :fixum) (pfstr :cdata)) - (:ref-fields (cui find-ucon-cui))) - -(defclass uxw (umlsclass) - ((wd :type string :initarg :wd :reader wd) - (cui :type fixnum :initform nil :initarg :cui :reader cui) - (lui :type fixnum :initform nil :initarg :lui :reader lui) - (sui :type fixnum :initform nil :initarg :sui :reader sui)) - (:metaclass ml-class) - (:default-initargs :wd nil :cui nil :lui nil :sui nil) - (:title "XW Index") - (:fields (wd :string) (cui :string fmt-cui) (lui :string fmt-lui) - (sui :string fmt-sui))) - -(defclass uxnw (umlsclass) - ((lat :type string :initarg :lat :reader lat) - (nwd :type string :initarg :nwd :reader nwd) - (cuilist :type list :initarg :cuilist :reader uxnw-cuilist)) - (:metaclass ml-class) - (:default-initargs :lat nil :nwd nil :cuilist nil) - (:title "XNW Index") - (:fields (lat :string) (nwd :string) (cuilist :string))) - -(defclass uxns (umlsclass) - ((lat :type string :initarg :lat :reader lat) - (nstr :type string :initarg :nstr :reader nstr) - (cuilist :type list :initarg :cuilist :reader cuilist)) - (:metaclass ml-class) - (:default-initargs :lat nil :nstr nil :cuilist nil) - (:title "XNS Index") - (:fields (lat :string) (nstr :string) (cuilist :string))) - - -;;; LEX objects - -(defclass lexterm (umlsclass) - ((eui :type fixnum :initarg :eui :reader eui) - (wrd :type string :initarg :wrd :reader wrd) - (s#abr :reader s#abr) - (s#agr :reader s#agr) - (s#cmp :reader s#cmp) - (s#mod :reader s#mod) - (s#nom :reader s#nom) - (s#prn :reader s#prn) - (s#prp :reader s#prp) - (s#spl :reader s#spl) - (s#trm :reader s#trm) - (s#typ :reader s#typ)) - (:metaclass ml-class) - (:default-initargs :eui nil :wrd nil) - (:title "Lexical Term") - (:subobjects-lists - (s#abr labr) (s#agr lagr) (s#cmp lcmp) (s#mod lmod) (s#nom unom) - (s#prn lprn) (s#prp lprp) (s#spl lspl) (s#trm ltrm) (s#typ ltyp)) - (:fields (eui :string fmt-eui) (wrd :string)) - (:ref-fields (eui find-lexterm-eui))) - - -(defclass labr (umlsclass) - ((eui :type integer :initarg :eui :reader eui) - (bas :type string :initarg :bas :reader bas) - (abr :type string :initarg :abr :reader abr) - (eui2 :type integer :initarg :eui2 :reader eui2) - (bas2 :type string :initarg :bas2 :reader bas2)) - (:metaclass ml-class) - (:default-initargs :eui nil :bas nil :abr nil :eui2 nil :bas2 nil) - (:title "Abbreviations and Acronyms") - (:fields (eui :string fmt-eui) (bas :string) (abr :string) - (eui2 :string fmt-eui) (bas2 :string ))) - -(defclass lagr (umlsclass) - ((eui :type integer :initarg :eui :reader eui) - (str :type string :initarg :str :reader str) - (sca :type string :initarg :sca :reader sca) - (agr :type string :initarg :agr :reader agr) - (cit :type string :initarg :cit :reader cit) - (bas :type string :initarg :bas :reader bas)) - (:metaclass ml-class) - (:default-initargs :eui nil :str nil :sca nil :agr nil :cit nil :bas nil) - (:title "Agreement and Inflection") - (:fields (eui :string fmt-eui) (str :string) (sca :string) (agr :string) - (cit :string) (bas :string))) - -(defclass lcmp (umlsclass) - ((eui :type integer :initarg :eui :reader eui) - (bas :type string :initarg :bas :reader bas) - (sca :type string :initarg :sca :reader sca) - (com :type string :initarg :com :reader com)) - (:metaclass ml-class) - (:default-initargs :eui nil :bas nil :sca nil :com nil) - (:title "Complementation") - (:fields (eui :string fmt-eui) (bas :string) (sca :string) (com :string))) - -(defclass lmod (umlsclass) - ((eui :type integer :initarg :eui :reader eui) - (bas :type string :initarg :bas :reader bas) - (sca :type string :initarg :sca :reader sca) - (psnmod :type string :initarg :psnmod :reader psnmod) - (fea :type string :initarg :fea :reader fea)) - (:metaclass ml-class) - (:default-initargs :eui nil :bas nil :sca nil :psnmod nil :fea nil) - (:title "Modifiers") - (:fields (eui :string fmt-eui) (bas :string) (sca :string) (psnmod :string) - (fea :string))) - -(defclass lnom (umlsclass) - ((eui :type integer :initarg :eui :reader eui) - (bas :type string :initarg :bas :reader bas) - (sca :type string :initarg :sca :reader sca) - (eui2 :type integer :initarg :eui2 :reader eui2) - (bas2 :type string :initarg :bas2 :reader bas2) - (sca2 :type string :initarg :sca2 :reader sca2)) - (:metaclass ml-class) - (:default-initargs :eui nil :bas nil :sca nil :eui2 nil :bas2 nil :sca2 nil) - (:title "Nominalizations") - (:fields (eui :string fmt-eui) (bas :string) (sca :string) - (eui2 :string fmt-eui) (bas2 :string) (sca2 :string))) - -(defclass lprn (umlsclass) - ((eui :type integer :initarg :eui :reader eui) - (bas :type string :initarg :bas :reader bas) - (num :type string :initarg :num :reader num) - (gnd :type string :initarg :gnd :reader gnd) - (cas :type string :initarg :cas :reader cas) - (pos :type string :initarg :pos :reader pos) - (qnt :type string :initarg :qnt :reader qnt) - (fea :type string :initarg :fea :reader fea)) - (:metaclass ml-class) - (:default-initargs :eui nil :bas nil :num nil :gnd nil :cas nil - :pos nil :qnt nil :fea nil) - (:title "Pronouns") - (:fields (eui :string fmt-eui) (bas :string) (num :string) (gnd :string) - (cas :string) (pos :string) (qnt :string) (fea :string))) - -(defclass lprp (umlsclass) - ((eui :type integer :initarg :eui :reader eui) - (bas :type string :initarg :bas :reader bas) - (str :type string :initarg :str :reader str) - (sca :type string :initarg :sca :reader sca) - (fea :type string :initarg :fea :reader fea)) - (:metaclass ml-class) - (:default-initargs :eui nil :bas nil :str nil :sca nil :fea nil) - (:title "Properties") - (:fields (eui :string fmt-eui) (bas :string) (str :string) (sca :string) - (fea :string))) - - -(defclass lspl (umlsclass) - ((eui :type integer :initarg :eui :reader eui) - (spv :type string :initarg :spv :reader spv) - (bas :type string :initarg :bas :reader bas)) - (:metaclass ml-class) - (:default-initargs :eui nil :spv nil :bas nil) - (:title "Spelling Variants") - (:fields (eui :string fmt-eui) (spv :string) (bas :string))) - - - -(defclass ltrm (umlsclass) - ((eui :type integer :initarg :eui :reader eui) - (bas :type string :initarg :bas :reader bas) - (gen :type string :initarg :gen :reader gen)) - (:metaclass ml-class) - (:default-initargs :eui nil :bas nil :gen nil) - (:title "Trade Marks") - (:fields (eui :string fmt-eui) (bas :string) (gen :string))) - -(defclass ltyp (umlsclass) - ((eui :type integer :initarg :eui :reader eui) - (bas :type string :initarg :bas :reader bas) - (sca :type string :initarg :sca :reader sca) - (typ :type string :initarg :typ :reader typ)) - (:metaclass ml-class) - (:default-initargs :eui nil :bas nil :sca nil :typ nil) - (:title "Inflection Type") - (:fields (eui :string fmt-eui) (bas :string) (sca :string) (typ :string))) - -(defclass lwd (umlsclass) - ((wrd :type string :initarg :wrd :reader wrd) - (euilist :type list :initarg :euilist :reader euilist)) - (:metaclass ml-class) - (:default-initargs :wrd nil :euilist nil) - (:title "Lexical Word Index") - (:fields (wrd :string) (euilist :string))) - -;;; Semantic NET objects - -(defclass sdef (umlsclass) - ((rt :type string :initarg :rt :reader rt) - (ui :type integer :initarg :ui :reader ui) - (styrl :type string :initarg :styrl :reader styrl) - (stnrtn :type string :initarg :stnrtn :reader stnrtn) - (def :type string :initarg :def :reader def) - (ex :type string :initarg :ex :reader ex) - (un :type string :initarg :un :reader un) - (rh :type string :initarg :rh :reader rh) - (abr :type string :initarg :abr :reader abr) - (rin :type string :initarg :rin :reader rin)) - (:metaclass ml-class) - (:default-initargs - :rt nil :ui nil :styrl nil :stnrtn nil :def nil :ex nil :un nil :rh nil - :abr nil :rin nil) - (:title "Basic information about Semantic Types and Relations") - (:fields - (rt :string) (ui :string fmt-tui) (styrl :string) (stnrtn :string-tui) - (def :string) (ex :string) (un :string) (rh :string) (abr :string) - (rin :string))) - -(defclass sstr (umlsclass) - ((styrl :type string :initarg :styrl :reader styrl) - (rl :type string :initarg :rl :reader rl) - (styrl2 :type string :initarg :styrl2 :reader styrl2) - (ls :type string :initarg :ls :reader ls)) - (:metaclass ml-class) - (:default-initargs :styrl nil :rl nil :styrl2 nil :ls nil) - (:title "Structure of the Network") - (:fields (styrl :string) (rl :string) (styrl2 :string) (ls :string))) - -(defclass sstre1 (umlsclass) - ((ui :type integer :initarg :ui :reader ui) - (ui2 :type integer :initarg :ui2 :reader ui2) - (ui3 :type integer :initarg :ui3 :reader ui3)) - (:metaclass ml-class) - (:default-initargs :ui nil :ui2 nil :ui3 nil) - (:title "Fully Inherited Set of Releatons (TUI's)") - (:fields (ui :string fmt-tui) (ui2 :string fmt-tui) (ui3 :string fmt-tui))) - -(defclass sstre2 (umlsclass) - ((sty :type string :initarg :ui :reader sty) - (rl :type string :initarg :ui2 :reader rl) - (sty2 :type string :initarg :ui3 :reader sty2)) - (:metaclass ml-class) - (:default-initargs :sty nil :rl nil :sty2 nil) - (:title "Fully Inherited Set of Releatons (strings)") - (:fields (sty :string) (rl :string) (sty2 :string))) - -;;; Formatting routines - -(defmethod fmt-cui ((c ucon)) - (format nil "C~7,'0d" (cui c))) - -(defmethod fmt-cui ((c fixnum)) - (format nil "C~7,'0d" c)) - -(defmethod fmt-cui ((c string)) - (if (eql (aref c 0) #\C) - c - (format nil "C~7,'0d" (parse-integer c)))) - -(defmethod fmt-cui ((c null)) - (format nil "nil")) - -(defmethod fmt-lui ((l uterm)) - (format nil "L~7,'0d" (lui l))) - -(defmethod fmt-lui ((l fixnum)) - (format nil "L~7,'0d" l)) - -(defmethod fmt-lui ((l string)) - (if (eql (aref l 0) #\L) - l - (format nil "L~7,'0d" (parse-integer l)))) - -(defmethod fmt-sui ((s ustr)) - (format nil "S~7,'0d" (sui s))) - -(defmethod fmt-sui ((s fixnum)) - (format nil "S~7,'0d" s)) - -(defmethod fmt-sui ((s string)) - (if (eql (aref s 0) #\S) - s - (format nil "S~7,'0d" (parse-integer s)))) - -(defmethod fmt-tui ((s fixnum)) - (format nil "T~3,'0d" s)) - -(defmethod fmt-tui ((s string)) - (if (eql (aref s 0) #\T) - s - (format nil "T~3,'0d" (parse-integer s)))) - -(defmethod fmt-eui ((e fixnum)) - (format nil "E~7,'0d" e)) - -(defmethod fmt-eui ((e string)) - (if (eql (aref e 0) #\E) - e - (format nil "E~7,'0d" (parse-integer e)))) - -(defmethod fmt-eui ((e null)) - (format nil "nil")) - -;;; Generic display functions - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defun english-term-p (obj) - (and (eq (class-name (class-of obj)) 'uterm) - (string-equal (lat obj) "ENG")))) - -(defun display-umls-obj - (obj &key (os *standard-output*) (format :text) (label nil) - (file-wrapper t) (english-only nil) (subobjects nil) - (refvars nil)) - (display-ml-class - obj :os os :format format :label label :subobjects subobjects - :file-wrapper file-wrapper - :english-only-function (if english-only #'english-term-p nil) - :refvars refvars)) - -(defmacro defludisp-ml-class (newfuncname lookup-func) - "Defines functions for looking up and displaying objects" - `(defun ,newfuncname - (keyval &key (os *standard-output*) (format :text) (label nil) - (file-wrapper t) (english-only nil) (subobjects nil)) - (let ((obj (funcall ,lookup-func keyval))) - (display-umls-obj obj :os os :format format :label label - :file-wrapper file-wrapper :english-only english-only - :subobjects subobjects)))) - -(defludisp-ml-class disp-con #'find-ucon-cui) -(defludisp-ml-class disp-term #'find-uterm-lui) -(defludisp-ml-class disp-str #'find-ustr-sui) - diff --git a/sql-classes.lisp b/sql-classes.lisp new file mode 100644 index 0000000..e193f8b --- /dev/null +++ b/sql-classes.lisp @@ -0,0 +1,1029 @@ +;;; $Id: sql-classes.lisp,v 1.1 2002/10/08 22:08:56 kevin Exp $ + +(in-package :umlisp) + +(declaim (optimize (speed 3) (safety 1))) + +(defvar *current-srl* nil) +(defun current-srl () + *current-srl*) +(defun current-srl! (srl) + (setq *current-srl* srl)) + + +;;; Accessors (read on demand) + +;; defines a slot-unbound method for class and slot-name, fills +;; the slot by calling reader function with the slot values of +;; the instance's reader-keys +(defmacro def-lazy-reader (class slot-name reader &rest reader-keys) + (let* ((the-slot-name (gensym)) + (the-class (gensym)) + (the-instance (gensym)) + (keys '())) + (dolist (key reader-keys) + (push (list 'slot-value the-instance (list 'quote key)) keys)) + (setq keys (nreverse keys)) + `(defmethod slot-unbound (,the-class (,the-instance ,class) + (,the-slot-name (eql ',slot-name))) + (declare (ignore ,the-class)) + (setf (slot-value ,the-instance ,the-slot-name) + (,reader ,@keys))))) + +(def-lazy-reader ucon s#term find-uterm-cui cui) +(def-lazy-reader ucon s#def find-udef-cui cui) +(def-lazy-reader ucon s#sty find-usty-cui cui) +(def-lazy-reader ucon s#rel find-urel-cui cui) +(def-lazy-reader ucon s#coc find-ucoc-cui cui) +(def-lazy-reader ucon s#lo find-ulo-cui cui) +(def-lazy-reader ucon s#atx find-uatx-cui cui) +(def-lazy-reader ucon s#sat find-usat-ui cui) + +;; For uterms +(def-lazy-reader uterm s#str find-ustr-cuilui cui lui) +(def-lazy-reader uterm s#sat find-usat-ui cui lui) + +;; For ustrs +(def-lazy-reader ustr s#sat find-usat-ui cui lui sui) +(def-lazy-reader ustr s#cxt find-ucxt-cuisui cui sui) +(def-lazy-reader ustr s#so find-uso-cuisui cui sui) + +;;; Object lookups + +;;; Lookup functions for uterms,ustr in ucons + +(defun find-uterm-in-ucon (ucon lui) + (find lui (s#term ucon) :key #'uterm-lui :test 'equal)) + +(defun find-ustr-in-uterm (uterm sui) + (find sui (s#str uterm) :key #'ustr-sui :test 'equal)) + +(defun find-ustr-in-ucon (ucon sui) + (let ((found-ustr nil)) + (dolist (uterm (s#term ucon)) + (unless found-ustr + (dolist (ustr (s#str uterm)) + (unless found-ustr + (when (string-equal sui (sui ustr)) + (setq found-ustr ustr)))))) + found-ustr)) + + +(defun find-ucon-cui (cui &key (srl *current-srl*)) + "Find ucon for a cui" + (if (stringp cui) + (setq cui (parse-cui cui))) + (if cui + (let ((ls (format nil "select KPFSTR,KCUILRL from MRCON where CUI=~d" + cui))) + (if srl + (string-append ls (format nil " and KCUILRL <= ~d limit 1" srl)) + (string-append ls " limit 1")) + (gu:awhen (car (mutex-sql-query ls)) + (make-instance 'ucon :cui cui :pfstr (car gu::it) + :lrl (ensure-integer (cadr gu::it))))) + nil)) + +(defun find-ucon-lui (lui &key (srl *current-srl*)) + "Find list of ucon for lui" + (if (stringp lui) + (setq lui (parse-lui lui))) + (if lui + (let ((ucons '()) + (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where LUI=~d" lui))) + (if srl + (string-append ls (format nil " and KCUILRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple)) + :pfstr (nth 1 tuple) + :lrl (ensure-integer (nth 2 tuple))) + ucons)) + (nreverse ucons)) + nil)) + +(defun find-ucon-sui (sui &key (srl *current-srl*)) + "Find list of ucon for sui" + (if (stringp sui) + (setq sui (parse-sui sui))) + (if sui + (let ((ucons '()) + (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where SUI=~d" sui))) + (when srl + (string-append ls (format nil " and KCUILRL <= ~d" srl))) + (let ((tuples (mutex-sql-query ls))) + (dolist (tuple tuples) + (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple)) + :pfstr (nth 1 tuple) + :lrl (ensure-integer (nth 2 tuple))) + ucons))) + (nreverse ucons)) + nil)) + +(defun find-ucon-cuisui (cui sui &key (srl *current-srl*)) + "Find ucon for cui/sui" + (if (stringp cui) + (setq cui (parse-cui cui))) + (if (stringp sui) + (setq sui (parse-sui sui))) + (if (and cui sui) + (let ((ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where KCUISUI=~d" + (make-cuisui cui sui)))) + (when srl + (string-append ls (format nil " and KCUILRL <= ~d" srl))) + (gu:aif (car (mutex-sql-query ls)) + (make-instance 'ucon :cui (ensure-integer (nth 0 gu::it)) + :pfstr (nth 1 gu::it) + :lrl (ensure-integer (nth 2 gu::it))) + nil)) + nil)) + +(defun find-ucon-str (str &key (srl *current-srl*)) + "Find ucon that are exact match for str" + (if str + (let ((ucons '()) + (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where STR='~a'" str))) + (when srl + (string-append ls " and KCUILRL <= ~d" srl)) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple)) + :pfstr (nth 1 tuple) + :lrl (ensure-integer (nth 2 tuple))) ucons)) + (nreverse ucons)) + nil)) + +(defun find-ucon-all (&key (srl *current-srl*)) + "Return list of all ucon's" + (let ((ls "select distinct CUI,KPFSTR,KCUILRL from MRCON")) + (when srl + (string-append ls (format nil " where KCUILRL <= ~d" srl))) + (string-append ls " order by CUI asc") + (with-sql-connection (db) + (clsql:map-query + 'list + #'(lambda (cui pfstr cuilrl) + (make-instance 'ucon :cui (ensure-integer cui) + :pfstr pfstr + :lrl (ensure-integer cuilrl))) + ls + :database db)))) + + + +(defun find-udef-cui (cui &key (srl *current-srl*)) + "Return a list of udefs for cui" + (let ((udefs '()) + (ls (format nil "select SAB,DEF from MRDEF where CUI=~d" cui))) + (when srl + (string-append ls (format nil " and KSRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'udef :sab (car tuple) :def (cadr tuple)) udefs)) + (nreverse udefs))) + +(defun find-usty-cui (cui &key (srl *current-srl*)) + "Return a list of usty for cui" + (let ((ustys '()) + (ls (format nil "select TUI,STY from MRSTY where CUI=~d" cui))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'usty :tui (ensure-integer (car tuple)) :sty (cadr tuple)) ustys)) + ustys)) + +(defun find-usty-word (word &key (srl *current-srl*)) + "Return a list of usty that match word" + (let ((ustys '()) + (ls (format nil "select distinct TUI,STY from MRSTY where STY like '%~a%'" word))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'usty :tui (ensure-integer (car tuple)) :sty (cadr tuple)) ustys)) + ustys)) + +(defun find-urel-cui (cui &key (srl *current-srl*)) + "Return a list of urel for cui" + (let ((urels '()) + (ls (format nil "select REL,CUI2,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI1=~d" cui))) + (when srl + (string-append ls (format nil " and KSRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'urel + :cui1 cui + :rel (nth 0 tuple) + :cui2 (ensure-integer (nth 1 tuple)) + :rela (nth 2 tuple) + :sab (nth 3 tuple) + :sl (nth 4 tuple) + :mg (nth 5 tuple) + :pfstr2 (nth 6 tuple)) + urels)) + (nreverse urels))) + +(defun find-urel-cui2 (cui2 &key (srl *current-srl*)) + "Return a list of urel for cui2" + (let ((urels '()) + (ls (format nil "select REL,CUI1,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI2=~d" cui2))) + (when srl + (string-append ls (format nil " and SRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'urel + :cui2 cui2 + :rel (nth 0 tuple) + :cui1 (ensure-integer (nth 1 tuple)) + :rela (nth 2 tuple) + :sab (nth 3 tuple) + :sl (nth 4 tuple) + :mg (nth 5 tuple) + :pfstr2 (nth 6 tuple)) + urels)) + (nreverse urels))) + +(defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*)) + (mapcar + #'(lambda (cui) (find-ucon-cui cui :key srl)) + (remove-duplicates (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl))))) + +(defun find-ucoc-cui (cui &key (srl *current-srl*)) + "Return a list of ucoc for cui" + (let ((ucocs '()) + (ls (format nil "select CUI2,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI1=~d" cui))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (string-append ls " order by COF asc") + (dolist (tuple (mutex-sql-query ls)) + (let ((cui2 (ensure-integer (nth 0 tuple)))) + (when (zerop cui2) + (setq cui2 nil)) + (push (make-instance 'ucoc :cui1 cui + :cui2 cui2 + :soc (nth 1 tuple) + :cot (nth 2 tuple) + :cof (ensure-integer (nth 3 tuple)) + :coa (nth 4 tuple) + :pfstr2 (nth 5 tuple)) + ucocs))) + ucocs)) ;; akready ordered by SQL select + +(defun find-ucoc-cui2 (cui2 &key (srl *current-srl*)) + "Return a list of ucoc for cui2" + (let ((ucocs '()) + (ls (format nil "select CUI1,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI2=~d" cui2))) + (when srl + (string-append ls (format nil " and KSRL <= ~d" srl))) + (string-append ls " order by COF asc") + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'ucoc :cui1 (ensure-integer (nth 0 tuple)) + :cui2 cui2 + :soc (nth 1 tuple) + :cot (nth 2 tuple) + :cof (ensure-integer (nth 3 tuple)) + :coa (nth 4 tuple) + :pfstr2 (nth 5 tuple)) + ucocs)) + ucocs)) ;; already ordered by SQL select + +(defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*)) + "List of ucon with co-occurance cui2" + (mapcar + #'(lambda (cui) (find-ucon-cui cui :key srl)) + (remove-duplicates (mapcar #'cui1 (find-ucoc-cui2 cui2 :srl srl))))) + +(defun find-ulo-cui (cui &key (srl *current-srl*)) + "Return a list of ulo for cui" + (let ((ulos '()) + (ls (format nil "select ISN,FR,UN,SUI,SNA,SOUI from MRLO where CUI=~d" cui))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'ulo :isn (nth 0 tuple) + :fr (ensure-integer (nth 1 tuple)) + :un (nth 2 tuple) + :sui (ensure-integer (nth 3 tuple)) + :sna (nth 4 tuple) + :soui (nth 5 tuple)) + ulos)) + (nreverse ulos))) + +(defmethod suistr ((lo ulo)) + "Return the string for a ulo object" + (find-string-sui (sui lo))) + +(defun find-uatx-cui (cui &key (srl *current-srl*)) + "Return a list of uatx for cui" + (let ((uatxs '()) + (ls (format nil "select SAB,REL,ATX from MRATX where CUI=~d" cui))) + (when srl + (string-append ls (format nil " and KSRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'uatx :sab (nth 0 tuple) + :rel (nth 1 tuple) + :atx (nth 2 tuple)) + uatxs)) + (nreverse uatxs))) + + +(defun find-uterm-cui (cui &key (srl *current-srl*)) + "Return a list of uterm for cui" + (let ((uterms '()) + (ls (format nil "select distinct LUI,LAT,TS,KLUILRL from MRCON where CUI=~d" cui))) + (when srl + (string-append ls (format nil " and KLUILRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'uterm :lui (ensure-integer (nth 0 tuple)) + :cui cui + :lat (nth 1 tuple) + :ts (nth 2 tuple) + :lrl (ensure-integer (nth 3 tuple))) + uterms)) + (nreverse uterms))) + +(defun find-uterm-lui (lui &key (srl *current-srl*)) + "Return a list of uterm for lui" + (if (stringp lui) + (setq lui (parse-lui lui))) + (let ((uterms '()) + (ls (format nil "select distinct CUI,LAT,TS,KLUILRL from MRCON where LUI=~d" lui))) + (when srl + (string-append ls (format nil " and KLUILRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'uterm :cui (ensure-integer (nth 0 tuple)) + :lui lui + :lat (nth 1 tuple) + :ts (nth 2 tuple) + :lrl (ensure-integer (nth 3 tuple))) + uterms)) + (nreverse uterms))) + +(defun find-uterm-cuilui (cui lui &key (srl *current-srl*)) + "Return single uterm for cui/lui" + (let ((ls (format nil "select LAT,TS,KLUILRL from MRCON where KCUILUI=~d limit 1" (make-cuilui cui lui)))) + (when srl + (string-append ls (format nil " and KLUILRL <= ~d" srl))) + (gu:aif (car (mutex-sql-query ls)) + (make-instance 'uterm :cui cui + :lui lui + :lat (nth 0 gu::it) + :ts (nth 1 gu::it) + :lrl (ensure-integer (nth 2 gu::it))) + nil))) + +(defun find-ustr-cuilui (cui lui &key (srl *current-srl*)) + "Return a list of ustr for cui/lui" + (declare (fixnum cui lui)) + (let ((ustrs '()) + (ls (format nil "select SUI,STT,STR,LRL from MRCON where KCUILUI=~d" (make-cuilui cui lui)))) + (when srl + (string-append ls (format nil " and LRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (let* ((sui (ensure-integer (car tuple))) + (ustr (make-instance 'ustr :sui sui + :cui cui + :cuisui (make-cuisui cui sui) + :lui lui + :stt (nth 1 tuple) + :str (nth 2 tuple) + :lrl (ensure-integer (nth 3 tuple))))) + (push ustr ustrs))) + (nreverse ustrs))) + +(defun find-ustr-cuisui (cui sui &key (srl *current-srl*)) + "Return the single ustr for cuisui" + (let ((ls (format nil "select LUI,STT,STR,LRL from MRCON where KCUISUI=~d" + (make-cuisui cui sui)))) + (when srl + (string-append ls (format nil " and LRL <= ~d" srl))) + (gu:aif (car (mutex-sql-query ls)) + (make-instance 'ustr :sui sui + :cui cui + :cuisui (make-cuisui cui sui) + :lui (ensure-integer (nth 0 gu::it)) + :stt (nth 1 gu::it) + :str (nth 2 gu::it) + :lrl (ensure-integer (nth 3 gu::it))) + nil))) + +(defun find-ustr-sui (sui &key (srl *current-srl*)) + "Return the list of ustr for sui" + (if (stringp sui) + (setq sui (parse-sui sui))) + (let ((ustrs '()) + (ls (format nil "select CUI,LUI,STT,STR,LRL from MRCON where SUI=~d" sui))) + (when srl + (string-append ls (format nil " and LRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (let ((cui (ensure-integer (car tuple)))) + (push (make-instance 'ustr :sui sui + :cui cui + :cuisui (make-cuisui cui sui) + :lui (ensure-integer (nth 1 tuple)) + :stt (nth 2 tuple) + :str (nth 3 tuple) + :lrl (ensure-integer (nth 4 tuple))) + ustrs))) + (nreverse ustrs))) + +(defun find-ustr-sab (sab &key (srl *current-srl*)) + "Return the list of ustr for sab" + (let ((ustrs '()) + (ls (format nil "select KCUISUI from MRSO where SAB='~a'" sab))) + (when srl + (string-append ls (format nil " and SRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (let ((cuisui (ensure-integer (car tuple)))) + (push (apply #'find-ustr-cuisui + (append + (multiple-value-list (decompose-cuisui cuisui)) + (list :srl srl))) + ustrs))) + (nreverse ustrs))) + +(defun find-ustr-all (&key (srl *current-srl*)) + "Return list of all ustr's" + (let ((ls "select distinct CUI,LUI,SUI,STT,LRL,KPFSTR from MRCON")) + (when srl + (string-append ls (format nil " where LRL <= ~d" srl))) + (string-append ls " order by SUI asc") + (with-sql-connection (db) + (clsql:map-query + 'list + #'(lambda (cui lui sui stt lrl pfstr) + (setq cui (ensure-integer cui)) + (setq lui (ensure-integer lui)) + (setq sui (ensure-integer sui)) + (setq lrl (ensure-integer lrl)) + (make-instance 'ustr :cui cui + :lui lui + :sui sui + :cuisui (make-cuisui cui sui) + :stt stt + :lrl lrl + :str pfstr)) + ls + :database db)))) + +(defun find-string-sui (sui &key (srl *current-srl*)) + "Return the string associated with sui" + (let ((ls (format nil "select STR from MRCON where SUI=~d" sui))) + (when srl + (string-append ls (format nil " and LRL <= ~d" srl))) + (string-append ls " limit 1") + (caar (mutex-sql-query ls)))) + +(defun find-uso-cuisui (cui sui &key (srl *current-srl*)) + (declare (fixnum cui sui)) + (let ((usos '()) + (ls (format nil "select SAB,CODE,SRL,TTY from MRSO where KCUISUI=~d" + (make-cuisui cui sui)))) + (when srl + (string-append ls (format nil " and SRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'uso :sab (nth 0 tuple) :code (nth 1 tuple) + :srl (nth 2 tuple) :tty (nth 3 tuple)) + usos)) + (nreverse usos))) + +(defun find-ucxt-cuisui (cui sui &key (srl *current-srl*)) + (declare (fixnum cui sui)) + (let ((ucxts '()) + (ls (format nil "select SAB,CODE,CXN,CXL,RNK,CXS,CUI2,HCD,RELA,XC from MRCXT where KCUISUI=~d" + (make-cuisui cui sui)))) + (when srl + (string-append ls (format nil " and KSRL <= ~d" srl))) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'ucxt :sab (nth 0 tuple) + :code (nth 1 tuple) + :cxn (ensure-integer (nth 2 tuple)) + :cxl (nth 3 tuple) + :rnk (ensure-integer (nth 4 tuple)) + :cxs (nth 5 tuple) + :cui2 (ensure-integer (nth 6 tuple)) + :hcd (nth 7 tuple) + :rela (nth 8 tuple) + :xc (nth 9 tuple)) + ucxts)) + (nreverse ucxts))) + +(defun find-usat-ui (cui &optional (lui nil) (sui nil) &key (srl *current-srl*)) + (let ((ls (format nil "select CODE,ATN,SAB,ATV from MRSAT where "))) + (cond + (sui (string-append ls (format nil "KCUISUI=~d" (make-cuisui cui sui)))) + (lui (string-append ls (format nil "KCUILUI=~d and sui=0" (make-cuilui cui lui)))) + (t (string-append ls (format nil "cui=~d and lui=0 and sui=0" cui)))) + (when srl + (string-append ls (format nil " and KSRL <= ~d" srl))) + (let ((usats '())) + (dolist (tuple (mutex-sql-query ls)) + (push (make-instance 'usat :code (nth 0 tuple) + :atn (nth 1 tuple) + :sab (nth 2 tuple) + :atv (nth 3 tuple)) + usats)) + (nreverse usats)))) + + +(defun find-pfstr-cui (cui) + (caar (mutex-sql-query (format nil "select KPFSTR from MRCON where CUI=~d limit 1" cui)))) + +(defun find-usty-tui (tui) + "Find usty for tui" + (setq tui (parse-tui tui)) + (gu:aif (car (mutex-sql-query + (format nil "select STY from MRSTY where TUI=~d limit 1" tui))) + (make-instance 'usty :tui tui :sty (nth 0 gu::it)) + nil)) + +(defun find-usty-sty (sty) + "Find usty for a sty" + (gu:aif (car (mutex-sql-query + (format nil "select TUI from MRSTY where STY='~a' limit 1" sty))) + (make-instance 'usty :tui (ensure-integer (nth 0 gu::it)) :sty sty) + nil)) + +(defun find-usty-all () + "Return list of usty's for all semantic types" + (let ((ustys '())) + (dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY")) + (push (find-usty-tui (nth 0 tuple)) ustys)) + (nreverse ustys))) + +(defun find-usty_freq-all () + (let ((usty_freqs '())) + (dolist (tuple (mutex-sql-query "select distinct TUI from MRSTY")) + (let* ((tui (car tuple)) + (freq (ensure-integer + (caar (mutex-sql-query + (format nil "select count(*) from MRSTY where TUI=~a" tui)))))) + (push (make-instance 'usty_freq :usty (find-usty-tui tui) :freq freq) usty_freqs))) + (sort usty_freqs #'> :key #'usty_freq-freq))) + + + + +(defun find-cui-max () + (let ((cui (caar (mutex-sql-query "select max(CUI) from MRCON")))) + (ensure-integer cui))) + +;;;; Cross table find functions + +(defun find-ucon-tui (tui &key (srl *current-srl*)) + "Find list of ucon for tui" + (when (stringp tui) + (setq tui (parse-tui tui))) + (let ((ucons '()) + (ls (format nil "select CUI from MRSTY where TUI=~d" tui))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (string-append ls " order by cui desc") + (dolist (tuple (mutex-sql-query ls)) + (push (find-ucon-cui (ensure-integer (car tuple)) :srl srl) ucons)) + ucons)) + +(defun find-ucon-word (word &key (srl *current-srl*) (like nil)) + "Return list of ucons that match word. Optionally, use SQL's LIKE syntax" + (let ((ucons '()) + (ls (format nil "select distinct cui from MRXW_ENG where wd~A'~A'" + (if like " LIKE " "=") + word))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (string-append ls " order by cui desc") + (dolist (tuple (mutex-sql-query ls)) + (push (find-ucon-cui (car tuple) :srl srl) ucons)) + ucons)) + +(defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil)) + "Return list of ucons that match word, optionally use SQL's LIKE syntax" + (let ((ucons '()) + (ls (format nil "select distinct cui from MRXNW_ENG where nwd~A'~A'" + (if like " LIKE " "=") + word))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (string-append ls " order by cui desc") + (dolist (tuple (mutex-sql-query ls)) + (push (find-ucon-cui (car tuple) :srl srl) ucons)) + ucons)) + +(defun find-ustr-word (word &key (srl *current-srl*)) + "Return list of ustrs that match word" + (let ((ustrs '()) + (ls (format nil "select cui,sui from MRXW_ENG where wd='~a'" word))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (string-append ls " order by cui desc,sui desc") + (dolist (tuple (mutex-sql-query ls)) + (push (find-ustr-cuisui (ensure-integer (car tuple)) (ensure-integer (cadr tuple)) :srl srl) + ustrs)) + ustrs)) + +(defun find-ustr-normalized-word (word &key (srl *current-srl*)) + "Return list of ustrs that match word" + (let ((ustrs '()) + (ls (format nil "select cui,sui from MRXNW_ENG where nwd='~a'" word))) + (when srl + (string-append ls (format nil " and KLRL <= ~d" srl))) + (string-append ls " order by cui desc,sui desc") + (dolist (tuple (mutex-sql-query ls)) + (push (find-ustr-cuisui (ensure-integer (car tuple)) (ensure-integer (cadr tuple)) :srl srl) + ustrs)) + ustrs)) + + +;;; Multiword lookup and score functions + +(defun find-ucon-multiword (str &key (srl *current-srl*)) + "Return sorted list of ucon's that match a multiword string" + (let* ((words (delimited-string-to-list str #\space)) + (ucons '())) + (dolist (word words) + (setq ucons (append ucons (find-ucon-word word :srl srl)))) + (sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui)))) + +(defun find-ucon-normalized-multiword (str &key (srl *current-srl*)) + "Return sorted list of ucon's that match a multiword string" + (let* ((words (delimited-string-to-list str #\space)) + (ucons '()) + (nwords '())) + (dolist (word words) + (let ((nws (lvg:process-terms word))) + (dolist (nword nws) + (push nword nwords)))) + (dolist (word nwords) + (setq ucons (append ucons (find-ucon-word word :srl srl)))) + (sort-score-ucon-str str (delete-duplicates ucons :test #'eql :key #'cui)))) + +(defun find-ustr-multiword (str &key (srl *current-srl*)) + "Return sorted list of ustr's that match a multiword string" + (let* ((words (delimited-string-to-list str #\space)) + (ustrs '())) + (dolist (word words) + (setq ustrs (append ustrs (find-ustr-word word :srl srl)))) + (sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'cui)))) + +(defun find-ustr-normalized-multiword (str &key (srl *current-srl*)) + "Return sorted list of ustr's that match a multiword string" + (let* ((words (delimited-string-to-list str #\space)) + (ustrs '()) + (nwords '())) + (dolist (word words) + (let ((nws (lvg:process-terms word))) + (dolist (nword nws) + (push nword nwords)))) + (dolist (word nwords) + (setq ustrs (append ustrs (find-ustr-word word :srl srl)))) + (sort-score-ustr-str str (delete-duplicates ustrs :test #'eql :key #'ustr-cui)))) + +(defun a (str) + (find-normalized-matches-for-str str #'find-ustr-normalized-word #'ustr-sui)) + +(defun find-normalized-matches-for-str (str lookup-func key-func) + "Return list of objects that normalize match for words in string, +eliminate duplicates." + (let ((objs '()) + (nwords '())) + (dolist (word (delimited-string-to-list str #\space)) + (dolist (nword (lvg:process-terms word)) + (unless (member nword nwords :test #'string-equal) + (push nword nwords)))) + (dolist (nw nwords) + (setq objs (append objs (funcall lookup-func nw)))) + (delete-duplicates objs :key key-func :test #'eql))) + +(defun sort-score-ucon-str (str ucons) + "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr" + (sort-score-umlsclass-str ucons str #'pfstr)) + +(defun sort-score-ustr-str (str ustrs) + "Return list of sorted and scored ucons. Score by match of str to ucon-pfstr" + (sort-score-umlsclass-str ustrs str #'str)) + +(defun sort-score-umlsclass-str (objs str lookup-func) + "Sort a list of objects based on scoring to a string" + (let ((scored '())) + (dolist (obj objs) + (push + (list obj + (score-multiword-match str (funcall lookup-func obj))) + scored)) + (mapcar #'car (sort scored #'> :key #'cadr)))) + +(defun score-multiword-match (s1 s2) + "Score a match between two strings with s1 being reference string" + (let* ((word-list-1 (delimited-string-to-list s1 #\space)) + (word-list-2 (delimited-string-to-list s2 #\space)) + (n1 (length word-list-1)) + (n2 (length word-list-2)) + (unmatched n1) + (score 0) + (nlong 0) + (nshort 0) + short-list long-list) + (declare (fixnum n1 n2 nshort nlong score unmatched)) + (if (> n1 n2) + (progn + (setq nlong n1) + (setq nshort n2) + (setq long-list word-list-1) + (setq short-list word-list-2)) + (progn + (setq nlong n2) + (setq nshort n1) + (setq long-list word-list-2) + (setq short-list word-list-1))) + (decf score (- nlong nshort)) ;; reduce score for extra words + (dotimes (iword nshort) + (declare (fixnum iword)) + (gu:aif (position (nth iword short-list) long-list :test #'string-equal) + (progn + (incf score (- 10 (abs (- gu::it iword)))) + (decf unmatched)))) + (decf score (* 2 unmatched)) + score)) + + +;;; LEX SQL functions + +(defun find-lexterm-eui (eui) + (gu:awhen (car (mutex-sql-query + (format nil "select WRD from LRWD where EUI=~d" eui))) + (make-instance 'lexterm :eui eui :wrd (nth 0 gu:it)))) + +(defun find-lexterm-word (wrd) + (gu:awhen (mutex-sql-query + (format nil "select EUI from LRWD where WRD='~a'" wrd)) + (let ((terms '())) + (dolist (tuple gu:it) + (let ((eui (ensure-integer (nth 0 tuple)))) + (push + (make-instance 'lexterm :eui eui :wrd (copy-seq wrd)) + terms))) + (nreverse terms)))) + +;; LEXTERM accessors, read on demand + +(def-lazy-reader lexterm s#abr find-labr-eui eui) +(def-lazy-reader lexterm s#agr find-lagr-eui eui) +(def-lazy-reader lexterm s#cmp find-lcmp-eui eui) +(def-lazy-reader lexterm s#mod find-lmod-eui eui) +(def-lazy-reader lexterm s#nom find-lnom-eui eui) +(def-lazy-reader lexterm s#prn find-lprn-eui eui) +(def-lazy-reader lexterm s#prp find-lprp-eui eui) +(def-lazy-reader lexterm s#spl find-lspl-eui eui) +(def-lazy-reader lexterm s#trm find-ltrm-eui eui) +(def-lazy-reader lexterm s#typ find-ltyp-eui eui) + +;; LEX SQL Read functions + +(defun find-labr-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,ABR,EUI2,BAS2 from LRABR where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'labr :eui eui + :bas (nth 0 tuple) + :abr (nth 1 tuple) + :eui2 (ensure-integer (nth 2 tuple)) + :bas2 (nth 3 tuple)) + results)) + (nreverse results)))) + +(defun find-labr-bas (bas) + (gu:awhen (mutex-sql-query + (format nil "select EUI,ABR,EUI2,BAS2 from LRABR where BAS='~a'" bas)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'labr :eui (ensure-integer (nth 0 tuple)) + :bas (copy-seq bas) + :abr (nth 1 tuple) + :eui2 (ensure-integer (nth 2 tuple)) + :bas2 (nth 3 tuple)) + results)) + (nreverse results)))) + +(defun find-lagr-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select STR,SCA,AGR,CIT,BAS from LRAGR where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'lagr + :eui eui + :str (nth 0 tuple) + :sca (nth 1 tuple) + :agr (nth 2 tuple) + :cit (nth 3 tuple) + :bas (nth 4 tuple)) + results)) + (nreverse results)))) + +(defun find-lcmp-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,SCA,COM from LRCMP where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'lcmp + :eui eui + :bas (nth 0 tuple) + :sca (nth 1 tuple) + :com (nth 2 tuple)) + results)) + (nreverse results)))) + +(defun find-lmod-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,SCA,PSN_MOD,FEA from LRMOD where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'lmod + :eui eui + :bas (nth 0 tuple) + :sca (nth 1 tuple) + :psnmod (nth 2 tuple) + :fea (nth 3 tuple)) + results)) + (nreverse results)))) + +(defun find-lnom-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,SCA,EUI2,BAS2,SCA2 from LRNOM where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'lnom + :eui eui + :bas (nth 0 tuple) + :sca (nth 1 tuple) + :eui2 (ensure-integer (nth 2 tuple)) + :bas2 (nth 3 tuple) + :sca2 (nth 4 tuple)) + results)) + (nreverse results)))) + +(defun find-lprn-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,NUM,GND,CAS,POS,QNT,FEA from LRPRN where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'lprn + :eui eui + :bas (nth 0 tuple) + :num (nth 1 tuple) + :gnd (nth 2 tuple) + :cas (nth 3 tuple) + :pos (nth 4 tuple) + :qnt (nth 5 tuple) + :fea (nth 6 tuple)) + results)) + (nreverse results)))) + +(defun find-lprp-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,STR,SCA,FEA from LRPRP where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'lprp + :eui eui + :bas (nth 0 tuple) + :str (nth 1 tuple) + :sca (nth 2 tuple) + :fea (nth 3 tuple)) + results)) + (nreverse results)))) + +(defun find-lspl-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select SPV,BAS from LRSPL where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'lspl + :eui eui + :spv (nth 0 tuple) + :bas (nth 1 tuple)) + results)) + (nreverse results)))) + + +(defun find-ltrm-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,GEN from LRTRM where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'ltrm + :eui eui + :bas (nth 0 tuple) + :gen (nth 1 tuple)) + results)) + (nreverse results)))) + +(defun find-ltyp-eui (eui) + (gu:awhen (mutex-sql-query + (format nil "select BAS,SCA,TYP from LRTYP where EUI=~d" eui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'ltyp + :eui eui + :bas (nth 0 tuple) + :sca (nth 1 tuple) + :typ (nth 2 tuple)) + results)) + (nreverse results)))) + +(defun find-lwd-wrd (wrd) + (gu:awhen (mutex-sql-query + (format nil "select EUI from LRWD where WRD='~a'" wrd)) + (let ((results '())) + (dolist (tuple gu::it) + (push (ensure-integer (nth 0 tuple)) results)) + (make-instance 'lwd :wrd wrd + :euilist (nreverse results))))) + +;;; Semantic Network SQL access functions + +(defun find-sdef-ui (ui) + (gu:awhen (car (mutex-sql-query + (format nil "select RT,STY_RL,STN_RTN,DEF,EX,UN,RH,ABR,RIN from SRDEF where UI=~d" ui))) + (make-instance 'sdef :rt (nth 0 gu::it) + :ui ui + :styrl (nth 1 gu::it) + :stnrtn (nth 2 gu::it) + :def (nth 3 gu::it) + :ex (nth 4 gu::it) + :un (nth 5 gu::it) + :rh (nth 6 gu::it) + :abr (nth 7 gu::it) + :rin (nth 8 gu::it)))) + +(defun find-sstre1-ui (ui) + (gu:awhen (mutex-sql-query + (format nil "select UI2,UI3 from SRSTRE1 where UI=~d" ui)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'sstre1 :ui ui + :ui2 (ensure-integer (nth 0 tuple)) + :ui3 (ensure-integer (nth 1 tuple))) + results)) + (nreverse results)))) + +(defun find-sstre1-ui2 (ui2) + (gu:awhen (mutex-sql-query + (format nil "select UI,UI3 from SRSTRE1 where UI2=~d" ui2)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'sstre1 :ui (ensure-integer (nth 0 tuple)) + :ui2 ui2 + :ui3 (ensure-integer (nth 1 tuple))) + results)) + (nreverse results)))) + +(defun find-sstr-rl (rl) + (gu:awhen (mutex-sql-query + (format nil "select STY_RL,STY_RL2,LS from SRSTRE where RL='~a'" rl)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'sstr + :rl rl + :styrl (nth 0 tuple) + :styrl2 (nth 1 tuple) + :ls (nth 2 tuple)) + results)) + (nreverse results)))) + + +(defun find-sstre2-sty (sty) + (gu:awhen (mutex-sql-query + (format nil "select RL,STY2 from SRSTRE2 where STY='~a'" sty)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'sstre2 + :sty (copy-seq sty) + :rl (nth 0 tuple) + :sty2 (nth 1 tuple)) + results)) + (nreverse results)))) + +(defun find-sstr-styrl (styrl) + (gu:awhen (mutex-sql-query + (format nil "select RL,STY_RL2,LS from SRSTR where RL='~a'" styrl)) + (let ((results '())) + (dolist (tuple gu::it) + (push + (make-instance 'sstr :styrl styrl + :rl (nth 0 tuple) + :styrl2 (nth 1 tuple) + :ls (nth 2 tuple)) + results)) + (nreverse results)))) + + diff --git a/sql.lisp b/sql.lisp index 3a71e36..7e5ce88 100644 --- a/sql.lisp +++ b/sql.lisp @@ -1,7 +1,7 @@ ;;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Pkg: umlisp -*- ;; SQL/UMLS database Layer over database backend ;; Copyright (c) 2001 Kevin M. Rosenberg, M.D. -;; $Id: sql.lisp,v 1.1 2002/10/05 20:17:14 kevin Exp $ +;; $Id: sql.lisp,v 1.2 2002/10/08 22:13:41 kevin Exp $ (in-package :umlisp) @@ -14,14 +14,14 @@ (sql-disconnect-pooled) (setq *umls-sql-dsn* dbname)) -(defvar *umls-sql-user* "webumls") +(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* "webumls") +(defvar *umls-sql-passwd* "secret") (defun umls-sql-passwd () *umls-sql-passwd*) (defun umls-sql-passwd! (p) diff --git a/umlisp.asd b/umlisp.asd index 368ce84..b83899c 100644 --- a/umlisp.asd +++ b/umlisp.asd @@ -1,5 +1,5 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; $Id: umlisp.asd,v 1.1 2002/10/05 20:17:14 kevin Exp $ +;;;; $Id: umlisp.asd,v 1.2 2002/10/08 22:08:56 kevin Exp $ (in-package :asdf) @@ -12,7 +12,7 @@ (:file "parse-macros" :depends-on ("sql")) (:file "parse-2002" :depends-on ("parse-macros")) (:file "parse-common" :depends-on ("parse-2002")) - (:file "obj" :depends-on ("utils")) - (:file "obj-sql" :depends-on ("obj" "sql")) - (:file "obj-composite" :depends-on ("obj-sql")))) + (:file "classes" :depends-on ("utils")) + (:file "sql-classes" :depends-on ("classes" "sql")) + (:file "composite" :depends-on ("sql-classes"))))