--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: parse-2002.lisp
+;;;; Purpose: Parsing and SQL insertion routines for UMLisp which may
+;;;; change from year to year
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
+;;;;
+;;;; $Id$
+;;;;
+;;;; This file, part of UMLisp, is
+;;;; Copyright (c) 2000-2004 by Kevin M. Rosenberg, M.D.
+;;;;
+;;;; UMLisp users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License.
+;;;; *************************************************************************
+
+(in-package #:umlisp-orf)
+
+;;; Pre-read data for custom fields into hash tables
+(defvar *preparse-hash-init?* nil)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(let ((pfstr-hash nil) ;;; Preferred concept strings by CUI
+ (cui-lrl-hash nil) ;;; LRL by CUI
+ (lui-lrl-hash nil) ;;; LRL by LUI
+ (cuisui-lrl-hash nil) ;;; LRL by CUISUI
+ (sab-srl-hash nil)) ;;; SRL by SAB
+
+ (defun make-preparse-hash-table ()
+ (if pfstr-hash
+ (progn
+ (clrhash pfstr-hash)
+ (clrhash cui-lrl-hash)
+ (clrhash lui-lrl-hash)
+ (clrhash cuisui-lrl-hash)
+ (clrhash sab-srl-hash))
+ (setf
+ pfstr-hash (make-hash-table :size 800000)
+ cui-lrl-hash (make-hash-table :size 800000)
+ lui-lrl-hash (make-hash-table :size 1500000)
+ cuisui-lrl-hash (make-hash-table :size 1800000)
+ sab-srl-hash (make-hash-table :size 100 :test 'equal))))
+
+ (defun buffered-ensure-preparse (&optional (force-read nil))
+ (when (or force-read (not *preparse-hash-init?*))
+ (make-preparse-hash-table)
+ (setq *preparse-hash-init?* t))
+ (with-buffered-umls-file (line "MRCON")
+ (let ((cui (parse-ui (aref line 0)))
+ (lui (parse-ui (aref line 3)))
+ (sui (parse-ui (aref line 5)))
+ (lrl (parse-integer (aref line 7))))
+ (unless (gethash cui pfstr-hash) ;; if haven't stored pfstr for cui
+ (if (and (string-equal (aref line 1) "ENG") ; LAT
+ (string-equal (aref line 2) "P") ; ts
+ (string-equal (aref line 4) "PF")) ; stt
+ (setf (gethash cui pfstr-hash) (aref line 6))))
+ (set-lrl-hash cui lrl cui-lrl-hash)
+ (set-lrl-hash lui lrl lui-lrl-hash)
+ (set-lrl-hash (make-cuisui cui sui) lrl cuisui-lrl-hash)))
+ (with-buffered-umls-file (line "MRSO")
+ (let ((sab (aref line 3)))
+ (unless (gethash sab sab-srl-hash) ;; if haven't stored
+ (setf (gethash sab sab-srl-hash) (aref line 6))))))
+
+ (defun ensure-preparse (&optional (force-read nil))
+ (when (or force-read (not *preparse-hash-init?*))
+ (make-preparse-hash-table)
+ (setq *preparse-hash-init?* t))
+ (with-umls-file (line "MRCON")
+ (let ((cui (parse-ui (nth 0 line)))
+ (lui (parse-ui (nth 3 line)))
+ (sui (parse-ui (nth 5 line)))
+ (lrl (parse-integer (nth 7 line))))
+ (unless (gethash cui pfstr-hash) ;; if haven't stored pfstr for cui
+ (if (and (string-equal (nth 1 line) "ENG") ; LAT
+ (string-equal (nth 2 line) "P") ; ts
+ (string-equal (nth 4 line) "PF")) ; stt
+ (setf (gethash cui pfstr-hash) (nth 6 line))))
+ (set-lrl-hash cui lrl cui-lrl-hash)
+ (set-lrl-hash lui lrl lui-lrl-hash)
+ (set-lrl-hash (make-cuisui cui sui) lrl cuisui-lrl-hash)))
+ (with-umls-file (line "MRSO")
+ (let ((sab (nth 3 line)))
+ (multiple-value-bind (val found) (gethash sab sab-srl-hash)
+ (declare (ignore val))
+ (unless found
+ (setf (gethash sab sab-srl-hash) (parse-integer (nth 6 line))))))))
+
+ (defun pfstr-hash (cui)
+ (gethash cui pfstr-hash))
+
+ (defun cui-lrl (cui)
+ (gethash cui cui-lrl-hash))
+
+ (defun lui-lrl (lui)
+ (gethash lui lui-lrl-hash))
+
+ (defun cuisui-lrl (cuisui)
+ (gethash cuisui cuisui-lrl-hash))
+
+ (defun sab-srl (sab)
+ (aif (gethash sab sab-srl-hash) it 0))
+)) ;; closure
+
+(defun set-lrl-hash (key lrl hash)
+ "Set the least restrictive level in hash table"
+ (multiple-value-bind (hash-lrl found) (gethash key hash)
+ (if (or (not found) (< lrl hash-lrl))
+ (setf (gethash key hash) lrl))))
+
+;; UMLS file and column structures
+;;; SQL datatypes symbols
+;;; sql-u - Unique identifier
+;;; sql-s - Small integer (16-bit)
+;;; sql-i - Integer (32-bit)
+;;; sql-l - Big integer (64-bit)
+;;; sql-f - Floating point
+;;; sql-c - Character data
+
+(defparameter +col-datatypes+
+ '(("AV" sql-f) ("BTS" sql-i) ("CLS" sql-i) ("COF" sql-i) ("CUI1" sql-u)
+ ("CUI2" sql-u) ("CUI" sql-u) ("CXN" sql-s) ("FR" sql-i) ("LRL" sql-s)
+ ("LUI" sql-u) ("MAX" sql-s) ("MIN" sql-s) ("RANK" sql-s) ("REF" sql-c)
+ ("RNK" sql-s) ("RWS" sql-i) ("SRL" sql-s) ("SUI" sql-u) ("TUI" sql-u)
+ ;;; Custom columns
+ ("KCUISUI" sql-l) ("KCUILUI" sql-l) ("KCUILRL" sql-i) ("KLUILRL" sql-i)
+ ("KSRL" sql-i) ("KLRL" sql-i)
+ ;;; LEX columns
+ ("EUI" sql-u) ("EUI2" sql-u)
+ ;;; Semantic net columns
+ ("UI" sql-u) ("UI2" sql-u) ("UI3" sql-u)
+ ;; New fields for 2002AD
+ ("RCUI" sql-u) ("VCUI" sql-u) ("CFR" sql-i) ("TFR" sql-i)
+ )
+ "SQL data types for each non-string column")
+
+(defparameter +custom-tables+
+ nil
+ #+ignore
+ '(("MRCONSO" "SELECT m.CUI, m.LAT, m.TS, m.LUI, m.STT, m.SUI, m.STR, m.LRL, s.SAB, s.TTY, s.SCD, s.SRL FROM MRCON m, MRSO s WHERE m.CUI=s.CUI AND m.LUI=s.LUI AND m.SUI=s.SUI")
+ ("MRCONFULL" "SELECT m.CUI, m.LAT, m.TS, m.LUI, m.STT, m.SUI, m.STR, m.LRL, s.SAB, s.TTY, s.SCD, s.SRL, t.TUI FROM MRCON m, MRSO s, MRSTY t WHERE m.CUI=s.CUI AND m.LUI=s.LUI AND m.SUI=s.SUI AND m.CUI=t.CUI AND s.CUI=t.CUI"))
+ "Custom tables to create")
+
+(defparameter +custom-cols+
+ '(("MRCON" "KPFSTR" "TEXT" 1024
+ (lambda (x) (pfstr-hash (parse-ui (nth 0 x)))))
+ ("MRCON" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 5 x))))))
+ ("MRCON" "KCUILUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 3 x))))))
+ ("MRCON" "KCUILRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cui-lrl (parse-ui (nth 0 x))))))
+ ("MRCON" "KLUILRL" "INTEGER" 0
+ (lambda (x) (write-to-string (lui-lrl (parse-ui (nth 3 x))))))
+ ("MRLO" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string
+ (if (zerop (length (nth 4 x)))
+ (cui-lrl (parse-ui (nth 0 x)))
+ (cuisui-lrl (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 4 x))))))))
+ ("MRSTY" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cui-lrl (parse-ui (nth 0 x))))))
+ ("MRCOC" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string
+ (max (cui-lrl (parse-ui (nth 0 x)))
+ (kmrcl:aif (cui-lrl (parse-ui (nth 1 x))) kmrcl::it 0)))))
+ ("MRSAT" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 5 x)))))
+ ("MRREL" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 4 x)))))
+ ("MRRANK" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 1 x)))))
+ ("MRDEF" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 1 x)))))
+ ("MRCXT" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 2 x)))))
+ ("MRATX" "KSRL" "INTEGER" 0
+ (lambda (x) (write-to-string (sab-srl (nth 1 x)))))
+ ("MRXW.ENG" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
+ ("MRXW.NONENG" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
+ ("MRXNW.ENG" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
+ ("MRXNS.ENG" "KLRL" "INTEGER" 0
+ (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
+ (parse-ui (nth 2 x))
+ (parse-ui (nth 4 x)))))))
+ ("MRREL" "KPFSTR2" "TEXT" 1024
+ (lambda (x) (pfstr-hash (parse-ui (nth 2 x)))))
+ ("MRCOC" "KPFSTR2" "TEXT" 1024
+ (lambda (x) (pfstr-hash (parse-ui (nth 1 x)))))
+ ("MRCXT" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
+ ("MRSAT" "KCUILUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
+ ("MRSAT" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 2 x))))))
+ ("MRSO" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 2 x))))))
+ ("MRXW.ENG" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
+ ("MRXNW.ENG" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
+ ("MRXNS.ENG" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
+ ("MRXW.NONENG" "LAT" "VARCHAR" 3 (lambda (x) (nth 0 x)))
+ ("MRXW.NONENG" "WD" "VARCHAR" 200 (lambda (x) (nth 1 x)))
+ ("MRXW.NONENG" "CUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 2 x)))))
+ ("MRXW.NONENG" "LUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 3 x)))))
+ ("MRXW.NONENG" "SUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 4 x)))))
+ ("MRXW.NONENG" "KCUISUI" "BIGINT" 0
+ (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x)))))))
+ "Custom columns to create.(filename, col, sqltype, value-func).")
+
+(defparameter +index-cols+
+ '(("CUI" "MRATX") ("CUI1" "MRCOC") ("CUI" "MRCON") ("LUI" "MRCON")
+ ("LRL" "MRCON")
+ ("SUI" "MRCON") ("CUI" "MRCXT") ("CUI" "MRDEF") ("CUI" "MRLO")
+ ("CUI1" "MRREL") ("CUI" "MRSAT") ("LUI" "MRSAT") ("SUI" "MRSAT")
+ ("CUI" "MRSO") ("SAB" "MRSO") ("SRL" "MRSO") ("CUI" "MRSTY")
+ ("TUI" "MRSTY") ("CUI" "MRXNS_ENG")
+ #+ignore ("NSTR" "MRXNS_ENG" 10)
+ ("CUI" "MRXNW_ENG") ("NWD" "MRXNW_ENG") ("WD" "MRXW_ENG")
+ ("KCUISUI" "MRCON") ("KCUILUI" "MRCON") ("KCUILRL" "MRCON")
+ ("KLUILRL" "MRCON") ("KCUISUI" "MRCXT")
+ ("KCUISUI" "MRSO") ("KCUISUI" "MRSAT") ("KCUILUI" "MRSAT")
+ ("KCUISUI" "MRXW_ENG") ("KCUISUI" "MRXNW_ENG")
+ ("KCUISUI" "MRXNS_ENG") ("KCUISUI" "MRXW_NONENG")
+ ("KSRL" "MRATX") ("KSRL" "MRCXT") ("KSRL" "MRDEF") ("KSRL" "MRRANK")
+ ("KSRL" "MRREL") ("KSRL" "MRSAT") ("KLRL" "MRCOC")
+ ("KLRL" "MRLO") ("KLRL" "MRSTY") ("KLRL" "MRXW_ENG") ("KLRL" "MRXNW_ENG")
+ ("KLRL" "MRXNS_ENG") ("KLRL" "MRXW_NONENG")
+ ;; LEX indices
+ ("EUI" "LRABR") ("EUI2" "LRABR") ("EUI" "LRAGR") ("EUI" "LRCMP") ("EUI" "LRMOD")
+ ("EUI" "LRNOM") ("EUI2" "LRNOM") ("EUI" "LRPRN") ("EUI" "LRPRP") ("EUI" "LRSPL")
+ ("EUI" "LRTRM") ("EUI" "LRTYP") ("EUI" "LRWD") ("WRD" "LRWD")
+ ("BAS" "LRABR")
+ ;; Semantic NET indices
+ ("UI" "SRSTRE1") ("UI2" "SRSTRE1") ("UI3" "SRSTRE1")
+ ("STY_RL" "SRDEF") ("RT" "SRDEF") ("STY_RL" "SRSTR") ("STY_RL2" "SRSTR")
+ ("RL" "SRSTR")
+ ("SRL" "MRSAB") ("RSAB" "MRSAB") ("VSAB" "MRSAB") ("RCUI" "MRSAB")
+ ("VCUI" "MRSAB") ("LAT" "MRSAB"))
+ "Columns in files to index")
+
+
+(defparameter +custom-index-cols+
+ nil
+ #+ignore
+ '(("CUI" "MRCONFULL") ("SAB" "MRCONFULL") ("TUI" "MRCONFULL"))
+ "Indexes to custom tables")
+
+;; File & Column functions
+
+(defun gen-ucols ()
+ (add-ucols (gen-ucols-meta))
+ (add-ucols (gen-ucols-custom))
+ (add-ucols (gen-ucols-generic "LRFLD"))
+ (add-ucols (gen-ucols-generic "SRFLD")))
+
+(defun gen-ucols-meta ()
+"Initialize all umls columns"
+ (let ((cols '()))
+ (with-umls-file (line "MRCOLS")
+ (destructuring-bind (col des ref min av max fil dty) line
+ (push (make-ucol col des ref (parse-integer min) (read-from-string av)
+ (parse-integer max) fil dty)
+ cols)))
+ (nreverse cols)))
+
+(defun gen-ucols-custom ()
+"Initialize umls columns for custom columns"
+ (loop for customcol in +custom-cols+
+ collect
+ (make-ucol (nth 1 customcol) "" 0 0 0 (nth 3 customcol)
+ (nth 0 customcol) nil :sqltype (nth 2 customcol)
+ :custom-value-fun (nth 4 customcol))))
+
+(defun gen-ucols-generic (col-filename)
+"Initialize for generic (LEX/NET) columns"
+ (let ((cols '()))
+ (with-umls-file (line col-filename)
+ (destructuring-bind (nam des ref fil) line
+ (setq nam (escape-column-name nam))
+ (dolist (file (delimited-string-to-list fil #\,))
+ (push
+ (make-ucol nam des ref nil nil nil file nil)
+ cols))))
+ (nreverse cols)))
+
+
+(defun gen-ufiles ()
+ (add-ufiles (gen-ufiles-generic "MRFILES"))
+ (add-ufiles (gen-ufiles-generic "LRFIL"))
+ (add-ufiles (gen-ufiles-generic "SRFIL"))
+ ;; needs to come last
+ (add-ufiles (gen-ufiles-custom)))
+
+
+(defun gen-ufiles-generic (files-filename)
+"Initialize all LEX file structures"
+ (let ((files '()))
+ (with-umls-file (line files-filename)
+ (destructuring-bind (fil des fmt cls rws bts) line
+ (push (make-ufile
+ fil des (substitute #\_ #\. fil) (parse-integer cls)
+ (parse-integer rws) (parse-integer bts)
+ (concatenate 'list (umls-field-string-to-list fmt)
+ (custom-colnames-for-filename fil)))
+ files)))
+ (nreverse files)))
+
+(defun gen-ufiles-custom ()
+ (make-ufile "MRXW.NONENG" "Custom NonEnglish Index" "MRXW_NONENG"
+ 5 0 0 (fields (find-ufile "MRXW.ENG"))))
+
+
+
projects / umlisp-orf.git / blobdiff