Return to %uxxxx.m CVS log

Up to [Coherent Logic Development] / freem / contrib

Annotation of freem/contrib/%uxxxx.m, revision 1.1.1.1

1.1       snw         1: %uxxxx ; FreeM %u utility library - version 0.5.0.1
                      2:  ; Jon Diamond - 1999-03-31
                      3:  q
                      4:  ; 
                      5:  ; INITIALISATION
                      6: init() n a
                      7:  i $d(^%uparams) s a="^%uparams"
                      8:  e  s a="^uparams"
                      9:  s %ulang=$g(@a@("lang")) i %ulang="" s %ulang=0
                     10:  s %uprompt=$g(@a@("prompt")) i %uprompt="" s %uprompt="^ulang"
                     11:  s %uwork=$g(@a@("work")) i %uwork="" s %uwork="^uwork("""_$j_""")"
                     12:  ; Really should be as below, but needs $system to be implemented
                     13:  ;s %uwork=$g(@a@("work"),"^uwork("""_$system_""","""_$j_""")")
                     14:  q "0,init^%uxxxx"
                     15:  ; 
                     16:  ; 
                     17:  ; READ WITH PROMPT
                     18: read(prompt,result,length,PX,PY,X,Y,timeout) 
                     19:  n a,error
                     20:  i '$d(%ulang) s error=$$init
                     21:  s prompt=$g(prompt)
                     22: %read1 i prompt'="" s error=$$write($$lprompt(prompt),$g(PX),$g(PY)) i error q error
                     23:  i $g(result)'="" s error=$$write(" <"_result_"> ") i error q error
                     24:  ; 
                     25:  ; move to X,Y ********
                     26:  i $g(X)'="" s $x=$g(X)
                     27:  i $g(Y)'="" s $y=$g(Y)
                     28:  i $g(timeout)="" d
                     29:  . r a
                     30:  e  d
                     31:  . r a:$g(timeout)
                     32:  ; 
                     33:  ; **** hitting escape or escape sequence processing???
                     34:  i a'="" s result=a
                     35:  i a="@" s result=""
                     36:  i a="^" q "-1,read^%uxxxx" ; *** Standard abort
                     37:  i $g(length),$l(result)>length s error=$$error("Too many characters") g %read1
                     38:  ; 
                     39:  q "0,read^%uxxxx"
                     40:  ; 
                     41:  ; 
                     42:  ; READ WITH NEWLINE FIRST
                     43: readn(prompt,result,length,PX,PY,X,Y,timeout) 
                     44:  n error
                     45:  i '$d(%ulang) s error=$$init i error q error
                     46:  s error=$$writep($g(prompt)) i error q error
                     47:  q $$read("",.result,$g(length),"","",$g(X),$g(Y),$g(timeout))
                     48:  ; 
                     49:  ; 
                     50:  ; READN FOR YES/NO
                     51: readyn(prompt,result) 
                     52:  n error,res,def
                     53:  s def=$g(result),def=$$lprompt($s(def=1:"Y",def=0:"N",1:""))
                     54:  i '$d(%ulang) s error=$$init i error q error
                     55: %readyn1 s res=def
                     56:  s error=$$readn(prompt,.res) i error<0 q error
                     57:  s res=$$upper(res)
                     58:  i res=$$lprompt("Y") s result=1
                     59:  e  i res=$$lprompt("N") s result=0
                     60:  e  s error=$$write(" - "_$$lprompt("Enter Y or N")) g %readyn1
                     61:  q "0,readyn^%uxxxx"
                     62:  ; 
                     63:  ; Application Validation Error display after Read (of any kind)
                     64: rerror(err)  i err?1"?".e q $$write(" "_err)
                     65:  q $$write(" - "_$$lprompt(err))
                     66:  ; 
                     67:  ; WRITE TEXT
                     68: write(text,X,Y) 
                     69:  n error
                     70:  i '$d(%ulang) s error=$$init i error q error
                     71:  ; 
                     72:  ; move to X,Y ********
                     73:  i $g(X)'="" s $x=$g(X)
                     74:  i $g(Y)'="" s $y=$g(Y)
                     75:  w text
                     76:  q "0,write^%uxxxx"
                     77:  ; 
                     78:  ; 
                     79:  ; WRITE WITH NEWLINE
                     80: writen(text) 
                     81:  w !,text
                     82:  q "0,writen^%uxxxx"
                     83:  ; 
                     84:  ; 
                     85:  ; WRITE WITH NEWLINE/PROMPT
                     86: writep(text) 
                     87:  n error
                     88:  i '$d(%ulang) s error=$$init() i error q error
                     89:  w !,$$lprompt(text)
                     90:  q "0,writep^%uxxxx"
                     91:  ; 
                     92:  ; 
                     93:  ; WRITE WITH FORMAT
                     94: writef(format,text) 
                     95:  n error,a
                     96:  i '$d(%ulang) s error=$$init i error q error
                     97:  s format=$g(format)
                     98:  f  q:format=""  s a=$p(format,","),format=$p(format,",",2,$l(format,",")) i a?."#"."!"!(a?1"?"1.n) x "w "_a
                     99:  w $g(text)
                    100:  q "0,writef^%uxxxx"
                    101:  ; 
                    102:  ; 
                    103:  ; Create+write Error message
                    104: error(error) 
                    105:  i +error=-1 q $$writep("User abort")
                    106:  s error=$$writep("Error - "_$$lprompt(error))
                    107:  q error
                    108:  ; 
                    109:  ; LANGUAGE CONVERSION
                    110: lprompt(prompt) i $g(prompt)="" q ""
                    111:  ; Remove trailing spaces before look-up and re-apply after
                    112:  ; Also everything after first -
                    113:  ; Everything before ~ is left unchanged and ~ replaced by -
                    114:  n s,t,u
                    115:  s u="" i prompt["~" s u=$p(prompt,"~")_" - ",prompt=$p(prompt,"~",2,$l(prompt,"~"))
                    116:  s t=$f(prompt,"-")-2
                    117:  i 't s t=$l(prompt)
                    118:  f t=t:-1 q:$e(prompt,t)'=" "
                    119:  s s=$e(prompt,t,$l(prompt)),prompt=$e(prompt,1,t-1)
                    120:  i prompt'="" s t=$g(@%uprompt@(%ulang,prompt)) i t'="" s prompt=t
                    121:  q u_prompt_s
                    122:  ; 
                    123:  ; ********** UPPER/LOWER CONVERSION NEED TO HANDLE DIFFERENT LANGUAGES/CHARACTERS
                    124: upper(text) 
                    125:  s text=$tr(text,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
                    126:  q text
                    127:  ; 
                    128: lower(text) 
                    129:  s text=$tr(text,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
                    130:  q text
                    131: