parse-2002.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          parse-2002.lisp
   6 ;;;; Purpose:       Parsing and SQL insertion routines for UMLisp which may
   7 ;;;;                change from year to year
   8 ;;;; Author:        Kevin M. Rosenberg
   9 ;;;; Date Started:  Apr 2000
  10 ;;;;
  11 ;;;; $Id: parse-2002.lisp,v 1.14 2003/06/11 01:42:03 kevin Exp $
  12 ;;;;
  13 ;;;; This file, part of UMLisp, is
  14 ;;;;    Copyright (c) 2000-2003 by Kevin M. Rosenberg, M.D.
  15 ;;;;
  16 ;;;; UMLisp users are granted the rights to distribute and use this software
  17 ;;;; as governed by the terms of the GNU General Public License.
  18 ;;;; *************************************************************************
  19
  20 (in-package #:umlisp)
  21
  22 (eval-when (:compile-toplevel)
  23   (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
  24
  25 ;;; Pre-read data for custom fields into hash tables
  26 (defvar *preparse-hash-init?* nil)
  27
  28 (eval-when (:compile-toplevel :load-toplevel :execute)
  29 (let ((pfstr-hash nil)      ;;; Preferred concept strings by CUI
  30       (cui-lrl-hash nil)    ;;; LRL by CUI
  31       (lui-lrl-hash nil)    ;;; LRL by LUI
  32       (cuisui-lrl-hash nil) ;;; LRL by CUISUI
  33       (sab-srl-hash nil))   ;;; SRL by SAB
  34
  35   (defun make-preparse-hash-table ()
  36     (if pfstr-hash
  37         (progn
  38           (clrhash pfstr-hash)
  39           (clrhash cui-lrl-hash)
  40           (clrhash lui-lrl-hash)
  41           (clrhash cuisui-lrl-hash)
  42           (clrhash sab-srl-hash))
  43       (setf
  44           pfstr-hash (make-hash-table :size 800000)
  45           cui-lrl-hash (make-hash-table :size 800000)
  46           lui-lrl-hash (make-hash-table :size 1500000)
  47           cuisui-lrl-hash (make-hash-table :size 1800000)
  48           sab-srl-hash (make-hash-table :size 100 :test 'equal))))
  49
  50   (defun buffered-ensure-preparse (&optional (force-read nil))
  51     (when (or force-read (not *preparse-hash-init?*))
  52       (make-preparse-hash-table)
  53       (setq *preparse-hash-init?* t))
  54     (with-buffered-umls-file (line "MRCON")
  55       (let ((cui (parse-ui (aref line 0)))
  56             (lui (parse-ui (aref line 3)))
  57             (sui (parse-ui (aref line 5)))
  58             (lrl (parse-integer (aref line 7))))
  59         (unless (gethash cui pfstr-hash)  ;; if haven't stored pfstr for cui
  60           (if (and (string-equal (aref line 1) "ENG") ; LAT
  61                    (string-equal (aref line 2) "P") ; ts
  62                    (string-equal (aref line 4) "PF")) ; stt
  63               (setf (gethash cui pfstr-hash) (aref line 6))))
  64         (set-lrl-hash cui lrl cui-lrl-hash)
  65         (set-lrl-hash lui lrl lui-lrl-hash)
  66         (set-lrl-hash (make-cuisui cui sui) lrl cuisui-lrl-hash)))
  67     (with-buffered-umls-file (line "MRSO")
  68       (let ((sab (aref line 3)))
  69         (unless (gethash sab sab-srl-hash)  ;; if haven't stored
  70           (setf (gethash sab sab-srl-hash) (aref line 6))))))
  71
  72   (defun ensure-preparse (&optional (force-read nil))
  73     (when (or force-read (not *preparse-hash-init?*))
  74       (make-preparse-hash-table)
  75       (setq *preparse-hash-init?* t))
  76     (with-umls-file (line "MRCON")
  77       (let ((cui (parse-ui (nth 0 line)))
  78             (lui (parse-ui (nth 3 line)))
  79             (sui (parse-ui (nth 5 line)))
  80             (lrl (parse-integer (nth 7 line))))
  81         (unless (gethash cui pfstr-hash)  ;; if haven't stored pfstr for cui
  82           (if (and (string-equal (nth 1 line) "ENG") ; LAT
  83                    (string-equal (nth 2 line) "P") ; ts
  84                    (string-equal (nth 4 line) "PF")) ; stt
  85               (setf (gethash cui pfstr-hash) (nth 6 line))))
  86         (set-lrl-hash cui lrl cui-lrl-hash)
  87         (set-lrl-hash lui lrl lui-lrl-hash)
  88         (set-lrl-hash (make-cuisui cui sui) lrl cuisui-lrl-hash)))
  89     (with-umls-file (line "MRSO")
  90       (let ((sab (nth 3 line)))
  91         (multiple-value-bind (val found) (gethash sab sab-srl-hash)
  92           (declare (ignore val))
  93           (unless found
  94             (setf (gethash sab sab-srl-hash) (parse-integer (nth 6 line))))))))
  95
  96   (defun pfstr-hash (cui)
  97     (gethash cui pfstr-hash))
  98
  99   (defun cui-lrl (cui)
 100     (gethash cui cui-lrl-hash))
 101
 102   (defun lui-lrl (lui)
 103     (gethash lui lui-lrl-hash))
 104
 105   (defun cuisui-lrl (cuisui)
 106     (gethash cuisui cuisui-lrl-hash))
 107
 108   (defun sab-srl (sab)
 109     (aif (gethash sab sab-srl-hash) it 0))
 110 )) ;; closure
 111
 112 (defun set-lrl-hash (key lrl hash)
 113   "Set the least restrictive level in hash table"
 114   (multiple-value-bind (hash-lrl found) (gethash key hash)
 115     (if (or (not found) (< lrl hash-lrl))
 116         (setf (gethash key hash) lrl))))
 117
 118 ;; UMLS file and column structures
 119 ;;; SQL datatypes symbols
 120 ;;; sql-u - Unique identifier
 121 ;;; sql-s - Small integer (16-bit)
 122 ;;; sql-i - Integer (32-bit)
 123 ;;; sql-l - Big integer (64-bit)
 124 ;;; sql-f - Floating point
 125
 126 (defparameter +col-datatypes+
 127     '(("AV" sql-f) ("BTS" sql-i) ("CLS" sql-i) ("COF" sql-i) ("CUI1" sql-u)
 128       ("CUI2" sql-u) ("CUI" sql-u) ("CXN" sql-s) ("FR" sql-i) ("LRL" sql-s)
 129       ("LUI" sql-u) ("MAX" sql-s) ("MIN" sql-s) ("RANK" sql-s) ("REF" sql-s)
 130       ("RNK" sql-s) ("RWS" sql-i) ("SRL" sql-s) ("SUI" sql-u) ("TUI" sql-u)
 131       ;;; Custom columns
 132       ("KCUISUI" sql-l) ("KCUILUI" sql-l) ("KCUILRL" sql-i) ("KLUILRL" sql-i)
 133       ("KSRL" sql-i) ("KLRL" sql-i)
 134       ;;; LEX columns
 135       ("EUI" sql-u) ("EUI2" sql-u)
 136       ;;; Semantic net columns
 137       ("UI" sql-u) ("UI2" sql-u) ("UI3" sql-u)
 138       ;; New fields for 2002AD
 139       ("RCUI" sql-u) ("VCUI" sql-u) ("CFR" sql-i) ("TFR" sql-i)
 140       )
 141     "SQL data types for each non-string column")
 142
 143 (defparameter +custom-tables+
 144     nil
 145   #+ignore
 146   '(("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")
 147     ("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"))
 148   "Custom tables to create")
 149
 150 (defparameter +custom-cols+
 151     '(("MRCON" "KPFSTR" "TEXT" 1024
 152                (lambda (x) (pfstr-hash (parse-ui (nth 0 x)))))
 153       ("MRCON" "KCUISUI" "BIGINT" 0
 154        (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 5 x))))))
 155       ("MRCON" "KCUILUI" "BIGINT" 0
 156        (lambda (x) (write-to-string (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 3 x))))))
 157       ("MRCON" "KCUILRL" "INTEGER" 0
 158        (lambda (x) (write-to-string (cui-lrl (parse-ui (nth 0 x))))))
 159       ("MRCON" "KLUILRL" "INTEGER" 0
 160        (lambda (x) (write-to-string (lui-lrl (parse-ui (nth 3 x))))))
 161       ("MRLO" "KLRL" "INTEGER" 0
 162        (lambda (x) (write-to-string
 163                     (if (zerop (length (nth 4 x)))
 164                         (cui-lrl (parse-ui (nth 0 x)))
 165                       (cuisui-lrl (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 4 x))))))))
 166       ("MRSTY" "KLRL" "INTEGER" 0
 167        (lambda (x) (write-to-string (cui-lrl (parse-ui (nth 0 x))))))
 168       ("MRCOC" "KLRL" "INTEGER" 0
 169        (lambda (x) (write-to-string
 170                     (max (cui-lrl (parse-ui (nth 0 x)))
 171                          (kmrcl:aif (cui-lrl (parse-ui (nth 1 x))) kmrcl::it 0)))))
 172       ("MRSAT" "KSRL" "INTEGER" 0
 173        (lambda (x) (write-to-string (sab-srl (nth 5 x)))))
 174       ("MRREL" "KSRL" "INTEGER" 0
 175        (lambda (x) (write-to-string (sab-srl (nth 4 x)))))
 176       ("MRRANK" "KSRL" "INTEGER" 0
 177        (lambda (x) (write-to-string (sab-srl (nth 1 x)))))
 178       ("MRDEF" "KSRL" "INTEGER" 0
 179        (lambda (x) (write-to-string (sab-srl (nth 1 x)))))
 180       ("MRCXT" "KSRL" "INTEGER" 0
 181        (lambda (x) (write-to-string (sab-srl (nth 2 x)))))
 182       ("MRATX" "KSRL" "INTEGER" 0
 183        (lambda (x) (write-to-string (sab-srl (nth 1 x)))))
 184       ("MRXW.ENG" "KLRL" "INTEGER" 0
 185        (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
 186                                                  (parse-ui (nth 2 x))
 187                                                  (parse-ui (nth 4 x)))))))
 188       ("MRXW.NONENG" "KLRL" "INTEGER" 0
 189        (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
 190                                                  (parse-ui (nth 2 x))
 191                                                  (parse-ui (nth 4 x)))))))
 192       ("MRXNW.ENG" "KLRL" "INTEGER" 0
 193        (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
 194                                                  (parse-ui (nth 2 x))
 195                                                  (parse-ui (nth 4 x)))))))
 196       ("MRXNS.ENG" "KLRL" "INTEGER" 0
 197        (lambda (x) (write-to-string (cuisui-lrl (make-cuisui
 198                                                  (parse-ui (nth 2 x))
 199                                                  (parse-ui (nth 4 x)))))))
 200       ("MRREL" "KPFSTR2" "TEXT" 1024
 201        (lambda (x) (pfstr-hash (parse-ui (nth 2 x)))))
 202       ("MRCOC" "KPFSTR2" "TEXT" 1024
 203        (lambda (x) (pfstr-hash (parse-ui (nth 1 x)))))
 204       ("MRCXT" "KCUISUI" "BIGINT" 0
 205        (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
 206       ("MRSAT" "KCUILUI" "BIGINT" 0
 207        (lambda (x) (write-to-string (make-cuilui (parse-ui (nth 0 x)) (parse-ui (nth 1 x))))))
 208       ("MRSAT" "KCUISUI" "BIGINT" 0
 209        (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 2 x))))))
 210       ("MRSO" "KCUISUI" "BIGINT" 0
 211        (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 0 x)) (parse-ui (nth 2 x))))))
 212       ("MRXW.ENG" "KCUISUI" "BIGINT" 0
 213        (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
 214       ("MRXNW.ENG" "KCUISUI" "BIGINT" 0
 215        (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
 216       ("MRXNS.ENG" "KCUISUI" "BIGINT" 0
 217        (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x))))))
 218       ("MRXW.NONENG" "LAT" "CHAR" 3 (lambda (x) (nth 0 x)))
 219       ("MRXW.NONENG" "WD"  "CHAR" 200  (lambda (x) (nth 1 x)))
 220       ("MRXW.NONENG" "CUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 2 x)))))
 221       ("MRXW.NONENG" "LUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 3 x)))))
 222       ("MRXW.NONENG" "SUI" "INTEGER" 0 (lambda (x) (write-to-string (parse-ui (nth 4 x)))))
 223       ("MRXW.NONENG" "KCUISUI" "BIGINT" 0
 224        (lambda (x) (write-to-string (make-cuisui (parse-ui (nth 2 x)) (parse-ui (nth 4 x)))))))
 225   "Custom columns to create.(filename, col, sqltype, value-func).")
 226
 227 (defparameter +index-cols+
 228     '(("CUI" "MRATX") ("CUI1" "MRCOC") ("CUI" "MRCON") ("LUI" "MRCON")
 229       ("LRL" "MRCON")
 230       ("SUI" "MRCON") ("CUI" "MRCXT") ("CUI" "MRDEF") ("CUI" "MRLO")
 231       ("CUI1" "MRREL") ("CUI" "MRSAT") ("LUI" "MRSAT") ("SUI" "MRSAT")
 232       ("CUI" "MRSO") ("SAB" "MRSO") ("SRL" "MRSO") ("CUI" "MRSTY")
 233       ("TUI" "MRSTY") ("CUI" "MRXNS_ENG") ("NSTR" "MRXNS_ENG" 10)
 234       ("CUI" "MRXNW_ENG") ("NWD" "MRXNW_ENG") ("WD" "MRXW_ENG")
 235       ("KCUISUI" "MRCON") ("KCUILUI" "MRCON") ("KCUILRL" "MRCON")
 236       ("KLUILRL" "MRCON") ("KCUISUI" "MRCXT")
 237       ("KCUISUI" "MRSO") ("KCUISUI" "MRSAT")  ("KCUILUI" "MRSAT")
 238       ("KCUISUI" "MRXW_ENG") ("KCUISUI" "MRXNW_ENG")
 239       ("KCUISUI" "MRXNS_ENG") ("KCUISUI" "MRXW_NONENG")
 240       ("KSRL" "MRATX") ("KSRL" "MRCXT") ("KSRL" "MRDEF") ("KSRL" "MRRANK")
 241       ("KSRL" "MRREL") ("KSRL" "MRSAT") ("KLRL" "MRCOC")
 242       ("KLRL" "MRLO") ("KLRL" "MRSTY") ("KLRL" "MRXW_ENG") ("KLRL" "MRXNW_ENG")
 243       ("KLRL" "MRXNS_ENG") ("KLRL" "MRXW_NONENG")
 244       ;; LEX indices
 245       ("EUI" "LRABR") ("EUI2" "LRABR") ("EUI" "LRAGR") ("EUI" "LRCMP") ("EUI" "LRMOD")
 246       ("EUI" "LRNOM") ("EUI2" "LRNOM") ("EUI" "LRPRN") ("EUI" "LRPRP") ("EUI" "LRSPL")
 247       ("EUI" "LRTRM") ("EUI" "LRTYP") ("EUI" "LRWD") ("WRD" "LRWD")
 248       ("BAS" "LRABR")
 249       ;; Semantic NET indices
 250       ("UI" "SRSTRE1") ("UI2" "SRSTRE1") ("UI3" "SRSTRE1")
 251       ("STY_RL" "SRDEF") ("RT" "SRDEF") ("STY_RL" "SRSTR") ("STY_RL2" "SRSTR")
 252       ("RL" "SRSTR")
 253       ("SRL" "MRSAB") ("RSAB" "MRSAB") ("VSAB" "MRSAB") ("RCUI" "MRSAB")
 254       ("VCUI" "MRSAB") ("LAT" "MRSAB"))
 255   "Columns in files to index")
 256
 257 (defvar +relationship-abbreviations+
 258   '(("RB" "Broader" "has a broader relationship")
 259     ("RN" "Narrower" "has a narrower relationship")
 260     ("RO" "Other related" "has relationship other than synonymous, narrower, or broader")
 261     ("RL" "Like" "the two concepts are similar or 'alike'.  In the current edition of the Metathesaurus, most relationships with this attribute are mappings provided by a source")
 262     ("RQ" "Unspecified" "unspecified source asserted relatedness, possibly synonymous")
 263     ("SY" "Source Synonymy" "source asserted synonymy")
 264     ("PAR" "Parent" "has parent relationship in a Metathesaurus source vocabulary")
 265     ("CHD" "Child" "has child relationship in a Metathesaurus source vocabulary")
 266     ("SIB" "Sibling" "has sibling relationship in a Metathesaurus source vocabulary")
 267     ("AQ" "Allowed" "is an allowed qualifier for a concept in a Metathesaurus source vocabulary")
 268     ("QB" "Qualified" "can be qualified by a concept in a Metathesaurus source vocabulary")))
 269
 270 (defparameter +custom-index-cols+
 271   nil
 272   #+ignore
 273   '(("CUI" "MRCONFULL") ("SAB" "MRCONFULL") ("TUI" "MRCONFULL"))
 274   "Indexes to custom tables")
 275
 276 ;; File & Column functions
 277
 278 (defun gen-ucols ()
 279   (add-ucols (gen-ucols-meta))
 280   (add-ucols (gen-ucols-custom))
 281   (add-ucols (gen-ucols-generic "LRFLD"))
 282   (add-ucols (gen-ucols-generic "SRFLD")))
 283
 284 (defun gen-ucols-meta ()
 285 "Initialize all umls columns"
 286   (let ((cols '()))
 287     (with-umls-file (line "MRCOLS")
 288       (destructuring-bind (col des ref min av max fil dty) line
 289         (push (make-ucol col des ref (parse-integer min) (read-from-string av)
 290                          (parse-integer max) fil dty)
 291               cols)))
 292     (nreverse cols)))
 293
 294 (defun gen-ucols-custom ()
 295 "Initialize umls columns for custom columns"
 296   (loop for customcol in +custom-cols+
 297         collect
 298         (make-ucol (nth 1 customcol) "" 0 0 0 (nth 3 customcol)
 299                    (nth 0 customcol) nil :sqltype (nth 2 customcol)
 300                    :custom-value-fun (nth 4 customcol))))
 301
 302 (defun gen-ucols-generic (col-filename)
 303 "Initialize for generic (LEX/NET) columns"
 304   (let ((cols '()))
 305     (with-umls-file (line col-filename)
 306       (destructuring-bind (nam des ref fil) line
 307         (setq nam (escape-column-name nam))
 308         (dolist (file (delimited-string-to-list fil #\,))
 309           (push
 310            (make-ucol nam des ref nil nil nil file nil)
 311            cols))))
 312     (nreverse cols)))
 313
 314
 315 (defun gen-ufiles ()
 316   (add-ufiles (gen-ufiles-generic "MRFILES"))
 317   (add-ufiles (gen-ufiles-generic "LRFIL"))
 318   (add-ufiles (gen-ufiles-generic "SRFIL"))
 319   ;; needs to come last
 320   (add-ufiles (gen-ufiles-custom)))
 321
 322
 323 (defun gen-ufiles-generic (files-filename)
 324 "Initialize all LEX file structures"
 325   (let ((files '()))
 326     (with-umls-file (line files-filename)
 327       (destructuring-bind (fil des fmt cls rws bts) line
 328         (push (make-ufile
 329                fil des (substitute #\_ #\. fil) (parse-integer cls)
 330                (parse-integer rws) (parse-integer bts)
 331                (concatenate 'list (umls-field-string-to-list fmt)
 332                             (custom-colnames-for-filename fil)))
 333               files)))
 334     (nreverse files)))
 335
 336 (defun gen-ufiles-custom ()
 337   (make-ufile "MRXW.NONENG" "Custom NonEnglish Index" "MRXW_NONENG"
 338               5 0 0 (fields (find-ufile "MRXW.ENG"))))
 339
 340
 341