+(defun remove-english-terms (uterms)
+ (remove-if #'english-term-p uterms))
+
+
+(defvar +relationship-abbreviations+
+ '(("RB" "Broader" "has a broader relationship")
+ ("RN" "Narrower" "has a narrower relationship")
+ ("RO" "Other related" "has relationship other than synonymous, narrower, or broader")
+ ("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")
+ ("RQ" "Unspecified" "unspecified source asserted relatedness, possibly synonymous")
+ ("SY" "Source Synonymy" "source asserted synonymy")
+ ("PAR" "Parent" "has parent relationship in a Metathesaurus source vocabulary")
+ ("CHD" "Child" "has child relationship in a Metathesaurus source vocabulary")
+ ("SIB" "Sibling" "has sibling relationship in a Metathesaurus source vocabulary")
+ ("AQ" "Allowed" "is an allowed qualifier for a concept in a Metathesaurus source vocabulary")
+ ("QB" "Qualified" "can be qualified by a concept in a Metathesaurus source vocabulary")))
+
+(defvar *rel-info-table* (make-hash-table :size 30 :test 'equal))
+(defvar *is-rel-table-init* nil)
+(unless *is-rel-table-init*
+ (dolist (relinfo +relationship-abbreviations+)
+ (setf (gethash (string-downcase (car relinfo)) *rel-info-table*)
+ (cdr relinfo)))
+ (setq *is-rel-table-init* t))
+
+(defun rel-abbr-info (rel)
+ (nth-value 0 (gethash (string-downcase rel) *rel-info-table*)))
+
+(defun filter-urels-by-rel (urels rel)
+ (remove-if-not (lambda (urel) (string-equal rel (rel urel))) urels))
+
+
+(defvar +language-abbreviations+
+ '(("BAQ" . "Basque")
+ ("DAN" . "Danish")
+ ("DUT" . "Dutch")
+ ("ENG" . "English")
+ ("FIN" . "Finnish")
+ ("FRE" . "French")
+ ("GER" . "German")
+ ("HEB" . "Hebrew")
+ ("HUN" . "Hungarian")
+ ("ITA" . "Italian")
+ ("NOR" . "Norwegian")
+ ("POR" . "Portuguese")
+ ("RUS" . "Russian")
+ ("SPA" . "Spanish")
+ ("SWE" . "Swedish")))
+
+(defvar *lat-info-table* (make-hash-table :size 30 :test 'equal))
+(defvar *is-lat-table-init* nil)
+(unless *is-lat-table-init*
+ (dolist (latinfo +language-abbreviations+)
+ (setf (gethash (string-downcase (car latinfo)) *lat-info-table*)
+ (cdr latinfo)))
+ (setq *is-lat-table-init* t))
+
+(defun lat-abbr-info (lat)
+ (nth-value 0 (gethash (string-downcase lat) *lat-info-table*)))
+
+
+(defun stt-abbr-info (stt)
+ (when (string-equal "PF" stt)
+ (return-from stt-abbr-info "Preferred"))
+ (when (char-equal #\V (schar stt 0))
+ (setq stt (subseq stt 1)))
+ (loop for c across stt
+ collect
+ (cond
+ ((char-equal #\C c)
+ "Upper/lower case")
+ ((char-equal #\W c)
+ "Word order")
+ ((char-equal #\S c)
+ "Singular")
+ ((char-equal #\P c)
+ "Plural")
+ ((char-equal #\O c)
+ "Other"))))
+
+
+(defun ucon-parents (con &optional sab)
+ (ucon-ancestors con sab t))
+
+(defun ucon-ancestors (ucon &optional sab single-level)
+ "Returns a list of ancestor lists for a concept"
+ (let* ((parent-rels (filter-urels-by-rel (s#rel ucon) "par"))
+ (anc nil))
+ (when sab
+ (setq parent-rels (delete-if-not
+ (lambda (rel) (string-equal sab (sab rel)))
+ parent-rels)))
+ (dolist (rel parent-rels (nreverse anc))
+ (let ((parent (find-ucon-cui (cui2 rel))))
+ (push
+ (if single-level
+ (list parent)
+ (list* parent (car (ucon-ancestors parent (sab rel) nil))))
+ anc)))))
+
+(defgeneric cxt-ancestors (obj))
+(defmethod cxt-ancestors ((con ucon))
+ (loop for term in (s#term con)
+ append (cxt-ancestors term)))
+
+
+(defmethod cxt-ancestors ((term uterm))
+ (loop for str in (s#str term)
+ append (cxt-ancestors str)))
+
+(defmethod cxt-ancestors ((str ustr))
+ "Return the ancestory contexts of a ustr"
+ (let* ((anc (remove-if-not
+ (lambda (cxt) (string-equal "ANC" (cxl cxt)))
+ (s#cxt str)))
+ (num-contexts (if anc
+ (apply #'max (mapcar (lambda (cxt) (cxn cxt)) anc))
+ 0))
+ (anc-lists '()))
+ (dotimes (i num-contexts (nreverse anc-lists))
+ (let* ((anc-this-cxn (remove-if-not
+ (lambda (cxt) (= (1+ i) (cxn cxt))) anc)))
+ (push
+ (sort anc-this-cxn (lambda (a b) (< (rnk a) (rnk b))))
+ anc-lists)))))
+
+
+#+scl