+(defgeneric pf-ustr (obj))
+(defmethod pf-ustr ((ucon ucon))
+ "Return the preferred ustr for a ucon"
+ (pf-ustr
+ (find-if (lambda (uterm) (string= "P" (ts uterm))) (s#term ucon))))
+
+(defmethod pf-ustr ((uterm uterm))
+ "Return the preferred ustr for a uterm"
+ (find-if (lambda (ustr) (string= "PF" (stt ustr))) (s#str uterm)))
+
+(defgeneric mesh-number (obj))
+(defmethod mesh-number ((con ucon))
+ (mesh-number (pf-ustr con)))
+
+(defmethod mesh-number ((ustr ustr))
+ (let ((codes
+ (map-and-remove-nils
+ (lambda (sat)
+ (when (and (string-equal "MSH" (sab sat))
+ (string-equal "MN" (atn sat)))
+ (atv sat)))
+ (s#sat ustr))))
+ (if (= 1 (length codes))
+ (car codes)
+ codes)))
+
+(defun ucon-ustrs (ucon)
+ "Return lists of strings for a concept"
+ (let (res)
+ (dolist (term (s#term ucon) (nreverse res))
+ (dolist (str (s#str term))
+ (push str res)))))
+
+
+(defmethod pfstr ((uterm uterm))
+ "Return the preferred string for a uterm"
+ (dolist (ustr (s#str uterm))
+ (when (string= "PF" (stt ustr))
+ (return-from pfstr (str ustr)))))
+
+(defmethod pfstr ((ustr ustr))
+ "Return the preferred string for a ustr, which is the string itself"
+ (str ustr))
+
+(defun remove-non-english-terms (uterms)
+ (remove-if-not #'english-term-p uterms))
+
+(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 &key (remove-duplicate-pfstr2 t) (sort :pfstr2))
+ (let ((f (remove-if-not (lambda (urel) (string-equal rel (rel urel))) urels)))
+ (when remove-duplicate-pfstr2
+ (setq f (remove-duplicates f :test 'equal :key 'u::pfstr2)))
+ (if sort
+ (sort (copy-seq f) 'string-lessp :key 'u::pfstr2)
+ f)))
+
+#+mrcoc
+(defun filter-ucocs (ucocs &key (remove-duplicate-pfstr2 t) (sort :pfstr2))
+ (when remove-duplicate-pfstr2
+ (setq ucocs (remove-duplicates ucocs :test 'equal :key 'u::pfstr2)))
+ (if sort
+ (sort (copy-seq ucocs) 'string-lessp :key 'u::pfstr2)
+ ucocs))
+
+
+(defvar +language-abbreviations+
+ '(("BAQ" . "Basque")
+ ("CZE" . "Chech")
+ ("DAN" . "Danish")
+ ("DUT" . "Dutch")
+ ("ENG" . "English")
+ ("FIN" . "Finnish")
+ ("FRE" . "French")
+ ("GER" . "German")
+ ("HEB" . "Hebrew")
+ ("HUN" . "Hungarian")
+ ("ITA" . "Italian")
+ ("JPN" . "Japanese")
+ ("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)
+ (aif (nth-value 0 (gethash (string-downcase lat) *lat-info-table*))
+ it
+ lat))
+
+
+
+(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 uso-unique-codes (usos)
+ (let ((sab-codes (make-hash-table :test 'equal)))
+ (dolist (uso usos)
+ (setf (gethash (sab uso) sab-codes) (code uso)))
+ (loop for key being the hash-key in sab-codes
+ collect (list key (gethash key sab-codes)))))
+
+(defun ucon-has-sab (ucon sab)
+ (and (find-if (lambda (uso) (string-equal sab (sab uso))) (s#so ucon)) t))
+
+
+#+scl
+(dolist (c '(urank udef usat uso ucxt ustr uterm usty urel
+ #+mrcoc ucoc
+ uatx uconso uxw uxnw uxns lexterm labr lagr lcmp lmod lnom lprn lprp lspl ltrm ltyp lwd sdef sstr sstre1 sstre2 usrl))