Exercise 6: Lookup Routine, version 2
The new, longer version of the lookup routine is shown below, broken into sections to help you understand it. This routine is also available in the SAMPLES namespace as lookup2.mac.
The modified getsubmit procedure is as follows. Since $$validDOB^datent writes an error message, it should be at the end of the If construct, so it won't write its message too early.
getsubmit() [submit] ; ask user what to search for, and take appropriate action { set id = 0 read !, "Lookup: ", submit quit:(submit = "") ; user entered nothing ; figure out what user entered if (submit = "?") { ; display help do help() quit } elseif submit?3n.1(1"-"3n.1(1"-"4n)) { ; allow full or partial phone numbers write "...finding phone number" do phone( .id ) quit:(id = 0) do display(id, "table") ; display the chosen person } elseif $$NameFormat( .submit )?1u.l.1(1","1u.l) { ; verify the name write "...finding name" do name( .id ) quit:(id = 0) do display(id, "table") ; display the chosen person } elseif $$validDOB^datent( submit ) { ; use validDOB^datent to verify the DOB write "...finding birthday" do dob( .id ) quit:(id = 0) do display(id, "table") ; display the chosen person quit } else { ; else it's an error; add this to what $$validDOB writes write ", name, or phone" } }
Copy code to clipboardThe modified dob procedure:
dob(id) [submit, list] ; perform dob lookup ; no partial matches ; if user picks a name from the list, ID is returned to the caller { kill list set intdob = $$validDOB^datent( submit ) ; convert dob ; is the date of birth in the index? if '$data( ^PersonI("DOB", intdob) ) { ; determine if there are any matches write "...no matches" quit } set loopid = "" ; loop through IDs, and number them for count = 1 : 1 { set loopid = $order( ^PersonI("DOB", intdob, loopid) ) quit:(loopid = "") set list( count ) = loopid write !, count, ") " do display(loopid, "line") } do select( .id ) }
Copy code to clipboardThe phone procedure is as follows. The bug mentioned in the description for the Hands-On Exercise occurs when the user specifies a 3-digit area code for lookup. $Order interprets this as a number (no “-” character), so the first $Order below won't return the right result. The solution is in the line that precedes the first $Order: appending a “-” to the area code.
phone(id) [submit, list] ; perform phone lookup ; if user picks a name from the list, ID is returned to the caller { kill list set count = 0 ; assume no matches set origph = submit set:(origph?3n) origph = origph _ "-" ; change to a string instead of a number ; origph may be an exact match, so find preceding phone set ph = $order( ^PersonI("Phone", origph), -1) /* loop through phone numbers, and number them, quit as soon as phone doesn't match original loopid holds the ONE ID per phone number */ for count = 1 : 1 { set ph = $order( ^PersonI("Phone", ph), 1, loopid) quit:( $extract(ph, 1, $length(origph)) '= origph ) set list( count ) = loopid write !, count, ") " do display(loopid, "line") } if '$data( list ) { ; were there matches? write "...no matches" quit } do select( .id ) }
Copy code to clipboardThe name procedure:
name(id) [submit, list] ; perform name lookup ; if user picks a name from the list, ID is returned to the caller { kill list set count = 0 ; assume no matches set origln = $piece(submit, ",", 1), origfn = $piece(submit, ",", 2) ; origln may be an exact match, so find preceding last name set ln = $order( ^PersonI("Name", origln), -1) ; loop through last names, quit as soon as last name doesn't match original for { set ln = $order( ^PersonI("Name", ln)) quit:($extract(ln, 1, $length(origln)) '= origln) ; origfn may be "". Otherwise, it may be an exact match, so find preceding first name if (origfn = "") { set fn = "" } else { set fn = $order( ^PersonI("Name", ln, origfn), -1) } ; loop through first names, quit as soon as first name doesn't match original, or is "" for { set fn = $order( ^PersonI("Name", ln, fn)) quit:(($extract(fn, 1, $length(origfn)) '= origfn) || (fn = "")) set loopid = "" ; loop through IDs for { set loopid = $order( ^PersonI("Name", ln, fn, loopid)) quit:( loopid = "" ) set count = count + 1 set list( count ) = loopid write !, count, ") " do display(loopid, "line") } } } if '$data( list ) { ; were there matches? write "...no matches" quit } do select( .id ) }
Copy code to clipboardThe $$NameFormat, $$up, and $$low functions:
NameFormat(name) ; change user's entry into proper name format ; SMITH,JOHN and smith,john -> Smith,John ; if name is passed-by-reference, it will be changed { set ln = $piece(name, ",", 1), fn = $piece(name, ",", 2) set ln = $$up($extract(ln)) _ $$low($extract(ln, 2, $length(ln))) if fn = "" { ; return last name only set name = ln quit name } set fn = $$up($extract(fn)) _ $$low($extract(fn, 2, $length(fn))) set name=ln _ "," _ fn ; return full name quit name } up(text) ; translate text to uppercase { quit $translate(text, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ") } low(text) ; translate text to lowercase { quit $translate(text, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz") }
Copy code to clipboardThe modified help procedure:
help() ; display different types of lookups { write !, "You can enter:" write !?10, "* full name: Smith,John", !?10, "* last name: Smith" write !?10, "* partial name: Sm,J or Smith,J or Sm,John" write !?10, "* phone number with area code: 617-621-0600" write !?10, "* partial phone numbers: 617 or 617-621" write !?10, "* date of birth", !! }
Copy code to clipboardThe modified display procedure:
display(id, style) [name, phone, intdob] ; given an ID, get data and write it { set rec = ^PersonD( id ) set name = $piece(rec, "^", 1) set phone = $piece(rec, "^", 2) set intdob = $piece(rec, "^", 3) if style = "line" { write name, ?20, phone, ?35, $zdate(intdob, 2) } else { write # ; clear screen do display^datent() } }
Copy code to clipboardThe select procedure:
select(id) [list] ; choose from the displayed items, and set up ID ; id is 0 if no choice is made, id is >0 when user makes a choice { for { read !!, "Choose by number: ", choice quit:( choice = "" ) set id = $get(list( choice ), 0) quit:(id '= 0) ; valid choice write !,"Invalid choice" } }
Copy code to clipboard