cQGSET	;Select a set of globals ;cQGSET;  ; Compiled February 27, 2006 13:42:02
	;
	g VAX
	G NOIMPL Q                              ;Original main entry point
INT	D OPTIONAL("PHYSICAL",0,0,-1,0,DIRNAM) Q  ;Original INT^%GSET 
NOIMPL	D OPTIONAL("PHYSICAL",0,0,-1,0) Q       ;Warn about replicated globals
WARNIMPL	D OPTIONAL("IMPLICIT",1,1,0,0) Q        ;Warn about implicits
ALLOWALL	D OPTIONAL("IMPLICIT",1,1,1,0) Q
VAX	D OPTQUIET("IMPLICIT",0,0,0,0) Q  ; Same as VAX ^%GSET
	; %G  = # globals in the set
	; %JO = $J
	; ^UTILITY(%JO,NAME)=""
	;
	;------------------
	; Internal entry used to compile a list in another directory.
	; Call:  DIRNAM = name of directory.
SELERR	Q  ;W !,"OPTIONAL^"_$ZN_"("""_SELFROM_""", ... -- bad argument ",$ZE Q    
OPTIONAL(SELFROM,SHOWHID,ALLOWREP,ALLOWIMP,ALLOWDAT,DIRNAM,SYSNAM)	
	N %A,%B,%C,%NO,%S,ALLOW,DIRINFO,GDBLOC7K,IF,LOC,MPAT,N
	N NOIMPWARN,NOREPWARN,NOACCWARN,NODATWARN   ;User's requests
	N LIST ;List of implicit globals included
	S:$G(^[$ZU(39)]SYS("GSETQUIET"))=1 NOIMPWARN=1,NOREPWARN=1,NOACCWARN=1,NODATWARN=1
	G 1
OPTQUIET(SELFROM,SHOWHID,ALLOWREP,ALLOWIMP,ALLOWDAT,DIRNAM,SYSNAM)	
	N %A,%B,%C,%NO,%S,ALLOW,DIRINFO,GDBLOCK,IF,LOC,MPAT,N
	N NOIMPWARN,NOREPWARN,NOACCWARN,NODATWARN   ;User's requests
	N LIST ;List of implicit globals included
	S NOIMPWARN=1,NOREPWARN=1,NOACCWARN=1,NODATWARN=1
1	;
	S:'$D(DIRNAM) DIRNAM=$$defdir^%GLO($ZU(5)) S:'$D(SYSNAM) SYSNAM=$$defsys^%GLO($ZU(5))
	S NSPNAM="^"_SYSNAM_"^"_DIRNAM
	S $ZT="SELERR"
	d PHYSICAL^%GLO(SHOWHID,DIRNAM,SYSNAM)
	S $ZT=""
	S %JO=$J K ^UTILITY(%JO) S %G=0,%S=1
	S $ZT="ERR^"_$ZN,$ZE=""
	;I $$YN("All Globals","N")="N" G GLO0
	S %A="",%B=0 D MULT,REPORT(%G) Q
GLO	D REPORT(%G)
GLO0	S $ZT="ERR" R !,"Global ^",%A S $ZT="" I %A="" Q
	S %S=1 I %A?1"'".E S %S=0,%A=$E(%A,2,$L(%A))
	I $E(%A)="?" W ! DO  W ! G GLO
	. I %A'="?" DO  Q  ;list the selected globals
	. . I '%G W !,"No globals are currently selected.",! Q
	. . D SELSHOW^%GD($NAME(^UTILITY(%JO)),DIRNAM)
	. D SELMARK^%GD($NAME(^UTILITY(%JO)),DIRNAM)
	;
	I %A["-" D RANGE G GLO
	;
	IF $$HASWILDS(%A) DO WILD G GLO
	D SING G GLO
WILD	S MPAT=$$PATRN(.%A),%B=%A
	I %B="" S %B=1 ;Kludge so we start after 0 if first char is wild
	I %B]"",%B?@MPAT,$D(^[NSPNAM]UTILITY("GLO",%B)) D S
	F  S %B=$o(^[NSPNAM]UTILITY("GLO",%B)) DO  Q:%B=""
	. Q:%B=""  I $E(%B,1,$L(%A))'=%A S %B="" Q
	. I %B?@MPAT D S ;right pattern?
	Q
SING	S ALLOW=$$ALLOW(%A,0,%S) D:ALLOW ADDREM(%A,%S) S %NO='ALLOW Q
S	S ALLOW=$$ALLOW(%B,1,%S) D:ALLOW ADDREM(%B,%S) Q
ADDREM(G,ADD)	; If ADD=1 add, if ADD=0 remove.
	I 'ADD='$D(^UTILITY(%JO,G)) Q  ;If it's not a change, do nothing.
	I ADD S ^UTILITY(%JO,G)="",%G=%G+1
	I 'ADD K ^UTILITY(%JO,G) S %G=%G-1
	Q
MULT	I %B="" S %B=0
MULT1	S %B=$O(^[NSPNAM]UTILITY("GLO",%B)) Q:%B=""!($E(%B,1,$L(%A))'=%A)
	D S G MULT1
RANGE	S %B=$P(%A,"-"),%C=$P(%A,"-",2) I %B]%C W " ???" Q
	I %B="" S %B=0
	E  I $D(^[NSPNAM]UTILITY("GLO",%B)) D S
R2	S %B=$O(^[NSPNAM]UTILITY("GLO",%B)) I %B'="",%B']%C D S G R2
	Q
	;TRAILER^GDISP is matching format.  When you change this, change
	;TRAILER^GDISP (or make an INC file). 
REPORT(SELECTED)	;Report status in a uniform way
	N TOTAL,DIR 
	;W !,SELECTED," item",$E("s",SELECTED'=1)," selected from"
	;W !,^[NSPNAM]UTILITY("GLO",0,"DESCRIP")
	Q
ALLOW(G,ERRNAME,ADD)	;input context: ALLOWIMP,ALLOWREP,ALLOWDAT,DIRNAM
	I 'ADD Q 1 ;Always allow exclusion
	N ALLOW,INDIR,ISIMP,ISREP,P,R
	Q:G="" 0 ;Never allow a null string
	I G["!" Q 1 ;Always accept patterns
	S INDIR=$D(^[NSPNAM]UTILITY("GLO",G))
	S $ZT="ALLOWERR",$ZE=""
	S ISREP=($S($ZU(90,1,$ZU(5),G)>0:$ZU(90,2,2,$ZU(90,1,$ZU(5),G)),$ZU(90,1,$ZU(5),G)<0:$ZU(90,2,5,-$ZU(90,1,$ZU(5),G)),1:0)'=0),ISIMP=($S($ZU(90,1,$ZU(5),G)>0:$ZU(90,2,3,$ZU(90,1,$ZU(5),G)),$ZU(90,1,$ZU(5),G)<0:$ZU(90,2,6,-$ZU(90,1,$ZU(5),G)),1:0)'=0)
ALLOWERR	S $ZT="" S:$ZE]"" $ZE="",(ISREP,ISIMP)=0
	;I 'INDIR,'ISIMP W " does not exist " Q 0 ;Must not exist.
	I 'INDIR,'ISIMP Q 0 ;Must not exist.
	S R=$$readable(G)
	I '$$ALLOW1(R'="",ALLOWDAT,R,.NOACCWARN) Q 0
	I '$$ALLOW1($$nodata(G),ALLOWDAT,"contains no data",.NODATWARN) Q 0
	I '$$ALLOW1(ISIMP,ALLOWIMP,"is implicit",.NOIMPWARN) Q 0
	I '$$ALLOW1(ISREP,ALLOWREP,"is replicated",.NOREPWARN) Q 0
	; At this point we know it's not forbidden or rejected.
	I INDIR Q 1 ;If in directory, all done.
	I '$D(LIST(G)) S LIST=LIST+1,LIST(G)=""
	Q 1 ;Implicit and selected
ALLOW1(IS,ALLOWED,TEXT,SUPWARN)	;internal to ALLOW 
	N RESULT,PROMPT
	Q:'IS 1 Q:ALLOWED=1 1
	;I ALLOWED<0 D ALLOWE W " -- not allowed here, not included" Q 0
	I ALLOWED<0 Q 0
	I $G(SUPWARN)'="" D  Q SUPWARN ;If SUPWARN nonnull, automatic. 
	. ;D ALLOWE W " -- " W:'SUPWARN " not " W "included"
	;D ALLOWE
	S RESULT=1 ; S RESULT=$$YN("Include it anyway","N")="Y"
	I '$D(SUPWARN) D  ;If no opinion expressed yet, ask.
	. S PROMPT="Exclude" S:RESULT PROMPT="Include"
	. S PROMPT=PROMPT_" any other similar globals without asking again"
	. S SUPWARN="" ;Define it so we don't ask again
	. ;I $$YN(PROMPT,"Y")="Y" S SUPWARN=RESULT
	. S SUPWARN=RESULT
	Q RESULT
ALLOWE	Q  ;W:ERRNAME !,"^",G,?12 W " ",TEXT Q
nodata(G)	S G="^["""_NSPNAM_"""]"_G 
	S $ZT="nodataer" Q '$D(@G) ;True if G has no data
nodataer	Q 0 ;Works in above context because readable has already been checked
readable(G)	S G="^["""_NSPNAM_"""]"_G,$ZT="readno",G=$D(@G) Q "" 
	;Nonnull if G can't be read
readno	Q "is not read-accessible ("_$P($ZE,">")_"> error)"
ERR	S $ZT="",%G=0 W !,$ZE K ^UTILITY(%JO) Q
	;Uses ZPATRN itself to make the determination so the definition
	;of what's "wild" is only coded in one place
HASWILDS(SPEC)	                ;Alter nothing. Return 1 if SPEC contains wilds
	N TEMP,TAME
	S TAME=SPEC
	S TEMP=$$PATRN(.TAME) ;Get the unwilded portion, ignore return value
	Q TAME'=SPEC          ;If no wilds, UNWILDED is whole of SPEC.
	;-=-=-=-=
LJ(x,n)	Q ($E(x_$J("",n),1,n)_$E(x,n+1,$L(x))) ;left justify text to n chars
PATRN(X)	N q,i,x,c S q=0,x="" F i=1:1:$L(X) S c=$E(X,i) S:c="""" c=c_c DO
	. I "*?&#"'[c S x=x_$S(q:c,1:"1"""_c),q=1 Q  ;simple text -- no pattern
	. S x=x_$E("""",q)_$S(c="&":"1A",c="#":"1N",c="*":".E",1:"1E"),q=0 Q
	S:q x=x_"""" S X=$P($P($P($P(X,"?"),"#"),"&"),"*") Q x ;return ?@x
YN(P,D,t)	N R,X S P=$G(P),D=$E($G(D)_"?"),t=$G(t) ;ask Yes/No w/ Prompt,Default
	S D=$S("Yy"[D:"Yes => ","Nn"[D:"No => ",1:"") ;Yes, No or no default
	F  W !,P_"? "_D Read:t R:t Read:'t R DO  I "YN"[R Q  ;timed or non-timed read
	. S X=R,R=$TR($E(R_D_"?"),"yn","YN") I "YN"'[R W "  enter Yes or No, please"
	W $E($S(R="N":"No",R="Y":"Yes",1:""),$L(X)+1,3) Q R
	;
ZZ	; 27.02.2006 - 13 u 42 * Cache-r5.3.4