+++ /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.git / blobdiff