Commit 43688d66 authored by David Trudgett's avatar David Trudgett


(in-package #:eclecticse.slk-581)
;;; A data record is of the following form, containing at least the
;;; four data items, first name, surname, sex/gender and date of birth:
;; ((:first-name "John")
;; (:surname "Smithsonian")
;; (:gender "Male")
;; (:dob "1963-03-17"))
(defun field-val (item)
"Return the value of ITEM, which is a (key value) pair."
(second item))
(defun trim (string)
"Remove spaces from start and end of STRING."
(string-trim '(#\Space) string))
(defun cleanse-item (string)
"Trim STRING and convert to upper case."
(if (stringp string)
(string-upcase (trim string))
(defun get-item (which data-rec)
"Retrieve a (key value) pair from the DATA-REC. WHICH is one of
-- :first-name :surname :gender :dob :slk"
(cleanse-item (field-val (assoc which data-rec))))
(defun cleanse-name (name)
"Remove non-alpha characters from NAME."
(remove-if-not #'alpha-char-p name))
(defun get-surname (data-rec)
"Retrieve the cleansed surname from DATA-REC."
(cleanse-name (get-item :surname data-rec)))
(defun get-first-name (data-rec)
"Retrieve the cleansed first name from DATA-REC."
(cleanse-name (get-item :first-name data-rec)))
(defun get-surname-letters (data-rec)
"Retrieve the three letters of the surname which form part of the
SLK code."
(let* ((surname (get-surname data-rec))
(surname-length (length surname))
(surname-missing (= 0 surname-length)))
(cond ((or surname-missing (= 1 surname-length))
((< surname-length 3)
(concatenate 'string (list (char surname 1)
((< surname-length 5)
(concatenate 'string (list (char surname 1)
(char surname 2)
(concatenate 'string (list (char surname 1)
(char surname 2)
(char surname 4)))))))
(defun get-first-name-letters (data-rec)
"Retrieve the two letters of the first name which form part of the SLK code."
(let* ((first-name (get-first-name data-rec))
(first-name-length (length first-name))
(first-name-missing (= 0 first-name-length)))
(cond ((or first-name-missing (= 1 first-name-length))
((< first-name-length 3)
(concatenate 'string (list (char first-name 1) #\2)))
(concatenate 'string (list (char first-name 1) (char first-name 2)))))))
(defun iso-date->ddmmyyyy (iso-date)
"Convert an ISO 8601 date with hyphens into DDMMYYYY."
(if (>= (length iso-date) 10)
(concatenate 'string
(subseq iso-date 8 10)
(subseq iso-date 5 7)
(subseq iso-date 0 4))
(defun get-dob (data-rec)
"Retrieve the date of birth in ddmmyyyy format, from DATA-REC."
(let ((dob (get-item :dob data-rec)))
(iso-date->ddmmyyyy dob)))
(defun get-sex-code (data-rec)
"Retrieve the SLK sex/gender code for DATA-REC."
(let ((sex (get-item :gender data-rec)))
(cond ((string= sex "MALE")
((string= sex "FEMALE")
((or (string= sex "INTERSEX") (string= sex "INDETERMINATE"))
;;;; eclecticse.slk-581.asd
(asdf:defsystem #:eclecticse.slk-581
:description "Generate Australian Government SLK-581 codes."
:author "David K. Trudgett <"
:license "LLGPL"
:version "1.0.0"
:serial t
:depends-on (#:cl-ppcre)
:components ((:file "package")
(:file "slk-581")))
;;;; package.lisp
(defpackage #:eclecticse.slk-581
(:use #:cl))
;;;; slk-581.lisp
(in-package #:eclecticse.slk-581)
;; The SLK-581 is a fourteen character code composed of the
;; concatenation of the follow four elements.
;; • Record 2nd, 3rd and 5th letters of last name (family name).
;; • Record 2nd and 3rd letters of first (given) name.
;; • Record the date of birth as a character string of the form ddmmyyyy.
;; • Record the sex of the client as :-
;; o Code 1 for Male
;; o Code 2 for Female
;; o Code 3 for Other, "intersex" or "indeterminate"
;; o Code 9 for Not stated/inadequately described
;; Additional notes:
;; • Do not count hyphens, apostrophes, blank spaces, or any other character that may
;; appear in a name which is not a letter of the alphabet.
;; • Where the name is not long enough to supply all the requested
;; letters, fill the remaining squares with a 2 to indicate that a
;; letter does not exist. This will occur if the first name is less
;; than 3 characters and if the last name is less than 5 characters.
;; If a name is too short, complete with 2’s.
;; • Where a name or part of a name is missing, substitute a 9 to indicate that the letter
;; is not known.
;; • Always use uppercase letters for SLK.
(defun slk-581 (data-rec)
"Generate the SLK-581 code for DATA-REC."
(concatenate 'string
(get-surname-letters data-rec)
(get-first-name-letters data-rec)
(get-dob data-rec)
(get-sex-code data-rec)))
(defun test-slk ()
"Run tests against all test data records and report the results."
(let ((results (mapcar (lambda (data-rec)
(if (string= (slk data-rec) (get-item :slk data-rec))
(if (every (lambda (result)
(eq result :pass))
"All tests pass."
(defun regex-check-slk (slk)
(equal 0 (cl-ppcre:scan *slk-scanner* slk)))
(defun remove-surname (full-name surname)
(let* ((surname-pos (search (string-upcase surname) (string-upcase full-name)))
(pos (if surname-pos
(position #\Space full-name
:start 0
:end surname-pos
:from-end t)
(if pos
(subseq full-name 0 pos)
(defun read-slk-source-data ()
(let ((fare-csv:*separator* #\Tab)
(data '()))
(with-open-file (slk-source *slk-info-file* :direction :input :external-format :utf-8)
(fare-csv:read-csv-line slk-source)
(loop for record = (fare-csv:read-csv-line slk-source)
for surname = (first record)
for dob = (second record)
for gender = (string-upcase (third record))
for full-name = (fourth record)
for first-name = (remove-surname full-name surname)
for dob-iso = (if (>= (length dob) 10)
(concatenate 'string
(subseq dob 6 10)
(subseq dob 3 5)
(subseq dob 0 2))
for output-record = (list (list :surname surname)
(list :first-name first-name)
(list :dob dob-iso)
(list :gender gender))
for gen-slk = (slk output-record)
while record do
(push (append (list (list :slk gen-slk)) output-record)
(nreverse data)))
(defun create-slk-lookup ()
(let ((lookup-table (make-hash-table :test 'equal)))
(loop for data-rec in (read-slk-source-data)
for surname = (string-upcase (get-surname data-rec))
for first-name = (string-upcase (get-first-name data-rec))
for dob = (get-dob data-rec)
for slk = (get-item :slk data-rec)
for key = (concatenate 'string surname first-name dob)
(setf (gethash key lookup-table) slk))
;;(defparameter *slk* (create-slk-lookup))
(defun lookup-slk (surname first-name dob)
"This lookup assumes that there will not be more than one client
with the same first name and surname born on the same date."
(let ((key (concatenate 'string
(string-upcase (cleanse-name surname))
(string-upcase (cleanse-name first-name))
(iso-date->ddmmyyyy dob))))
(values (gethash key *slk*) key)))
(in-package #:eclecticse.slk-581)
(defparameter *test-data*
'(((:first-name "Jane") (:surname "Citizen")
(:gender "Female") (:dob "1963-05-27")
(:slk "ITZAN270519632"))
((:first-name "Joseph") (:surname "Bloggs")
(:gender "Male") (:dob "1959-12-31")
(:slk "LOGOS311219591"))
((:first-name "Jane") (:surname "Luca")
(:gender "Female") (:dob "1963-05-27")
(:slk "UC2AN270519632"))
((:first-name "Jo") (:surname "O'Donnell")
(:gender "Female") (:dob "1963-05-27")
(:slk "DONO2270519632"))
((:first-name "J") (:surname "Bloggs")
(:gender "Female") (:dob "1963-05-27")
(:slk "LOG99270519632"))
((:first-name "J") (:surname "Blog")
(:gender "Female") (:dob "1963-05-27")
(:slk "LO299270519632"))
((:first-name "J") (:surname "O")
(:gender "Male") (:dob "1959-12-31")
(:slk "99999311219591"))
((:first-name "J") (:surname "Blog")
(:gender "Not stated") (:dob "1967-06-20")
(:slk "LO299200619679"))
((:first-name "Joseph") (:surname "Bloggs")
(:gender "Intersex") (:dob "1959-12-31")
(:slk "LOGOS311219593")))
"Test data with known correct SLK-581 values.")
(defparameter *slk-scanner* (cl-ppcre:create-scanner
(concatenate 'string
"[1-2][0-9])02))(19|2[0-9])[0-9]{2}[1 2 3 9]"))
"Regular expression to validate structure of an SLK-581 code.")
((:first-name "Jane") (:surname "Citizen") (:gender "Female") (:dob "1963-05-27") (:slk "ITZAN270519632"))
((:first-name "Joseph") (:surname "Bloggs") (:gender "Male") (:dob "1959-12-31") (:slk "LOGOS311219591"))
((:first-name "Jane") (:surname "Luca") (:gender "Female") (:dob "1963-05-27") (:slk "UC2AN270519632"))
((:first-name "Jo") (:surname "O'Donnell") (:gender "Female") (:dob "1963-05-27") (:slk "DONO2270519632"))
((:first-name "J") (:surname "Bloggs") (:gender "Female") (:dob "1963-05-27") (:slk "LOG99270519632"))
((:first-name "J") (:surname "Blog") (:gender "Female") (:dob "1963-05-27") (:slk "LO299270519632"))
((:first-name "J") (:surname "O") (:gender "Male") (:dob "1959-12-31") (:slk "99999311219591"))
((:first-name "J") (:surname "Blog") (:gender "Not stated") (:dob "1967-06-20") (:slk "LO299200619679"))
((:first-name "Joseph") (:surname "Bloggs") (:gender "Other") (:dob "1959-12-31") (:slk "LOGOS311219593"))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment