 set %i=$io,n=0 read code xecute code use 0 close %i do ^%C kill ^$routine("%C") write !,"Loaded "_n_" routines",! quit
 for  read rou quit:rou=""  use 0 write rou,! use %i kill ln for i=1:1 read ln(i) if ln(i)="" merge ^$routine(rou)=ln set n=n+1 quit
%RR
%RR ; Routine Restore from file
 new file
 read "Restore from file: ",file,! quit:file=""
 do INT(file,0) quit
;---
INT(file,nosay) new %,a,r,zr,num,$etrap
 if $get(file)="" goto ^%RR
 set zr="INT^%RR",nosay=$get(nosay),num=0,$etrap="do EX^%RR"
 open 1:(file:"read") use 1 read a,r use $principal set a=$translate(a,$char(13)),r=$translate(r,$char(13))
 if nosay<2 write !,a,!,r,!
 if 'nosay read "Restore N> ",%,! if $extract($&e(%))'="Y" close 1 write "ABORTED",! quit
 use 1 for  read r set r=$translate(r,$char(13)) quit:r=""  do  quit:$ascii($key)=255
 . set r=$piece(r,"^") ; Needed to support ISC Cache routine export format
 . if nosay<2 use $principal write:$x>70 ! write r,?$x\10+1*10 use 1
 . kill a for %=1:1 read a(%) set a(%)=$translate(a(%),$char(13)) quit:a(%)=""  quit:$ascii($key)=255
 . merge ^$routine(r)=a set num=num+1
;---
EX new ecode use $principal
 if r'="" write "$ECODE=,"_$piece($ecode,",",2)_","_$&%errmsg($piece($ecode,",",2)),!!
 else  write:nosay<2 !!,"Loaded "_num_" routines",!
 set ecode=$piece($ecode,",",2),$ecode="" use:r'="" 1 if r=""!(ecode="Z51") close 1 quit

%RS
%RS ; Routine Save
 new rou,file,head
 read !,"Routine(s): ",rou quit:rou=""
 read !,"Filename:   ",file goto %RS:file=""
 read !,"Header Txt: ",head,! set:head="" head=rou
 do INT(rou,file,head) quit
;---
INT(rou,file,head) new %,vol,uci,r,zr,ui,num,$etrap
 if $get(rou)=""!($get(file)="") goto ^%RS
 set zr="INT^%RS",num=0,$etrap="do EX^%RS"
 set head=$get(head,rou)
 set ui=$$UI^%U() kill ^UTILITY(ui) set rou=$$PAT^%U(rou)
 do INT^%RD(3,rou,^$job($job,"routine"),"","z","^UTILITY("_ui_")")
 if $order(^UTILITY(ui,""))="" write !,"?No routines selected.",! quit
 set %=^$job($job,"routine_vol"),vol=^$system("vol",%,"name")
 set uci=^$system("vol",%,"uci",^$job($job,"routine"))
 open 1:(file:"write") use 1 write "Saved by %RS from ["_uci_","_vol_"] on "
 write $$D^%D($horolog)," at ",$$T^%T($piece($horolog,",",2)),!,head,!
 set r="" for  set r=$order(^UTILITY(ui,r)) quit:r=""  do
 . use $principal write:$x>70 ! write r,?$x\10+1*10 use 1 write r,!
 . set %=0 for  set %=$order(^$routine(r,%)) quit:%=""  write ^$routine(r,%),!
 . set num=num+1 write !
;---
EX new ecode write ! use $principal
 if r'="" write "$ECODE=,"_$piece($ecode,",",2)_","_$&%errmsg($piece($ecode,",",2))
 else  write !!,"Saved "_num_" routines"
 set ecode=$piece($ecode,",",2),$ecode="" use:r'="" 1 if r=""!(ecode="Z51") close 1 write ! quit

%GR
%GR ; Global Restore from file
 new file
 read "Restore from file: ",file,! quit:file=""
 do INT(file,0) quit
;---
INT(file,nosay) new %,g,s,zr,$etrap
 if $get(file)="" goto ^%GR
 set zr="INT^%GR",nosay=$get(nosay),$etrap="do EX^%GR"
 open 1:(file:"read") use 1 read g,% use $principal set g=$translate(g,$char(13)),%=$translate(%,$char(13))
 if nosay<2 write !,g,!,%,!
 if 'nosay read "Restore N> ",%,! if $extract($&e(%))'="Y" close 1 write "ABORTED",! quit
 use 1 for  read g,% set g=$translate(g,$char(13)),%=$translate(%,$char(13)) quit:$extract(g)="*"  do  quit:$ascii($key)=255
 . set @g=% if nosay<2 use $principal write:$x>70 ! write g,?$x\10+1*10 use 1
 . for  read s,% set s=$translate(s,$char(13)),%=$translate(%,$char(13)) quit:$extract(s)="*"  set:$extract(s)="^" g="" set @(g_s)=%
;---
EX use $principal write:nosay<2 ! close 1 quit

%GS
%GS ; Global Save
 new glo,file,head
 read !,"Global(s):  ",glo quit:glo=""
 read !,"Filename:   ",file goto %RS:file=""
 read !,"Header Txt: ",head,! set:head="" head=glo
 do INT(glo,file,head) quit
;---
INT(glo,file,head) new %,vol,uci,g,zr,ui,$etrap
 if $get(glo)=""!($get(file)="") goto ^%GS
 set zr="INT^%GS",$etrap="do EX^%GS"
 set head=$get(head,glo)
 set ui=$$UI^%U() kill ^UTILITY(ui) set glo=$$PAT^%U(glo)
 do INT^%GD(3,glo,^$job($job,"global"),"","z","^UTILITY("_ui_")")
 if $order(^UTILITY(ui,""))="" write !,"?No globals selected.",! quit
 set %=^$job($job,"global_vol"),vol=^$system("vol",%,"name")
 set uci=^$system("vol",%,"uci",^$job($job,"global"))
 open 1:(file:"write") use 1 write "Saved by %GS from ["_uci_","_vol_"] on "
 write $$D^%D($horolog)," at ",$$T^%T($piece($horolog,",",2)),!,head,!
 set glo="" for  set glo=$order(^UTILITY(ui,glo)) quit:glo=""  set g="^"_glo do
 . use $principal write:$x>70 ! write glo,?$x\10+1*10 use 1
 . write g,!,$get(@g),! for  set g=$query(@g) quit:g=""  write "("_$piece(g,"(",2,999),!,@g,!
 . write "*",!,"*",!
 write "**",!,"**",! use $principal
;---
EX close 1 write ! quit

%BLKDMP
%BLKDMP ; Dump a block to $io formatted
 new vol,blk
 write:$x ! read "Volume Number: ",vol,! set:'vol vol=^$job($job,"global_vol")
 for  read "Block Number: ",blk,! quit:'blk  do INT(vol,blk)
 quit
;---
INT(vol,blk,xx) new %,f,i,g,li,d,da,buf,ccc,ucc,k,key,data,zr,$etrap
 ; NOTE: if do INT^%BLKDMP(1,36,"^GLOB") will set contents of volume 1, block 36 to ^GLOB
 set zr="INT^%BLKDMP",buf="",$etrap="do EXIT^%BLKDMP"
 set vol=$get(vol,^$job($job,"global_vol")),vol=-vol
 new varlen,hdrsize,long set varlen=$get(^$system("name_length"),8),hdrsize=varlen+12,long=0
 ; NOTE: If blk ends in +, it will output the full data, not truncate it to 500
 if $extract(blk,$length(blk))="+" set long=$get(^$system("string_max"),32767),blk=+blk
 set blk=+blk\1 ; normalize block number
 ; Note: blk=0 means vol:blk is already in View Buffer and should be removed
 quit:vol>-1!(blk<1)  view vol:blk
 set %=$view(vol,0) if '% write "Block not in use",! view vol:0 goto EXIT
 if '$data(xx) write "Block: ",$select(blk:blk,1:"")," belongs to UCI# ",%#64," "
 set f=^$system("vol",-vol,"uci",%#64) if '$data(xx) write:$length(f) "(",f,") "
 set d=%\64,g=$&e($view(vol,12,varlen),"c") if $data(xx),'d goto EXIT
 if '$data(xx) write $select(g="$GLOBAL":"global directory",d:"data",1:"pointer")," block",!
 set:g="$GLOBAL" d=0
 if '$data(xx) write "Right: ",$view(vol,4,4)," Global: ",g,! write "Index Contains:",!
 set li=$view(vol,8,2)*2,i=hdrsize
 for  do  set i=i+2 quit:i>li
 . set f=$view(vol,i,2)*4 if 'f write $justify(i,5)_" ..." quit
 . set ccc=$view(vol,f+2),ucc=$view(vol,f+3),%=ucc set:%=1!(%=2) %=3 set:%=4 %=5
 . set:ucc $extract(buf,ccc+1,999)=$extract($view(vol,f+4,%),1,ucc) set k=buf,f=f+ucc+4
 . set key="" set:$length(buf) key="(" for  set key=key_$$UNKEY() quit:'$length(k)  set key=key_","
 . set:$length(buf) key=key_")" set:'$length(key) key="("""")"
 . if '$data(xx) write $justify(i,5)_" "_key_"="
 . if 'd set:f#4 f=f\4+1*4 write:'$data(xx) $view(vol,f,4),! quit
 . set k=$view(vol,f,2),f=f+2
 . if 'k set data=""
 . else  do
 . . if k<5,k'=3 set da="" for %=1:1:k set da=da_$char($view(vol,f+%-1))
 . . else  set da=$view(vol,f,k)
 . . set data=$$DISP^%U(da,long)
 . if '$data(xx) write """",data,"""",! quit
 . set @(xx_$select(key="("""")":"",1:key)_"=data")
;---
EXIT if blk view vol:0 ; Free the GBD if we allocated it
 quit
;---
UNKEY() new c,t,x
 ; Get string from key - check null
 if $extract(k,1,2)=$char(0,0) set k=$extract(k,3,999) quit """"""
 ; Check for a string
 if $ascii(k)=128 set c=""""_$piece($extract(k,2,999),$char(0))_"""",k=$piece(k,$char(0),2,999) quit c
 ; Get count
 set c=$ascii(k),k=$extract(k,2,999)
 ; Check for "0"
 if c=64&'k set k=$extract(k,2,999) quit "0"
 ; If it's negative, do the complementing
 if c<64 set c=63-c,t=$translate($piece(k,$char(255)),"0123456789","9876543210"),k=$piece(k,$char(255),2,999)
 ; Extract this (positive) subscript
 else  set t=$piece(k,$char(0)),k=$piece(k,$char(0),2,999)
 ; Quit with the number
 quit $select(c<64:"-",1:"")_$extract(t,1,c#64)_$select($length(t)>(c#64):"."_$extract(t,c#64+1,999),1:"")

%C
%C ; ^%C contents
 set ^%C="MCL Version 1.0"
 set ^%C("BP")="do BP^%DEBUG"
 set ^%C("BP",1)="Show current breakpoints and handlers"
 set ^%C("CD")="do CD^%U(ccl)"
 set ^%C("CD",1)="Change directory (UCI)"
 set ^%C("CLEAR")="write $char(27)_""[H""_$char(27)_""[J"""
 set ^%C("CLEAR",1)="Clear the screen"
 set ^%C("COPY")="merge:ccl?1(1""%"",1A).A1"" ""1(1""%"",1A).A ^$routine($piece(ccl,"" "",2))=^$routine($piece(ccl,"" ""))"
 set ^%C("COPY",1)="Copy from routine to routine"
 set ^%C("DCHANGE")="do INT^%DED(ccl)"
 set ^%C("DCHANGE",1)="Edit a document using your favorite editor"
 set ^%C("DDIRECT")="do INT^%DD(ccl)"
 set ^%C("DDIRECT",1)="Obtain a document directory"
 set ^%C("DELETE")="do DEL^%RD(ccl,sw)"
 set ^%C("DELETE",1)="Delete [/NOQuery] routine specification"
 set ^%C("DIRECTORY")="xecute ^%C(""RDIRECTORY"")"
 set ^%C("DIRECTORY",1)="Obtain a list of routines - same as RDIRECTORY"
 set ^%C("DSCAN")="do INT^%DED(ccl,1)"
 set ^%C("DSCAN",1)="Scan a document - read-only"
 set ^%C("DUMP")="do INT^%BLKDMP(^$job($job,""global_vol""),ccl)"
 set ^%C("DUMP",1)="Dump a block (formatted)"
 set ^%C("EDIT")="do INT^%ED(ccl)"
 set ^%C("EDIT",1)="Edit a routine using your favorite editor"
 set ^%C("ERROR")="do ^%ETDISP"
 set ^%C("ERROR",1)="Display logged errors"
 set ^%C("EXIT")="Internal %M command"
 set ^%C("EXIT",1)="Exit from MCL to either RSM direct mode or OS shell"
 set ^%C("GDIRECTORY")="do INT^%GD(0,ccl)"
 set ^%C("GDIRECTORY",1)="Global directory specification"
 set ^%C("GEFFICIENCY")="do INT^%GE(ccl)"
 set ^%C("GEFFICIENCY",1)="Display storage efficiency of a global"
 set ^%C("GRESTORE")="do INT^%GR(ccl)"
 set ^%C("GRESTORE",1)="Global restore filename"
 set ^%C("GSAVE")="do INT^%GS($piece(ccl,"" ""),$piece(ccl,"" "",2),$piece(ccl,"" "",3,99))"
 set ^%C("GSAVE",1)="Global save specification filename header text"
 set ^%C("HELP")="Internal %M command"
 set ^%C("HELP",1)="This text is displayed"
 set ^%C("LIST")="do INT^%GL(ccl,sw)"
 set ^%C("LIST",1)="List global /D=data only, /L=max level, /M=max lines"
 set ^%C("OS")="set:ccl="""" ccl=""exec $SHELL"" write $&%spawn(ccl)"
 set ^%C("OS",1)="Execute OS (UNIX) command - shell"
 set ^%C("RDIRECTORY")="do INT^%RD($select(sw[""L"":1,sw[""U"":2,1:0),ccl)"
 set ^%C("RDIRECTORY",1)="Routine directory /FL (first line) or /FU (full) spec"
 set ^%C("RECOMP")="do ^%RECOMP"
 set ^%C("RECOMP",1)="Recompile all routines in current environment (UCI)"
 set ^%C("ROUCHECK")="do RC^%RD(ccl)"
 set ^%C("ROUCHECK",1)="Check the compile syntax on routine specification"
 set ^%C("RRESTORE")="do INT^%RR(ccl)"
 set ^%C("RRESTORE",1)="Routine restore filename"
 set ^%C("RSAVE")="do INT^%RS($piece(ccl,"" ""),$piece(ccl,"" "",2),$piece(ccl,"" "",3,99))"
 set ^%C("RSAVE",1)="Routine save specification filename header text"
 set ^%C("SCAN")="do INT^%ED(ccl,1)"
 set ^%C("SCAN",1)="Scan a routine - read-only"
 set ^%C("SHOW")="do INT^%SS(ccl)"
 set ^%C("SHOW",1)="Show SYSTEM, LOCKS, or <Job #>"
 set ^%C("STATUS")="do INT^%STA(ccl)"
 set ^%C("STATUS",1)="Show system statistics, specify interval (e.g., STATUS 15)"
 set ^%C("SYSTAT")="do ^%SS"
 set ^%C("SYSTAT",1)="Obtain a system status"
 set ^%C("TYPE")="do 0^%TYP(ccl)"
 set ^%C("TYPE",1)="Type out a routine (like more)"

%D
%D ; Convert %D to printable date
 set:$data(%D)#2=0 %D=+$horolog set %D=$$D(%D) quit
;---
D(d) new m,y,%,zr set zr="D^%D"
 if d<0!(d>423316) quit ""
 set:d>21608 d=d+1 set m=1,y=d\1461*4+1841,d=d#1461
 set:'d d=1461,y=y-4 for %=1:1:3 quit:d<366  set y=y+1,d=d-365
 for %=31,28+(y#4=0),31,30,31,30,31,31,30,31,30,31 quit:d'>%  set m=m+1,d=d-%
 set m=$piece("Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec",",",m)
 quit $translate($justify(d,2)," ",0)_" "_m_" "_y

%T
%T ; Convert %T to printable time
 set:$data(%T)#2=0 %T=$piece($horolog,",",2) set %T=$$T(%T) quit
;---
T(h) new typ,m,s,%,zr set zr="T^%T"
 if h<0!(h>86399) quit ""
 set typ=$get(typ,0),%=""
 set s=h#60,h=h\60,m=h#60,h=h\60
 if 'typ set %=$select(h<12:" AM",1:" PM"),h=h#13+('h*12)+(h>12)
 quit $translate($justify(h,2)," ",0)_":"_$translate($justify(m,2)," ",0)_":"_$translate($justify(s,2)," ",0)_%

%DD
%DD ; Do a document directory
 do INT(".E") quit
;---
INT(pat) new st,end,g,%,%d,%v,f,r,zr set zr="INT^%DD"
 set fl=$get(fl),pat=$get(pat,".E")
 set:pat="" pat=".E" if $extract(pat)'=".",$extract(pat)'?1N set pat=$$PAT^%U(pat)
 write "Document Directory matching '"_pat_"'.",!! set r=" "
 for st=0:1 set r=$order(^%D(r)) quit:r=""  if r?@pat do
 . write r,?30 set end="" set:r["." end=$&e($piece(r,".",$length(r,".")))
 . set %d=^%D(r),%v=0 for  quit:'$order(^%D(%d,%v))  set %v=$order(^(%v))
 . set f=0,%=0 if end="JPG"!(end="PNG")!(end="GIF")!(end="CLASS") do  quit
 . . for  set %=$order(^%D(%d,%v,%)) quit:'%  set f=f+$length(^(%))
 . . write $justify(f,10)," bytes",!
 . for f=0:1 set %=$order(^%D(%d,%v,%)) quit:'%
 . write $justify(f,10)," lines",!
 quit

%DEBUG
%DEBUG ; Tools for the interactive debugger
TRACE ; Dump a stack trace - useful for the quit handler (run as BREAK ":DO TRACE^%DEBUG")
 new v4wCurrent,v4wStack
 set v4wCurrent=$select($stack($stack(-1)-1)="BREAK":$stack-2,1:$stack-1)
 write !," STACK | COMMAND |    ECODE    |       PLACE       | MCODE",!
 write "-------+---------+-------------+-------------------+-------",!
 for v4wStack=$select($stack(-1)<($stack+1):$stack+1,1:$stack(-1)):-1:0 do
 . write $select(v4wStack=v4wCurrent:">>",1:"  ")
 . write $justify(v4wStack,4)," |",$justify($stack(v4wStack),8)," |",$justify($stack(v4wStack,"ecode"),12)
 . write " |",$justify($stack(v4wStack,"place"),18)," |",?53,$stack(v4wStack,"mcode"),!
 write !,"ETRAP [STACK="_v4wCurrent_"]: "_$etrap,!
 quit
;---
BP ; Show current debugging breakpoints and handlers
 new routine,line,cnt,tag,offset,ln
 write "QUIT breakpoint handler code is:",!
 if $get($ZBP)'="" write $ZBP,!
 write !,"Current breakpoints and handlers:",!
 set (routine,line)=""
 for  set routine=$order($ZBP(routine)) quit:routine=""  do
 . for  set line=$order($ZBP(routine,line)) quit:line=""  do
 . . set tag="",offset=0,ln=line
 . . if $data(^$routine(routine,ln)) do
 . . . for  set tag=$piece($piece(^$routine(routine,ln)," "),"(") quit:tag'=""!(ln=1)  do
 . . . . set offset=$increment(offset),ln=$increment(ln,-1)
 . . write $justify($increment(cnt),3)," "_tag_$select(offset:"+"_offset,tag="":"+"_line,1:"")
 . . write "^"_routine_$select(tag'="":" [+"_line_"]",1:"")_" :"
 . . if $ZBP(routine,line)'="" write $ZBP(routine,line),!
 . . else  write !
 write !
 quit

%DED
%DED ; Edit a document using $EDITOR
 new doc
 read !,"Document: ",doc,! quit:doc=""  do INT(doc) quit
;---
INT(doc,ro) new file,f,ui,%d,%v,%l,%,zr set zr="INT^%DED",ro=$get(ro)
 if $get(doc)="" quit
 ; Get the index, continue if OK
 set %d=$get(^%D(doc)) goto CONT:%d
 ; Create if it doesn't exist
 set %d=$order(^%D(" "),-1)+1,^(%d,0)=doc,^(1,1)="",^%D(doc)=%d
;---
; Look for a version
CONT set %=$order(^%D(%d,0)),%v=$order(^(%)) if '%v set %v=%+1 do
 . ; Create a new version
 . set %1=0 for %l=1:1 set %1=$order(^%D(%d,%,%1)) quit:'%1  set ^%D(%d,%v,%l)=^%D(%d,%,%1)
 ; Attempt to lock if required
 if 'ro lock +^%D(%d):1 else  write !,"?Can't lock document "_doc,! quit
 ; Setup the file name
 set ui=$$UI^%U(),file=doc_"."_ui open 1:(file:"write")
 if 'ro use 1 write "Editing "_doc,!,"Remove above to NOT save document.",! use $principal
 set %=0 use 1 for  set %=$order(^%D(%d,%v,%)) quit:'%  write ^(%),!
 use $principal close 1
 set f=$&%getenv("EDITOR") set:f="" f="vi" set f=f_" "_file
 if $extract(f)="x",ro set f=f_"&"
 set %=$&%spawn(f)
 if ro open 1:(file:"write") close 1 quit
 write !,"Saving edit...",!
 open 1:(file:"read") use 1 read f,% use $principal
 if "Editing "_doc'=f write "Edit NOT saved!",! goto EXIT
 ; Save the data
 use 1 set %v=%v+1 for %l=1:1 read f quit:$ascii($key)=255  set ^%D(%d,%v,%l)=f
 ; Remove an old version - done
 set %v=$order(^%D(%d,""),-1),%v=$order(^(%v),-1) if %v set %=$order(^(%v),-1) if % kill ^(%)
;---
EXIT use $principal close 1 open 1:(file:"write") close 1 lock -^%D(%d) quit

%ED
%ED ; Edit a routine using $EDITOR
 new rou
 read !,"Routine: ",rou,! quit:rou=""  do INT(rou) quit
;---
INT(rou,ro) new ui,file,f,%,zr,$etrap set $etrap="do EXIT^%ED"
 set zr="INT^%ED",ro=$get(ro) if $get(rou)="" quit
 if $get(^$system("name_length"),8)=32 goto CONT:rou?1A.31AN,CONT:rou?1"%".31AN&(^$job($job,"routine")=1) quit
 else  goto CONT:rou?1A.7AN,CONT:rou?1"%".7AN&(^$job($job,"routine")=1) quit
;---
CONT if 'ro lock +^$routine(rou):1 else  write !,"?Can't lock routine "_rou,! quit
 if ro,'$data(^$routine(rou)) write !,"?No such routine "_rou,! quit
 set ui=$$UI^%U(),file=rou_"-"_ui_".rsm" open 1:(file:"write")
 if 'ro use 1 write "Editing "_rou,!,"Remove above to NOT save routine.",!,rou,! use $principal
 if '$data(^$routine(rou)) write !,"Creating routine "_rou,! use 1 write rou_" ; New routine",!
 else  set %=0 use 1 for  set %=$order(^$routine(rou,%)) quit:'%  write ^$routine(rou,%),!
 write !! use $principal close 1
 set f=$&%getenv("EDITOR") set:f="" f="vi" set f=f_" "_file
 if $extract(f)="x",ro set f=f_"&"
 set %=$&%spawn(f)
 if ro open 1:(file:"write") close 1 quit
 write !,"Saving edit...",!
 open 1:(file:"read") kill ^UTILITY(ui) use 1 read f,%,% use $principal
 if "Editing "_rou'=f write "Edit NOT saved!",! goto EXIT
 use 1 for %=1:1 read ^UTILITY(ui,%) quit:^UTILITY(ui,%)=""  quit:$ascii($key)=255
 merge ^$routine(rou)=^UTILITY(ui) kill ^UTILITY(ui)
;---
EXIT use $principal close 1 open 1:(file:"write") close 1 lock -^$routine(rou) quit

%ET
%ET ; RSM Error Trapper
 ; Don't error trap in here
 new $etrap set $etrap=""
 ; Save $test and $ecode - If we don't have a file, get it
 kill zz set zz("$T")=$test,zz("$ECODE")=$extract($ecode,1,255) if '$data(zf(1)) do
 . ; Store permanent junk
 . set zz("$H")=$horolog,zz("$I")=$io,zz("$J")=$job,zz("$P")=$principal,zz("$X")=$x,zz("$Y")=$y,zz("$R")=$reference
 . ; Get next number
 . lock +^ERT set zf(1)=$get(^ERT)+1,^ERT=zf(1) lock -^ERT
 . ; Setup the global ref
 . set zf(1)="^ERT("_zf(1)_",",zz=$piece(zz("$ECODE"),",",2)
 . ; Set '$ZE' as reason
 . if $length(zz) set zz("$ZE")=$&%errmsg(zz)
 ; Command stack. Store current context and maximum (or current) context level
 set zz("$STACK")=$stack-1,zz("$STACK(-1)")=$stack(-1),zz("$ESTACK")=$estack-1
 ; Save here too
 set zf(2)=zz("$STACK")
 ; Store $stack($stack)
 set zz("$STACK("_zf(2)_")")=$stack(zf(2))
 ; Save where we are up to
 set zf(1)=$piece(zf(1),",")_","_zz("$ESTACK")_")" merge @zf(1)=zz kill zz set zf=$&%zwrite(zf(1))
 ; Store remaining information
 for zz="PLACE","MCODE","ECODE" set zz("$"_zz_"()")=$stack(zf(2),zz)
 ; Get the routine name
 set zz=$piece($piece($stack(zf(2),"PLACE"),"^",2)," ") do
 . ; Try to get the first line
 . if $length(zz) set zz="+1^"_zz,zz("$ROUTINE")=$text(@zz)
 . ; Quit if not set
 . if '$data(zz("$R")) quit
 . ; Quit if last subscript null
 . if '$length($qsubscript(zz("$R"),$qlength(zz("$R")))) quit
 . ; Get extra $reference information
 . set zz("$D(@$R)")=$data(@zz("$R")) if zz("$D(@$R)")#2 set zz("@$R")=@zz("$R")
 ; If RSM, save some more of this
 if $extract(zf(1))="^" merge @zf(1)=zz kill zz,zf
 ; Quit leaving $ecode set
 quit
;---
; The final Trap entry point - clear $ecode and exit
ZT set $ecode="" quit

%ETDISP
%ETDISP ; RSM Error Display
 ; Save Command Stack, locks etc. - set errortrap to do nothing
 new eg,n,er,cs,qv,g,zr,ter,$etrap
 set zr="^%ETDISP",$etrap="do ZT^%ET",eg="^ERT"
 write !,?10,"Reference Standard M - Error display utility",!!
 ; Check for transfered errors
 if '$get(@eg) set %=$order(@eg@("Z"),-1) if % set @eg=%
 ; Check for any errors
 if '$get(@eg) kill @eg write ?20,"No errors recorded.",! quit
 set %="" for n=0:1 set er=%,%=$order(@eg@(%)) quit:'%
 if 'n kill @eg write ?20,"No errors recorded.",! quit
 goto D1:n=1 write n_" error"_$select(n>1:"s",1:0)_" recorded.",!
;---
ER read "Error #: ",er set er=$&e(er) write ! quit:er'="HELP"&(er?1A.E)
 if er="?"!(er="HELP") do  goto ER
 . write ! set er="" for  set er=$order(@eg@(er)) quit:'er  do S1
 . write ?4,"Enter error number, <Return> for last error, E to EXIT.",!
 . write ?4,"/D to delete the entire error trap global and exit.",!!
 ; Check for a global /D
 if er="/D" kill @eg write !,"deleted...",! quit
 if er="" set er=$order(@eg@("z"),-1) set:er="" er=" "
 if '$data(@eg@(er)) write "?No such error number.",! goto ER
;---
; Display 1 error passed in er
D1 write ! do S1
 ; Say what
 write $get(@eg@(er,ter,"$ROUTINE")),!,$get(@eg@(er,ter,"$MCODE()")),!
;---
DV new v,err,pat,f
 write:$x ! read "Variable: ",v write !
 if $extract($&e(v),1,2)="/D" do  set v="/D"
 . ; Fetch the current '$ZE' for the /A switch
 . set err=$get(@eg@(er,ter,"$EC"))_": "_$piece($get(^("$ZE")),",",1,2)
 . kill @eg@(er) if $&e(v)["/A" set %=0 for  set %=$order(@eg@(%)) quit:'%  do
 . . ; Get Top Error - just dong if no such
 . . set %1=$order(@eg@(%,"z"),-1) if '%1 kill @eg@(%) quit
 . . ; Dong it - then dong all the same if /A specified
 . . if $get(@eg@(%,%1,"$EC"))_": "_$piece($get(^("$ZE")),",",1,2)=err kill @eg@(%)
 . ; If there are no errors left, dong the whole thing - unlock and quit
 . kill:'$order(@eg@(0)) @eg quit
 ; See if there are more errors
 if $&e(v)="/D" set er=$order(@eg@(er),-1) set:'er er=$order(^(0)) quit:'er  goto D1
 quit:$&e(v)="EXIT"  goto ER:v=""
 if $&e(v)="HELP" write ! do  goto DV
 . write ?5,"Enter variable to display. Wild card characters ? and * may be used.",!
 . write ?5,"/D to delete error, /D/A to delete all of this type.",!
 . write ?5,"Press <Return> for 'Error #:' prompt.",!
 . write ?5,"*$R* will display all information about the last global reference.",!
 . write ?5,"$ST* will display the call stack.",!
 . write ?5,"<Help> or HELP for help. EXIT to exit.",!
 . write ?5,"To examine variables HELP and EXIT, use HEL? and EXI? respectively.",!!
 set pat="" if v'["?",v'["*" do V1 goto DV
 ; Go through supplied pattern char by char and treat ?*" specially
 for %=1:1:$length(v) set f=$extract(v,%),pat=pat_$select(f="*":".E",f="?":"1E",f="""":"1""""""""",1:"1"""_f_"""")
 ; Scan all variables at Top Error
 set v="" for  set v=$order(@eg@(er,ter,v)) goto DV:v=""  if v?@pat do V1
;---
; Write out this level
V1 write v,?9," = ",$select($data(@eg@(er,ter,v)):$$CC(^(v)),1:"<UNDEF>"),!
 ; Display at other levels
 for %=ter-1:-1:0 if $data(@eg@(er,%,v)) write " @ lev-",%,?9," = ",$$CC(@eg@(er,%,v)),!
 quit
;---
D0 write !?10,"No "_$select(%=89:"previous",1:"next")_" error - select by number.",!
 goto ER
;---
CC(d) new f,%,x
 if d?.E1C.E set d=$$DISP^%U(d)
 quit """"_d_""""
;---
; Summarize the error in er
S1 new %dt
 set ter=$order(@eg@(er,"z"),-1),%dt=$get(@eg@(er,ter,"$H"))
 write $justify(er,3),?4,$$D^%D(+%dt)_" "_$$T^%T($piece(%dt,",",2)),?29
 set %=$get(@eg@(er,ter,"$ECODE"))_": "_$get(^("$ZE")) write $extract(%,1,55),! quit

%G
%G ; Global Extended Lister
 new  ; General Stack
 new $etrap set $etrap="do ERR^%G" for  do RGLB quit:%g=""  write ! do GO
;---
EXIT write ! quit
;---
ERR set er=$piece($ecode,",",2) write !,"Error: ",er," ",$&%errmsg(er),! set $ecode="" quit
;---
GO set $etrap="do ERR^%G",%hn=%n if %hn?1"^[".E set %hn="^"_$piece(%hn,"]",$length(%hn,"]"))
 set hgdiff=$length(%n)-$length(%hn),lwlh=0,lwlev=0,lwleng=0
 if '%m,%n_"("=%g,$data(@%n)'=10 write %hn write !,@%n,!
 if $order(@%n@(""))="" quit
 set sholev=%l-(%e>1),gref=%n_"(",href=%hn_"(" do CHILDREN(1) quit
;---
CHILDREN(lev) new length,subscr,z ; Stack Important !
 set $etrap="do ERR^%G"
 set length=$length(gref),subscr=$select(lev'>%l:%b(lev),1:"")
 if subscr'="",$data(^(subscr))
 else  set subscr=$order(^(subscr))
 for  quit:$$PASTEND  do ACHILD if subscr'="" set subscr=$order(^(subscr))
 quit
;---
ACHILD set $etrap="do ERR^%G"
 set subs=$$QS(subscr),gref=gref_subs,href=href_subs,%d=$data(^(subscr))
 if lev>sholev,%d'=10!(%e=2) do SHOWREF write:%d=10 "pointer" write:%d'=10 "="_^(subscr) write !
 if %d>9,%e'=2!(lev<%l) do DESCEND
 set gref=$extract(gref,1,length),href=$extract(href,1,length-hgdiff)
 set:lev'>%m subscr="" quit
;---
PASTEND() if subscr="" quit 1
 if lev>%l quit 0
 if %c(lev)="" quit %b(lev)'=""&(%b(lev)'=subscr)
 if subscr=%c(lev) quit 0
 if subscr'["E",subscr=+subscr goto GSE
 if %c(lev)'["E",%c(lev)=+%c(lev) quit 1
 quit subscr]%c(lev)
;---
GSE if %c(lev)'["E",%c(lev)=+%c(lev) quit subscr>%c(lev)
 quit 0
;---
SHOWREF ; Show global reference (KEY)
 if lwlev=lev write ?lwlh-$length(href)+lwleng,$extract(href,lwleng+1,999)
 else  write href set lwlh=$length(href),lwlev=lev
 write ")" set lwleng=length-hgdiff quit
;---
DESCEND set gref=gref_",",href=href_",",dummy=$order(^(subscr,""))
 do CHILDREN(lev+1) set dummy=$order(@($extract(gref,1,$length(gref)-1)_")"))
 set lwlev=0,lwleng=0 quit
;---
QS(str) set oet=$etrap,$etrap="do QSERR^%G"
 if str'["E",str=+str quit str
;---
NOTCN set $etrap=oet,temp=str,str=""
 for piece=1:1:$length(temp,"""") set str=str_""""""_$piece(temp,"""",piece)
 set str=$extract(str,3,999)
 quit """"_str_""""
;---
QSERR set $ecode="" goto NOTCN
;---
; READ Global KEY-Mask...
RGLB for  do READ quit:%g=""  quit:%m'<0
 quit
;---
READ read !,"Global ^",%g quit:%g=""  if %g="?" do ^%GD set %m=-2 quit
 do PROC if %m=-2  write *7,"  [Invalid global reference]" quit
 do GDEF if %m=-2  write *7,"  [Invalid global reference]" quit
;---
GDEF set $etrap="do DERR^%G" if '$data(@%n) write "  ???" set %m=-2
 quit
;---
DERR set er=$piece($ecode,",",2) write:$&%errmsg(er)'["<SYNTAX>" !,$ecode set %m=-2,$ecode="" quit
;---
PROC if $extract(%g)'="^" set %g="^"_%g
 if $extract(%g,2)="$" s %m=-2 write "  ???" quit  ; No support for SSVNs
 set %f=0 if %g?1"^(".E quit
 set %f=2 if %g'["(" set %g=%g_"("
 if %g?.E1"," set %e=1
 else  if %g?.E1")" set %e=2,%g=$extract(%g,1,$length(%g)-1)_","
 else  set %e=3
 if '%f set %m=-2 quit
 kill %b,%a set %x=$piece(%g,"(",2,256) set %n=$piece(%g,"("),%nfull=%n
 set %glo=$piece(%n,"^",2,$length(%n,"^")) do R quit
;---
R set %m=1,%b=1,%l=0,%p=0 goto RT:%x=""
;---
RRR set %a="" if $extract(%x,%m)="," set %x=$extract(%x,1,%m-1)_""""""_$extract(%x,%m,999)
;---
RR if $extract(%x,%m)="""" for %i=1:1 set %m=%m+1 quit:%m>$length(%x)  if $extract(%x,%m)="""" set %m=%m+1 goto RR
 if $extract(%x,%m)="(" set %p=%p+1,%m=%m+1 goto RR
 if $extract(%x,%m)=")",%p set %p=%p-1,%m=%m+1 goto RR
 if ":,)"'[$extract(%x,%m),$extract(%x,%m)'?1C set %m=%m+1 goto RR
 if $extract(%x,%m)?1P,%p set %m=%m+1 goto RR
 if $extract(%x,%m)=":" goto RE:%a]"" set %a=1_$extract(%x,%b,%m-1),%m=%m+1,%b=%m goto RR
 if $extract(%x,%m)'=",",$extract(%x,%m)'=")",$extract(%x,%m)]"" goto RE
 set %l=%l+1,%b(%l)=$extract(%x,%b,%m-1),%m=%m+1,%b=%m
 do S quit:%m=-2  goto RRR:%m'>$length(%x)
;---
RT for %i=1:1:%l quit:%b(%i)=""!(%c(%i)]"")
 set %m=%i-1 quit
;---
RE set %m=-2 quit
;---
S set %c(%l)="" if %a]"" do  goto S1
 . do S1 set %c(%l)=$select(%b(%l)]"":%b(%l),1:$char(255,255)),%b(%l)=$extract(%a,2,999)
;---
S1 if %b(%l)'["E",%b(%l)=+%b(%l) quit
 if %p=1,%e=2,%m'<$length(%x) do
 . set:%b(%l)?.E1"," %b(%l)=$extract(%b(%l),1,$length(%b(%l))-1),%m=%m-1
 . set %e=3,%b(%l)=%b(%l)_")"
 quit:%b(%l)=""
 set $etrap="do S1ERR^%G" if %b(%l)["%" new %a,%c,%d,%e,%f,%g,%i,%m,%n,%p,%x,%zt
 set @("%b(%l)="_%b(%l)) quit
;---
S1ERR set er=$piece($ecode,",",2) write "  "_$piece($&%errmsg(er),">")_"> in ",%b(%l) set %m=-2,$ecode="" quit

%GD
%GD ; Do a global directory for current UCI
 do INT(0,".E") quit
;---
INT(fl,pat,uci,st,end,g) new %,f,l,zr set zr="INT^%GD"
 set fl=$get(fl),pat=$get(pat,".E"),uci=$get(uci,^$job($job,"global"))
 set:pat="" pat=".E" if $extract(pat)'=".",$extract(pat)'?1N set pat=$$PAT^%U(pat)
 set st=$get(st),end=$get(end,"z"),l=st if uci set uci=^$system("vol",^$job($job,"global_vol"),"uci",uci)
 if fl=3,'$data(g) set g="sel"
 if fl-3 write "Global Directory of ["_uci_"] matching '"_pat_"'.",!!
 for  set l=$order(^[uci]$global(l)) quit:l=""!($extract(l)]end)  if l?@pat do
 . if '$data(@("^"_l)) quit
 . if 'fl write:$x>70 ! write l,?$x\10+1*10 quit
 . if fl=3,$extract(l)'="$" set @g@(l)=""
 quit

%GE
%GE ; Global efficiency
 new g
 read !,"Global: ^",g,! quit:g=""  do INT(g) quit
;---
INT(g) new %,uci,b,nb,all,fre,l,ta,tu,siz,isd,zr set zr="INT^%GE"
 if $get(g)="" goto ^%GE
 new vol set vol=$get(vol,^$job($job,"global_vol")),vol=-vol
 set g=$translate(g,"^"),uci="",a=0,siz=^$system("vol",-vol,"block")
 if g["]" set uci=$piece(g,"]")_"]",g=$piece(g,"]",2)
 set %="^"_uci_"$GLOBAL("""_g_""")",ta=0,tu=0
 if '$data(@%) write "Global ^",uci,g," does not exist",! quit
 set b=@% write "Global efficiency for ^",uci,g," (",b,")",!
 ; Get all levels
 for l=1:1 view vol:b set isd=$view(vol,0)>64 do  quit:isd  set b=nb
 . if 'isd set %=$view(vol,$get(^$system("name_length"),8)+12,2)*4+2,%=$view(vol,%+1)+2+% set:%#4 %=%\4+1*4 set nb=$view(vol,%,4)
 . write "Level",$justify(l,3),": " set fre=0
 . for all=0:1 quit:'b  view vol:b set b=$view(vol,4,4),fre=$view(vol,10,2)*2+1-$view(vol,8,2)*2+fre
 . set all=all*siz,fre=all-fre write $justify(fre,16)," bytes used of ",$justify(all,16)
 . write $justify(fre/all*100,7,2),"%",! set ta=ta+all,tu=tu+fre
 write "Total:    ",$justify(tu,16)," bytes used of ",$justify(ta,16),$justify(tu/ta*100,7,2),"%",!
 quit

%GL
%GL ; List global
 new ccl
 read "Global: ",ccl,! quit:ccl=""  do INT(ccl,"/M") quit
;---
INT(ccl,sw) new gl,q,stop,f
 if $get(ccl)="" goto ^%GL
 set gl=ccl if ccl["/" set q=0 do
 . for %=1:1:$length(ccl) do
 . . set:$extract(ccl,%)="""" q='q if 'q,$extract(ccl,%)="/" set sw=$get(sw)_$extract(ccl,%,999),gl=$extract(ccl,1,%-1)
 if $extract(gl)'="^" set gl="^"_gl
 if $piece(gl,"(")["$" write "?Can't list an SSVN",! quit
 if $data(@gl)=0 write "?Global undefined",! quit
 set stop=$extract(gl,$length(gl))=")" set:stop gl=$extract(gl,1,$length(gl)-1)
 set f=$piece(gl,"(",2,999),gl=$piece(gl,"(")_$select(gl["(":"(",1:""),q=0 goto NA:f=""
 if $extract(f)'="""" set gl=gl_""""
 for %=1:1:$length(f) do
 . if $extract(f,%)="""" set q='q,gl=gl_"""" quit
 . if $extract(f,%)'=","!q set gl=gl_$extract(f,%) quit
 . set gl=gl_$select($extract(f,%-1)="""":"",1:"""")_","_$select($extract(f,%+1)="""":"",1:"""")
 set:$extract(gl,$length(gl))'="""" gl=gl_"""" set gl=gl_")"
;---
NA new ns,ls,l1,max,lev,do,nc,cnt
 set gl=$name(@gl,999)
 set ns=$qlength(gl),ls=$qsubscript(gl,ns),l1="" set:ns l1=$name(@gl,ns-1)
 set max=100,lev=999,do=0,nc=0
 if sw["/D" set do=1
 if sw["/L" set lev=+$extract($piece(sw,"/L",2),2,99)
 if sw["/N" set nc=1
 if sw["/M" set max=+$extract($piece(sw,"/M",2),2,99)
 set cnt=0 if $data(@gl)#10 write gl,"=",@gl,! set cnt=1
 for  set gl=$query(@gl) quit:gl=""  do  quit:stop>1
 . if stop,$name(@gl,ns-1)'=l1!($qsubscript(gl,ns)]]ls) set stop=2 quit
 . quit:$qlength(gl)>lev
 . set f=@gl set:f?.E1C.E&'nc f=$$DISP^%U(f) write:'do gl,"=" write f,!
 . set cnt=cnt+1 if cnt=max set stop=2
 write:cnt=max "** "_max_" nodes printed **",! quit

%LPC
%LPC ; WAA-Longitudinal Parity Check ;15-June-2000
 quit
;---
;;%LPC Version 1.0
LRC(data) ; Main Entry point
 new i,x,char,count,array,longsum,bite,lbite
 set x=0
 for i=1:1:$length(data) set char=$extract(data,i),char=$ascii(char),char=$$CKBYTE(char),array(i)=char
 for i=8:-1:1 do
 . new j,cnt
 . set j=0,cnt=0
 . for  set j=$order(array(j)) quit:j<1  do
 . . set cnt=cnt+$extract(array(j),i)
 . . quit
 . set count(i)=(cnt#2)
 . quit
 for i=1:1:7 if count(i) set x=x+$select(i=1:64,i=2:32,i=3:16,i=4:8,i=5:4,i=6:2,i=7:1,1:0)
 quit x
;---
CKBYTE(x) ; Convert to byte and checkbit
 new y,i,ck
 set y="",ck=0
 set y=$$BYTE(x)
 for i=7:-1:1 if $extract(y,i) set ck=ck+1
 set y=y_('(ck#2))
 quit y
;---
BYTE(y) ; Convert to byte
 new byte
 set byte=""
 do LOOP
 quit byte
;---
LOOP ; Main loop to convert to bit
 new bit
 if y=0 quit
 set bit=y#2
 set byte=bit_byte
 if bit=0 set y=y/2
 if bit=1 set y=y\2
 goto LOOP

%M
%M ; The M Command Language
 new cmd,cs,wid,a,bl,$etrap
 set $ecode="",$etrap="do ERROR^%M"
;---
START set wid="terminator="_$char(1,2,4,5,6,7,9,10,11,12,13,14,15,16,18,20)
 use $principal:("controlc":"delete=none":"notypeahead":"escape":"echo":wid)
 ; Work out Bottom Line and Width
 write $&v(999,999),$char(27)_"[6n" read a use $principal:("delete=both":"typeahead")
 set bl=+$piece($key,"[",2),wid=+$piece($key,";",2)
 set:'bl bl=24 set:'wid wid=80 ; Default in case terminal is wonky
 do READ if $get(cmd)'="EXIT" goto START
 use $principal:("delete=delete":"terminator="_$char(13)) set $ecode="" quit
;---
READ new vol,uci,pmt,%pmt,e,cst,key,p,sav
 set vol=^$job($job,"global_vol"),uci=^$job($job,"global")
 set pmt="MCL ["_^$system("vol",vol,"uci",uci)_","_^$system("vol",vol,"name")_"]> "
 set %pmt=$length(pmt),e=$char(27)
 new $estack write $&v(bl,1),!,pmt
 set cst=$get(cs)+1 read cmd set key=$key if $ascii($key)=127!($ascii($key)=8) set key=127
 set p=$length(cmd)+%pmt+1 do KEY goto K
;---
AD write $&v(bl-($length(cmd)+%pmt\wid-(p-1\wid)),p-1#wid+1)
;---
RS read *a set key=$key if a=127!(a=8) set key=127,a=27
 if a<32,a'=27 set key=$char(a),a=27
 if a=27 do KEY goto K
 if p>($length(cmd)+%pmt) set cmd=cmd_$char(a),p=p+1 goto RS
 set cmd=$extract(cmd,1,p-%pmt-1)_$char(a)_$extract(cmd,p-%pmt,$length(cmd))
 if '($length(cmd)+%pmt#wid) write e_"["_(p-1\wid+1)_"A"_e_"[2K"_e_"[J"_e_"["_wid_"D"_pmt_cmd
 else  write e_"[J"_$extract(cmd,p-%pmt+1,$length(cmd))
 set p=p+1 goto AD
;---
K set sav=bl-($length(cmd)+%pmt\wid)
 if key=42!(key=45) goto DOIT ; <Enter>|<Ctrl><J>|<Ctrl><M>
 if key=33 set p=%pmt+1 goto AD ; <Ctrl><A>
 if key=81 set cst=cst-1 set:cst<1 cst=$get(cs)+1 set cmd=$get(cs(cst)),key=55,p=%pmt+1+$length(cmd) ; <Up>
 if key=82 set cst=cst+1 set:cst>($get(cs)+1) cst=1 set cmd=$get(cs(cst)),key=55,p=%pmt+1+$length(cmd) ; <Down>
 if key=36 set cmd=$extract(cmd,1,p-%pmt-1),key=55,p=$length(cmd)+%pmt+1 ; <Ctrl><D>
 if key=37 set p=$length(cmd)+%pmt+1 goto AD ; <Ctrl><E>
 if key=53 set cmd=$extract(cmd,p-%pmt,$length(cmd)),key=55,p=%pmt+1 ; <Ctrl><U>
 if key=55 write $&v(sav,1),e_"[J",$&v(bl-($length(cmd)+%pmt\wid),1),pmt,cmd goto AD ; <Ctrl><W>
 if key=58 set cmd="EXIT" goto DOIT ; <Ctrl><Z>
 if key=83,p'>($length(cmd)+%pmt) set p=p+1 goto AD ; <Right>
 if key=84,p>(%pmt+1) set p=p-1 goto AD ; <Left>
 if key=87 set cmd=$extract(cmd,1,p-%pmt-1)_$extract(cmd,p-%pmt+1,$length(cmd)) ; <Delete>
 if key=96!(key=112) set cmd="HELP" goto DOIT ; <F1>|<Help>
 if key=127,p>(%pmt+1) set cmd=$extract(cmd,1,p-%pmt-2)_$extract(cmd,p-%pmt,$length(cmd)),p=p-1 write e_"[D" ; <Backspace>|<Ctrl><H>
 if key'=87&(key'=127) write $char(7) goto RS
 if p<(%pmt+1) write $char(7) goto RS
 if '($length(cmd)+%pmt+1#wid) write e_"[2K"_e_"[B"_e_"[s"_e_"["_wid_"D"_pmt_cmd_e_"[u"
 else  write e_"[J",$extract(cmd,p-%pmt,$length(cmd))
 goto AD
;---
DOIT write:p'>($length(cmd)+%pmt) $&v($length(cmd)+%pmt\wid+1+bl,1) write !
;---
INT new %,ccl,c,sw
 set cmd=$&e(cmd,"b"),ccl=$piece(cmd," ",2,999),c=$&e($piece(cmd," ")) quit:c=""
 if $get(cs(+$get(cs)))'=cmd set cs=$get(cs)+1,cs(cs)=cmd
 if c?1U do:c="K"  xecute cmd quit
 . quit:cmd["("!($extract(ccl)'="^")  if $&e(ccl)="^$J"!($&e(ccl)="^$JOB") write "Use ^SSD please.",! set cmd="Q" quit
 . write "KILL entire global: N> "
 . read %,! if $extract($&e(%))'="Y" set cmd="Q"
 if c=$extract("EXIT",1,$length(c)) set cmd="EXIT" quit
 if c=$extract("HELP",1,$length(c)) goto ^%MH
 set sw=$piece(c,"/",2,9),c=$piece(c,"/") set:$length(sw) sw="/"_sw
 set %=c set:'$data(^%C(c)) %=$order(^%C(c)) if $extract(%,1,$length(c))=c new $etrap,bl xecute ^(%) quit
 write "?No such MCL command - try HELP",! quit
;---
KEY if key=127 quit
 if $length(key)=1 set key=$ascii(key)+32 quit
 if $length(key)=3 set key=$ascii(key,3)+16 quit
 set key=$extract(key,3,4)+84 quit
;---
WWW(req,data) ; Web interface
 new cmd,e
 set cmd=$get(data("CMD")),e=$char(27)
 if '$get(restrict,0),cmd'="" do INT quit ""
 quit "Operation not implemented!"
;---
ERROR new s,er use $principal
 if $estack<2 write:$ecode'="" "ECODE="_$ecode,! set $ecode="" quit
 quit:$stack-$stack(-1)  set s=$stack-1 if $ecode[",Z51," write:$x ! write "^C",! quit
 set er=$piece($ecode,",",2) write:$x ! if $length(er) write "Error: "_er_" "_$&%errmsg(er),!
 write "$STACK="_s,?12,$stack(s),?20,$stack(s,"place"),!
 write "Code:",?12,$stack(s,"mcode"),! quit

%MH
%MH ; Help on MCL
 write !,e_"[1m"_e_"[4m","M Command Language Help Menu",e_"[0m"," - commands are case-insensitive",!
 write "Enter any M command (short form only) or one of the following:",!!
 set %="@" for  set %=$order(^%C(%)) quit:%'?1U.E  write %,?12,^%C(%,1),!
 write !,"Key usage:  <F1> or <Help> this message",!
 write ?12,"<Up> and <Down> move through entered lines",!
 write ?12,"<Left> and <Right> move in current command",!
 write ?12,"<Ctrl><A> move to begining of line",!
 write ?12,"<Ctrl><D> delete to end of line",!
 write ?12,"<Ctrl><E> move to end of line",!
 write ?12,"<Ctrl><U> delete to begining of line",!
 write ?12,"<Ctrl><W> refresh screen",!
 write ?12,"<Ctrl><Z> exit MCL",!
 quit

%RD
%RD ; Do a routine directory for current UCI or manager %
 do INT(0,".E") quit
;---
LIB do INT(0,"1""%"".E",1,"%","%") quit
;---
INT(fl,pat,uci,st,end,g) new %,f,r,zr set zr="INT^%RD"
 new big set big=$$BIGEND^%U
 new web set web=$piece($device,",",2)=2
 set fl=$get(fl),pat=$get(pat,".E"),uci=$get(uci,^$job($job,"routine"))
 set:pat="" pat=".E" if $extract(pat)'=".",$extract(pat)'?1N set pat=$$PAT^%U(pat)
 set st=$get(st),end=$get(end,"z"),r=st if uci set uci=^$system("vol",^$job($job,"routine_vol"),"uci",uci)
 if fl=3,'$data(g) set g="sel"
 if fl-3 write "Routine Directory of ["_uci_"] matching '"_pat_"'.",!!
 if fl=2 write "Routine",?10," Size",?20,"Owner",?30,"Compiled",!!
 for  set r=$order(^[uci]$routine(r)) quit:r=""!($extract(r)]end)  if r?@pat do
 . if 'fl write:$x>70 ! write r,?$x\10+1*10 quit
 . if fl=1 write r,?10,^[uci]$routine(r,1),! quit
 . if fl=2 set f=^[uci]$routine(r,0),%=r do  quit
 . . if $extract(r)="%" set %="%25"_$extract(r,2,9)
 . . if web write "<a href=""?$$WWW^%25M&cmd=typ%20"_%_""">"_r_"</a>" set $x=$length(r)
 . . else  write r
 . . write ?10,$justify($length(f),5),?20
 . . if $get(big,0) write $ascii(f,3)*256+$ascii(f,4)
 . . else  write $ascii(f,4)*256+$ascii(f,3)
 . . write ?30
 . . if $get(big,0) set %=$ascii(f,5)*256+$ascii(f,6)*256+$ascii(f,7)*256+$ascii(f,8)
 . . else  set %=$ascii(f,8)*256+$ascii(f,7)*256+$ascii(f,6)*256+$ascii(f,5)
 . . write $$D^%D(%)," at "
 . . if $get(big,0) set %=$ascii(f,9)*256+$ascii(f,10)*256+$ascii(f,11)*256+$ascii(f,12)
 . . else  set %=$ascii(f,12)*256+$ascii(f,11)*256+$ascii(f,10)*256+$ascii(f,9)
 . . write $$T^%T(%),!
 . if fl=3 set @g@(r)=""
 quit
;---
DEL(ccl,sw) new %,r,sel,ok,zr set zr="DEL^%RD",sw=$get(sw)["/NOQ"
 do INT(3,ccl) set r="",ok=1
 for  set r=$order(sel(r)) quit:r=""  do:'sw  if ok kill ^$routine(r) if sw write:$x>70 ! write r,?$x\10+1*10
 . write "Delete "_r read " OK: N> ",%,! set ok=$extract($&e(%))="Y"
 write ! quit
;---
RC(ccl) new %,r,sel,cnt,total,zr set zr="RC^%RD"
 do INT(3,ccl) set r=""
 for  set r=$order(sel(r)) quit:r=""  write:$x ! write r,! set cnt=$&%rouchk(r) write cnt,!! set total=$get(total,0)+cnt
 write $fnumber(total,",")_" total error"_$select(total=1:"",1:"s")
 quit

%RECOMP
%RECOMP ; Recompile ALL routines
 new r
 write !,"Recompiling ALL routines in the current environment (UCI)",!
 set r="" for  set r=$order(^$routine(r)) quit:r=""  write:$x>70 ! write r,?$x\10+1*10 merge ^$routine(r)=^$routine(r)
 write !,"Done",! quit

%SS
%SS ; System Status
 write "Job",?5,"PID",?15,"User",?25,"Pri",?30,"Routine",?40,"Commands",?50
 write "GlobRefs",?60,"Where",!
 new j set j=0 for  set j=$order(^$job(j)) quit:'j  do  write !
 . new $etrap set $etrap="set $EC="""""
 . write j,?5,^$job(j,"pid"),?15,^$job(j,"owner"),?25,$justify(^$job(j,"priority"),3)
 . write ?30,^$job(j,"routine_name"),?40,$justify(^$job(j,"commands"),8),?50
 . write $justify(^$job(j,"grefs"),8),?60,$extract(^$job(j,"$io",0),1,20)
 write ! quit
;---
INT(j) new %,zr set zr="INT^%SS",j=$&e(j) if j="" write "Show LOCKS, SYSTEM or Job#",! quit
 new vol set vol=^$job($job,"global_vol")
 ; Show LOCKS
 if $extract("LOCKS",1,$length(j))=j do  quit
 . write " Job  Count  Reference",! set j=""
 . for  set j=$order(^$lock(j)) quit:j=""  set %=^$lock(j) write:%'="" $justify(+%,4),$justify($piece(%,",",2),7),"  ",j,!
 ; Show SYSTEM
 if $extract("SYSTEM",1,$length(j))=j do  quit
 . write "$SYSTEM=",$system,!,"UCI# Name",!
 . ; Dump the UCIs
 . for %=1:1:63 set j=^$system("vol",vol,"uci",%) if $length(j) write $justify(%,3),"  ",j,!
 . write "Max: ",^$job," job",$select(^$job>1:"s",1:""),!
 . write "Vol: ",^$system("vol",vol,"name")," in file ",^$system("vol",vol,"file"),!
 . write ^$system("vol",vol,"size")," [",^$system("vol",vol,"block")/1024," KiB] Blocks, "
 . write ^$system("vol",vol,"free")," Free",!
 . set j=^$system("vol",vol,"logrd"),%=^$system("vol",vol,"phyrd")
 . write "Database reads - Logical: ",j,"  Physical: ",%
 . write:j "  Cache hits: ",$justify((j-%)/j*100,0,2),"%" write !
 ; Show JOB #
 if j'?1.N!(j<1)!(j>^$job) quit
 write "       Job: "_j if '$data(^$job(j)) write " No such job",! quit
 write "   PID: "_^$job(j,"pid")_"   User: "_^$job(j,"owner")
 write "   Priority: "_^$job(j,"priority"),! set %=^$job(j,"process_start")
 write "Started at: "_$$T^%T($piece(%,",",2))," on ",$$D^%D(%)
 write "  UCI Global: "_^$job(j,"global")_"  Lock: "_^$job(j,"lock")
 write "  Routine: "_^$job(j,"routine"),!
 write "   Routine: "_^$job(j,"routine_name"),"  Commands: ",^$job(j,"commands")
 write " GlobRefs: ",^$job(j,"grefs"),!
 set %=^$job(j,"$reference") if $length(%) write "    Global: ",%,!
 set %=^$job(j,"$stack",^$job(j,"$stack"),"mcode") if $length(%) write "      Code: ",%,!
 write "     Stack: ",^$job(j,"$stack",^$job(j,"$stack"),"place")," (Current)",!
 for %=^$job(j,"$stack")-1:-1:1 write $justify(%,10),": ",^$job(j,"$stack",%,"place"),!
 quit

%STA
%STA ; System Statistics
 read !,"Interval: ",int,! quit:int<1  do INT(int) quit
;---
INT(int) new %,o,n,ex,i,ls,zr,$etrap set zr="INT^%STA",$etrap="do ERR^%STA",ex=0
 new vol set vol=^$job($job,"global_vol")
 set ls="dbget,dbset,dbkil,dbdat,dbord,dbqry,lasttry,lastok,logrd,phyrd,logwt,phywt,blkalloc,blkdeall,blkreorg,diskerrors"
 write $&v(1,1),$char(27)_"[?25l",$char(27)_"[J" set:'int int=1
 do GET quit:ex  merge o=n for  do GET quit:ex  do PRT merge o=n quit:ex  read *%:int
 write $&v(23,1),! quit
;---
ERR write $char(27)_"[?25h" goto ^%ET:$ecode'["Z51" set $ecode="",ex=1 quit
;---
GET for i=1:1:$length(ls,",") set n($piece(ls,",",i))=^$system("vol",vol,$piece(ls,",",i))
 set n=$horolog quit
;---
PRT write $&v(1,1),"System Statistics - ",$$T^%T($piece($horolog,",",2))
 write " ("_int_" secs)",!
 write "Volume: ",^$system("vol",vol,"name")
 write " in file: ",^$system("vol",vol,"file"),!
 write ^$system("vol",vol,"size")," [",^$system("vol",vol,"block")/1024," KiB] blocks - "
 write ^$system("vol",vol,"free")," available ("
 write $justify(^$system("vol",vol,"free")/^$system("vol",vol,"size")*100,0,2),"%)"
 write $char(27)_"[0K",!! ; Clear to end-of-line to avoid display bug when available blocks shrink
 write ?15,$justify("Total",10),?30,$justify("Increment",10),!
 for i=1:1:$length(ls,",") set %=$piece(ls,",",i) write %,?15,$justify(n(%),10),?30,$justify(n(%)-o(%),10),!
 write "cache",?15,$justify(n("logrd")-n("phyrd")/n("logrd")*100,10,2),"%",?30
 set %=n("logrd")-o("logrd") if '% write $justify("",11),!
 else  write $justify(%-(n("phyrd")-o("phyrd"))/%*100,10,2),"%",!
 quit

%TYP
%TYP ; Type a routine
 new rou
 read "Routine: ",rou,! quit:rou=""
 do 0(rou) quit
;---
 ; Type routine rou
0(rou) new %,%1,f,l,w,s,stop,e set stop=0,e=$char(27)
 ; See if we need a continue - setup for a ^C
 new $etrap set $etrap="set $ecode="""",stop=1"
 if $get(rou)="" goto ^%TYP
 ; Check it
 if '$data(^$routine(rou)) write "?No such routine as "_rou,! quit
 ; Get the size
 set s=$order(^$routine(rou,""),-1)
 ; Get term setup - clear $y
 set l=99999,w=999,$y=1 if $piece($device,",",2)=4 do
 . ; Work out screen dimensions
 . new a use $principal:"notypeahead"
 . write $&v(999,999),$char(27)_"[6n"
 . read a use $principal:"typeahead"
 . set l=+$piece($key,"[",2),w=+$piece($key,";",2)
 . set:'l l=24 set:'w w=80 ; Default in case terminal is wonky
 . write $char(13) ; Start in the left column after working out the screen dimensions
 ; Get each line in turn
 for %=1:1 quit:'$data(^$routine(rou,%))  set f=^$routine(rou,%) do  quit:stop
 . ; Format it
 . set:$extract(f)'=";" %1=$piece($piece(f," "),"("),f=%1_$justify("",9-$length(%1))_$piece(f,$select($length(%1):%1,1:" "),2,9999)
 . ; For each bit
 . for  quit:$extract(f,2,99)?." "  do:$y'<l  quit:stop  write $extract(f,1,w),! set f="_"_$extract(f,w+1,9999)
 . . ; Do a fancy prompt and get a response
 . . write e_"[7m"_rou_" ("_$justify(%/s*100,0,0)_"%)"_e_"[0m" read *%1
 . . ; Check for a return
 . . write *13,e,"[K" if %1=13!(%1=10) quit
 . . ; Check for a quit (or ^Z)
 . . if %1=81!(%1=113)!(%1=26) set stop=1 quit
 . . ; All else is another page
 . . set $y=1
 quit

%U
%U ; General Utilities
 quit
;---
UI() new %,zr set zr="UI^%U"
 lock +^%AUTH("ui") set %=$get(^%AUTH("ui"))+1,^("ui")=% lock -^%AUTH("ui") quit %
;---
DISP(s,l) new %,c,f,zr,lim set zr="DISP^%U",f=""
 ; Return s (which contains control characters) as displayable string
 set lim=$select($get(l):l,1:510)
 ; Process each character in the input string
 for %=1:1:$length(s) set c=$ascii(s,%) do  if $length(f)>(lim-10) set f=f_"..." quit
 . ; If it's a normal printable character, add to f and quit
 . if c>31,c<127 set f=f_$char(c) quit
 . ; Look after the normal controls
 . if c<32 set f=f_"<"_$select('c:"Nul",c=8:"Tab",c=10:"LF",c=12:"FF",c=13:"CR",1:"^"_$char(c+64))_">" quit
 . ; And delete - all below 128 now done
 . if c=127 set f=f_"<Del>" quit
 . ; For control characters 128 to 139, enclose in << >>
 . if c<140 set f=f_$char(171)_"^"_$char(c+64)_$char(187) quit
 . ; Assume a "normal" eight bit character
 . set f=f_$char(c)
 ; Quit with result
 quit f
;---
; Create a pattern match from wildcards
PAT(str) new s,n,c,p,zr set zr="PAT^%U"
 set p="" for  quit:str=""  set s=$piece(str,","),str=$piece(str,",",2,99) if $length(s) set p=p_"," do
 . for n=1:1:$length(s) set c=$extract(s,n),p=p_$select(c="*":".E",c="?":"1E",c="""":"1""""""""",1:"1"""_c_"""")
 set p=$extract(p,2,999) set:p["," p="1("_p_")" quit p
;---
CD(uci) new %,zr set zr="CD^%U"
 new vol set vol=^$job($job,"global_vol")
 if uci="" goto ^%ZUCI
 ; Make it into a number if possible
 if 'uci for %=1:1:63 if ^$system("vol",vol,"uci",%)=uci set uci=% quit
 ; Validate it
 goto CDE:uci<1!(uci>63),CDE:'$length(^$system("vol",vol,"uci",uci))
 ; Set all the bits
 for %="GLOBAL","LOCK","ROUTINE" set ^$job($job,%)=uci
 quit
;---
CDE write !,"?Invalid UCI specified",! quit
;---
BIGEND() ; Is machine big-endian?
 quit $get(^$system("big_endian"),0)

%WWW
%WWW ; WWW Stuff
 new port,jobs
 ; Open the server port - default to port 80 and 5 jobs
 set port=80,jobs=5 goto OPEN
;---
START(port,jobs,restrict) ; Pass in port and max jobs to fork, and optionally prevent the web interface with restrict
OPEN ; Pass through from top using defaults
 new $etrap,mjn set $etrap="do %ET^%WWW",mjn=$job
 open 10:($get(port,80):"server="_$get(jobs,5))
;---
; Get a message
READ do RECV^%WWW1(.aa)
 ; Look for a GET
 for %=1:1 goto ERR:'$data(aa(%)) if $extract(aa(%),1,5)="GET /" quit
 ; Extract file specification
 set file=$piece($extract(aa(%),6,99999)," HTTP/1.") set:file="" file="index.html"
 ; Log it if applicable
 set %=$get(^WWWLOG) if % set ^WWWLOG(%)=$horolog_","_$piece(device,",",3)_","_file,^WWWLOG=%+1
 ; Look after extrinsics elsewhere
 if $extract(file)="?" goto EXT
;---
; Check for % characters
FILE if file["%" set file=$$REMP(file)
 ; Extract just the file name, also get the extension (in upper case)
 set f=$piece(file,"/",$length(file,"/")),EXT="" set:f["." ext=$&e($piece(f,".",$length(f,".")))
 ; Get the reference, if no such, give error and exit
 set ref=$$GETFILE(f) if ref="" do ERR^%WWW1() halt:mjn-$job  goto READ
 ; Send it
 do SEND^%WWW1(ref,ext) halt:mjn-$job  goto READ
;---
; Extrinsic functions - extract the function name
EXT set fun=$piece($extract(file,2,999),"&"),fun=$$REMP(fun),file=$piece(file,"&",2,9999)
 ; Extract the fields
 kill bb for  quit:file=""  set f=$piece(file,"&"),file=$piece(file,"&",2,9999) do
 . ; Store one field
 . set i=$piece(f,"="),f=$piece(f,"=",2,999),i=$$REMP(i) set:$length(i) bb(i)=$$REMP(f)
 ; Setup the extrinsic and execute it
 set fun="ret="_fun_"(.aa,.bb)" do  if $length(ret) do ERR^%WWW1(ret) halt
 . ; Saving the error trap
 . new $etrap set $etrap="do %ET^%WWW",@fun
 ; Display a file if required
 if $get(aa)'="" set file=aa goto FILE
 ; Done
 halt:mjn-$job  goto READ
;---
; Extrinsic error trap
%ET new f set f=$piece($ecode,",",2),f="RSM Error: "_f_" "_$&%errmsg(f)
 if f["Z51"!(f["Z42")!(f["Z213") close 10 use $principal write f,! set $ecode="" quit
 if f["Z49" set $ecode="" hang 1 goto LOOP^%WWW1
 do ERR^%WWW1(f) goto ^%ET
;---
; Give error and halt
ERR do ERR^%WWW1("Invalid HTTP message received") use 10:"disconnect" close 10 halt:mjn-$job  goto READ
;---
; Lookup a file in %D
GETFILE(f) new %,v,zr set zr="GETFILE^%WWW"
 ; Lookup the file
 set %=$get(^%D(file)) quit:'% ""
 ; Get the version
 set v=$order(^%D(%,""),-1) quit:'v ""
 ; Quit with the ref
 quit "^%D("_%_","_v_")"
;---
; Remove %nn stuff from a string
REMP(f) new %,x,zr set zr="REMP^%WWW",x=""
 ; Do it
 for  set %=$find(f,"%") quit:'%  set x=x_$extract(f,1,%-2)_$$CC($extract(f,%,%+1)),f=$extract(f,%+2,99999)
 ; And quit
 quit x_f
;---
; Convert Hex to Character
CC(h) new %,zr set zr="CC^%WWW",h=$&e(h)
 ; Make sure there are at least 2
 set:$length(h)<2 h=$extract("00",1,2-$length(h))_h
 ; Setup the 'HEX' array 0 -> F
 for %=0:1:15 set %(%)=% set:%>9 %($char(55+%))=%
 ; Quit with decimal value
 quit $char(%($extract(h))*16+%($extract(h,2)))

%WWW1
%WWW1 ; WWW Stuff - subroutines
;---
; Get into d which must be passed by ref, number of lines returned in d
RECV(d) new %,n,to,zr set zr="RECV^%WWW1"
 kill d set to=10,d=1
LOOP ; Entry point for error handler when job table is full
 ; Read first (no timeout) then the rest
 use 10 read d(1) set device=$device if d(1)'="" for d=2:1 read d(d):to quit:d(d)=""
 ; Clean up the request info
 kill d(d) set d=""
 set n=$get(^WWW) if n for %=1:1 quit:'$data(d(%))  set ^WWW(n+%-1)=d(%)
 if n set ^WWW=n+%-1
 ; And exit
 quit
;---
; ref -> Global ref to send, sends @ref@(n)
; typ -> HTML  = text/html (default)
;        JS    = text/javascript
;        CSS   = text/css
;        JPG   = image/jpeg
;        PNG   = image/png
;        GIF   = image/gif
;        CLASS = class
; HTTP/1.1 200 OK
; Content-Type: (as above)
; Content-Length: (length in bytes)
; <blank line>
; File
SEND(ref,typ) new %,l,zr,$etrap set zr="SEND^%WWW1",$etrap="do X^%WWW1",typ=$get(typ),l=0
 use 10 new type set type=""
 ;Get typ into browser format
 set type=$select(typ="JPG":"image/jpeg",typ="PNG":"image/png",typ="GIF":"image/gif",typ="CLASS":"class",1:type)
 set:type="" type=$select(typ="CSS":"text/css",typ="JS":"text/javascript",1:"text/html")
 ; Send HTTP response headers
 write "HTTP/1.1 200 OK",!
 write "Date: "_$$D^%D($horolog)_"  "_$$T^%T($piece($horolog,",",2)),!
 write "Server: "_$piece($piece($system,",",2)," for")_" HTTP Server",!
 write "Content-Type: "_type write:$extract(type,1,4)="text" "; charset=iso-8859-1"
 write !
 ; Calculate the total length
 set %=0 for  set %=$order(@ref@(%)) quit:'%  set l=l+$length(@ref@(%))
 write "Content-Length: "_l,!
 ; Terminate header, output file (terminate text lines with CRLF)
 write ! set %=0 for  set %=$order(@ref@(%)) quit:'%  write @ref@(%) write:'l !
 ; And exit
 quit
;---
X if $get(mjn)=$job set $ecode="" quit
 halt:$ecode["Z47"  goto ^%ET
;---
; Send an error message - ensure there is a message
ERR(err) new %,msg,zr set zr="ERR^%WWW1",err=$get(err,"File not found")
 ; Setup the error message
 set msg(1)="<html><body onLoad=""alert('"_err_"'); history.back(); return false""></body></html>"
 ; Send it and quit
 do SEND("msg") quit

%WWWU
%WWWU ; Web Utilities
 new %d,%l,bs,ch,ext,f,n,s,opt,boh,$etrap set $etrap="do ^%ET",u="|"
 set opt(1)="Edit a document|^%DED",opt(2)="List documents|^%DD"
 set opt(3)="Delete a document|DEL",opt(4)="Import a document|IMP"
;---
START write !,"RSM Web Utilities",!
 for %=1:1 quit:'$data(opt(%))  write %,". ",$piece(opt(%),u),!
 read "Option: ",f,! set f=$extract($&e(f)) quit:f=""
 if 'f for %=1:1 quit:'$data(opt(%))  if $extract(opt(%))=f set f=% quit
 if 'f write "?Invalid option",$char(7),! goto START
 do @$piece(opt(f),u,2) goto START
;---
; Delete a documment
DEL read "Enter Name of document to delete: ",f,! quit:f=""!f
 if '$data(^%D(f)) write "?No such document",$char(7),! goto DEL
 set %=^%D(f) kill ^%D(f),^%D(%) write "Deleted.",! quit
;---
; Import a document
IMP read "Enter Name of document to import: ",f,! quit:f=""!f
 ; Get name, ensure doesn't exist
 set n=$piece(f,"/",$length(f,"/")) if $data(^%D(n)) write "?Document "_n_" exists"_$char(7),! goto IMP
 ; Calculate block overhead - header (20 or 44) + index (2) + chunk (2) + CCC (1) + UCC (1) + key (~8) + DBC (2) + alignment (~4)
 set boh=$get(^$system("name_length"),8)+32
 ; Get block size and the extension
 set bs=^$system("vol",^$job($job,"global_vol"),"block")-boh,ext="" if n["." set ext=$&e($piece(n,".",$length(n,".")))
 ; Open the file
 set ch=0 do  if 'ch write "?File "_f_" does not exist"_$char(7),! goto IMP
 . ; Ignore errors
 . new $etrap set $etrap="set $ecode=""""" close 1 open 1:(f:"read") set ch=1
 ; Get size
 set s=$&%file(f,"size") if 's write "?File "_f_" is empty"_$char(7),! goto IMP
 ; Create the document
 set %d=$order(^%D(" "),-1)+1,^%D(%d,0)=n,^(1,1)="",^%D(n)=%d
 ; Check for a binary type
 if ext="JPG"!(ext="PNG")!(ext="GIF")!(ext="CLASS") use 1:("terminator=") set f=s do  quit
 . ; Read in each chunk
 . for %l=1:1 set %=f set:%>bs %=bs set f=f-% read ^%D(%d,1,%l)#% quit:'f
 . ; Finish up
 . close 1 use $principal write s," bytes in ",%l," record",$select(%l>1:"s",1:"")," read.",!
 ; Read in a text file
 use 1 for %l=1:1 read ^%D(%d,1,%l) if $ascii($key)=255 kill:'$length(^%D(%d,1,%l)) ^%D(%d,1,%l) quit
 use $principal close 1 write %l," lines read.",! quit

%X364
%X364 ; Terminal Control Mnemonic Namespace - ANSI X3.64-1979 R1990 (ISO 6429:1992 / ECMA-48:1991)
; Kindly donated by Colin Richardson originally for MUMPS V1
; RSM - this is a subset of the ANSI X3.64 control codes
; Usage: use $io::"%X364" write /CUP(line,col) ; This will position the cursor
; $x and $y are preserved or set as appropriate.
;---
BEL      write *7 quit  ; Ring Bell (non-standard - but common)
CHA(n)   set n=$get(n,1) write $char(27,91)_n_"G" set $x=n-1 quit  ; Cursor Horizontal Absolute
CHT(n)   set n=$get(n,1) write $char(27,91)_n_"I" set $x=$x\8*8+(n*8) quit  ; Cursor Horizontal Tab
CNL(n)   set n=$get(n,1) write $char(27,91)_n_"E" set $y=$y+n quit  ; Cursor Next Line
CPL(n)   set n=$get(n,1) write $char(27,91)_n_"F" set $y=$y-n quit  ; Cursor Preceding Line
CUB(n)   set n=$get(n,1) write $char(27,91)_n_"D" set $x=$x-n quit  ; Cursor Backward
CUD(n)   set n=$get(n,1) write $char(27,91)_n_"B" set $y=$y+n quit  ; Cursor Down
CUF(n)   set n=$get(n,1) write $char(27,91)_n_"C" set $x=$x+n quit  ; Cursor Forward
CUP(x,n) set n=$get(n,1),x=$get(x,1) write $char(27,91)_x_";"_n_"H" set $x=n-1,$y=x-1 quit  ; Cursor Position
CUU(n)   set n=$get(n,1) write $char(27,91)_n_"A" set $y=$y-n quit  ; Cursor Up
CVT(n)   write $char(27,91)_$get(n,1)_"Y" quit  ; Cursor Vertical Tab
DCH(n,x) set x=$x write $char(27,91)_$get(n,1)_"P" set $x=x quit  ; Delete Characters
DCS(x)   set x=$x write $char(27)_"P" set $x=x quit  ; Device Control String
DL(n,x)  set x=$x write $char(27,91)_$get(n,1)_"M" set $x=x quit  ; Delete Lines
EA(n,x)  set x=$x write $char(27,91)_+$get(n)_"O" set $x=x quit  ; Erase in Area
ECH(n,x) set x=$x write $char(27,91)_+$get(n,1)_"X" set $x=x quit  ; Erase Characters
; n=0: cursor to end of screen, n=1: start of screen to cursor, n=2: all screen
ED(n,x)  set x=$x write $char(27,91)_+$get(n)_"J" set $x=x quit  ; Erase Display
EF(n,x)  set x=$x write $char(27,91)_+$get(n)_"N" set $x=x quit  ; Erase Field
; n=0: cursor to end, n=1: start of line to cursor, n=2: whole line
EL(n,x)  set x=$x write $char(27,91)_+$get(n)_"K" set $x=x quit  ; Erase in line
EPA(x)   set x=$x write $char(27)_"W" set $x=x quit  ; End Protected Area
ESA(x)   set x=$x write $char(27)_"G" set $x=x quit  ; End Selected Area
HPA(n)   set n=$get(n,1) write $char(27,91)_n_"`" set $x=n-1 quit  ; Horizontal Position Absolute
HPR(n)   set n=$get(n,1) write $char(27,91)_n_"a" set $x=$x+n quit  ; Horizontal Position Relative
HTJ(x)   set x=$x write $char(27)_"I" set $x=x quit  ; Horizontal Tab w/Justify
HTS(x)   set x=$x write $char(27)_"H" set $x=x quit  ; Horizontal Tab Set
HVP(x,n) set n=$get(n,1),x=$get(x,1) write $char(27,91)_x_";"_n_"f" set $x=n-1,$y=x-1 quit  ; Horizontal Vertical Position
ICH(n,x) set x=$x,n=$get(n,1) write $char(27,91)_n_"@" set $x=x+n quit  ; Insert CHaracters
IL(n,x)  set x=$x write $char(27,91)_$get(n,1)_"L" set $x=x quit  ; Insert Lines
NEL      write $char(27)_"E" set $x=0,$y=$y+1 quit  ; Next Line
NP(n,x)  set x=$x write $char(27,91)_$get(n,1)_"U" set $x=x quit  ; Next Page
PLD(x)   set x=$x write $char(27)_"K" set $x=x quit  ; Partial Line Down
PLU(x)   set x=$x write $char(27)_"L" set $x=x quit  ; Partial Line Up
PM(x)    set x=$x write $char(27)_"^" set $x=x quit  ; Privacy Message
PP(n,x)  set x=$x write $char(27,91)_$get(n,1)_"V" set $x=x quit  ; Preceding page
PU1(x)   set x=$x write $char(27)_"Q" set $x=x quit  ; Private Use 1
PU2(x)   set x=$x write $char(27)_"R" set $x=x quit  ; Private Use 2
REP(x)   set x=$x write $char(27,91)_"b" set $x=x quit  ; Repeat Character
RI       write $char(27)_"M" set $y=$y-1 quit  ; Reverse Index
RIS      write $char(27)_"c" set $x=0,$y=0 quit  ; Reset to Initial State
RM(n,x)  set x=$x write $char(27,91)_$get(n)_"l" set $x=x quit  ; Reset mode
SGR(n,x) set x=$x write $char(27,91)_$get(n,0)_"m" set $x=x quit  ; Set Graphic Rendition
SPA(x)   set x=$x write $char(27)_"V" set $x=x quit  ; Start Protected Area
SS2(x)   set x=$x write $char(27)_"N" set $x=x quit  ; Single Shift 3
SS3(x)   set x=$x write $char(27)_"O" set $x=x quit  ; Single Shift 3
SSA(x)   set x=$x write $char(27)_"F" set $x=x quit  ; Start Selected Area
ST(x)    set x=$x write $char(27)_"\" set $x=x quit  ; String Terminator
STS(x)   set x=$x write $char(27)_"S" set $x=x quit  ; Set Transmit State
SU(x)    set x=$x write $char(27,91)_"S" set $x=x quit  ; Scroll Up
TBC(n,x) set x=$x write $char(27,91)_$get(n,0)_"g" set $x=x quit  ; Tab Clear
VPA(n)   set n=$get(n,1) write $char(27,91)_n_"d" set $y=n-1 quit  ; Vertical Position Absolute
VPR(n)   set n=$get(n,1) write $char(27,91)_n_"e" set $y=$y+n quit  ; Vertical Position Relative
VTS(x)   set x=$x write $char(27)_"J" set $x=x quit  ; Vertical Tabulation Set

%ZOSV
%ZOSV ; SFISC/AC - View commands & special functions. ;06/09/99  12:54
 ;;8.0;KERNEL;**13,65,71,94,107,118**;Jul 05, 1995
 ;;Originally for MUMPS V1 - RDN
 quit
;---
ACTJ() new %,cn ; # active jobs
 set %=0 for cn=0:1 set %=$order(^$job(%)) quit:'%
 quit cn
;---
AVJ() new %,cn ; # available jobs
 set %=0 for cn=0:1 set %=$order(^$job(%)) quit:'%
 quit ^$job-cn
;---
PASSALL ;
 use $io:("terminator=":"noescape") quit
;---
NOPASS ;
 use $io:("terminator="_$char(13,10):"escape") quit
;---
PRGMODE ;
 write !!,"THIS DOESN'T DO ANYTHING",!! quit
;---
PROGMODE() ;
 quit 1
;---
UCI ;
 new v,u set v=^$job($job,"global_vol"),u=^$job($job,"global"),Y=^$system("vol",v,"uci",u)_","_^$system("vol",v,"name") quit
;---
UCICHECK(x) ;
 new %,%1,u,v,y,vol
 if '(x?3U!(x?3U1","3U)) quit ""
 set vol=^$job($job,"global_vol")
 if $piece(x,",",2)'="",$piece(x,",",2)'=^$system("vol",vol,"name") quit ""
 set u=$piece(x,","),y="" for %=1:1:63 if ^$system("vol",vol,"uci",%)=u set y=u_","_^$system("vol",vol,"name") quit
 quit y
;---
SHARELIC(type) ; See if can share a C/S license DSM 7.2
 quit
;---
PRIORITY ;
 quit
;---
PRIINQ() ;
 quit ^$job($job,"priority")
;---
BAUD set X="UNKNOWN" quit
;---
LGR() quit $reference ; Last global ref.
;---
EC() quit $ecode ; Error code
;---
DOLRO ; Save entire symbol table in location specified by x
 set %=$&%zwrite(X) quit
;---
ORDER ; Save parts of symbol table in location specified by x
 ; Parts indicated by X1("namespace*")="" array
 if $data(X1("*"))#2 do DOLRO quit
 write !!,"THIS DOESN'T DO ANYTHING",!! quit
;---
PARSIZ ;
 set X=3 quit
;---
NOLOG ;
 set Y=0 quit
;---
;DEVOPN goto DEVOPN^%ZOSV1
;DEVOK  goto DEVOK^%ZOSV1
;RES    goto RES^%ZOSV1
;---
GETENV ; Get environment return Y='UCI^VOL/DIR^NODE^BOX LOOKUP'
 do UCI set Y=$translate(Y,",","^")_"^"_$piece($&%getenv("HOST"),".")
 set $piece(Y,"^",4)=$piece(Y,"^",2)_":"_$piece(Y,"^",3) quit
;---
VERSION(x) ; Return OS version, x=1 - return OS
 if $get(x) quit "Reference Standard M"
 quit $piece($piece($system,"V",2)," ")
;---
SETNM(x) ; Set name, trap dup's, fall into SETENV
 new $etrap set $etrap="set $ECODE="""" quit"
;---
SETENV ; Set environment x='PROCESS NAME^ '
 write !!,"THIS DOESN'T DO ANYTHING",!! quit
;---
T0 ; Start RT clock
T1 ; Store RT datum w/ZHDIF
ZHDIF ; Display diff of two '$ZH's
 write !!,"THIS DOESN'T DO ANYTHING",!! quit
;---
LOGRSRC(opt,type,status) ; Record resource usage in ^XTMP("KMPR"
 quit
;---
SETTRM(x) ; Turn on specified terminators
 use $io:("terminator="_x) quit 1

%ZRCHG
%ZRCHG ; WAA Routine change utility
 new replace,with,line,case,ln,cnt
 set cnt=0
 do ^%ZRSEL
 if '$data(^%UTILITY($job,"ROUTINE")) goto EXIT
 read !,"Replace String: ",replace goto:replace="" EXIT
 read !,"With String: ",with goto:with="" EXIT
 set routine=""
 for  set routine=$order(^%UTILITY($job,"ROUTINE",routine)) quit:routine=""  do
 . new ln,line
 . set ln=0
 . for  set ln=$order(^$routine(routine,ln)) quit:ln<1  do
 . . set (line,line(routine,ln))=^$routine(routine,ln)
 . . if line[replace do
 . . . new con,total
 . . . write !,"    Routine: ",routine,"  LINE# ",ln
 . . . write !,"Old: ",line set cnt=cnt+1
 . . . set total=$length(line,replace)
 . . . for con=1:1:total set $piece(nline,with,con)=$piece(line,replace,con)
 . . . set line(routine,ln)=nline
 . . . write !,"New: ",nline
 . . . quit
 . . quit
 . merge ^$routine(routine)=line(routine)
 . quit
 write !,cnt," Changes made."
 quit
;---
EXIT ; Clean up
 kill ^UTILITY($job,"ROUTINE")
 do ^%RECOMP
 quit

%ZRS
%ZRS ; Routine Save
 new file,head,%,vol,uci,ui,r,zr
 do ^%ZRSEL
 if '$data(^%UTILITY($job,"ROUTINE")) write !,"?No routines selected.",! quit
 read !,"Filename:   ",file goto %ZRS:file=""
 read !,"Header Txt: ",head,! set:head="" head="No Heading"
 do INT(file,head) quit
;---
INT(file,head) new %,vol,uci,ui,r,zr new $etrap set zr="INT^%ZRS",$etrap="do EX^%ZRS"
 set ui=$$UI^%U()
 merge ^UTILITY(ui)=^%UTILITY($job,"ROUTINE")
 set %=^$job($job,"routine_vol"),vol=^$system("vol",%,"name")
 set uci=^$system("vol",%,"uci",^$job($job,"routine"))
 open 1:(file:"write") U 1 write "Saved by %ZRS(MODIFIED %RS) from ["_uci_","_vol_"] on "
 write $$D^%D($horolog)," at ",$$T^%T($piece($horolog,",",2)),!,head,!
 set r="" for  set r=$order(^UTILITY(ui,r)) quit:r=""  do
 . use $principal write:$x>70 ! write r,?$x\10+1*10 use 1 write r,!
 . set %=0 for  set %=$order(^$routine(r,%)) quit:%=""  write ^$routine(r,%),!
 . write !
;---
EX write ! use $principal close 1 write !
 kill ^UTILITY(ui),^%UTILITY($job,"ROUTINE")
 quit

%ZRSE
%ZRSE ; WAA Routine search utility
 new string,line,case,ln,cnt
 set cnt=0
 do ^%ZRSEL
 if '$data(^%UTILITY($job,"ROUTINE")) goto EXIT
 read !,"Search for: ",string goto:string="" EXIT
;---
CASE read !,"Case sensitive? (NO) :",case if case="" set case="NO"
 set x=case,y=$translate(x,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
 if '("YN"[$extract(case,1)) goto EXIT
 if $extract(case,1)="Y" set case=1
 if $extract(case,1)="N" set case=0,x=string,y=$translate(x,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ"),y=string
 set routine=""
 for  set routine=$order(^%UTILITY($job,"ROUTINE",routine)) quit:routine=""  do
 . new ln
 . set ln=0
 . for  set ln=$order(^$routine(routine,ln)) quit:ln<1  do
 . . set line=^$routine(routine,ln)
 . . if 'case set x=line,y=$translate(x,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ"),line=y
 . . if line[string write !,"    Routine: ",routine,"  LINE# ",ln,!,line set cnt=cnt+1
 . . quit
 . quit
 write !,cnt," Matches found."
 quit
;---
EXIT ; Clean up
 kill ^UTILITY($job,"ROUTINE")
 quit

%ZRSEL
%ZRSEL ; WAA-This routine is to select routines using wild cards 6/16/00
 ; General Utility version 1.0
 ;
 ; *=all routines
 ; nsp*=routinestarting with the listed namespace
 ; ^D(Up-arrow "D")= Display list of select routines
 ; ^L(Up-arrow "L")= Display list of all the routines in the current UCI
;---
; List of routines will be stored in the global ^%UTILITY($job,"ROUTINE")
EN1 ; Main entry point
 new x,j
 kill ^%UTILITY($job,"ROUTINE")
;---
LOOP ; Main read loop
 read !,"Select Routine(s): ",x quit:x=""
 if x="^D" do LIST goto LOOP
 if x="^L" write ! do ^%RD goto LOOP
 set j=$extract(x,1) if j="-" set x=$extract(x,2,$length(x)),j=$extract(x,1) do DEL goto LOOP
 if x="*" do AWILD goto LOOP
 if $length(x)>$get(^$system("name_length"),8) write !,"NAME TOO LONG" goto LOOP
 if j'?1A,(j'?1"%") write !,"INVALID NAME" goto LOOP
 if x["*" do AWILD goto LOOP
 if '$data(^$routine(x)) write !,"INVALID ROUTINE NAME" goto LOOP
 set ^%UTILITY($job,"ROUTINE",x)=""
 goto LOOP
;---
DEL ; Delete routine from list
 if x="*" kill ^%UTILITY($job,"ROUTINE") quit
 if x["*" set y=$piece(x,"*") do
 . for  set y=$order(^%UTILITY($job,"ROUTINE",y)) quit:y=""  quit:y'[x  do
 . . kill ^%UTILITY($job,"ROUTINE",y)
 . . quit
 . quit
 else  kill ^%UTILITY($job,"ROUTINE",x)
 quit
;---
AWILD ; Select all routines as wildcards
 new y
 set y=$piece(x,"*")
 for  set y=$order(^$routine(y)) quit:y=""  quit:y'[$piece(x,"*")  set ^%UTILITY($job,"ROUTINE",y)=""
 quit
;---
LIST ; List selected routines
 new y
 set y=""
 write !
 if '$data(^%UTILITY($job,"ROUTINE")) write !,"NO ROUTINES HAVE BEEN SELECTED" quit
 for  set y=$order(^%UTILITY($job,"ROUTINE",y)) quit:y=""  do
 . write:$x>72 !
 . write y,?($x+(10-($x#10)))
 . quit
 quit

%ZUCI
%ZUCI ; WAA-Change UCI; 6/19/00
 ; %ZUCI 1.0
 new x
EN1 ; Main entry point
 read !,"What UCI: ",x
 if x="?" do LIST goto EN1
 do CD(x)
 write !,$$UCI
 quit
;---
CD(uci) ;
 new vol set vol=^$job($job,"global_vol")
 ; Make it into a number if possible
 if 'uci for %=1:1:63 if ^$system("vol",vol,"uci",%)=uci set uci=% quit
 ; Validate it
 goto CDE^%U:uci<1!(uci>63),CDE^%U:'$length(^$system("vol",vol,"uci",uci))
 ; Set all the bits
 for %="global","lock","routine" set ^$job($job,%)=uci
 quit
;---
LIST ; List all UCIs within a volume set
 new vol,uci,x
 set vol=^$job($job,"global_vol"),uci=""
 write !,"User Class Identifiers [UCI] within the volume set: ",^$system("vol",vol,"name")
 write !,?10,"UCI#",?40,"UCI"
 write !,?10,"----",?40,"---"
 do GET(vol,.uci)
 set x=0 for  set x=$order(uci(x)) quit:x=""  write !,?10,x,?40,uci(x)
 quit
;---
GET(vol,uci) ; Build an array of all the UCIs within the volume set
 new x
 set uci=0
 quit:vol'>0  set x=0
 for  set x=$order(^$system("vol",vol,"uci",x)) quit:x<1  set uci=x,uci(x)=^$system("vol",vol,"uci",x)
 quit
;---
UCI() ; Return the current UCI and volume set
 new uci,y,vol,jn,ucin,voln
 set y=""
 set jn=$job
 set uci=^$job(jn,"routine"),vol=^$job(jn,"routine_vol")
 set voln=^$system("vol",vol,"name"),ucin=^$system("vol",vol,"uci",uci)
 set y=ucin_","_voln
 quit y

BENCH
BENCH ; From the DSM - BENCH ;V 2.9 28 Feb 99  01:27 PM
 write !!,"Use this utility to provide a benchmark test of CPU",!!
 new i,a,b,x
 goto A
;---
AAA quit
;---
A hang 1 set a=$piece($horolog,",",2)
 for i=1:1:1000000
 set a=$piece($horolog,",",2)-a,^FOR=a write a," seconds for: for i=1:1:1000000",!
;---
A1 set a=$piece($horolog,",",2)
 do SET for i=1:1:1000000 if $data(x)
 set a=$piece($horolog,",",2)-a,^OVR=a write a-^FOR," seconds for: if $data(x) ;x undefined",!!
;---
EVA write !!,"***COMMANDS AND EVALUATER***",!! set ^OVR=^FOR
 do SET for i=1:1:1000000 set x=""
 set a=$piece($horolog,",",2)-a,^SET=a write a-^OVR," seconds for: set x=""""",!
 do SET for i=1:1:1000000 set x=1
 do OUT write "set x=1",!
;---
EVB do SET for i=1:1:1000000 set x="ABCDEFGHIJ"
 do OUT write "set x=""ABCDEFGHIJ""",!
 do SET for i=1:1:1000000 set x="ABCDEFGHIJ01234567890123456789"
 do OUT write "set x=""ABCDEFGHIJ01234567890123456789""",!
 do SET for i=1:1:1000000 set x="^^"_"ABCD"_"^"_"ABCD"_"^"_"^"_"ABCD"
 do OUT write "set x=""^^""_""ABCD""_""^""_""ABCD""_""^""_""^""_""ABCD""",!
 set b=55 do SET for i=1:1:1000000 set x=b+33
 do OUT write "set x=b+33 ;b=55",!
 do SET for i=1:1:1000000 set x=b-1
 do OUT write "set x=b-1 ;b=55",!
 set b=55 do SET for i=1:1:1000000 if b>22
 do OUT write "if b>22 ;b=55",!
 set b="ABCDEFGHIJ" do SET for i=1:1:1000000 if b="ABCDEFGHIJ"
 do OUT write "if b=""ABCDEFGHIJ"" ;true ",!
 do SET for i=1:1:1000000 if b["HIJ"
 do OUT write "if b[""HIJ"" ;true ",!
;---
FUN write !!,"***FUNCTIONS***",! set ^OVR=^SET
 do SET for i=1:1:1000000 set x=$extract("ABCDEFGHIJ",9)
 do OUT write "$extract(""ABCDEFGHIJ"",9)",!
 do SET for i=1:1:1000000 set x=$extract("ABCDEFGHIJ",9,10)
 do OUT write "$extract(""ABCDEFGHIJ"",9,10)",!
 do SET for i=1:1:1000000 set x=$find("ABCDEFGHIJ","G",6)
 do OUT write "$find(""ABCDEFGHIJ"",""G"",6)",!
 do SET for i=1:1:1000000 set x=$length("ABCDEFGHIJ")
 do OUT write "$length(""ABCDEFGHIJ"")",!
 do SET for i=1:1:1000000 set x=$piece("A,B,C,D,E",",",3)
 do OUT write "$piece(""A,B,C,D,E"","","",3)",!
 do SET for i=1:1:1000000 set x=$piece("A,B,C,D,E",",",3,5)
 do OUT write "$piece(""A,B,C,D,E"","","",3,5)",!
;---
MIS write !!,"***MISCELLANEOUS TESTS***",!! set ^OVR=^FOR
 set b=55 do SET for i=1:1:1000000 set x=b*33
 do OUT write "set x=b*33 ;b=55",!
 do SET for i=1:1:1000000 set x=b\10
 do OUT write "set X=b\10 ;b=55",!
 do SET for i=1:1:1000000 set x=.5+.005
 do OUT write "set x=.5+.005",!
 do SET for i=1:1:1000000 do END
 do OUT write "do END ; END at bottom of routine",!
 do SET for i=1:1:1000000 do AAA
 do OUT write "do AAA ;AAA at beginning of routine",!
;---
END quit
;---
SET hang 1 set a=$piece($horolog,",",2) quit
;---
OUT write $piece($horolog,",",2)-a-^OVR," seconds for: " quit

COMPRESS
COMPRESS ; Compress a specific global on-line
 new g
 read !,"Compress which Global: ^",g,! quit:g=""
 write "Priority being lowered to 20 (the lowest)",! set ^$job($job,"priority")=20
 do INT(g) quit
;---
INT(g) new %,lev,zr,$etrap set zr="INT^COMPRESS",$etrap="do ^%ET",lev=15
 set g="^"_$translate(g,"^") if '$data(@g) write "Global ",g," does not exist",! quit
 for  set lev=$&%compress(g,lev) quit:g["("  set lev=lev-1 quit:lev<2
 if lev>-1 write "Done",! quit
 set lev="M"_-lev  write *7,$&%errmsg(lev),! quit

DECOMP
DECOMP ; Decompile an RSM routine
 new rou,c read !,"Routine: ",rou,! quit:rou=""
 set c=$get(^$routine(rou,0)) if c="" write "?No such routine as ",rou,! quit
 write "Decompile of ",rou,! do INT(c) quit
;---
INT(c) new %,v,usr,d,t,h,tag,var,i,s,a,$etrap set $etrap="do ^%ET"
 new big,varlen set big=$$BIGEND^%U,varlen=$get(^$system("name_length"),8)
 set v=$$S(1) ; The compiler version
 set usr=$$S(3) ; The user
 set d=$$I(5),t=$$I(9) ; The date and time
 for %=1:1:6 set h(%)=$$S(%-1*2+13) ; Tag off, num; var off, num; code off, size
 write "Compiler version: ",v,"  User: ",usr,"  When: ",$$D^%D(d)," ",$$T^%T(t),!
 ; Load all tags into the tag array
 for v=1:1:h(2) do
 . set t=v-1*(varlen+2)+h(1)+1 ; Offset to this tag
 . set d="" for %=0:1:(varlen-1) set i=$ascii(c,t+%) quit:'i  set d=d_$char(i) ; Extract the tag name
 . set tag($$S(t+varlen))=d ; Save the tag indexed by address
 ; End of tag load code
 new col,j set col=10,j="" for  set j=$order(tag(j)) quit:j=""  set col=$select($length(tag(j))+2>col:$length(tag(j))+2,1:col)
 write !,"Tag",?col,"Offset",!
 set %="" for  set %=$order(tag(%)) quit:%=""  write tag(%),?col,$justify(%,6),!
 ; Load all variables
 for v=1:1:h(4) do
 . set t=v-1*varlen+h(3)+1 ; Offset to this variable
 . set d="" for %=0:1:(varlen-1) set i=$ascii(c,t+%) quit:'i  set d=d_$char(i) ; Extract the variable name
 . set var(v-1)=d ; Save var name indexed by idx
 write !,"Variables by Index",!
 set %="" for  set %=$order(var(%)) quit:%=""  write:$x>70 ! write var(%),?$x\10+1*10
 write:$x ! write !,"Code at offset ",h(5)," for ",h(6)," bytes."
 set v=h(5)+1,t=v+h(6),a=""
;---
LIN goto EXIT:v>t set d=$ascii(c,v),v=v+1
 if d=170 write ! do
 . set i=$$S(v),s=$$S(v+2),v=v+4 set:s s=s-1
 . ; Dump source right above decompiled bytecode
 . write !,^$routine(rou,i),!
 . write "Line:",$justify(i,5),"   Size: ",s,!,?6 if $length(a) write a,!,?6 set a=""
 . for %=1:1:s write:$x>75 !,?6 write $justify($ascii(c,v),4) set v=v+1
 if d=171 set a="Formal: (" set i=$ascii(c,v),v=v+1 do
 . if i=0 set a=a_")"
 . else  for %=1:1:i set a=a_var($ascii(c,v))_$select(i-%:",",1:")"),v=v+1
 if d=2 set i=$$S(v) write ?6,"Error: ",i
 goto LIN
;---
EXIT write !! quit
;---
S(o) ; Extract a u_short from c at offset o
 if $get(big,0) quit $ascii(c,o)*256+$ascii(c,o+1)
 else  quit $ascii(c,o+1)*256+$ascii(c,o)
;---
I(o) new %,n ; Extract a u_int from c at offset o
 set n=0
 if $get(big,0) for %=0:1:3 set n=n*256+$ascii(c,o+%)
 else  for %=3:-1:0 set n=n*256+$ascii(c,o+%)
 quit n

FBENCH
FBENCH ; DBB;12-JUN-81 1:25 AM; Benchmark Reference Standard M
 kill  set k=1,t=1,t(0)=0,n=1000000 ; Set n to multiple of 500
 kill ^TSX write !,"Test #    Name      msec/Pass     Without for",!!
 for k=0:1:11 do DRV
 kill ^TSX kill  write !,*7,"Finished",! quit
;---
DRV ;
 write $justify(k,4),?7
 write $piece("For Loop^Do-Quit^String^Pattern^Function^Conversion^Integer^Real^Symbol Tbl^Glb Set^Glb Retrv^Composite","^",k+1)
 kill (k,n,t) if $text(@("A"_k))'="" do @("A"_k)
 hang 1 set t=$piece($horolog,",",2) do @k set t=$piece($horolog,",",2)-t set:'k t(0)=t/n
 set nn=$select(k<11:n,1:n\10) write ?20,$justify(t/nn*1000,8,2),?34,$justify(t/nn-t(0)*1000,8,2),! quit
;---
0 for j=1:1:n
 quit
;---
1 for j=1:1:n do A2,A2
 quit
;---
A2 set d="aaa/aaa,aaa,aaa" quit
;---
2 for j=1:1:n set i=$extract("abcdefghijklm",3,6)_$piece(d,",",2)["cdeg"
 quit
;---
A3 set c="abcd123XX" quit
;---
3 for j=1:1:n if c?1"abc".A3N.E,c?4E1"123"2U
 quit
;---
A4 set a=1,b=0,c=123.456 quit
;---
4 for j=1:1:n set i=$length($select($data(XXX):0,a:$justify(c,7,2),1:0))
 quit
;---
A5 set a=10,b=13 quit
;---
5 for j=1:1:n set i=a_b+a_b
 quit
;---
A6 set i=200 quit
;---
6 for j=1:1:n set i=i*i\i+i-i*25\25+25-25
 quit
;---
A7 set r=".222" quit
;---
7 for j=1:1:n set Y=r*r/r+r-r*.125/.125+.125-.125
 quit
;---
A8 set d=""
 for j=81:1:90 set d=d_"a" for i=71:1:90 set @($char(j,i)_"=d")
 kill i,j,d quit
;---
8 for j=1:1:n set a=j ;,a=tg,a=wq,a=zz
 quit
;---
9 for j=1:1:n\500 for y=1:1:20 set a=$extract(123456789,1,y#10) for x=1:1:25 set ^TSX(y,x)=a
 quit
;---
10 for j=1:1:n\500 for y=1:1:20 for x=1:1:25 set c=^TSX(y,x)
 quit
;---
11 for j=1:1:n\10 do B11
 quit
;---
B11 set a1=1,b1=a1+1,c1=b1_b1,d1=$extract(c1,3,99),e1="abcdefg"
 for i=2:1:5,8 set f(i)=$extract("123456789",1,i)
 kill:$length($data(f(3))) f(3) set l=i*22/3,e=$justify(l,6,2)
;---
B11B set l=$order(f(l)) goto:l'="" B11B
 set a="aaa,",a=a_a_a_"xxxx" if a?3A1P.E set b=$piece(a,",",2,3)
 set:b["ppp" b=3 set c="d",@c=123
 kill a1,a,c1,c,f quit

FIX
FIX ; Fix Database
 ; New a few things, setup error trap - volume set to current global volume
 new dtyp,dgd,d,k,blk,cmd,lcmd,bsiz,i,vol,$estack,$etrap set $etrap="do ERR^FIX"
 set vol=^$job($job,"global_vol"),vol=-vol
 new varlen,hdrsize,idx,long set varlen=$get(^$system("name_length"),8),hdrsize=varlen+12,idx=hdrsize/2,long=0
 set ^$system("vol",-vol,"writelock")=1 write !,"Writelocking the database for volume "_-vol
 for  write "." quit:^$system("vol",-vol,"writelock")>0  hang 1
;---
; Get some input
ASK new %
 write:$x ! write "FIX> " read cmd,! set lcmd=cmd,cmd=$&e(cmd) set:cmd="" cmd="?"
 ; Check for a block number
 ; NOTE: If blk ends in +, it will output the full data, not truncate it to 500
 if cmd?1.N.1"+" do  do BLK goto ASK
 . set blk=cmd if $extract(blk,$length(blk))="+" set long=$get(^$system("string_max"),32767),blk=+blk
 ; Look for Check
 if cmd="C" do  goto ASK
 . ; Ensure we have a block
 . if '$get(blk) write "?No current block"_$char(7) quit
 . ; Do it
 . set %=$&%ic(-vol,blk) write !,$select(%>1:%_" Errors",%:"1 Error",1:"No errors"),!
 ; Check for Dump
 if $extract(cmd)="D" do  write ! goto ASK
 . ; Enable writes
 . write "Write enabling disk... " set ^$system("vol",-vol,"writelock")=0
 . ; Do it
 . do INT^%BLKDMP(-vol,blk_$select(long:"+",1:""),"^%DUMP") write "dumped to ^%DUMP()",!
 . set ^$system("vol",-vol,"writelock")=1 write !,"Writelocking the database for volume "_-vol
 . for  write "." quit:^$system("vol",-vol,"writelock")>0  hang 1
 ; Check for Environment (UCI)
 if $extract(cmd)="E" do  goto ASK
 . ; Do it
 . for %=2:1:$length(cmd) if $extract(cmd,%)?1N set:+$extract(cmd,%,9)<64&$extract(cmd,%,9) d(0)=+$extract(cmd,%,9) quit
 ; Check for F or .
 if $extract(cmd)="F"!(cmd=".") do SAVE^FIX2 goto ASK
 ; Check for Global name change
 if $extract(cmd)="G" set lcmd=$extract(lcmd,2,99) do  goto ASK
 . ; Do it if OK
 . if varlen=32,lcmd?1"%"1.31AN!(lcmd?1A1.31AN) set k=lcmd quit
 . if varlen=8,lcmd?1"%"1.7AN!(lcmd?1A1.7AN) set k=lcmd quit
 . ; Complain
 . write "?Invalid global name '",lcmd,"'",$char(7),!
 ; Insert
 if $extract(cmd)="I" do INSERT^FIX1 goto ASK
 ; Check for KILL
 if $extract(cmd)="K" do  goto ASK
 . ; Get the index
 . set i=0 for %=2:1:$length(cmd) if $extract(cmd,%)?1N set i=+$extract(cmd,%,99) quit
 . ; Complain on error
 . if '$data(k(i)) write "?No such index as ",i,$char(7),! quit
 . ; Check for last
 . if '$order(k(i)) kill k(i)
 . ; Else shuffle down
 . else  for %=i:1 quit:'$data(k(%+1))  set k(%)=k(%+1),d(%)=d(%+1) kill k(%+1),d(%+1)
 . ; and say
 . write "Killed.",!
 ; Check for List
 if $extract(cmd)="L" do LIST goto ASK
 ; Check for a quit
 if $extract(cmd)="Q" view:$get(blk) vol:0 set ^$system("vol",-vol,"writelock")=0 quit
 ; Check for RL change
 if $extract(cmd)="R" do  goto ASK
 . ; Store it here
 . for %=2:1:$length(cmd) if $extract(cmd,%)?1N set d=+$extract(cmd,%,99) quit
 ; Check for Up
 if $extract(cmd)="U" do UP^FIX2 goto ASK
 ; Check for Zot
 if $extract(cmd)="Z" do  goto ASK
 . ; Zot the block
 . set bsiz=^$system("vol",-vol,"block") for i=0:4:bsiz-1 set %=$view(vol,i,4,0)
 . ; Write it back
 . view vol:-blk kill blk
 ; Locate
 if $extract(cmd)="^" do LOCATE^FIX1 goto ASK
 ; Else give help
 do HELP^FIX2 goto ASK
;---
; Get the block and right link (if any)
BLK if 'blk do HELP^FIX2 quit
 new rl,rl1
 view vol:blk set rl=$view(vol,4,4) if rl do
 . new r,ucc
 . ; Get the block, addr of first record and size of same - adj for view
 . view vol:rl set r=$view(vol,hdrsize,2)*4,ucc=$view(vol,r+3,1),%=ucc set:%<3 %=3 set:%=4 %=5
 . ; Get the key into rl1
 . set rl1="^"_$piece($view(vol,12,varlen),$char(0))_"("_$$FULLUNK^FIX1($extract($view(vol,r+4,%),1,ucc))_")"
 . ; Re-get the original block
 . view vol:blk
 ; Load the arrays
 do LOADA^FIX1
 write "Block Number: ",blk,"  Type: ",$select('d(0):"Unused",k="$GLOBAL":"Global Directory",dtyp:"Data",1:"Pointer")
 if 'd(0) write ! quit
 write "  Last Index: ",$view(vol,8,2),"  Last Free: ",$view(vol,10,2),"  Free: ",$view(vol,10,2)*2-$view(vol,8,2)*2+2,!
 write "UCI# ",$view(vol,0,1)#64," ["_^$system("vol",-vol,"uci",$view(vol,0,1)#64)_"]  Right -> ",rl,! set %=$order(k(""),-1)
 write "First Node: ^",k,$select($length($get(k(idx))):"("_$$FULLUNK^FIX1(k(idx))_")",1:""),!
 write:$get(%) "Last  Node: ^",k,"(",$$FULLUNK^FIX1(k(%)),")",!
 if rl write "Right Link: "_rl1,!
 quit
;---
; Check for a current block
LIST if '$get(blk) write "?No current block",$char(7),! quit
 new srch
 set srch=$extract(lcmd,2,999)
 write $select($length(srch):"Search ",1:"Listing of block "),blk," (local copy) Global: ",k
 write:$length(srch) " [",srch,"]" write "  UCI# ",d(0)," ["_^$system("vol",-vol,"uci",d(0))_"]  Right: ",d,!
 write "Index Contains:",! for i=idx:1 quit:'$data(k(i))  do
 . ; Get something we can display
 . set %=d(i) set:'long&($length(%)>500) %=$extract(%,1,500)_"..." set:%?.E1C.E %=$$DISP^%U(%,long)
 . if $length(srch),%'[srch quit
 . write $justify(i,5)," ","(",$$FULLUNK^FIX1(k(i)),")=",% write:$data(dgd(i)) ?30,$justify(dgd(i),10) write !
 quit
;---
; Quit when done
ERR if $estack<2 set $ecode="" view:$get(blk) vol:0 quit
 set ^$system("vol",-vol,"writelock")=0 write !,"**ERROR BEING LOGGED**",! goto ^%ET

FIX1
FIX1 ; Fix subroutine
 quit
;---
; Load Arrays d and k and set dtyp from the current block
LOADA kill d,k,dgd new key,%,i,r,ucc,ccc,dbc set key=""
 ; Store global name in k and RL in d
 set k=$piece($view(vol,12,varlen),$char(0)),d=$view(vol,4,4),d(0)=$view(vol,0,1)#64
 ; Set dtyp true for a data block
 set dtyp=$view(vol,0,1)>64&(k'="$GLOBAL")
 ; Scan all indexes
 for i=idx:1:$view(vol,8,2) do
 . ; Get the Record address, CCC and UCC
 . set r=$view(vol,i*2,2)*4,ccc=$view(vol,r+2,1),ucc=$view(vol,r+3,1)
 . ; Ensure we get a string return for the next $view()
 . set %=ucc,k(i)="" set:%=1!(%=2) %=3 set:%=4 %=5
 . ; If there is a key
 . if ucc do
 . . ; Copy uncommon key characters to the key buffer
 . . set $extract(key,ccc+1,ccc+ucc)=$extract($view(vol,r+4,%),1,ucc)
 . . ; Copy the key into the array
 . . set k(i)=$extract(key,1,ccc+ucc)
 . ; Point at data - If it's a data block
 . set r=r+ucc+4 if dtyp do
 . . ; Get the DBC, clear the data
 . . set dbc=$view(vol,r,2),d(i)=""
 . . ; Do it this way if it would have been an int
 . . if dbc<5 for %=1:1:dbc set d(i)=d(i)_$char($view(vol,r+1+%,1))
 . . ; This way to get a string
 . . else  set d(i)=$view(vol,r+2,dbc)
 . ; Else it's a pointer (or directory), round up (if required) and get blk#
 . else  set:r#4 r=r\4+1*4 set d(i)=$view(vol,r,4)
 . ; If Global directory get DGD flag data
 . if k="$GLOBAL" set dgd(i)=$view(vol,r+4,4)
 quit
;---
; Locate a block
LOCATE new uci,glo,tb,ik,i set uci=^$system("vol",-vol,"uci",^$job($job,"global")),lcmd=$extract(lcmd,2,999)
 if lcmd="" do HELP^FIX2 quit
 ; Check for a specified UCI
 if $extract(lcmd)="[" set uci=$piece($extract(lcmd,2,999),"]"),uci=$translate(uci,""""),lcmd=$piece(lcmd,"]",2,999)
 ; Setup the global and lcmd as the subscripts
 set glo=$piece(lcmd,"("),lcmd=$piece(lcmd,"(",2,999),lcmd=$extract(lcmd,1,$length(lcmd)-1)
 ; Attempt to get the top block
 set tb=$get(^[uci]$global(glo))
 ; Complain if no such
 if 'tb write "?No such global as ^",glo," in UCI: ",uci,$char(7),! quit
 ; Make a key from it
 set ik=$$DOKEY(lcmd),blk=tb
;---
; Get the block - done if it's data
LOC1 view vol:blk do LOADA if dtyp!(glo="$GLOBAL") goto BLK^FIX
 ; Look for it
 for i=idx:1 quit:'$data(k(i))  if ik']k(i) quit
 ; Backup if required
 if $get(k(i))'=ik set i=i-1
 ; Loop again
 set blk=d(i) goto LOC1
;---
; Remove the i from lcmd
INSERT new f,glo,q,%,s,i set lcmd=$extract(lcmd,2,999)
 ; Scan looking for the =
 set q=0 for %=1:1:$length(lcmd)+1 do  quit:q<0
 . ; Check for a quote
 . if $extract(lcmd,%)="""" set q='q quit
 . ; Check for the =
 . quit:q  if $extract(lcmd,%)="=" set q=-1
 ; Separate the source and destination
 set glo=$extract(lcmd,1,%-1),lcmd=$extract(lcmd,%+1,999)
 ; Check for a block#
 if 'dtyp,lcmd'?1.N write "?Must specify a block# in a pointer block",$char(7) quit
 ; Remove any quotes
 if $extract(lcmd)="""" set @("lcmd="_lcmd)
 set:$extract(glo)="^" glo=$extract(glo,2,99)
 ; Get subs into s
 set s=$piece(glo,"(",2,999),glo=$piece(glo,"(")
 ; Check the global name (if any)
 if $length(glo),glo'=k write "?This block is ^",k," not ^",glo,$char(7) quit
 ; Check for a trailing )
 if $extract(s,$length(s))'=")" write "?Junk subscript provided",$char(7) quit
 ; Get the key
 set s=$extract(s,1,$length(s)-1),s=$$DOKEY(s)
 ; Check if before first
 if s']k(idx) write "WARNING: Specified key is before first key",!
 ; Look for insert point
 for i=idx:1 quit:'$data(k(i))  if s']k(i) quit
 ; Check for end
 if '$data(k(i)) write "WARNING: Specified key is after last key",!
 ; See if it's already there
 else  if k(i)=s write "?That key exists",$char(7) quit
 ; Get last entry - copy down
 set f=$order(k(""),-1) for %=f:-1:i set k(%+1)=k(%),d(%+1)=d(%) set:$data(dgd(%)) dgd(%+1)=dgd(%)
 ; Store the new values and quit
 set k(i)=s,d(i)=lcmd write "Inserted." quit
;---
; Build a key for k - check for null then a string
BLDKEY(k) quit:k="" "" if +k'=k quit $char(128)_k_$char(0)
 ; Check 0 - then positive numbers
 quit:k=0 $char(64,0)  if k>0 quit $char($length($piece(k,"."))+64)_$translate(k,".")_$char(0)
 ; Finally the negative numbers
 quit $char(63-($length($piece(k,"."))-1))_$translate(k,"0123456789.-","9876543210")_$char(255)
;---
; Build a full key
DOKEY(k) new %,q,f
 set f="" for  quit:k=""  do
 . ; Scan looking for first subscript
 . set q=0 for %=1:1:$length(k)+1 do  quit:q<0
 . . ; Check for a quote
 . . if $extract(k,%)="""" set q='q quit
 . . ; Check for a comma
 . . quit:q  if $extract(k,%)="," set q=-1
 . ; Get this subs into q, rest into k - remove quotes if required
 . set q=$extract(k,1,%-1),k=$extract(k,%+1,999) if $extract(q)="""" set @("q="_q)
 . ; Add to the key
 . set f=f_$$BLDKEY(q)
 ; Quit with the key
 quit f
;---
; Get string from key - check null
UNKEY(k) new %,x,c
 if $extract(k,1,2)=$char(0,0) set k=$extract(k,3,999) quit ""
 ; Special case for top node
 if k="" quit ""
 ; Check for a string
 if $ascii(k)=128 set %=$piece($extract(k,2,999),$char(0)),k=$piece(k,$char(0),2,999) quit %
 ; Get count - Remove terminator and trailing rubish from k, reset k
 set c=$ascii(k),x=$piece($piece($extract(k,2,999),$char(0)),$char(255)),k=$extract(k,$length(x)+3,999)
 ; Check for "0"
 if c=64&'x quit "0"
 ; If it's negative, do the complementing
 if c<64 set c=63-c,x=$translate(x,"0123456789","9876543210")
 ; Quit with the number
 quit $select(c<64:"-",1:"")_$extract(x,1,c#64)_$select($length(x)>(c#64):"."_$extract(x,c#64+1,999),1:"")
;---
; Do a full unkey
FULLUNK(k) new a,%,f
 set a="" for  set %=$$UNKEY(.k) do:+%'=%  set a=a_","_% quit:k=""
 . ; Simple (no embedded ")
 . if %'["""" set %=""""_%_"""" quit
 . ; Double the quotes
 . set f="""" for  quit:%=""  set f=f_$select($extract(%)="""":"""""",1:$extract(%)),%=$extract(%,2,999)
 . ; Terminate it
 . set %=f_""""
 quit $extract(a,2,999)

FIX2
FIX2 ; Fix subroutines
 quit
;---
HELP ; Help menu
 write "Enter the number of the block to examine or one of:",!
 write ?8,"C to Check the current block and its descendants",!
 write ?8,"D to Dump the content of the current [data only] block to ^%DUMP()",!
 write ?8,"En to change the Environment (UCI) number for this block to n",!
 write ?8,"F or . to File (save) the current block",!
 write ?8,"Gname to change the Global name",!
 write ?8,"H or ? for Help",!
 write ?8,"I^node=value to Insert node with value or block number",!
 write ?8,"Kn to Kill (remove) index n",!
 write ?8,"L[search string] to List the local copy of the current block",!
 write ?8,"Q to Quit",!
 write ?8,"Rn to change the Right pointer to n",!
 write ?8,"U to go Up a level in the current global",!
 write ?8,"Z to Zot the block (mark unused) F or . are NOT required",!
 write ?8,"^spec to locate the block containing spec",!
 quit
;---
; Move up from current block
UP new key,glo,tb,f,i,% set f=$view(vol,0,1)#64,f=^$system("vol",-vol,"uci",f)
 ; Save a few required values - get top of current global
 set key=k(idx),glo=k,tb=blk,blk=^[f]$global(glo)
 ; If already at top, select the directory and use that
 if blk=tb set blk=^[f]$global("$GLOBAL") goto BLK^FIX
;---
; Get the data into the arrays
UP1 view vol:blk do LOADA^FIX1
 ; Check that we got the correct one
 if k'=glo write "?Found incorrect global in UP",$char(7),! goto BLK^FIX
 ; Ensure still a pointer
 if dtyp write "?Got back to data level in UP",$char(7),! goto BLK^FIX
 ; Look for it
 for i=idx:1 quit:'$data(k(i))  if key']k(i) quit
 ; Backup if required
 if $get(k(i))'=key set i=i-1
 ; If there, exit
 if tb=d(i) goto BLK^FIX
 ; Loop again
 set blk=d(i) goto UP1
;---
; Save current data
SAVE if '$get(blk) write "?There is no current block",$char(7),! quit
 ; Get block size
 new bsiz,ccc,ucc,i,r,%,f,cs,sz set bsiz=^$system("vol",-vol,"block"),sz=0
 ; Loop thru all keys
 for i=idx:1 quit:'$data(k(i))  do
 . ; Locate common character count
 . for ccc=0:1:$length($get(k(i-1))) quit:$extract($get(k(i-1)),ccc+1)'=$extract(k(i),ccc+1)
 . ; Get UCC and Chunk Size - round up if required
 . set ucc=$length(k(i))-ccc,cs=4+ucc+$select(dtyp:$length(d(i))+2,1:4) set:cs#4 cs=cs\4+1*4
 . ; Add required space
 . set sz=sz+cs+2
 ; Complain if it won't fit
 set sz=(bsiz-22)-sz if sz<0 write "?Doesn't fit by ",$translate(sz,"-")," bytes",$char(7),! quit
 ; Zot the block (except first 4 bytes)
 for i=4:4:bsiz-1 set %=$view(vol,i,4,0)
 ; Reset block type
 set %=$view(vol,0,1,k="$GLOBAL"!dtyp*64+d(0))
 ; Reset RL, last index, last free
 set %=$view(vol,4,4,d),%=$view(vol,8,2,idx-1),%=$view(vol,10,2,bsiz/4-1)
 ; Store the global name
 set i=k_$translate($justify("",varlen-$length(k))," ",$char(0)),%=$view(vol,12,varlen,i)
 ; Loop thru all keys
 for i=idx:1 quit:'$data(k(i))  do
 . ; Locate common character count
 . for ccc=0:1:$length($get(k(i-1))) quit:$extract($get(k(i-1)),ccc+1)'=$extract(k(i),ccc+1)
 . ; Get UCC and Chunk Size - round up if required
 . set ucc=$length(k(i))-ccc,cs=4+ucc+$select(dtyp:$length(d(i))+2,1:4) set:cs#4 cs=cs\4+1*4
 . ; Allow for flags word
 . if k="$GLOBAL" set cs=cs+4
 . ; Set last free and this index - make r = address
 . set r=$view(vol,10,2)-(cs/4),%=$view(vol,10,2,r),r=r+1,%=$view(vol,i*2,2,r),r=r*4
 . ; and last index, setup chunk size, CCC and UCC
 . set %=$view(vol,8,2,i),%=$view(vol,r,2,cs),%=$view(vol,r+2,1,ccc),%=$view(vol,r+3,1,ucc)
 . ; Store it this way for a small size
 . if ucc<5 for f=1:1:ucc set %=$view(vol,r+3+f,1,$ascii(k(i),ccc+f))
 . ; or this way for a longer string
 . else  set %=$view(vol,r+4,ucc,$extract(k(i),ccc+1,ccc+ucc))
 . ; Point at the DBC
 . set r=r+ucc+4
 . ; For version 1.31 (or earlier), trim flags word
 . if k="$GLOBAL",$piece($system,"V",2)<1.32 set dgd(i)=dgd(i)#3
 . ; Do a pointer or Global Directory this way
 . if 'dtyp set:r#4 r=r\4+1*4 set %=$view(vol,r,4,d(i)) set:k="$GLOBAL" %=$view(vol,r+4,4,dgd(i)) quit
 . ; Store the length
 . set %=$view(vol,r,2,$length(d(i)))
 . ; Store it this way for a small size
 . if $length(d(i))<5 for f=1:1:$length(d(i)) set %=$view(vol,r+1+f,1,$ascii(d(i),f))
 . ; or this way for a longer string
 . else  set %=$view(vol,r+2,$length(d(i)),d(i))
 ; Do it and exit
 view vol:-blk write "Filed.",! kill blk quit

IC
IC ; Check database integrity
 new $etrap set $etrap="do ERR^IC"
 new er,vol set vol=^$job($job,"global_vol")
 set ^$system("vol",vol,"writelock")=1 write !,"Writelocking the database for volume "_vol
 for  write "." quit:^$system("vol",vol,"writelock")>0  hang 1
 write !,"Checking Database..",! set er=$&%ic(vol,0)
 write ! write:er er write $select(er=0:"NO errors",er>1:" errors",1:" error")," found.",!
 write !,"Checking Map Block..",! set er=$&%ic(vol,-1)
 write ! write:er er write $select(er=0:"NO errors",er>1:" errors",1:" error")," found.",!
;---
ERR set ^$system("vol",vol,"writelock")=0 quit

JOURNLST
JOURNLST ; List journal file contents
 new $etrap set $etrap="close 1 do ^%ET"
;---
ASK new file,ans,data,action,uci,size,name,time,ext,off,offset,magic,varlen,timelen
 new slen,key,ref,dbc,long,quit,start,end,epoch
 set file=$get(^$system("vol",^$job($job,"global_vol"),"journal_file")),long=0
 write "Enter file"_$select(file'="":" [<space><enter> for "_file_"]",1:"")_": "
 read ans set:ans'=" "&(ans'="+") file=ans write:ans=" "!(ans="+") file write ! set:ans="+" file=file_ans quit:file=""
 ; NOTE: If file ends in +, it will output the full data, not truncate it to 500
 if $extract(file,$length(file))="+" set long=$get(^$system("string_max"),32767),file=$extract(file,1,$length(file)-1)
 if '$&%file(file,"exists") write "NO SUCH FILE",! goto ASK
 close 1 open 1:(file:"read") use 1:("terminator=")
 read magic#4,offset#8 use $principal
 set magic=$$CVT(magic),offset=$$CVT(offset)
 if magic-4155766916 write "Invalid MAGIC number",! close 1 goto ASK
 set (varlen,timelen)=8
 set off=12 use 1 read time#timelen use $principal
 set size=$$CVT($extract(time,1,2)),action=$ascii(time,3),uci=$ascii(time,4)
 ; Configure for new format journal, with 64 bit time_t and 32 character names
 if size=12 do
 . set varlen=32,timelen=12 use 1 read ext#4 use $principal set time=time_ext write !,"Reference Standard M Journal Version 2",!!
 else  write !,"Reference Standard M Journal Version 1",!!
 write "Do you want to display the entire journal ["_file_"]?"
 read " ([Y]/N): ",ans write !
 set ans=$translate(ans,"yn","YN"),ans=$extract(ans)
 if ans="N" do
 . read "Enter start datetime for journal display: ",start write !
 . if start set start=$translate($&%spawn("date -ud '"_start_"' +""%s""",1),$char(10,13))
 . else  set start=0
 . read "Enter end datetime for journal display: ",end write !
 . if end set end=$translate($&%spawn("date -ud '"_end_"' +""%s""",1),$char(10,13))
 . else  set end=999999999999
 else  set start=0,end=999999999999
 set quit=0
 write !,"Date/Time",?25,"Action",?33,"UCI",?38,"Reference/Data",!
 ; Scan the file
 for  do  quit:off'<offset!quit
 . ; Get the fixed fields
 . if off>12 use 1 read time#timelen use $principal set size=$$CVT($extract(time,1,2)),action=$ascii(time,3),uci=$ascii(time,4)
 . ; Convert time
 . set epoch=$$CVT($extract(time,5,timelen)),time=(epoch\86400+47117)_","_(epoch#86400)
 . ; Setup action
 . set action=$select(action=5:"KILL",action=4:"SET",action=3:"ESTOP",action=2:"STOP",action=1:"START",'action:"CREATE")
 . ; Write the first bit
 . if epoch'>end&(epoch'<start) do
 . . write $$D^%D(+time)," ",$$T^%T($piece(time,",",2)),?25,action write:uci ?33,uci
 . . if size=timelen write !
 . ; If a "small" one, that's all
 . if size=timelen set off=off+size quit
 . ; Get the rest of the record
 . set:size#4 size=size\4+1*4 set off=off+size use 1 read data#(size-timelen) use $principal
 . if epoch>end set quit=1 quit
 . if epoch<start quit
 . ; Check for a 64 bit time_t here when listing an old format journal
 . if timelen=8,$extract(data,1,4)=$char(0,0,0,0) set data=$extract(data,5,99999)
 . ; Extract the name and key length
 . set name=$translate($extract(data,1,varlen),$char(0)),slen=$ascii(data,varlen+1),data=$extract(data,varlen+2,99999)
 . ; Get the key
 . set key=$$FULLUNK^FIX1($extract(data,1,slen)),data=$extract(data,slen+1,99999)
 . ; Write the key - quit if not SET
 . set ref="^"_name_$select(slen:"("_key_")",1:"") write ?38,ref if action'="SET" write ! quit
 . ; Extract the data
 . set dbc=$$CVT($extract(data,1,2)),data=$$DISP^%U($extract(data,3,dbc+2),long)
 . ; Finally the data (if any)
 . write "=",data,!
 close 1 quit
;---
CVT(bin) new i ; Convert binary string to number
 set i=0
 if $$BIGEND^%U for  set i=i*256+$ascii(bin),bin=$extract(bin,2,$length(bin)) quit:'$length(bin)
 else  for  set i=i*256+$ascii(bin,$length(bin)),bin=$extract(bin,1,$length(bin)-1) quit:'$length(bin)
 quit i

JOURNREC
JOURNREC ; Forward recover database from backup and journal file
 new $etrap set $etrap="close 1 do ^%ET"
;---
ASK new file,ans,data,action,uci,size,name,time,ext,off,offset,magic,varlen,timelen
 new slen,key,ref,dbc,long,quit,type,start,end,verbose,setcnt,killcnt,epoch
 new vol set vol=^$job($job,"global_vol")
 if ^$job>1 write "Journal recovery must be run in single-user mode",! quit
 set file=$get(^$system("vol",vol,"journal_file")),long=0
 write "Enter file"_$select(file'="":" [<space><enter> for "_file_"]",1:"")_": "
 read ans set:ans'=" " file=ans write:ans=" " file write ! quit:file=""
 if '$&%file(file,"exists") write "NO SUCH FILE",! goto ASK
 close 1 open 1:(file:"read") use 1:("terminator=")
 read magic#4,offset#8 use $principal
 set magic=$$CVT^JOURNLST(magic),offset=$$CVT^JOURNLST(offset)
 if magic-4155766916 write "Invalid MAGIC number",! close 1 goto ASK
 set (varlen,timelen)=8
 set off=12 use 1 read time#timelen use $principal
 set size=$$CVT^JOURNLST($extract(time,1,2)),action=$ascii(time,3),uci=$ascii(time,4)
 ; Configure for new format journal, with 64 bit time_t and 32 character names
 if size=12 do
 . set varlen=32,timelen=12 use 1 read ext#4 use $principal set time=time_ext write !,"Reference Standard M Journal Version 2",!!
 else  write !,"Reference Standard M Journal Version 1",!!
 write "Do you want to apply the entire journal ["_file_"] to "_^$system("vol",vol,"name")_" ["_^$system("vol",vol,"file")_"]?"
 read " ([Y]/N): ",ans write !
 set ans=$translate(ans,"yn","YN"),ans=$extract(ans)
 if ans="N" do
 . read "Enter start datetime for journal display: ",start write !
 . if start set start=$translate($&%spawn("date -ud '"_start_"' +""%s""",1),$char(10,13))
 . else  set start=0
 . read "Enter end datetime for journal display: ",end write !
 . if end set end=$translate($&%spawn("date -ud '"_end_"' +""%s""",1),$char(10,13))
 . else  set end=999999999999
 else  set start=0,end=999999999999
 read "Do you want to apply both sets and kills, only sets, or only kills? ([B]/S/K): ",type write !
 set type=$translate(type,"bsk","BSK")
 read "Do you want verbose output of the journal recovery process? ([N]/Y): ",verbose write !!
 set verbose=$select($extract($translate(verbose,"yn","YN"))="Y":1,1:0)
 set quit=0,type=$select($extract(type)="S":"SET",$extract(type)="K":"KILL",1:"BOTH")
 if verbose write "Date/Time",?25,"Action",?33,"UCI",?38,"Reference/Data",!
 set (setcnt,killcnt)=0
 ; Scan the file
 for  do  quit:off'<offset!quit
 . ; Get the fixed fields
 . if off>12 do
 . . use 1 read time#timelen use $principal set size=$$CVT^JOURNLST($extract(time,1,2)),action=$ascii(time,3),uci=$ascii(time,4)
 . ; Convert time
 . set epoch=$$CVT^JOURNLST($extract(time,5,timelen)),time=(epoch\86400+47117)_","_(epoch#86400)
 . ; Setup action
 . set action=$select(action=5:"KILL",action=4:"SET",action=3:"ESTOP",action=2:"STOP",action=1:"START",'action:"CREATE")
 . if action'="SET"&(action'="KILL") set off=off+size quit
 . ; Write the first bit
 . if verbose,epoch'>end&(epoch'<start)&(type=action!(type="BOTH")) do
 . . write $$D^%D(+time)," ",$$T^%T($piece(time,",",2)),?25,action write:uci ?33,uci
 . ; If a "small" one, that's all
 . if size=timelen set off=off+size write:verbose ! quit
 . ; Get the rest of the record
 . set:size#4 size=size\4+1*4 set off=off+size use 1 read data#(size-timelen) use $principal
 . if type'=action&(type'="BOTH") set off=off+size quit
 . if epoch>end set quit=1 quit
 . if epoch<start quit
 . ; Check for a 64 bit time_t here when listing an old format journal
 . if timelen=8,$extract(data,1,4)=$char(0,0,0,0) set data=$extract(data,5,99999)
 . ; Extract the name and key length
 . set name=$translate($extract(data,1,varlen),$char(0)),slen=$ascii(data,varlen+1),data=$extract(data,varlen+2,99999)
 . ; Get the key
 . set key=$$FULLUNK^FIX1($extract(data,1,slen)),data=$extract(data,slen+1,99999)
 . ; Write the key if verbose on - quit if not SET
 . set ref="^"_name_$select(slen:"("_key_")",1:"") write:verbose ?38,ref if action'="SET" write:verbose !
 . ; Finally kill the data (if any)
 . if action="KILL"&(type="KILL"!(type="BOTH")) kill @ref set killcnt=$increment(killcnt) quit
 . ; Extract the data
 . set dbc=$$CVT^JOURNLST($extract(data,1,2)),data=$$DISP^%U($extract(data,3,dbc+2),long)
 . ; Finally set the data
 . set @ref=data,setcnt=$increment(setcnt)
 . ; Write the data (if verbose on)
 . if verbose write "=",data,!
 write !,"Processed "_(setcnt+killcnt)_" journal entries: "_setcnt_" sets and "_killcnt_" kills",!
 close 1 quit

MATH
MATH ;
 ; Unless otherwise noted, the code below in ^MATH1 through ^MATH4 was approved
 ; in document X11/95-11 (except for the KVALUE^MATH4 polyfill).
 ;
 ; If corrections have been applied, first the original line appears, with three
 ; semicolons at the beginning of the line.
 ;
 ; Then the source of the correction is acknowledged, then the corrected line
 ; appears, followed by a line containing three semicolons.
 ;
 ; MATH library dispatch routine
;---
ABS(x)                  goto ABS^MATH1
ARCCOS(x)               goto ARCCOS^MATH1
ARCCOSX(x,prec)         goto ARCCOSX^MATH1
ARCCOSH(x,prec)         goto ARCCOSH^MATH1
ARCCOT(x,prec)          goto ARCCOT^MATH1
ARCCOTH(x,prec)         goto ARCCOTH^MATH1
ARCCSC(x,prec)          goto ARCCSC^MATH1
ARCSEC(x,prec)          goto ARCSEC^MATH1
ARCSIN(x)               goto ARCSIN^MATH1
ARCSINX(x,prec)         goto ARCSINX^MATH1
ARCSINH(x,prec)         goto ARCSINH^MATH1
ARCTAN(x,prec)          goto ARCTAN^MATH1
ARCTANH(x,prec)         goto ARCTANH^MATH1
CABS(z)                 goto CABS^MATH1
CADD(x,y)               goto CADD^MATH1
CCOS(z,prec)            goto CCOS^MATH1
CDIV(x,y)               goto CDIV^MATH1
CEXP(z,prec)            goto CEXP^MATH1
CLOG(z,prec)            goto CLOG^MATH2
CMUL(x,y)               goto CMUL^MATH2
COMPLEX(x)              goto COMPLEX^MATH2
CONJUG(z)               goto CONJUG^MATH2
COS(x)                  goto COS^MATH2
COSX(x,prec)            goto COSX^MATH2
COSH(x,prec)            goto COSH^MATH2
COT(x,prec)             goto COT^MATH2
COTH(x,prec)            goto COTH^MATH2
CPOWER(z,n,prec)        goto CPOWER^MATH2
CSC(x,prec)             goto CSC^MATH2
CSCH(x,prec)            goto CSCH^MATH2
CSIN(z,prec)            goto CSIN^MATH2
CSUB(x,y)               goto CSUB^MATH2
DECDMS(x,prec)          goto DECDMS^MATH2
DEGRAD(x)               goto DEGRAD^MATH2
DMSDEC(x)               goto DMSDEC^MATH2
E()                     goto E^MATH2
EXP(x,prec)             goto EXP^MATH3
LOG(x,prec)             goto LOG^MATH3
LOG10(x,prec)           goto LOG10^MATH3
MTXADD(a,b,r,rows,cols) goto MTXADD^MATH3
MTXCOF(a,i,k,n)         goto MTXCOF^MATH3
MTXCOPY(a,r,rows,cols)  goto MTXCOPY^MATH3
MTXDET(a,n)             goto MTXDET^MATH3
MTXEQU(a,b,r,n,m)       goto MTXEQU^MATH3
MTXINV(a,r,n)           goto MTXINV^MATH3
MTXMUL(a,b,r,m,l,n)     goto MTXMUL^MATH3
MTXSCA(a,r,rows,cols,s) goto MTXSCA^MATH3
MTXSUB(a,b,r,rows,cols) goto MTXSUB^MATH3
MTXTRP(a,r,m,n)         goto MTXTRP^MATH3
MTXUNIT(r,n,sparse)     goto MTXUNIT^MATH3
PI()                    goto PI^MATH3
PRODUCE(in,spec,max)    goto PRODUCE^MATH3
RADDEG(x)               goto RADDEG^MATH3
REPLACE(in,spec)        goto REPLACE^MATH3
SEC(x,prec)             goto SEC^MATH4
SECH(x,prec)            goto SECH^MATH4
SIGN(x)                 goto SIGN^MATH4
SIN(x)                  goto SIN^MATH4
SINX(x,prec)            goto SINX^MATH4
SINH(x,prec)            goto SINH^MATH4
SQRT(x,prec)            goto SQRT^MATH4
TAN(x,prec)             goto TAN^MATH4
TANH(x,prec)            goto TANH^MATH4
FORMAT(v,s)             goto FORMAT^MATH4
XOR(a,b,w)              goto XOR^MATH4
CRC16(string,seed)      goto CRC16^MATH4
CRC32(string,seed)      goto CRC32^MATH4
CRCCCITT(string,seed)   goto CRCCCITT^MATH4
LOWER(a,charmod)        goto LOWER^MATH4
PATCODE(a,pat,charmod)  goto PATCODE^MATH4
UPPER(a,charmod)        goto UPPER^MATH4
KVALUE(r,row,col)       goto KVALUE^MATH4

MATH1
MATH1 ;
;---
ABS quit $translate(+x,"-")
;---
ARCCOS ;
 ;;; ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Comment: This version of the function is
 ;          optimized for speed, not for precision.
 ;          The 'precision' parameter is not supported,
 ;          and the precision is at best 2 in 10**-8.
 ;;;
 new a,n,r,sign,xx
 if x<-1 set $ecode=",M28,"
 if x>1  set $ecode=",M28,"
 set sign=1 set:x<0 x=-x,sign=-1
 set a(0)=1.5707963050,a(1)=-0.2145988016,a(2)=0.0889789874
 set a(3)=-0.0501743046,a(4)=0.0308918810,a(5)=-0.0170881256
 set a(6)=0.0066700901,a(7)=-0.0012624911
 set r=a(0),xx=1 for n=1:1:7 set xx=xx*x,r=a(n)*xx+r
 ;;; Set R=$$SQRT^MATH(1-X)*R ; Number ~~
 ; Winfried Gerum (8 June 1995)
 set r=$$SQRT^MATH(1-x,11)*r
 ;;;
 quit r*sign
;---
ARCCOSX ;
 ;;; New L,LIM,K,SIG,SIGS ; Number ~~
 ; Winfried Gerum (8 June 1995)
 new l,lim,k,sig,sigs,value
 ;;;
 if x<-1 set $ecode=",M28,"
 if x>1 set $ecode=",M28,"
 set prec=$get(prec,11)
 ;;; If $translate(X,"-")=1 Set VALUE=0 Quit ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 if $translate(x,"-")=1 quit 0
 ;;;
 set sig=$select(x<0:-1,1:1),value=1-(x*x)
 ;;; Set X=$$SQRT^MATH(VALUE) ; Number ~~
 ; Winfried Gerum (8 June 1995)
 set x=$$SQRT^MATH(value,prec)
 ;;;
 ;;; If $translate(X,"-")=1 Do  quit ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 if $translate(x,"-")=1 do  quit value
 . set value=$$PI^MATH()/2*x
 . quit
 ;;; If X>0.9 Do  Quit ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 if x>0.9 do  quit value
 . set sigs=$select(x<0:-1,1:1)
 . set value=1/(1/x/x-1)
 . ;;; Set X=$$SQRT^MATH(VALUE) ; Number ~~
 . ; Winfried Gerum (8 June 1995)
 . set x=$$SQRT^MATH(value,prec)
 . ;;; Set VALUE=$$ARCTAN^MATH(X,10)*SIGS ; Number ~~
 . ; Winfried Gerum (8 June 1995)
 . set value=$$ARCTAN^MATH(x,prec)*sigs
 set (value,l)=x
 set lim=$select((prec+3)'>11:prec+3,1:11),@("lim=1E-"_lim)
 for k=3:2 do  quit:($translate(l,"-")<lim)
 . set l=l*x*x*(k-2)/(k-1)*(k-2)/k,value=value+l
 . quit
 quit $select(sig<0:$$PI^MATH()-value,1:value)
;---
ARCCOSH ;
 if x<1 set $ecode=",M28,"
 new sq
 ;;; ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Alan Frank (October 1995)
 set prec=$get(prec,11)
 ;;;
 set sq=$$SQRT^MATH(x*x-1,prec)
 quit $$LOG^MATH(x+sq,prec)
;---
ARCCOT ;
 set prec=$get(prec,11)
 set x=1/x
 quit $$ARCTAN^MATH(x,prec)
;---
ARCCOTH ;
 new l1,l2
 ;;; ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Alan Frank (October 1995)
 set prec=$get(prec,11)
 ;;;
 set l1=$$LOG^MATH(x+1,prec)
 set l2=$$LOG^MATH(x-1,prec)
 quit l1-l2/2
;---
ARCCSC ;
 set prec=$get(prec,11)
 set x=1/x
 quit $$ARCSINX^MATH(x,prec)
;---
ARCSEC ;
 set prec=$get(prec,11)
 set x=1/x
 quit $$ARCCOSX^MATH(x,prec)
;---
ARCSIN ;
 ;;; ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Comment: This version of the function is
 ;          optimized for speed, not for precision.
 ;          The 'precision' parameter is not supported,
 ;          and the precision is at best 2 in 10**-8.
 ;;;
 new a,n,r,sign,xx
 if x<-1 set $ecode=",M28,"
 if x>1  set $ecode=",M28,"
 set sign=1 set:x<0 x=-x,sign=-1
 set a(0)=1.5707963050,a(1)=-0.2145988016,a(2)=0.0889789874
 set a(3)=-0.0501743046,a(4)=0.0308918810,a(5)=-0.0170881256
 set a(6)=0.0066700901,a(7)=-0.0012624911
 set r=a(0),xx=1 for n=1:1:7 set xx=xx*x,r=a(n)*xx+r
 ;;; Set R=$$SQRT^MATH(1-X)*R ; Number ~~
 ; Winfried Gerum (8 June 1995)
 set r=$$SQRT^MATH(1-x,11)*r
 ;;;
 set r=$$PI^MATH()/2-r
 quit r*sign
;---
ARCSINX ;
 new l,lim,k,sigs,value
 set prec=$get(prec,11)
 ;;; If $translate(X,"-")=1 Do  Quit ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 if $translate(x,"-")=1 do  quit value
 . set value=$$PI^MATH()/2*x
 ;;; If X>0.99999 Do  Quit ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 if x>0.99999 do  quit value
 . set sigs=$select(x<0:-1,1:1)
 . set value=1/(1/x/x-1)
 . ;;; Set X=$$SQRT^MATH(VALUE) ; Number ~~
 . ; Winfried Gerum (8 June 1995)
 . set x=$$SQRT^MATH(value,prec)
 . ;;; Set VALUE=$$ARCTAN^MATH(X,10)*SIGS ; Number ~~
 . ; Winfried Gerum (8 June 1995)
 . set value=$$ARCTAN^MATH(x,prec)*sigs
 set (value,l)=x
 set lim=$select((prec+3)'>11:prec+3,1:11),@("lim=1E-"_lim)
 for k=3:2 do  quit:($translate(l,"-")<lim)
 . set l=l*x*x*(k-2)/(k-1)*(k-2)/k,value=value+l
 . quit
 quit value
;---
ARCSINH ;
 if x<1 set $ecode=",M28,"
 new sq
 ;;; ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Alan Frank (October 1995)
 set prec=$get(prec,11)
 ;;;
 set sq=$$SQRT^MATH(x*x+1,prec)
 quit $$LOG^MATH(x+sq,prec)
;---
ARCTAN ;
 new fold,hi,l,lim,lo,k,sign,sigs,sigt,value
 set prec=$get(prec,11)
 set lo=0.0000000001,hi=9999999999
 set sigt=$select(x<0:-1,1:1),x=$translate(x,"-")
 set x=$select(x<lo:lo,x>hi:hi,1:x)
 ;;; Set FOLD=$select(X'<1:0,1:1), ; Number ~~
 ; Eli Reidler (28 June 1996)
 set fold=$select(x'<1:0,1:1)
 ;;;
 set x=$select(fold:1/x,1:x)
 set l=x,value=$$PI^MATH()/2-(1/x),sign=1
 ;;; If X<1.3 Do  Quit ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 if x<1.3 do  quit value
 . set x=$select(fold:1/x,1:x),value=1/((1/x/x)+1)
 . ;;; Set $$SQRT^MATH(VALUE) ; Number ~~
 . ; Winfried Gerum (8 June 1995)
 . ; Eli Reidler (28 June 1996)
 . set x=$$SQRT^MATH(value,prec)
 . if $translate(x,"-")=1 do  quit
 . . set value=$$PI^MATH()/2*x
 . . quit
 . if x>0.9 do  quit
 . . set sigs=$select(x<0:-1,1:1)
 . . set value=1/(1/x/x-1)
 . . set x=$$SQRT^MATH(value)
 . . set value=$$ARCTAN(x,10)
 . . set value=value*sigs
 . . quit
 . set (value,l)=x
 . set lim=$select((prec+3)'>11:prec+3,1:11),@("lim=1E-"_lim)
 . for k=3:2 do  quit:($translate(l,"-")<lim)
 . . set l=l*x*x*(k-2)/(k-1)*(k-2)/k,value=value+l
 . . quit
 . set value=$select(sigt<1:-value,1:value)
 . quit
 set lim=$select((prec+3)'>11:prec+3,1:11),@("lim=1E-"_lim)
 for k=3:2 do  quit:($translate(1/l,"-")<lim)
 . ;;; Set L=L*X*X,VALUE=VALUE+(1/(K*L)*SIGN), ; Number ~~
 . ; Eli Reidler (28 June 1996)
 . set l=l*x*x,value=value+(1/(k*l)*sign)
 . set sign=sign*-1
 . quit
 set value=$select(fold:$$PI^MATH()/2-value,1:value)
 set value=$select(sigt<1:-value,1:value)
 quit value
;---
ARCTANH ;
 if x<-1 set $ecode=",M28,"
 if x>1  set $ecode=",M28,"
 ;;; ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Alan Frank (October 1995)
 set prec=$get(prec,11)
 ;;;
 quit $$LOG^MATH(1+x/(1-x),prec)/2
;---
CABS ;
 new zre,zim
 set zre=+z,zim=+$piece(z,"%",2)
 quit $$SQRT^MATH(zre*zre+(zim*zim))
;---
CADD ;
 new xre,xim,yre,yim
 set xre=+x,xim=+$piece(x,"%",2)
 set yre=+y,yim=+$piece(y,"%",2)
 quit xre+yre_"%"_(xim+yim)
;---
CCOS ;
 new e1,e2,ia
 ;;; ; Number ~~
 ; Alan Frank (October 1995)
 set prec=$get(prec,11)
 ;;;
 set ia=$$CMUL^MATH(z,"0%1")
 set e1=$$CEXP^MATH(ia,prec)
 set ia=-ia_"%"_(-$piece(ia,"%",2))
 set e2=$$CEXP^MATH(ia,prec)
 set ia=$$CADD^MATH(e1,e2)
 quit $$CMUL^MATH(ia,"0.5%0")
;---
CDIV ;
 new d,im,re,xim,xre,yim,yre
 set xre=+x,xim=+$piece(x,"%",2)
 set yre=+y,yim=+$piece(y,"%",2)
 set d=yre*yre+(yim*yim)
 set re=xre*yre+(xim*yim)/d
 set im=xim*yre-(xre*yim)/d
 quit re_"%"_im
;---
CEXP ;
 new r,zim,zre
 ;;; ; Number ~~
 ; Alan Frank (October 1995)
 set prec=$get(prec,11)
 ;;;
 set zre=+z,zim=+$piece(z,"%",2)
 set r=$$EXP^MATH(zre,prec)
 quit r*$$COSX^MATH(zim,prec)_"%"_(r*$$SINX^math(zim,prec))

MATH2
MATH2 ;
;---
CLOG ;
 new abs,arg,zim,zre
 ;;; ; Number ~~
 ; Alan Frank (October 1995)
 set prec=$get(prec,11)
 ;;;
 set abs=$$CABS^MATH(z)
 set zre=+z,zim=+$piece(z,"%",2)
 ;;; Set ARG=$$ARCTAN^MATH(ZIM,ZRE,PREC) ; Number ~~
 ; Alan Frank (October 1995)
 set arg=$$ARCTAN^MATH(zim/zre,prec)
 ;;;
 quit $$LOG^MATH(abs,prec)_"%"_arg
;---
CMUL ;
 new xim,xre,yim,yre
 set xre=+x,xim=+$piece(x,"%",2)
 set yre=+y,yim=+$piece(y,"%",2)
 quit xre*yre-(xim*yim)_"%"_(xre*yim+(xim*yre))
;---
COMPLEX quit +x_"%0"
;---
CONJUG ;
 new zim,zre
 set zre=+z,zim=+$piece(z,"%",2)
 quit zre_"%"_(-zim)
;---
COS ;
 ;;; ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Comment: This version of the function is
 ;          optimized for speed, not for precision.
 ;          The 'precision' parameter is not supported,
 ;          and the precision is at best 1 in 10**-9.
 ;          Note that this function does not accept its
 ;          parameter in degrees, minutes and seconds.
 ;;;
 new a,n,pi,r,sign,xx
 ; This approximation only works for 0 <= x <= pi/2
 ; so reduce angle to correct quadrant.
 set pi=$$PI^MATH(),x=x#(pi*2),sign=1
 set:x>pi x=2*pi-x
 set:x*2>pi x=pi-x,sign=-1
 set xx=x*x,a(1)=-0.4999999963,a(2)=0.0416666418
 set a(3)=-0.0013888397,a(4)=0.0000247609,a(5)=-0.0000002605
 set (x,r)=1 for n=1:1:5 set x=x*xx,r=a(n)*x+r
 quit r*sign
;---
COSX ;
 new l,lim,k,sign,value
 ;;; Set:X[":" X=$$DMSDEC^MATH(X,12) ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Comment: The official description does not mention than
 ;          the function may also be called with the first
 ;          parameter in degrees, minutes and seconds.
 set:x[":" x=$$DMSDEC^MATH(x)
 ;;;
 set prec=$get(prec,11)
 set x=x#(2*$$PI^MATH())
 set (value,l)=1,sign=-1
 set lim=$select((prec+3)'>11:prec+3,1:11),@("lim=1E-"_lim)
 for k=2:2 do  quit:($translate(l,"-")<lim)  set sign=sign*-1
 . set l=l*x*x/(k-1*k),value=value+(sign*l)
 . quit
 quit value
;---
COSH ;
 ;;; New F,I,P,R,T,XX ; Number ~~
 ; Winfried Gerum (8 June 1995)
 new e,f,i,p,r,t,xx
 ;;;
 set prec=$get(prec,11)+1
 set @("e=1E-"_prec)
 set xx=x*x,f=1,(p,r,t)=1,i=1
 for  set t=t*xx,f=i+1*i*f,r=t/f+r,p=p-r/r,i=i+2 if -e<p,p<e quit
 quit r
;---
COT ;
 new c,l,lim,k,sign,value
 ;;; Set:X[":" X=$$DMSDEC^MATH(X,12) ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Comment: The official description does not mention than
 ;          the function may also be called with the first
 ;          parameter in degrees, minutes and seconds.
 set:x[":" x=$$DMSDEC^MATH(x)
 ;;;
 set prec=$get(prec,11)
 set (value,l)=1,sign=-1
 set lim=$select((prec+3)'>11:prec+3,1:11),@("lim=1E-"_lim)
 for k=2:2 do  quit:($translate(l,"-")<lim)  set sign=sign*-1
 . set l=l*x*x/(k-1*k),value=value+(sign*l)
 . quit
 set c=value
 set x=x#(2*$$PI^MATH())
 set (value,l)=x,sign=-1
 set lim=$select((prec+3)'>11:prec+3,1:11),@("lim=1E-"_lim)
 for k=3:2 do  quit:($translate(l,"-")<lim)  set sign=sign*-1
 . set l=l/(k-1)*x/k*x,value=value+(sign*l)
 . quit
 if 'value quit "INFINITE"
 quit value=c/value
;---
COTH ;
 new sinh
 if 'x quit "INFINITE"
 ;;; ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Alan Frank (October 1995)
 set prec=$get(prec,11)
 ;;;
 set sinh=$$SINH^MATH(x,prec)
 if 'sinh quit "INFINITE"
 quit $$COSH^MATH(x,prec)/sinh
;---
CPOWER ;
 new ar,nim,nre,phi,pi,r,rho,th,zim,zre
 ;;; ; Number ~~
 ; Alan Frank (October 1995)
 set prec=$get(prec,11)
 ;;;
 set zre=+z,zim=+$piece(z,"%",2)
 set nre=+n,nim=+$piece(n,"%",2)
 if 'zre,'zim,'nre,'nim set $ecode=",M28,"
 ;;; If 'ZRE,'ZIM quit "0%0% ; Number ~~
 ; Eli Reidler (28 June 1996)
 if 'zre,'zim quit "0%0"
 ;;;
 set pi=$$PI^MATH()
 ;;; Set R=$$SQRT^MATH(ZRE*ZRE+(ZIM*ZIM,PREC)) ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 set r=$$SQRT^MATH(zRE*zRE+(zIM*zIM),prec)
 ;;;
 ;;; If ZRE set TH=$$ARCTAN^MATH(ZIM,ZRE,PREC) ; Number ~~
 ; Alan Frank (October 1995)
 if zre set th=$$ARCTAN^MATH(zim/zre,prec)
 ;;;
 ;;; Else  set TH=$select(ZRE>0:PI/2,1:-PI/2) ; Number ~~
 ; Winfried Gerum (8 June 1995)
 else  set th=$select(zim>0:pi/2,1:-pi/2)
 ;;;
 set rho=$$LOG^MATH(r,prec)
 set ar=$$EXP^MATH(rho*nre-(th*nim),prec)
 set phi=rho*nim+(nre*th)
 quit ar*$$COSX^MATH(phi,prec)_"%"_(ar*$$SINX^MATH(phi,prec))
;---
CSC ;
 new l,lim,k,sign,value
 ;;; Set:X[":" X=$$DMSDEC^MATH(X,12) ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Comment: The official description does not mention than
 ;          the function may also be called with the first
 ;          parameter in degrees, minutes and seconds.
 set:x[":" x=$$DMSDEC^MATH(x)
 ;;;
 ;;; Set PREC=$select($data(PREC)#2:PREC,1:10) ; Number ~~
 ; Winfried Gerum (8 June 1995)
 set prec=$get(prec,11)
 ;;;
 set x=x#(2*$$PI^MATH())
 set (value,l)=x,sign=-1
 set lim=$select((prec+3)'>11:prec+3,1:11),@("lim=1E-"_lim)
 for k=3:2 do  quit:($translate(l,"-")<lim)  set sign=sign*-1
 . set l=l/(k-1)*x/k*x,value=value+(sign*l)
 . quit
 if 'value quit "INFINITE"
 quit 1/value
;---
CSCH ;;; Quit 1/$$SINH^MATH(X,PREC) ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Alan Frank (October 1995)
 quit 1/$$SINH^MATH(x,$get(prec,11))
 ;;;
;---
CSIN ;
 new ia,e1,e2
 ;;; ; Number ~~
 ; Alan Frank (October 1995)
 set prec=$get(prec,11)
 ;;;
 set ia=$$CMUL^MATH(z,"0%1")
 set e1=$$CEXP^MATH(ia,prec)
 set ia=-ia_"%"_(-$piece(ia,"%",2))
 set e2=$$CEXP^MATH(ia,prec)
 set ia=$$CSUB^MATH(e1,e2)
 set ia=$$CMUL^MATH(ia,"0.5%0")
 quit $$CMUL^MATH("0%-1",ia)
;---
CSUB ;
 new xim,xre,yim,yre
 set xre=+x,xim=+$piece(x,"%",2)
 set yre=+y,yim=+$piece(y,"%",2)
 quit xre-yre_"%"_(xim-yim)
;---
DECDMS ;
 set prec=$get(prec,5)
 set x=x#360*3600
 set x=+$justify(x,0,$select((prec-$length(x\1))'<0:prec-$length(x\1),1:0))
 quit x\3600_":"_(x\60#60)_":"_(x#60)
;---
DEGRAD quit x*$$PI^MATH()/180
;---
DMSDEC ;
 quit $piece(x,":")+($piece(x,":",2)/60)+($piece(x,":",3)/3600)
;---
E new prec,e
 set prec=^$job($job,"precision")
 set e=2.7182818284590452353602874713526624977572470936999595749669676277
 set e=e_2407663035354759457138217852516642742746639193200305992181741359
 set e=$extract(e,1,prec+3)
 if prec=0 quit 2
 if prec=128 quit e
 quit $extract(e,1,$length(e)-2)_($extract(e,$length(e)-1)+$select($extract(e,$length(e))>4:1,1:0))

MATH3
MATH3 ;
;---
EXP ;
 new l,lim,k,value
 set prec=$get(prec,11)
 set l=x,value=x+1
 set lim=$select((prec+3)'>11:prec+3,1:11),@("lim=1E-"_lim)
 for k=2:1 set l=l*x/k,value=value+l quit:($translate(l,"-")<lim)
 quit value
;---
LOG ;
 new l,lim,m,n,k,value
 if x'>0 set $ecode=",M28,"
 set prec=$get(prec,11)
 set m=1
 ;;; If X>0 For N=0:1 Quit:(X/M)<10  Set M=M*10 ; Number ~~
 ; Winfried Gerum (8 June 1995)
 for n=0:1 quit:(x/m)<10  set m=m*10
 ;;;
 if x<1 for n=0:-1 quit:(x/m)>0.1  set m=m*0.1
 set x=x/m
 set x=(x-1)/(x+1),(value,l)=x
 set lim=$select((prec+3)'>11:prec+3,1:11),@("lim=1E-"_lim)
 for k=3:2 set l=l*x*x,m=l/k,value=m+value set:m<0 m=-m quit:m<lim
 ; NOTE: log10: E**2.3025850929940456840179914546843642076011014886287729760333279009=10
 set value=value*2+(n*2.30258509298749)
 quit value
;---
LOG10 ;
 new l,lim,m,n,k,value
 if x'>0 set $ecode=",M28,"
 set prec=$get(prec,11)
 set m=1
 ;;; If X>0 For N=0:1 Quit:(X/M)<10  Set M=M*10 ; Number ~~
 ; Winfried Gerum (8 June 1995)
 for n=0:1 quit:(x/m)<10  set m=m*10
 ;;;
 if x<1 for n=0:-1 quit:(x/m)>0.1  set m=m*0.1
 set x=x/m
 set x=(x-1)/(x+1),(value,l)=x
 set lim=$select((prec+3)'>11:prec+3,1:11),@("lim=1E-"_lim)
 for k=3:2 set l=l*x*x,m=l/k,value=m+value set:m<0 m=-m quit:m<lim
 set value=value*2+(n*2.30258509298749)
 quit value/2.30258509298749
;---
MTXADD ;
 ; Add a[rows,cols] to b[rows,cols], result goes to r[rows,cols]
 if $data(a)<10  quit 0
 if $data(b)<10  quit 0
 if $get(rows)<1 quit 0
 if $get(cols)<1 quit 0
 new row,col,any
 for row=1:1:rows for col=1:1:cols do
 . do KVALUE^MATH(.r,row,col) set any=0
 . set:$data(a(row,col))#2 any=1
 . set:$data(b(row,col))#2 any=1
 . set:any r(row,col)=$get(a(row,col))+$get(b(row,col))
 . quit
 quit 1
;---
MTXCOF ;
 ; Compute cofactor for element [i,k] in matrix A[N,N]
 new t,r,c,rr,cc
 set cc=0 for c=1:1:n do:c'=k
 . set cc=cc+1,rr=0
 . for r=1:1:n set:r'=i rr=rr+1,t(rr,cc)=$get(a(r,c))
 . quit
 quit $$MTXDET^MATH(.t,n-1)
;---
MTXCOPY ;
 ; Copy a[rows,cols] to r[rows,cols]
 if $data(a)<10  quit 0
 if $get(rows)<1 quit 0
 if $get(cols)<1 quit 0
 new row,col
 for row=1:1:rows for col=1:1:cols do
 . do KVALUE^MATH(.r,row,col)
 . set:$data(a(row,col))#2 r(row,col)=a(row,col)
 . quit
 quit 1
;---
MTXDET ;
 ; Compute determinant of matrix a[n,n]
 if $data(a)<10 quit ""
 if $get(n)<1   quit ""
 ; First the simple cases
 if n=1 quit $get(a(1,1))
 if n=2 quit $get(a(1,1))*$get(a(2,2))-($get(a(1,2))*$get(a(2,1)))
 new det,i,sign
 ; det a = sum (k=1:n) element (i,k) * cofactor [i,k]
 set det=0,sign=1
 for i=1:1:n do
 . set det=$get(a(1,i))*$$MTXCOF^MATH(.a,1,i,n)*sign+det
 . set sign=-sign
 . quit
 quit det
;---
MTXEQU ;
 ; Solve matrix equation a [m,m] * r [m,n] = b [m,n]
 if $get(m)<1 quit ""
 if $get(n)<1 quit ""
 ;;; If '$$MTXDET^MATH(.A) quit 0
 ; Ed de Moel, 29 August 1999
 if '$$MTXDET^MATH(.a,m) quit 0
 ;;;
 new i,i1,j,j1,j2,k,l,t,t1,t2,temp,x
 set x=$$MTXCOPY^MATH(.a,.t,n,n)
 set x=$$MTXCOPY^MATH(.b,.r,n,m)
 ; Reduction of matrix a, steps of reduction are counted by index k
 for k=1:1:n-1 do
 . ; Search for largest coefficient of t
 . ; (denoted by temp)
 . ; in first column of reduced system
 . set temp=0,j2=k
 . for j1=k:1:n do
 . . quit:$translate($get(t(j1,k)),"-")>$translate(temp,"-")
 . . set temp=t(j1,k),j2=j1
 . . quit
 . ; Exchange row number k with row number j2, if necessary
 . do:j2'=k
 . . for j=k:1:n do
 . . . set t1=$get(t(k,j)),t2=$get(t(j2,j))
 . . . kill t(k,j),t(j2,j)
 . . . if t1'="" set t(j2,j)=t1
 . . . if t2'="" set t(k,j)=t2
 . . . quit
 . . for j=1:1:m do
 . . . set t1=$get(r(k,j)),t2=$get(r(j2,j))
 . . . kill r(k,j),r(j2,j)
 . . . if t1'="" set r(j2,j)=t1
 . . . if t2'="" set r(k,j)=t2
 . . . quit
 . . quit
 . ; Actual reduction
 . for i=k+1:1:n do
 . . for j=k+1:1:n do
 . . . quit:'$get(t(k,k))
 . . . set t(i,j)=-$get(t(k,j))*$get(t(i,k))/t(k,k)+$get(t(i,j))
 . . . quit
 . . for j=1:1:m do
 . . . quit:'$get(t(k,k))
 . . . set r(i,j)=-$get(r(k,j))*$get(t(i,k))/t(k,k)+$get(r(i,j))
 . . . quit
 . . quit
 . quit
 ; Backsubstitution
 for j=1:1:m do
 . if $get(t(n,n)) set r(n,j)=$get(r(n,j))/t(n,n)
 . if n-1>0 for i1=1:1:n-1 do
 . . set i=n-i1
 . . for l=i+1:1:n do
 . . . set r(i,j)=-$get(t(i,l))*$get(r(l,j))+$get(r(i,j))
 . . . quit
 . . if $get(t(i,i)) set r(i,j)=$get(r(i,j))/$get(t(i,i))
 . . quit
 . quit
 ;;; Quit $$MTXDET^MATH(.R)
 ; Ed de Moel, 29 Aug 1999
 quit $select(m=n:$$MTXDET^MATH(.r,m),1:1)
 ;;;
;---
MTXINV ;
 ; Invert a[n,n], result goes to r[n,n]
 if $data(a)<10 quit 0
 if $get(n)<1   quit 0
 new t,x
 set x=$$MTXUNIT^MATH(.t,n)
 quit $$MTXEQU^MATH(.a,.t,.r,n,n)
;---
MTXMUL ;
 ; Multiply a[m,l] by b[l,n], result goes to r[m,n]
 if $data(a)<10 quit 0
 if $data(b)<10 quit 0
 if $get(l)<1   quit 0
 if $get(m)<1   quit 0
 if $get(n)<1   quit 0
 new i,j,k,sum,any
 for i=1:1:m for j=1:1:n do
 . set (sum,any)=0
 . do KVALUE^MATH(.r,i,j)
 . for k=1:1:l do
 . . set:$data(a(i,k))#2 any=1
 . . set:$data(b(k,j))#2 any=1
 . . set sum=$get(a(i,k))*$get(b(k,j))+sum
 . . quit
 . set:any r(i,j)=sum
 . quit
 quit 1
;---
MTXSCA ;
 ; Multiply a[rows,cols] with the scalar s, result goes to r[rows,cols]
 if $data(a)<10   quit 0
 if $get(rows)<1  quit 0
 if $get(cols)<1  quit 0
 if '($data(s)#2) quit 0
 new row,col
 for row=1:1:rows for col=1:1:cols do
 . do KVALUE^MATH(.r,row,col)
 . set:$data(a(row,col))#2 r(row,col)=a(row,col)*s
 . quit
 quit 1
;---
MTXSUB ;
 ; Subtract b[rows,cols] from a[rows,cols], result goes to r[rows,cols]
 if $data(a)<10  quit 0
 if $data(b)<10  quit 0
 if $get(rows)<1 quit 0
 if $get(cols)<1 quit 0
 new row,col,any
 for row=1:1:rows for col=1:1:cols do
 . do KVALUE^MATH(.r,row,col) set any=0
 . set:$data(a(row,col))#2 any=1
 . set:$data(b(row,col))#2 any=1
 . ;
 . ;;; Set:ANY R(ROW,COL)=$GET(A(ROW,COL)-$GET(B(ROW,COL)) ; Number ~~
 . ; Eli Reidler (28 June 1996)
 . set:any r(row,col)=$get(a(row,col))-$get(b(row,col))
 . ;;;
 . ;
 . quit
 quit 1
;---
MTXTRP ;
 ; Transpose a[m,n], result goes to r[n,m]
 if $data(a)<10 quit 0
 if $get(m)<1   quit 0
 if $get(n)<1   quit 0
 new i,j,k,d1,v1,d2,v2
 for i=1:1:m+n-1 for j=1:1:i+1\2 do
 . set k=i-j+1
 . if k=j do  quit
 . . set v1=$get(a(j,j)),d1=$data(a(j,j))#2
 . . if j'>n,j'>m do KVALUE^MATH(.r,j,j) set:d1 r(j,j)=v1
 . . quit
 . ;
 . set v1=$get(a(k,j)),d1=$data(a(k,j))#2
 . set v2=$get(a(j,k)),d2=$data(a(j,k))#2
 . if k'>m,j'>n do KVALUE^MATH(.r,k,j) set:d2 r(k,j)=v2
 . if j'>m,k'>n do KVALUE^MATH(.r,j,k) set:d1 r(j,k)=v1
 . quit
 quit 1
;---
MTXUNIT ;
 ; Create a unit matrix r[n,n]
 if $get(n)<1 quit 0
 new row,col
 for row=1:1:n for col=1:1:n do
 . do KVALUE^MATH(.r,row,col)
 . if $get(sparse) quit:row'=col
 . set r(row,col)=$select(row=col:1,1:0)
 . quit
 quit 1
;---
PI new prec,pi
 set prec=^$job($job,"precision")
 set pi=3.141592653589793238462643383279502884197169399375105820974944592307
 set pi=pi_81640628620899862803482534211706798214808651328230664709384460
 set pi=$extract(pi,1,prec+3)
 if prec=0 quit 3
 if prec=128 quit pi
 quit $extract(pi,1,$length(pi)-2)_($extract(pi,$length(pi)-1)+$select($extract(pi,$length(pi))>4:1,1:0))
;---
PRODUCE ;
 new value,again,p1,p2,i,count
 set value=in,count=0
 for  do  quit:'again
 . set again=0
 . set i=""
 . for  set i=$order(spec(i)) quit:i=""  do  quit:count<0
 . . quit:$get(spec(i,1))=""
 . . quit:'($data(spec(i,2))#2)
 . . for  quit:value'[spec(i,1)  do  quit:count<0
 . . . set p1=$piece(value,spec(i,1),1)
 . . . set p2=$piece(value,spec(i,1),2,$length(value))
 . . . set value=p1_spec(i,2)_p2,again=1
 . . . set count=count+1
 . . . if $data(max),count>max set count=-1,again=0
 . . . quit
 . . quit
 . quit
 quit value
;---
RADDEG quit x*180/$$PI^MATH()
;---
REPLACE ;
 new l,mask,k,i,lt,f,value
 set l=$length(in),mask=$justify("",l)
 set i="" for  set i=$order(spec(i)) quit:i=""  do
 . quit:'($data(spec(i,1))#2)
 . quit:spec(i,1)=""
 . quit:'($data(spec(i,2))#2)
 . set lt=$length(spec(i,1))
 . set f=0 for  set f=$find(in,spec(i,1),f) quit:f<1  do
 . . quit:$extract(mask,f-lt,f-1)["X"
 . . set value(f-lt)=spec(i,2)
 . . set $extract(mask,f-lt,f-1)=$translate($justify("",lt)," ","X")
 . . quit
 . quit
 set value="" for k=1:1:l do
 . if $extract(mask,k)=" " set value=value_$extract(in,k) quit
 . set:$data(value(k)) value=value_value(k)
 . quit
 quit value

MATH4
MATH4 ;
;---
SEC ;
 new l,lim,k,sign,value
 ;;; Set:X[":" X=$$DMSDEC^MATH(X,12) ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Comment: The official description does not mention than
 ;          the function may also be called with the first
 ;          parameter in degrees, minutes and seconds.
 set:x[":" x=$$DMSDEC^MATH(x)
 ;;;
 set prec=$get(prec,11)
 set x=x#(2*$$PI^MATH())
 set (value,l)=1,sign=-1
 set lim=$select((prec+3)'>11:prec+3,1:11),@("lim=1E-"_lim)
 for k=2:2 do  quit:($translate(l,"-")<lim)  set sign=sign*-1
 . set l=l*x*x/(k-1*k),value=value+(sign*l)
 . quit
 if 'value quit "INFINITE"
 quit 1/value
;---
SECH ;;; Quit 1/$$COSH^MATH(X,PREC) ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Alan Frank (October 1995)
 quit 1/$$COSH^MATH(x,$get(prec,11))
 ;;;
;---
SIGN quit $select(x<0:-1,x>0:1,1:0)
;---
SIN ;
 ;;; ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Comment: This version of the function is
 ;          optimized for speed, not for precision.
 ;          The 'precision' parameter is not supported,
 ;          and the precision is at best 1 in 10**-9.
 ;          Note that this function does not accept its
 ;          parameter in degrees, minutes and seconds.
 ;;;
 new a,n,pi,r,sign,xx
 ; This approximation only works for 0 <= x <= pi/2 so reduce angle to correct quadrant.
 set pi=$$PI^MATH(),x=x#(pi*2),sign=1
 set:x>pi x=2*pi-x,sign=-1
 ;;; Set:X*2<PI X=PI-X Set X=-PI/2+2 ; Number ~~
 ; Winfried Gerum (8 June 1995)
 set:x*2<pi x=pi-x
 ;;;
 set xx=x*x,a(1)=-0.4999999963,a(2)=0.0416666418
 set a(3)=-0.0013888397,a(4)=0.0000247609,a(5)=-0.0000002605
 set (x,r)=1 for n=1:1:5 set x=x*xx,r=a(n)*x+r
 quit r*sign
;---
SINX ;
 new l,lim,k,sign,value
 ;;; Set:X[":" X=$$DMSDEC^MATH(X,12) ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Comment: The official description does not mention than
 ;          the function may also be called with the first
 ;          parameter in degrees, minutes and seconds.
 set:x[":" x=$$DMSDEC^MATH(x)
 ;;;
 set prec=$get(prec,11)
 set x=x#(2*$$PI^MATH())
 set (value,l)=x,sign=-1
 set lim=$select((prec+3)'>11:prec+3,1:11),@("lim=1E-"_lim)
 for k=3:2 do  quit:($translate(l,"-")<lim)  set sign=sign*-1
 . set l=l/(k-1)*x/k*x,value=value+(sign*l)
 . quit
 quit value
;---
SINH ;
 ;;; New F,I,P,R,T,XX ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 new e,f,i,p,r,t,xx
 ;;;
 set prec=$get(prec,11)+1
 set @("e=1E-"_prec)
 set xx=x*x,f=1,i=2,(p,r,t)=x
 for  set t=t*xx,f=i+1*i*f,r=t/f+r,p=p-r/r,i=i+2 if -e<p,p<e quit
 quit r
;---
SQRT ;
 if x<0 set $ecode=",M28,"
 if x=0 quit 0
 ;;; ; Number ~~
 ; Alan Frank (October 1995)
 set prec=$get(prec,11)
 ;;;
 ;;; If X<1 Quit 1/$$SQRT^MATH(1/X) ; Number ~~
 ; Winfried Gerum (8 June 1995)
 if x<1 quit 1/$$SQRT^MATH(1/x,prec)
 ;;;
 new p,r,e
 set prec=$get(prec,11)+1
 ;;; Set @(E="1E-"_PREC) ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 set @("e=1E-"_prec)
 ;;;
 set r=x
 for  set p=r,r=x/r+r/2,p=p-r/r if -e<p,p<e quit
 quit r
;---
TAN ;
 new l,lim,k,s,sign,value
 ;;; Set:X[":" X=$$DMSDEC^MATH(X,12) ; Number ~~
 ; Winfried Gerum (8 June 1995)
 ; Comment: The official description does not mention than
 ;          the function may also be called with the first
 ;          parameter in degrees, minutes and seconds.
 set:x[":" x=$$DMSDEC^MATH(x)
 ;;;
 set prec=$get(prec,11)
 set x=x#(2*$$PI^MATH())
 set (value,l)=x,sign=-1
 set lim=$select((prec+3)'>11:prec+3,1:11),@("lim=1E-"_lim)
 for k=3:2 do  quit:($translate(l,"-")<lim)  set sign=sign*-1
 . set l=l/(k-1)*x/k*x,value=value+(sign*l)
 . quit
 set s=value
 set x=x#(2*$$PI^MATH())
 set (value,l)=1,sign=-1
 set lim=$select((prec+3)'>11:prec+3,1:11),@("lim=1E-"_lim)
 for k=2:2 do  quit:($translate(l,"-")<lim)  set sign=sign*-1
 . set l=l*x*x/(k-1*k),value=value+(sign*l)
 . quit
 if 'value quit "INFINITE"
 quit s/value
;---
TANH ;
 ;;; ; Number ~~
 ; Alan Frank (October 1995)
 set prec=$get(prec,11)
 ;;;
 quit $$SINH^MATH(x,prec)/$$COSH^MATH(x,prec)
;---
FORMAT ;
 ; The code below was approved in document X11/SC13/TG2/1999-1
 new lo,mask,out,p,pos,spec,up,v1,v2,val,x
 set lo="abcdefghijklmnopqrstuvwxyz"
 set up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 ; Array spec() contains the formatting directives
 ; First set defaults
 set spec("CS")="$" ; Currency symbol
 set spec("DC")="." ; Decimal separator
 set spec("EC")="*" ; Error character
 set spec("SL")="," ; Separator characters > 1
 set spec("FS")=" " ; Fill string
 ; Other specifiers may be
 ; FM = Format Mask
 ; FO = Fill On/Off
 ; SR = Separator characters < 1
 ; Then Inherit properties from System,
 ; overwriting the defaults
 ; NOTE: ^$system($system,"format",...) is not supported in RSM
 ;;set x="" for  set x=$order(^$system($system,"format",x)) quit:x=""  do
 ;;. set spec(x)=^$system($system,"format",x)
 ;;. quit
 ;Then Inherit properties from current process overwriting the system and the defaults
 ; NOTE: ^$job($job,"format",...) is not supported in RSM
 ;;set x="" for  set x=$order(^$job($job,"format",x)) quit:x=""  do
 ;;. set spec(x)=^$job($job,"format",x)
 ;;. quit
 ; Then look at actual parameters overwriting anything else
 set s=$get(s) for  quit:s=""  do
 . new e,i,str,v
 . set x=$piece(s,"=",1)
 . set i=$length(x)+2,str=0,v=""
 . set:x="" i=1
 . for i=i:1:$length(s)+1 do  quit:'i
 . . set e=$extract(s_":",i)
 . . if 'str,e=":" set s=$extract(s,i+1,$length(s)),i=0 quit
 . . set v=v_e quit:e'=""""
 . . set str=1-str
 . . quit
 . if i>$length(S) set S=""
 . if x'="",v'="" set @("spec($translate(x,lo,up))="_v) quit
 . set $ecode=",M28,"
 . quit
 ; Make certain that DC and EC are non-empty and not longer than 1 character
 set spec("DC")=$extract(spec("DC")_".",1)
 set spec("EC")=$extract(spec("EC")_"*",1)
 set val=$get(v),(mask,out)=$get(spec("FM"))
 if mask="" quit val
 ; Currency string
 set x=spec("CS")
 set pos=0 for  set pos=$find(mask,"c",pos) quit:pos<1  do
 . set $extract(out,pos-1)=$extract(x,1)
 . set x=$extract(x,2,$length(x))_$extract(x,1)
 . quit
 ; Sign
 set x=$select(val>0:"+",val<0:"-",1:" ")
 set pos=0 for  set pos=$find(mask,"+",pos) quit:pos<1  do
 . set $extract(out,pos-1)=x
 . quit
 set pos=0 for  set pos=$find(mask,"-",pos) quit:pos<1  do
 . set $extract(out,pos-1)=$select(x="-":x,1:" ")
 . quit
 if x'="-" set out=$translate(out,"()","  ")
 ; Decimal separator
 set pos=$find(mask,"d")
 do:pos'<1
 . set $extract(out,pos-1)=spec("DC")
 . for  set pos=$find(mask,"d",pos) quit:pos<1  do
 . . set $extract(out,pos-1)=spec("EC")
 . . quit
 . quit
 ; Right (default, format letter "n") or left (format letter "l") adjustment?
 if mask["l",mask["n" set $ecode=",M28,"
 ; Left and Right Separators
 set v1=$piece(val,".",1),v2=$piece(val,".",2)
 set v1=$translate(v1,"-")
 if mask'["l" do
 . set x="" for p=1:1:$length(v1) set x=$extract(v1,p)_x
 . set v1=x
 . quit
 set pos=$find(mask,"d") set:pos<1 pos=$length(mask)+2
 ; Integer part and Left separators
 set x=spec("SL")
 set p(1)=pos-2,p(2)=-1,p(3)=1
 set:mask["l" p(1)=1,p(2)=1,p(3)=pos-2
 for p=p(1):p(2):p(3) do
 . if "fln"[$extract(mask,p) do
 . . set $extract(out,p)=$extract(v1,1)
 . . set v1=$extract(v1,2,$length(v1))_spec("FS")
 . . if $translate(v1,spec("FS"))="" set x=spec("FS")
 . . quit
 . if $extract(mask,p)="s" do
 . . set $extract(out,p)=$extract(x,1)
 . . set x=$extract(x,2,$length(x))_$extract(x,1)
 . quit
 ; Fractional part and Right separators
 set x=$get(spec("SR"),spec("SL"))
 set:v2="" v2=0
 for p=pos:1:$length(mask) do
 . if "fn"[$extract(mask,p) do
 . . set $extract(out,p)=$extract(v2,1)
 . . set v2=$extract(v2,2,$length(v2))_"0"
 . . quit
 . if $extract(mask,p)="s" do
 . . set $extract(out,p)=$extract(x,1)
 . . set x=$extract(x,2,$length(x))_$extract(x,1)
 . . quit
 . quit
 ; Fill String
 set x=$get(spec("FS"))
 for p=1:1:$l(mask) do
 . quit:"nf"'[$extract(mask,p)
 . quit:$extract(out,p)'=" "
 . set $extract(out,p)=$extract(x,1)
 . set x=$extract(x,2,$length(x))_$extract(x,1)
 . quit
 ; Justification
 for x="+ | +","- | -","( | ("," )|) " do
 . new find,repl
 . set find=$piece(x,"|",1),repl=$piece(x,"|",2)
 . for  quit:out'[find  do
 . . set out=$piece(out,find,1)_repl_$piece(out,find,2,$l(out)+2)
 . . quit
 . quit
 quit out
;---
XOR new i,m,r
 set r=b,m=1
 for i=1:1:w do
 . set:a\m#2 r=r+$select(r\m#2:-m,1:m)
 . set m=m+m
 . quit
 quit r
;---
CRC16 ;
 ; The code below was approved in document X11/1998-32
 ; Polynomial x**16 + x**15 + x**2 + x**0
 new i,j,r
 if '$data(seed) set r=0
 else  if seed'<0,seed'>65535 set r=seed\1
 else  set $ecode=",M28,"
 for i=1:1:$length(string) do
 . set r=$$xor($ascii(string,i),r,8)
 . for j=0:1:7 do
 . . if r#2 set r=$$XOR(r\2,40961,16)
 . . else  set r=r\2
 . . quit
 . quit
 quit r
;---
CRC32 ;
 ; The code below was approved in document X11/1998-32
 ; Polynomial X**32 + X**26 + X**23 + X**22 +
 ;          + X**16 + X**12 + X**11 + X**10 +
 ;          + X**8  + X**7  + X**5  + X**4 +
 ;          + X**2  + X     + 1
 new i,j,r
 if '$data(seed) set r=4294967295
 else  if seed'<0,seed'>4294967295 set r=4294967295-seed
 else  set $ecode=",M28,"
 for i=1:1:$length(string) do
 . set r=$$XOR($ascii(string,i),r,8)
 . for j=0:1:7 do
 . . if r#2 set r=$$XOR(r\2,3988292384,32)
 . . else  set r=r\2
 . . quit
 . quit
 quit 4294967295-r
;---
CRCCCITT ;
 ; The code below was approved in document X11/1998-32
 ; Polynomial x**16 + x**12 + x**5 + x**0
 new i,j,r
 if '$data(seed) set r=65535
 else  if seed'<0,seed'>65535 set r=seed\1
 else  set $ecode=",M28,"
 for i=1:1:$length(string) do
 . set r=$$XOR($ascii(string,i)*256,r,16)
 . for j=0:1:7 do
 . . set r=r+r
 . . quit:r<65536
 . . set r=$$XOR(4129,r-65536,13)
 . . quit
 . quit
 quit r
;---
LOWER new lo,up,x,y
 ; The code below was approved in document X11/1998-21
 set x=$get(charmod)
 set lo="abcdefghijklmnopqrstuvwxyz"
 set up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 if x?1"^"1E.E do
 . set x=$extract(x,2,$length(x))
 . if x?1"|".E do
 . . set x=$reverse($extract(x,2,$length(x)))
 . . set y=$reverse($piece(x,"|",2,$length(x)+2))
 . . set x=$reverse($piece(x,"|",1))
 . . set x=$get(^[y]$global(x,"character"))
 . . quit
 . else  set x=$get(^$global(x,"character"))
 . quit
 if x="" set x=^$job($job,"character")
 ; NOTE: RSM doesn't yet implement ^$character(...,"lower")
 set x=$get(^$character(x,"lower"))
 if x="" quit $translate(a,up,lo)
 set @("x="_x_"(a)")
 quit x
;---
PATCODE new x,y
 ; The code below was approved in document X11/1998-21
 set x=$get(charmod)
 if x?1"^"1E.E do
 . set x=$extract(x,2,$length(x))
 . if x?1"|".E do
 . . set x=$reverse($extract(x,2,$length(x)))
 . . set y=$reverse($piece(x,"|",2,$length(x)+2))
 . . set x=$reverse($piece(x,"|",1))
 . . set x=$get(^[y]$global(x,"character"))
 . . quit
 . else  set x=$get(^$global(x,"character"))
 . quit
 if x="" set x=^$job($job,"character")
 ; NOTE: RSM doesn't yet implement ^$character(...,"patcode",...)
 set x=$get(^$character(x,"patcode",pat))
 if x="" quit 0
 set @("x="_x_"(a)")
 quit x
;---
UPPER new lo,up,x,y
 ; The code below was approved in document X11/1998-21
 set x=$get(charmod)
 set lo="abcdefghijklmnopqrstuvwxyz"
 set up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 if x?1"^"1E.E do
 . set x=$extract(x,2,$length(x))
 . if x?1"|".E do
 . . set x=$reverse($extract(x,2,$length(x)))
 . . set y=$reverse($piece(x,"|",2,$length(x)+2))
 . . set x=$reverse($piece(x,"|",1))
 . . set x=$get(^[y]$global(x,"character"))
 . . quit
 . else  set x=$get(^$global(x,"character"))
 . quit
 if x="" set x=^$job($job,"character")
 ; NOTE: RSM doesn't yet implement ^$character(...,"upper")
 set x=$get(^$character(x,"upper"))
 if x="" quit $translate(a,lo,up)
 set @("x="_x_"(a)")
 quit x
;---
KVALUE(r,row,col) ; KVALUE polyfill
 new tmp,i,j merge tmp=r kill r
 for i=1:1:row for j=1:1:col if '(i=row&(j=col)) set r(i,j)=tmp(i,j)
 quit

MUMTRIS
MUMTRIS ;V 3.011 09 Jun 2012 11:28 AM
; Mumtris
; Copyright © 2012 Piotr Koper <piotr.koper@gmail.com>
; Converted for MUMPS V1 by Ray Douglas Newman
;
; This program is free software: you can redistribute it and/or modify
; it under the terms of the GNU Affero General Public License as
; published by the Free Software Foundation, either version 3 of the
; License, or (at your option) any later version.
;
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
; GNU Affero General Public License for more details.
;
; You should have received a copy of the GNU Affero General Public License
; along with this program. If not, see <http://www.gnu.org/licenses/>.
;
; Mumtris
; This is a tetris game in MUMPS, for GT.M, have fun.
;
; Resize your terminal (e.g., maximize your PuTTY window), restart GT.M so that
; it can report true size of your terminal, and do ^mumtris.
;
; Try setting ansi=0 for GT.M compatible cursor positioning.
;
; NOTICE: Mumtris uses "active waiting" for making delays lower that 1s.
;         That means that one of your CPU will be used at 99%. It's not a bug,
;         the Mumtris and GT.M will be fully responsive. Take care when
;         running on production system ;-)
mumtris ;
 new ansi,e,n,w,h,gr,fl,hl,sc,lv,lc,sb,st,ml,dh,dw,mx,my,mt,r,y,x,t10m,c,ne,i,q
 set ansi=1          ; use (faster) ANSI CSI instead of use $principal:X=x positioning
 set w=10            ; matrix width
 set h=22            ; matrix height (see below)
 set gr=1            ; grid
 set fl=1            ; fill
 set hl=1            ; help
 set sc=0            ; score
 set lv=1            ; level
 set lc=0            ; lines cleared at current level
 set sb=40           ; step base
 set st=$$step       ; current step
 set ml=3            ; move/rotate hold limit (without fall)
 do dev              ; defines dw, dh (device width, device height)
 set h=dh-2          ; comment out to disable auto height
 set mx=dw/2-(3*w/2) ; matrix left coordinate
 set my=dh/2-(h/2)-1 ; matrix top coordinate
 set mt="3 5_9 8 2_9 .2_02 /5 \2 2_ 2_2 6_/2 |8_|2_| 6_0 /2 \ /2 \|2 |2 \/5 \3 2_\_2 2_ \2 |/2 3_/0/4 Y4 \2 |2 /2 Y Y2 \2 |2 |2 | \/2 |\3_ \0\4_|2_2 /4_/|2_|_|2 /2_|2 |2_|2 |2_/4_2 >08 \/9 3 \/9 9 2 \/0" ; Mumtris
 ;use $principal:"noecho" do cls
 use $principal do cls
 do intro
 do elements
 set ne=$random(e)+1 ; new element
 do change do new() do preview
 do score() do help do redraw
 set (i,q)=0
 for  quit:q  do
 . do pos(0,0)
 . set c=$$key
 . if c=1 do exit set q=1 quit
 . set i=$select('c:0,1:i+1)
 . set:i'<ml (i,c)=0
 . if c'=3&$$fall do lock do clear do change do preview if $$new do over do exit set q=1 quit
 . do redraw
 quit
;---
key() ; 1 - exit, 2 - harddrop, 3 - other char
 new q,c,d,ex,hd
 set (q,d,ex,hd)=0
 new i
 new l set l=1
 for  quit:q  do
 . read *c:0
 . if c<0&'d do
 . . for i=1:1:st*t10m read *c:0 quit:c>0  if $horolog
 . if c<0 set q=1 quit
 . set d=2
 . if c=27 do  quit:q
 . . read *c:0 if c<0 set (q,ex)=1 quit
 . . if c=91 read *c:0
 . do:c=65 rotate
 . do:c=66 fall(1)
 . do:c=67 right
 . do:c=68 left
 . if c=70!(c=102) set fl=fl+1#3 do preview
 . set:c=71!(c=103) gr='gr
 . if c=72!(c=104) set hl='hl do help
 . set:c=81!(c=113) (q,ex)=1
 . if c=32 do drop set hd=1
 quit $select(ex:1,hd:2,d:3,1:0)
;---
redraw ;
 do matrix
 do stack
 do draw(n,r,y,x)
 quit
;---
ticks ;
 new h,b,e,q
 set h=$horolog,(b,e,q)=0 for i=1:1:1000000000 if h'=$horolog set h=$horolog do  quit:q
 . if 'b set b=i
 . else  set e=i,q=1
 set t10m=(e-b)\100
 quit
;---
delay(d) ;
 new i for i=1:1:t10m*d if $horolog
 quit
;---
change ;
 set n=ne
 set ne=$random(e)+1
 set x=0,y=0,r=1
 quit
;---
new() ;
 set r=1,x=w/2-2,y=1-e(n,r)
 quit:$quit $$collision(r,y,x) quit
;---
drop ;
 new i
 set i=0 for  quit:$$fall  set i=i+2
 do score(i)
 quit
;---
rotate ;
 new k
 set k=r#e(n)+1
 quit:$$collision(k,y,x)
 set r=k
 quit
;---
fall(k) ;
 new c
 if $$collision(r,y+1,x) quit:$quit 1 quit
 set y=y+1
 do:$get(k) score(1)
 quit:$quit 0 quit
;---
right quit:$$collision(r,y,x+1)  set x=x+1 quit
;---
left quit:$$collision(r,y,x-1)  set x=x-1 quit
;---
collision(r,y,x) ;
 new i,j,q
 set q=0
 for i=1:1:4 quit:q  for j=1:1:4 quit:q  set:$get(e(n,r,j,i))&($get(n(y+j,x+i))!(y+j>h!(x+i>w!(x+i<1)))) q=1
 quit q
;---
lock ;
 new i,j
 for i=1:1:4 quit:q  for j=1:1:4 quit:q  set:$get(e(n,r,j,i)) n(y+j,x+i)=1
 quit
;---
clear ;
 new c,i,j,q
 set c=0
 for j=h:-1:1 do
 . set q=0
 . for i=1:1:w if '$get(n(j,i)) set q=1 quit
 . quit:q
 . for i=j:-1:1 kill n(i) m n(i)=n(i-1)
 . set j=j+1,c=c+1
 . do redraw
 if c do
 . do score($select(c=4:800,1:i*200-100*lv))
 . set lc=lc+c
 . if lv*10'>lc do score(,1) set lc=0
 quit
;---
exit ;
 new s
 set s=mt_"09  Piotr Koper <piotr.koper@gmail.com>09 8 h2tps:2/github.com/pkoper"
 do cls do write(.s,dh/2-3,dw/2-24) hang 1 read *s:0 read *s:4
 do cls use $principal:"echo"
 quit
;---
intro ;
 new s
 set s=mt_"9 9 8 Mumtris for Reference Standard M (RSM)0"
 do cls hang 1 do write(.s,dh/2-3,dw/2-24) hang 1
 do ticks
 do cls
 read s:0
 quit
;---
cls ;
 do pos(0,0,1)
 quit
;---
pos(y,x,c) ;
 if ansi do
 . ; Workaround for ANSI driver: NL in some safe place (1,1)
 . write $char(27)_"[1;1f",!,$char(27)_"["_(y+1)_";"_(x+1)_"f"
 . write:$get(c) $char(27)_"[2J"
 else  do
 . ; NOTE: x and y are not implemented
 . ;use $principal:(x=x:y=y)
 . ; NOTE: clearscreen is not implemented
 . ;use:$get(c) $principal:clearscreen
 .  use:$get(c) $principal write #
 quit
;---
over ;
 new s
 set s="2 8_9 9 6 8_0 /2 5_/5_4 5_3 4_3 \5_2 \3_2 2_ 9_2_0/3 \2 3_\2_2 \2 /5 \_/ 2_ \3 /3 |3 \2 \/ 2/ 2_ \_2 2_ \0\4 \_\2 \/ 2_ \|2"
 set s=s_" Y Y2 \2 3_/2 /4 |4 \3 /\2 3_/|2 | \/0 \6_2 (4_2 /2_|_|2 /\3_2 > \7_2 /\_/2 \3_2 >2_|08 \/5 \/6 \/5 \/9  \/9  \/0"
 do cls do write(.s,dh/2-3,dw/2-32) hang 1 read *s:0 read *s:2
 quit
;---
write(s,y,x) ;
 new i,j,l,c,d
 do pos(y,x)
 set l=$l(s) for i=1:1:l do
 . set c=$e(s,i)
 . if c?1N do
 . . if 'c set y=y+1 do pos(y,x) quit
 . . set d=$e(s,i+1) for j=1:1:c write d
 . . set i=i+1
 . else  write c
 do pos(0,0)
 quit
;---
help ;
 new i,x,l,j
 set i=9
 for x="MOVE: LEFT, RIGHT","TURN: UP","DROP: SPACE","","FILL: F","GRID: G","HELP: H","","QUIT: ESC, Q" do
 . set i=i+1 do pos(dh/2-(h/2)+i,dw/2+(3*w/2+3)) do
 . . if hl write x
 . . else  set l=$l(x) for j=1:1:l write " "
 quit
;---
fill() quit $select(fl=1:"[#]",fl=2:"[+]",1:"[ ]")
;---
draw(n,r,y,x,o) ;
 new i,j
 set x=3*x+mx+1,y=y+my
 for i=1:1:4 if y+i>my for j=1:1:4 write $select($get(e(n,r,i,j)):$$fill,$get(o):"   ",1:"")
 ;;f i=1:1:4 i y+i>my use $p:y=y+i-1 f j=1:1:4 u $p:(x=3*(j-1)+x) w $s($g(e(n,r,i,j)):$$fill,$g(o):"   ",1:"")
 ;;                   ^^^^^^^^^^^^^^ what does that mean?
 quit
;---
step() quit 0.85**lv*sb+(0.1*lv)
;---
score(s,l) ;
 set:$get(s) sc=sc+s
 if $get(l) set lv=lv+l,st=$$step
 do pos(dh/2-(h/2)+2,dw/2+(3*w/2+3)) write "SCORE: ",sc
 do pos(dh/2-(h/2)+3,dw/2+(3*w/2+3)) write "LEVEL: ",lv
 quit
;---
preview ;
 do draw(ne,1,3,-5,1)
 quit
;---
stack ;
 new i,j,x,y
 set x=mx+1,y=my
 for i=1:1:h for j=1:1:w if $get(n(i,j)) do pos(y+i-1,3*(j-1)+x) write $$fill
 quit
;---
matrix ;
 new i,j
 for i=0:1:h-1 do
 . do pos(my+i,mx) write "|" for j=1:1:w write $select(gr:" . ",1:"   ")
 . write "|"
 do pos(my+h,mx) write "|" for j=1:1:w*3 write "~"
 write "|",!
 quit
;---
dev ;
 new size
 set size=$&e($&%spawn("stty size",1),"c")
 set dh=$p(size," "),dw=$p(size," ",2)
 quit
;---
elements ;
 ; e - elements
 ; e(elemId) - rotateVersions
 ; e(elemId,rotateVersion) - bottom coordinate
 ; e(elemId,rotateVersion,y,x) - point
 set e=7
 ; ____
 set e(1)=2,e(1,1)=2
 set (e(1,1,2,1),e(1,1,2,2),e(1,1,2,3),e(1,1,2,4))=1
 set (e(1,2,1,2),e(1,2,2,2),e(1,2,3,2),e(1,2,4,2))=1
 ; |__
 set e(2)=4,e(2,1)=2
 set (e(2,1,1,1),e(2,1,2,1),e(2,1,2,2),e(2,1,2,3))=1
 set (e(2,2,1,2),e(2,2,1,3),e(2,2,2,2),e(2,2,3,2))=1
 set (e(2,3,2,1),e(2,3,2,2),e(2,3,2,3),e(2,3,3,3))=1
 set (e(2,4,1,2),e(2,4,2,2),e(2,4,3,1),e(2,4,3,2))=1
 ; __|
 set e(3)=4,e(3,1)=2
 set (e(3,1,1,3),e(3,1,2,1),e(3,1,2,2),e(3,1,2,3))=1
 set (e(3,2,1,2),e(3,2,2,2),e(3,2,3,2),e(3,2,3,3))=1
 set (e(3,3,2,1),e(3,3,2,2),e(3,3,2,3),e(3,3,3,1))=1
 set (e(3,4,1,1),e(3,4,1,2),e(3,4,2,2),e(3,4,3,2))=1
 ; ||
 set e(4)=1,e(4,1)=2
 set (e(4,1,1,1),e(4,1,1,2),e(4,1,2,1),e(4,1,2,2))=1
 ; _-
 set e(5)=2,e(5,1)=3
 set (e(5,1,2,2),e(5,1,2,3),e(5,1,3,1),e(5,1,3,2))=1
 set (e(5,2,1,2),e(5,2,2,2),e(5,2,2,3),e(5,2,3,3))=1
 ; _|_
 set e(6)=4,e(6,1)=2
 set (e(6,1,1,2),e(6,1,2,1),e(6,1,2,2),e(6,1,2,3))=1
 set (e(6,2,1,2),e(6,2,2,2),e(6,2,2,3),e(6,2,3,2))=1
 set (e(6,3,2,1),e(6,3,2,2),e(6,3,2,3),e(6,3,3,2))=1
 set (e(6,4,1,2),e(6,4,2,1),e(6,4,2,2),e(6,4,3,2))=1
 ; -_
 set e(7)=2,e(7,1)=3
 set (e(7,1,2,1),e(7,1,2,2),e(7,1,3,2),e(7,1,3,3))=1
 set (e(7,2,1,2),e(7,2,2,1),e(7,2,2,2),e(7,2,3,1))=1
 quit

SSD
SSD ; Shutdown
 new vol set vol=""
 for  set vol=$order(^$system("vol",vol),-1) quit:vol=""  write ! do
 . set ^$system("vol",vol,"writelock")=1 write "Writelocking the database for volume "_vol
 . for  write "." quit:^$system("vol",vol,"writelock")>0  hang 1
 write !,"Shutting Down.",! kill ^$job halt

UCI
UCI ; WAA-This routine will be for UCI management. 5/30/00
 ; It will allow the developer to create, edit, and delete UCIs.
 ; It will also display existiing UCIs
 new enter,menu,opt
;---
ENT do MNUDSP
 read !,?10,"Enter Option: ",enter quit:enter=""
 if enter'?1N write !,"ENTER THE NUMBER OF THE MENU OPTION...",*7 goto ENT
 if '$data(menu(enter)) write !,"INVALID OPTION...",*7 goto ENT
 set opt=$piece(menu(enter),";",4) xecute opt goto ENT
 quit
;---
MNUDSP ; Display menu
 new x
 set x=1
 write !,"UCI Management...",!
 for  set menu=$text(MENU+x) quit:$piece(menu,";",3)=""  set menu(x)=menu,x=x+1 do
 . write !,?20,$piece(menu,";",3)
 . quit
 quit
;---
CREAT ; Create a UCI but not UCI 1 (manager)
 new nuci,x,flg,vol,uci
 set vol=^$job($job,"global_vol"),uci=""
 do DISP("Create a UCI...",.vol,.uci)
;---
CR1 ; Prompt
 read !!,"Enter new UCI name: ",nuci quit:nuci=""
 if $get(^$system("name_length"),8)=32,nuci'?1.32A write !,"INVALID UCI NAME??",*7 goto CR1
 else  if $get(^$system("name_length"),8)=8,nuci'?1.8A write !,"INVALID UCI NAME??",*7 goto CR1
 set (x,flg)=0
 for  set x=$order(uci(x)) quit:x=""  if uci(x)=nuci write !,"CAN NOT NAME UCI THE SAME AS EXISTING UCI.",*7 set flg=1 quit
 if flg goto CR1
 for uci=2:1:63 if ^$system("vol",vol,"uci",uci)="" set ^$system("vol",vol,"uci",uci)=nuci write !,nuci," has been created..." quit
 do LIST^UCI
 quit
;---
EDIT ; Edit an existing UCI but not UCI 1 (manager)
 new head,ouci,nuci,vol,uci,x,y
 set vol=^$job($job,"global_vol"),uci=""
 do DISP("Rename a UCI...",.vol,.uci)
;---
ED1 ; Edit prompt
 read !,"Select UCI to Edit: ",ouci quit:ouci=""
 if '$data(uci(ouci)) write !,"INVALID UCI??",*7 goto ED1
 if +ouci=0 set ouci=uci(ouci)
;---
ED2 ; Edit Prompt
 read !,"Enter New UCI Name: ",nuci
 if $get(^$system("name_length"),8)=32,nuci'?1.32A write !,"BAD UCI NAME??",*7 goto ED2
 if $get(^$system("name_length"),8)=8,nuci'?1.8A write !,"BAD UCI NAME??",*7 goto ED2
 if $data(uci(nuci)) write !,"CANNOT USE NAME UCI ",nuci," ALREADY EXISTS??",*7 goto ED2
 set ^$system("vol",vol,"uci",ouci)=nuci write !,ouci," has been renamed to ",nuci,"..."
 do LIST
 quit
;---
DELETE ; Delete an existing UCI but not UCI 1 (manager)
 new duci,vol,uci
 set vol=^$job($job,"global_vol"),uci=""
 do DISP("Delete a UCI...",.vol,.uci)
;---
DE1 ; Select Prompt
 read !,"Select UCI to DELETE: ",duci quit:duci=""
 if '$data(uci(duci)) write !,"INVALID UCI??",*7 goto DE1
 if +duci=0 set duci=uci(duci)
 if uci(duci)=^$system("vol",vol,"uci",1) write !,"CANNOT DELETE UCI 1 (MANAGER) ["_uci(duci)_"]",*7 goto DE1
 kill ^$system("vol",vol,"uci",duci)
 do LIST
 quit
;---
DISP(head,vol,uci) ; Generic display of UCI
 new x,z
 if head="" quit
 if vol="" set vol=^$job($job,"global_vol")
 set uci=""
 write !,head
 do LIST
 do GET(vol,.uci)
 set x=0 for  set x=$order(uci(x)) quit:x=""  set z=uci(x),uci(z)=x
 quit
;---
LIST ; List all UCIs within a volume set
 new vol,uci,x
 set vol=^$job($job,"global_vol"),uci=""
 write !,"User Class Identifiers [UCI] within the Volume set: ",^$system("vol",vol,"name")
 write !,?10,"UCI#",?40,"UCI"
 write !,?10,"----",?40,"---"
 do GET(vol,.uci)
 set x=0 for  set x=$order(uci(x)) quit:x=""  write !,?10,x,?40,uci(x)
 quit
;---
GET(vol,uci) ; Build an array of all the UCIs within the volume set
 new x
 if vol'>0 quit
 set (x,uci)=0
 for  set x=$order(^$system("vol",vol,"uci",x)) quit:x=""  set uci=x,uci(x)=^$system("vol",vol,"uci",x)
 quit
;---
MENU ; Menu list
 ;;1) List UCI;D LIST
 ;;2) Create UCI;D CREAT
 ;;3) Edit UCI;D EDIT
 ;;4) Delete UCI;D DELETE
 ;;


; Package: Reference Standard M
; File:    rsm/utils.rsm
; Summary: Impementation of the M Language and Database System
;
; David Wicksell <dlw@linux.com>
; Copyright © 2020-2024 Fourth Watch Software LC
; https://gitlab.com/Reference-Standard-M/rsm
;
; Based on MUMPS V1 by Raymond Douglas Newman
; Copyright © 1999-2018
; https://gitlab.com/Reference-Standard-M/mumpsv1
;
; This program is free software: you can redistribute it and/or modify it
; under the terms of the GNU Affero General Public License (AGPL) as
; published by the Free Software Foundation, either version 3 of the
; License, or (at your option) any later version.
;
; This program is distributed in the hope that it will be useful, but
; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General Public
; License for more details.
;
; You should have received a copy of the GNU Affero General Public License
; along with this program. If not, see https://www.gnu.org/licenses/.
;
; SPDX-FileCopyrightText:  © 2020 David Wicksell <dlw@linux.com>
; SPDX-License-Identifier: AGPL-3.0-or-later
