X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql-classes.lisp;h=08d16cffbcc720cef635fe63c1104d30ad7f8d48;hb=9933fa3041681062c104cb9459f4d8c5d111c810;hp=e954fe83278928f9ce63085d1a07b7047c038b6d;hpb=32c52aa77759462004f83129200dca3b0a916766;p=umlisp.git diff --git a/sql-classes.lisp b/sql-classes.lisp index e954fe8..08d16cf 100644 --- a/sql-classes.lisp +++ b/sql-classes.lisp @@ -7,7 +7,7 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: sql-classes.lisp,v 1.20 2003/05/03 00:27:30 kevin Exp $ +;;;; $Id: sql-classes.lisp,v 1.27 2003/05/03 19:53:59 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. @@ -56,34 +56,45 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" :lrlname lrlname :single single :distinct distinct :order order :like like)))) +(defmacro query-string-macro (table fields &optional srl where-name where-value + &key (lrlname "KCUILRL") single distinct order like) + (let* ((%%fields (format nil "select ~A~{~:@(~A~)~^,~}" + (if distinct "distinct " "") (quote fields))) + (%%order (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}" order) ""))) + `(concatenate + 'string + (format nil "select ~A from ~:@(~A~)" ,%%fields ,table) + (if ,where-name + (format nil + (if (stringp ,where-value) + (if like + " where ~A like '%~A%'" + " where ~A='~A'") + " where ~A=~A") + ,where-name ,where-value) + "") + (if ,srl (format nil " and ~:@(~A~) <= ~D" ,lrlname ,srl) "") + ,%%order + (if ,single " limit 1" "")))) + (defun query-string (table fields &optional srl where-name where-value &key (lrlname "KCUILRL") single distinct order like) - (let ((qs (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)" - (if distinct "distinct " "") - fields table))) - (when where-name - (setq qs (concatenate 'string qs - (format nil - (if (stringp where-value) - (if like - " where ~A like '%~A%'" - " 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 order - (setq qs (concatenate 'string qs - (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}" - (flatten - (loop for o in order collect - (if (atom o) - (list o 'asc) - (list (car o) (cdr o))))))))) - (when single - (setq qs (concatenate 'string qs " limit 1"))) - qs)) + (concatenate + 'string + (format nil "select ~A~{~:@(~A~)~^,~} from ~:@(~A~)" + (if distinct "distinct " "") fields table) + (if where-name + (format nil + (if (stringp where-value) + (if like + " where ~A like '%~A%'" + " where ~A='~A'") + " where ~A=~A") + where-name where-value) + "") + (if srl (format nil " and ~:@(~A~) <= ~D" lrlname srl) "") + (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}" order) "") + (if single " limit 1" ""))) (defun find-ucon-cui (cui &key (srl *current-srl*)) "Find ucon for a cui" @@ -92,6 +103,18 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" :pfstr kpfstr :lrl (ensure-integer kcuilrl)))) +(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") + (awhen (car (mutex-sql-query ls)) + (destructuring-bind (kpfstr kcuilrl) + (make-instance 'ucon :cui cui :pfstr kpfstr + :lrl (ensure-integer kcuilrl))))))) (defun find-ucon-cui-sans-pfstr (cui &key (srl *current-srl*)) "Find ucon for a cui" @@ -134,24 +157,6 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (make-instance 'ucon :cui (ensure-integer cui) :pfstr kpfstr :lrl (ensure-integer kcuilrl)))) -(defun f2 (&key (srl *current-srl*)) - "Return list of all ucon's" - (with-umlisp-query ('mrcon (cui kpfstr kcuilrl) srl nil nil) - (make-instance 'ucon :cui (ensure-integer cui) :pfstr kpfstr - :lrl (ensure-integer kcuilrl)))) - -(defun f1 (&key (srl *current-srl*)) - "Return list of all ucon's" - (with-sql-connection (db) - (clsql:map-query - 'list - #'(lambda (cui pfstr cuilrl) - (make-instance 'ucon :cui (ensure-integer cui) - :pfstr pfstr - :lrl (ensure-integer cuilrl))) - (query-string 'mrcon '(cui kpfstr kcuilrl) srl nil nil) - :database db))) - (defun find-ucon-all (&key (srl *current-srl*)) "Return list of all ucon's" (with-sql-connection (db) @@ -162,7 +167,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" :pfstr pfstr :lrl (ensure-integer cuilrl))) (query-string 'mrcon '(cui kpfstr kcuilrl) srl nil nil - :order '((cui . asc)) :distinct t) + :order '(cui asc) :distinct t) :database db))) (defun map-ucon-all (fn &key (srl *current-srl*)) @@ -175,7 +180,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (make-instance 'ucon :cui (ensure-integer cui) :pfstr pfstr :lrl (ensure-integer cuilrl)))) - (query-string 'mrcon '(cui kpfstr kcuilrl) srl nil nil :order '((cui . asc)) :distinct t) + (query-string 'mrcon '(cui kpfstr kcuilrl) srl nil nil :order '(cui asc) :distinct t) :database db))) @@ -214,7 +219,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-ucoc-cui (cui &key (srl *current-srl*)) "Return a list of ucoc for cui" (with-umlisp-query ('mrcoc (cui2 soc cot cof coa kpfstr2) srl 'cui1 (parse-cui cui) - :lrlname "KSRL" :order '((cof . asc))) + :lrlname "KSRL" :order '(cof asc)) (setq cui2 (ensure-integer cui2)) (when (zerop cui2) (setq cui2 nil)) (make-instance 'ucoc :cui1 (parse-cui cui) :cui2 (ensure-integer cui2) :soc soc :cot cot @@ -223,7 +228,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-ucoc-cui2 (cui2 &key (srl *current-srl*)) "Return a list of ucoc for cui2" (with-umlisp-query ('mrcoc (cui1 soc cot cof coa kpfstr2) srl 'cui2 (parse-cui cui2) - :lrlname "KSRL" :order '((cof . asc))) + :lrlname "KSRL" :order '(cof asc)) (setq cui2 (ensure-integer cui2)) (when (zerop cui2) (setq cui2 nil)) (make-instance 'ucoc :cui1 (ensure-integer cui1) :cui2 (parse-cui cui2) :soc soc :cot cot @@ -320,7 +325,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" :lrl lrl :str pfstr)) (query-string 'mrcon '(cui lui sui stt lrl kpfstr) srl nil nil :lrlname 'lrl :distinct t - :order '((sui . asc))) + :order '(sui asc)) :database db))) (defun find-string-sui (sui &key (srl *current-srl*)) @@ -411,38 +416,39 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS" (defun find-ucon-tui (tui &key (srl *current-srl*)) "Find list of ucon for tui" - (with-umlisp-query ('mrsty (cui) srl 'tui (parse-tui tui) :lrlname 'klrl :order '((cui . asc))) + (with-umlisp-query ('mrsty (cui) srl 'tui (parse-tui tui) :lrlname 'klrl + :order '(cui asc)) (find-ucon-cui (ensure-integer cui) :srl srl))) (defun find-ucon-word (word &key (srl *current-srl*) (like nil)) "Return list of ucons that match word. Optionally, use SQL's LIKE syntax" (with-umlisp-query ('mrxw_eng (cui) srl 'wd word :like like :distinct t - :lrlname 'klrl :order '((cui . asc))) + :lrlname 'klrl :order '(cui asc)) (find-ucon-cui cui :srl srl))) (defun find-ucon-normalized-word (word &key (srl *current-srl*) (like nil)) "Return list of ucons that match word, optionally use SQL's LIKE syntax" (with-umlisp-query ('mrxnw_eng (cui) srl 'nwd word :like like :distinct t - :lrlname 'klrl :order '((cui . asc))) + :lrlname 'klrl :order '(cui asc)) (find-ucon-cui cui :srl srl))) (defun find-ustr-word (word &key (srl *current-srl*)) "Return list of ustrs that match word" (with-umlisp-query ('mrxw_eng (cui sui) srl 'wd word :lrlname 'klrl - :order '((cui . asc) (sui . asc))) + :order '(cui asc sui asc)) (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl))) (defun find-ustr-normalized-word (word &key (srl *current-srl*)) "Return list of ustrs that match word" (with-umlisp-query ('mrxnw_eng (cui sui) srl 'nwd word :lrlname 'klrl - :order '((cui . asc) (sui . asc))) + :order '(cui asc sui asc)) (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) :srl srl))) ;; Special tables (defun find-usrl-all () - (with-umlisp-query ('usrl (sab srl) nil nil nil :order '((sab . asc))) + (with-umlisp-query ('usrl (sab srl) nil nil nil :order '(sab asc)) (make-instance 'usrl :sab sab :srl (ensure-integer srl)))) ;;; Multiword lookup and score functions