Skip to main content

Exercise 6: Lookup Routine, version 2

  1. 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.

  2. 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" }
        }
  3. The 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 )
        }
  4. The 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 )
        }
  5. The 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 )
      }
  6. The $$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") }
  7. The 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", !!
        }
  8. The 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()
            }
        }
  9. The 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"
            }
        }
FeedbackOpens in a new tab