cQXLINF1	; Convenience subroutines for global translation ; HYY363 10/05/99  ; Compiled January 3, 2006 13:43:48  ; Compiled April 18, 2007 14:10:12
	; +--------------------------------------------------------+
	; | Copyright 1986-2005 by InterSystems Corporation,       |
	; | Cambridge, Massachusetts, U.S.A.                       |
	; | All rights reserved.                                   |
	; |                                                        |
	; | Confidential, unpublished property of InterSystems.    |
	; |                                                        |
	; | This media contains an authorized copy or copies       |
	; | of material copyrighted by InterSystems and is the     |
	; | confidential, unpublished property of InterSystems.    |
	; | This copyright notice and any other copyright notices  |
	; | included in machine readable copies must be reproduced |
	; | on all authorized copies.                              |
	; +--------------------------------------------------------+
	;%ST.INC PWC637 05/22/02
	;%system.INC ; JO1908, 4/11/08
	; %system.inc: compiled for USEDYNPIDTAB
	; %system.inc: compiled for USEDYNTTYHASH
	; %system.inc: compiled for USETTYHASH
	; GXLATE.INC DPB125 06/04/93
dheader(D)	;Subheader for a directory
	W !,$$DC("-",79),!,D Q
footer	W !,$$DC("=",79)
	i $d(repstat) d
	. w !!,?10,"[<global>] shows redirection scheme for one global;"
	. w !,?10,"[<global1>:<global2>] shows redirection scheme for a"
	. w !,?15,"range between 2 globals; a square bracket [] means that"
	. w !,?15,"left or right margin is inclusive, while a parenthesis"
	. w !,?15,"means that the margin is exclusive."
	. w !,?15,"An empty parenthesis before or after ':', that is "
	. w !,?15,"(: or :) , means that the redirection scheme is "
	. w !,?15,"effective from the start of alphabet space, or till"
	. w !,?15,"its end, respectively"
	. w !
	. w !,?15,"A subscript mapping is missing if it is the same as "
	. w !,?15,"the default mapping of the global. The default mapping"
	. w !,?15,"of a global is missing if it is the same as the default"
	. w !,?15,"global dataset."
	. w !
	W:$D(repstat("->")) !,?10,"->","  implicit"
	W:$D(repstat("+>")) !,?10,"+>","  replicated"
	W:$D(repstat("*>")) !,?10,"*>","  lock target"
	I $D(repstat("P")) D
	. W !,?10,"*U  unreachable -- at least one destination for this "
	. w "pattern is not"
	. w !,?29,"defined in the current MNET configuration."
	. W !,?29,"Any reference to this pattern will generate a"
	. W !,?29,"<NOSYS> error.",!
	I $D(repstat("R")) D
	. W !,?10,"*R  at least one replication destination for this "
	. w "pattern is not"
	. w !,?29,"defined in the current MNET configuration."
	. W !,?29,"Any reference to this pattern will generate"
	. w !,?29,"a <NOSYS> error. However replication will have"
	. w !,?29,"taken place to destinations that preceed the "
	. w !,?29,"unreachable destination when the error is"
	. w !,?29,"returned."
	Q  
	;
SLMDUMP	;
	; This entry point dumps the SLM keys for one global in raw
	; form as opposed to ^%GXLINFO which formats the data. This is
	; not a supported entry point as it may not work in the future.
	;
	s $ZT="SLMDERR"
	r !,"Namespace (return to exit)? ",nsname
	q:nsname=""
	r !,"Global (*=object code)? ^",globnam
	i globnam="*" s globnam="rOBJ"
	s nspat=$ZU(90,1,nsname,globnam)
	i 'nspat w !,"no mapping found for ^",globnam," in ",nsname g SLMDUMP
	s tabid=$ZU(90,2,8,nspat)
	i 'tabid w !,"^",globnam," is not slmapped in ",nsname g SLMDUMP
	s defdir=$ZU(90,2,3,nspat)
	i 'defdir s defdir=$ZU(90,3,1,nsname)
	s info=$ZU(90,16,tabid)
	s nument=+$P(info,"^",1)
	s colseq=+$P(info,"^",2)
	w !,"There are ",nument," entries, the collation sequence is ",colseq
	w !,"Default directory for non % globals: "
	w ^|"%SYS"|SYS("GREDIR","GINDTAB",defdir)
	w !,"Entry",?7,"Subscr pattern",?30,"Impl dest",?70,"Repl pat"
	f i=0:1:nument-1 d
	. s subscr=$ZU(90,17,tabid,i)
	. i $L(subscr)=0 s subscr="<nullstr>"
	. s dstinfo=$ZU(90,18,tabid,i)
	. s impldst=+$P(dstinfo,"^",1)
	. i impldst=0 s impldst=defdir
	. s reppat=+$P(dstinfo,"^",2)
	. s impldir=$G(^|"%SYS"|SYS("GREDIR","GINDTAB",impldst))
	. i impldir="" s impldir=impldst
	. w !,i,?7
	. f j=1:1:$L(subscr) s ch=$A($E(subscr,j)) d
	. . i ch>32,ch<127 w $C(ch) q
	. . w "<$C(",ch,")>"
	. w ?30,impldir,?75,reppat
	w !
	g SLMDUMP
SLMDERR	;
	s $ZT=""
	w !,"Error: ",$ZE," encountered - exiting"
	q
	;
showslm(d,i,rmap)	;
	q:'$d(@tran@(d,"#",i,"slm"))
	;
	s:'$d(rmap) rmap=""
	n p,first s p=@tran@(d,"#",i),first=1
	n ent,imp,n,rep,replst,sub
	;loop through slm entries
	s ent=""
	s rep=@tran@(d,"#",i,"slm",0,0,"replid")
	s imp=@tran@(d,"#",i,"slm",0,0,"implid")
	w !
	f  s ent=$o(@tran@(d,"#",i,"slm",0,ent)) q:ent=""  d  q:ent=""
	. ;get first subscript that does not have last default mapping
	. s sub(1)=@tran@(d,"#",i,"slm",0,ent,"subscript")
	. s imp(1)=@tran@(d,"#",i,"slm",0,ent,"implid")
	. s rep(1)=@tran@(d,"#",i,"slm",0,ent,"replid")
	. q:'imp(1)&'rep(1)  ;commented out until range symbols are fixed
	. ;check to see if range set up
	. s ent=$o(@tran@(d,"#",i,"slm",0,ent))
	. i ent="" s (sub(2),rep(2),imp(2))=""
	. e  d
	. . s sub(2)=@tran@(d,"#",i,"slm",0,ent,"subscript")
	. . s imp(2)=@tran@(d,"#",i,"slm",0,ent,"implid")
	. . s rep(2)=@tran@(d,"#",i,"slm",0,ent,"replid")
	. . ;i sub(2)[$c(1)!(sub(2)=sub(1)) s (sub(2),rep(2),imp(2))="" ;HYY079
	. . s ent=$o(@tran@(d,"#",i,"slm",0,ent),-1)
	.  ;display entry as close to possible as entered in by user
	. i $l(rmap) d
	. . w:$x>1 ! w "   ["_$tr(sub(1),"""") w:sub(2)'="" ":"_$tr(sub(2),"""") w ")"
	. . w:$x>23 !
	. . d:imp(1) 
	. . . w ?26,rmap
	. . . s SYSNO=$ZU(90,6,imp(1))
	. . . i SYSNO d
	. . . . S SYSNAME=""
	. . . . F  S SYSNAME=$ZU(63,2,SYSNAME) Q:(SYSNAME="")  Q:$ZU(63,0,SYSNAME)=SYSNO
	. . . . w ?36,SYSNAME
	. . . w ?56,$ZU(90,7,imp(1))
	. e  d
	. . i first,$O(@$NAME(@tran@(d,p,"R"))@(""))="",$G(@tran@(d,p,"L"))="" W "   "_$tr($p(p,":"),"[("),!
	. . s first=0
	. . W ?7,$S(sub(1)[$C(1):"(",1:"[")_"("_$P(sub(1),$C(1),1)_")"
	. . W ":"
	. . W "("_$P(sub(2),$C(1),1)_")"_$S(sub(2)[$C(1):"]",1:")")
	. . ;display data location
	. . w:$x>23 !
	. . i imp(1) d
	. . . w ?23,"->"
	. . . s SYSNO=$ZU(90,6,imp(1))
	. . . i SYSNO d
	. . . . S SYSNAME=""
	. . . . F  S SYSNAME=$ZU(63,2,SYSNAME) Q:(SYSNAME="")  Q:$ZU(63,0,SYSNAME)=SYSNO
	. . . . w ?26,SYSNAME
	. . . w ?36,$ZU(90,7,imp(1))
	. . ;get and display replication stuff
	. . i rep(1) d
	. . . k replst d repset^%GXLINFO(rep(1),"replst")
	. . . s n="" f  s n=$o(replst(n)) q:n=""  s PP="" d showpat0^%GXLINFO("+>",n)
	. . w !
	;
	q
	;getnext(nsp) returns the namespace following nsp on gxl table
	;sort of like $ORDER on namespaces
getnext(nsp)	;
	s $zt="etget"
	n entnum,ent1
	i $g(nsp)="" q $ZU(90,2,0,1)
	q $ZU(90,2,0,$ZU(90,1,nsp)+$ZU(90,0,nsp))
	;getsubmap(nsp) returns a list of global mapping patterns, delimited
	;  by ",", for namespace nsp.
	;getsubmap(nsp,glo) returns a list of SLM patterns in $LIST format
	;  for global glo in namespace nsp
getsubmap(nsp,glo)	
	s $zt="etget"
	n ent1,ent2,i
	q:$g(nsp)="" ""
	i $g(glo)="" d  q glo
	. s ent1=$ZU(90,1,nsp),ent2=$ZU(90,0,nsp)+ent1-1
	. s glo="" f i=ent1:1:ent2 s glo=glo_$ZU(90,2,1,i)_","        
	s ent1=$ZU(90,1,nsp,glo) q:ent1'>0 ""
	n slmtabid,nument
	s slmtabid=$ZU(90,2,8,ent1) q:'slmtabid ""
	s nument=$p($ZU(90,16,slmtabid),"^")
	s glo="" f i=0:1:(nument-1) s $li(glo,i+1)=$ZU(90,17,slmtabid,i)
	q glo 
	;return value is in the form of system^directory
	;getdest(nsp) returns the default global location for namespace nsp
	;getdest(nsp,glo) returns the location for ^[nsp]glo
	;getdest(nsp,glo,sub) returns the location for ^[nsp]glo(sub)    
getdest(nsp,glo,sub)	
	s $zt="etget"
	n ent1,ent2,i,dest
	q:$g(nsp)="" ""
	s dest=0 i $g(glo)="",$g(sub)="" g exit
	q:$g(glo)="" ""
	s ent1=$ZU(90,1,nsp,glo) i ent1<0 s ent1=-ent1,sub="" ;no slm for * match 
	i 'ent1
	e  i $g(sub)'="" d  i (dest'="")  ;if dest="" then we fall through as if sub=""
	. n slmtabid,slmtabhd,nument,encrule,encsub,pat
	. s slmtabid=$ZU(90,2,8,ent1) q:'slmtabid  
	. s slmtabhd=$ZU(90,16,slmtabid),nument=$p(slmtabhd,"^")
	. i $e(sub)="(",$e(sub,$l(sub))=")" s sub=$e(sub,2,$l(sub)-1)
	. s encrule=$zu(70,1,$p(slmtabhd,"^",2)),encsub=$$encodesub(sub,encrule)
	. f i=0:1 q:i=nument  s pat=$ZU(90,17,slmtabid,i) q:pat=sub  i pat]"",$e(pat,$l(pat))'=$c(1) q:$$encodesub(pat,encrule)]encsub 
	. i pat'=sub s i=i-1
	. s dest=$p($ZU(90,18,slmtabid,i),"^")
	. i 'dest s dest=$ZU(90,2,3,ent1)
	e  s dest=$s($ZU(90,2,1,ent1)=glo:$ZU(90,2,3,ent1),1:$ZU(90,2,6,ent1)) i 1
exit	i 'dest s dest=$ZU(90,3,1,nsp)
	q $zu(63,4,$ZU(90,6,dest))_"^"_$ZU(90,7,dest)
etget	
	s $zt=""
	;w $ze,!
	q ""
encodesub(sub,rule)	;encode subscripts like "d",9,"foobar" by the given rule
	n encsub,len,x,vnam,i
	s encsub="",vnam="x("_sub_")",len=$ql(vnam)
	f i=1:1:len s encsub=encsub_$zu(70,2,$qs(vnam,i),rule)_$c(0)
	q encsub
DC(c,n)	Q $TR($J("",n)," ",$E(c_" "))