演習 6 ： Lookup ルーチン、バージョン 2
-
以下は新規でより長い lookup ルーチンです。わかりやすいようにセクションを分割して表示しています。このルーチンも、lookup2.mac として、SAMPLES ネームスペースで使用できます。
-
変更された getsubmit プロシージャは、以下のとおりです。$$validDOB^datent はエラー・メッセージを記述するため、If 文の最後にもってきます。そうすることによって、あまり早い段階からメッセージを記述することもありません。
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" } } -
以下は、変更された dob プロシージャです。
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 ) } -
以下は phone プロシージャです。検索のために 3 桁のエリア・コードを指定すると、演習で述べたバグが発生します。$Order は、“-” 文字ではなく、数としてこれを解釈するので、以下の最初の $Order は正しい結果を返しません。回避策として、最初の $Order の前の行で、エリア・コードに “-” を追加します。
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 ) } -
以下は name プロシージャです。
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 ) } -
以下は、$$NameFormat、$$up と $$low 関数です。
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") } -
以下は、変更された help プロシージャです。
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", !! } -
以下は、変更された display プロシージャです。
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() } } -
以下は select プロシージャです。
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" } }
