;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: sql-classes.lisp,v 1.15 2003/05/02 07:09:07 kevin Exp $
+;;;; $Id: sql-classes.lisp,v 1.16 2003/05/02 18:47:53 kevin Exp $
;;;;
;;;; This file, part of UMLisp, is
;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
;;;; *************************************************************************
(in-package :umlisp)
-(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))
+(declaim (optimize (compilation-speed 0) (debug 3)))
(defvar *current-srl* nil)
(setq found-ustr ustr))))))
found-ustr))
+(defun umlisp-query (table fields srl where-name where-value
+ &key (lrlname "KCUILRL") final)
+ "Query the UMLisp database. Return a list of umlisp objects whose name
+is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
+ (when where-value
+ (mutex-sql-query
+ (query-string table fields srl where-name where-value lrlname final))))
+
+
+(defun query-string (table fields &optional srl where-name where-value
+ (lrlname "KCUILRL") final)
+ (let ((qs (format nil "select ~{~:@(~A~)~^,~} from ~:@(~A~)" fields table)))
+ (when where-name
+ (setq qs (concatenate 'string qs
+ (format nil
+ (if (stringp where-value)
+ " where ~A='~A'"
+ " where ~A=~A")
+ where-name where-value))))
+ (when srl
+ (setq qs (concatenate 'string qs (format nil " and ~:@(~A~) <= ~D"
+ lrlname srl))))
+ (when final
+ (setq qs (concatenate 'string qs " " final)))
+ qs))
(defun find-ucon-cui (cui &key (srl *current-srl*))
+ "Find ucon for a cui"
+ (loop
+ (for tuple in (umlisp-query 'mrcon '(kpfstr kcuilrl) srl
+ 'cui (parse-cui cui) :final "limit 1")
+ collect
+ (make-instance 'ucon :cui (parse-cui cui)
+ :pfstr (car tuple)
+ :lrl (ensure-integer (cadr tuple))))))
+
+(defun find-ucon-cui-old (cui &key (srl *current-srl*))
"Find ucon for a cui"
(when (stringp cui) (setq cui (parse-cui cui)))
(when cui
- (let ((ls (format nil "select KPFSTR,KCUILRL from MRCON where CUI=~d" cui)))
- (when srl
- (string-append ls (format nil " and KCUILRL <= ~d" srl)))
- (string-append ls " limit 1")
+ (let ((ls
+ (maybe-add-srl
+ (format nil "select KPFSTR,KCUILRL from MRCON where CUI=~d" cui)
+ srl :final "limit 1")))
(awhen (car (mutex-sql-query ls))
(make-instance 'ucon :cui cui :pfstr (car it)
:lrl (ensure-integer (cadr it)))))))
"Find ucon for a cui"
(when (stringp cui) (setq cui (parse-cui cui)))
(when cui
- (let ((ls (format nil "select KCUILRL from MRCON where CUI=~d" cui)))
- (when srl
- (string-append ls (format nil " and KCUILRL <= ~d" srl)))
- (string-append ls " limit 1")
+ (let ((ls (maybe-add-srl
+ (format nil "select KCUILRL from MRCON where CUI=~d" cui)
+ srl :final "limit 1")))
(awhen (car (mutex-sql-query ls))
(make-instance 'ucon :cui cui
:lrl (ensure-integer (car it))
(defun find-pfstr-cui (cui &key (srl *current-srl*))
"Find preferred string for a cui"
- (when (stringp cui)
- (setq cui (parse-cui cui)))
+ (when (stringp cui) (setq cui (parse-cui cui)))
(when cui
- (let ((ls (format nil "select KPFSTR from MRCON where CUI=~d" cui)))
- (when srl
- (string-append ls (format nil " and KCUILRL <= ~d" srl)))
- (string-append ls " limit 1")
+ (let ((ls (maybe-add-srl
+ (format nil "select KPFSTR from MRCON where CUI=~d" cui)
+ srl :final "limit 1")))
(awhen (car (mutex-sql-query ls))
(car it)))))
(when (stringp lui) (setq lui (parse-lui lui)))
(when 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)))
+ (ls
+ (maybe-add-srl
+ (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where LUI=~d" lui)
+ srl)))
(dolist (tuple (mutex-sql-query ls))
(destructuring-bind (cui pfstr lrl) tuple
(push (make-instance 'ucon :cui (ensure-integer cui)
(when (stringp sui) (setq sui (parse-sui sui)))
(when 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)))
+ (ls (maybe-add-srl
+ (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where SUI=~d" sui)
+ srl)))
(let ((tuples (mutex-sql-query ls)))
(dolist (tuple tuples)
(destructuring-bind (cui pfstr lrl) tuple
(when (stringp cui) (setq cui (parse-cui cui)))
(when (stringp sui) (setq sui (parse-sui sui)))
(when (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)))
+ (let ((ls
+ (maybe-add-srl
+ (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where KCUISUI=~d"
+ (make-cuisui cui sui))
+ srl)))
(awhen (car (mutex-sql-query ls))
(destructuring-bind (cui pfstr lrl) it
(make-instance 'ucon :cui (ensure-integer cui)
"Find ucon that are exact match for str"
(when 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))
+ (ls (maybe-add-srl
+ (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where STR='~a'" str)
+ srl)))
(dolist (tuple (mutex-sql-query ls))
(destructuring-bind (cui pfstr lrl) tuple
(push (make-instance 'ucon :cui (ensure-integer cui)
(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)))
+ (let ((ls (maybe-add-srl "select distinct CUI,KPFSTR,KCUILRL from MRCON"
+ srl)))
(string-append ls " order by CUI asc")
(with-sql-connection (db)
(clsql:map-query
(defun map-ucon-all (fn &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")
+ (let ((ls (maybe-add-srl "select distinct CUI,KPFSTR,KCUILRL from MRCON"
+ srl :final "order by CUI asc")))
(with-sql-connection (db)
(clsql:map-query
nil
(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)))
+ (ls (maybe-add-srl
+ (format nil "select SAB,DEF from MRDEF where CUI=~d" cui)
+ srl :var "KSRL")))
(dolist (tuple (mutex-sql-query ls))
(destructuring-bind (sab def) tuple
(push (make-instance 'udef :sab sab :def def) 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)))
+ (ls (maybe-add-srl
+ (format nil "select TUI,STY from MRSTY where CUI=~d" cui)
+ srl :var "KLRL")))
(dolist (tuple (mutex-sql-query ls))
(destructuring-bind (tui sty) tuple
(push (make-instance 'usty :tui (ensure-integer tui) :sty sty) 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)))
+ (ls (maybe-add-srl
+ (format nil "select distinct TUI,STY from MRSTY where STY like '%~a%'" word)
+ srl :var "KLRL")))
(dolist (tuple (mutex-sql-query ls))
(destructuring-bind (tui sty) tuple
(push (make-instance 'usty :tui (ensure-integer tui) :sty sty) 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)))
+ (ls (maybe-add-srl
+ (format nil "select REL,CUI2,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI1=~d" cui)
+ srl :var "KSRL")))
(dolist (tuple (mutex-sql-query ls))
(destructuring-bind (rel cui2 rela sab sl mg pfstr2) tuple
(push (make-instance 'urel
(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)))
+ (ls (maybe-add-srl
+ (format nil "select REL,CUI1,RELA,SAB,SL,MG,KPFSTR2 from MRREL where CUI2=~d" cui2)
+ srl :var "SRL")))
(dolist (tuple (mutex-sql-query ls))
(destructuring-bind (rel cui1 rela sab sl mg pfstr2) tuple
(push (make-instance 'urel
(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")
+ (ls (maybe-add-srl
+ (format nil "select CUI2,SOC,COT,COF,COA,KPFSTR2 from MRCOC where CUI1=~d" cui)
+ srl :var "KLRL" :final "order by COF asc")))
(dolist (tuple (mutex-sql-query ls))
(destructuring-bind (cui2 soc cot cof coa pfstr2) tuple
(setq cui2 (ensure-integer cui2))
projects / umlisp.git / blobdiff