22-Nov-94  4:37 PM
Saved by ^%DAUROED from environment DSMMGR
COPYSET
COPYSET	;GFSALLEE,COPYSET,GL,GL;22-Nov-94  4:37 PM;Copy an array and set the copy to a specified value
	;DASL;N;GL
	;; Ver.X94B2201 ; UTILSAL;; 22-NOV-1994
	; Gary Frank Sallee 17-Jun-1994 voice (714) 970-2864
	; 19912 Fernglen Dr., Yorba Linda, CA 92686-6014
	; A copyright is not stated nor implied by the above.
	; This routine is free. Use at your discretion and at your risk.
	;
	; This routine will COPY all or part of a local or global array to
	; a partially defined or whole global or local array.
	;
	; A substitution string may be defined for the data in the nodes.
	;
	; COPYSET may be run either as an interactive or a callable routine.
	;
	; The input for SOURCE and DEST are checked. This routine will Remove
	; <SPACE>s, duplicate <COMMA>s and trailing <COMMA>s, then add a right
	; parenthesis if needed. The SOURCE is checked for existence as a
	; global and a local array. If both exist, you are informed. If only
	; one exists, then the existing array is chosen and you are informed.
	; The DEST is checked for existence, and you are warned.
	;
	; The substitution VALUE will be ignored if both the argument and the
	; keyboard inputs are null. The array data will be moved. If the VALUE
	; is specified as an argument or a keyboard input, then VALUE is set
	; into any node that has data in the SOURCE array.
	;
	; A	General Answer string. Mostly Yes or No.
	; A1	General Answer string. Working variable
	; A2	General Answer string. Working variable
	; B	Branch indirection label
	; BA	Flag to throttle output for batch mode (internal)
	; BATCH	Flag to throttle output for batch mode (external)
	; C	Flag to Confirm message for each node copies (internal)
	; CONF	Flag to Confirm message for each node copies (external)
	; D	Destination array name (internal)
	; DEST	Destination array name (external)
	; D1	Modification of Destination array name
	; D2	Modification of Destination array name
	; D3	Modification of Destination array name
	; D3F	Flag for Destination subscripting
	; DTIME	Delay time for read time-outs. (external)
	; DTYME	Delay time for read time-outs. (internal) Default 60sec.
	; I	Integer variable used locally and reused later
	; LD	Length of Destination array name
	; LD1	Length + 1 of Destination array name
	; LS	Length of Source array name
	; LS1	Length + 1 of Source array name
	; LS2	Length + 2 of Source array name
	; T	Flag for Terminal (Not batch) type of input and output
	; S	Source array name (internal)
	; SOURCE Source array name (external)
	; S1	Modification of Source array name
	; S2	Modification of Source array name
	; S3	Modification of Source array name
	; S3L	Length of source name with partial subscripts, for finish test
	; T	Flag indicates terminal output, not batch
	; V	Value to set the the copy equal to (internal)
	; VALUE Value to set the the copy equal to (external)
	;
	;COPYSET ;Copy an array and set the copy to a specified value  page 02
	;
	;   This COPYSET routine mostly replaces the Copy (^%GC) utility.
	;   COPYSET will deal with both local and global arrays.
	;   COPYSET attempts to correct some typographical input errors, 
	; i.e. double commas, missing right parenthesis, and imbedded spaces.
	;
	; The pass-in arguments are six variable names listed below:
	;
	; To set a default DEST, 		SET DEST=destination arrayname
	; To set a default SOURCE,		SET SOURCE=source array name
	; To set a default substitute VALUE,	SET VALUE=substitute value
	; To inhibit terminal confirming messages, SET CONF=0
	; To inhibit all terminal interaction, 	SET BATCH=1
	;   The above variables will be left unchanged by the routine.
	;
	;   Some variables are allowed to be passed into this COPY: BATCH,
	; CONF(irm), DTIME, DEST(ination), and SOURCE. 
	;   There is no subroutining in this COPY. This routine would be half
	; the length, and would be much easier to maintain with subroutines.
	;   There should be an error flag passed out of the routine.
	;   There is no wild carding of superior subscripts. This would be a
	; handy feature.
	;   There is no "^" escape.
	;   There is no Clear Field key or command for default arguments.
	;   There is no (?) Help. There should be Help.
	;   There is no error trapping. There should be error trapping. 
	;   The error messages are not in standard format. The messages should
	; be in standard format.
	;
        ; Caution is advised if your intent is to use the same global for the
        ; SOURCE and the DESTination. If you add to the upper end of the 
        ; global array, even a little, then you will form an endless routine
        ; loop that will add subscripts until memory is exhausted.
	;
	;COPYSET ;Copy an array and set the copy to a specified value  page 03
	;
	; EXAMPLE of COPYSET routine run interactively
	;
	; ODD>D ^COPYSET
	; 
	; You may COPY all or part of a global or local array.
	; You may optionally SET all data nodes to a specified value.
	; The following questions will ask for necessary information.
	; 
	; SOURCE array name?  TMP8(4,"X"
	; 
	; TMP8(4,"X") does exist.
	; 
	; DESTINATION array name?  TMP8("Y","X",4
	; This TMP8("Y","X",4) is not a ^ global array.
	; Should I use ^TMP8("Y","X",4)? (Y/N) [No]:
	; 
	; SET VALUE for data?
	; 
	;  Substitute SET VALUE:  There is no data substitution. I will copy source data.
	;       SOURCE array: TMP8(4,"X")
	;  DESTINATION array: TMP8("Y","X",4)
	; 
	; Do you want to change anything? (Y/N) [No]:
	; ?COPY-I-SET TMP8("Y","X",4,6)=TMP8(4,"X",6)
	; 
	; ?COPY-I-SET TMP8("Y","X",4,6,1)=TMP8(4,"X",6,1)
	; ?COPY-I-SET TMP8("Y","X",4,6,2)=TMP8(4,"X",6,2)
	; ?COPY-I-SET TMP8("Y","X",4,6,4)=TMP8(4,"X",6,4)
	; COPYSET is finished.
	; The COPYSET utility thanks you.  Good bye.
	; 
	; ODD>ZW
	; TMP8(4,"X",6)=33
	; TMP8(4,"X",6,1)=22
	; TMP8(4,"X",6,2)=44
	; TMP8(4,"X",6,4)=33
	; TMP8("Y","X",4,6)=33
	; TMP8("Y","X",4,6,1)=22
	; TMP8("Y","X",4,6,2)=44
	; TMP8("Y","X",4,6,4)=33
	; 
	; ODD>
	;
	;COPYSET ;Copy an array and set the copy to a specified value   page 04
	NEW A,A1,A2,B,BA,C,D,D1,D2,D3,D3F,DTYME,E1,I,I2
	NEW LD,LD1,LS,LS1,LS2,MER,MIN,S,S1,S2,S3,S3L,T,V
	SET BA=0,C=1,T=1,DTYME=60 ; Init strings, flags, time-out
	SET (A,D,LS,S,V)="",B="COPY99" ; Initialize branch to exit routine.
	;
	I ($D(BATCH)#10) S BA=BATCH ; If BATCH exists, set BA.
	I ($D(CONF)#10) S C=CONF ; If CONF(irm) exists, set C.
	I ($D(DEST)#10) S D=DEST ; If DEST(ination) exists, set D.
	I ($D(DTIME)#10) S DTYME=DTIME ; If DTIME exists, set DTYME.
	I ($D(SOURCE)#10) S S=SOURCE ; If SOURCE exists, set S.
	I ($D(VALUE)#10) S V=VALUE ; If VALUE exists, set V.
	S:(BA) BA=1,T=0,C=0 ; Flags for Batch, Terminal, Confirm
	S MIN="?COPY-I-",MER="?COPY-E-"
COPY02	;
	S A=""
	G:('T) COPY03 ; If BATCH (not Terminal), then skip input routine
	W:(T) !,"You may COPY all or part of a global or local array."
	W:(T) !,"You may optionally SET all data nodes to a specified value."
	W:(T) !,"The following questions will ask for necessary information."
	W:(T) !!,"SOURCE array name? ",S," "
	R:(T) A:(DTYME) I ('$T) G COPY99 ; Exit if timeout.
COPY03	;
	I (A="")&(S="") G COPY99 ; Exit if <RETURN> and no source defined.
	S:(A="") A=S ; Test S if A is blank.
	;
	; Remove <SPACE>s, duplicate <COMMA>s and trailing <COMMA>s
	F  S I=$F(A," ") Q:(I<2)  S I2=I-2,A1=$E(A,I,999),A=$E(A,1,I2)_A1
	F  S I=$F(A,",,") Q:(I<3)  S I=I-1,I2=I-2,A1=$E(A,I,999),A=$E(A,1,I2)_A1
	; Add trailing ")", if necessary.
	S A1=$E(A,$L(A)) I ($F(A,"(")>0)&(A1'=")") S A=A_")"
	F  S I=$F(A,",)") Q:(I<3)  S I=I-1,I2=I-2,A1=$E(A,I,999),A=$E(A,1,I2)_A1
	; F  S I=$L(A) S A1=$E(A,I) Q:(A1'=",")!(A="")  S A=$E(A,1,(I-1))
	;
	I (A="") G COPY99 ; Exit if <RETURN> and no source defined.
	; Output message existence of A and ^A
	S B="COPY06"
	I ($D(@A)) W:(T) !!,A," does exist."
	I ('$T) W:(T) !!,A," does not exist." D  G @B
	. I ($E(A,1,1)'="^") S A="^"_A D  
	. . I ($D(@A)) W:(T) !,A," does exist."
	. . I '($D(@A)) W:(T) !,A," does not exist." S B="COPY02" S:('T) B="COPY99"
COPY06	;
	; Ask if ^A should be used for source
	S B="COPY08" S S=A G:(T) COPY10
	I ($E(A,1,1)'="^") S A="^"_S I ($D(@A)) DO  G @B
	. W:(T) !!,"This ",S," is not a ^ global array.",!,"Should I use ^",S,"? "
	. R:(T) "(Y/N) [No]: ",A:(DTYME) I '($T) S B="COPY99" G COPY07 ; Exit timeout
	. S A=$E(A,1,1) I (A="Y")!(A="y") S S="^"_S
COPY07	. ;
COPY08	;
	; Display source name
	W:(T) !,"      SOURCE array: ",S
COPY10	;
	; Double check existence for predefined source
	I '($D(@S)) W:(T) !,S," does not exist",! S S="ERRCOPY10" G COPY02:(T),COPY99:('T)
	S A=""
	I ('T) G COPY13 ; If BATCH (not Terminal) then skip input routine	
COPY12	;
	W:(T) !!,"DESTINATION array name? ",D," "
	R:(T) A:(DTYME) I '($T) G COPY99 ; Exit if Timeout
COPY13	;
	I (A="")&(D="") G COPY99 ; Exit if <RETURN> and no destination defined
	S:(A="") A=D ; Test D if A is blank.
COPY15	;
	;
	; Remove <SPACE>s, duplicate <COMMA>s and trailing <COMMA>s
	F  S I=$F(A," ") Q:(I<2)  S I2=I-2,A1=$E(A,I,999),A=$E(A,1,I2)_A1
	F  S I=$F(A,",,") Q:(I<3)  S I=I-1,I2=I-2,A1=$E(A,I,999),A=$E(A,1,I2)_A1
	; Add trailing ")", if necessary.
	S A1=$E(A,$L(A)) I ($F(A,"(")>0)&(A1'=")") S A=A_")"
	F  S I=$F(A,",)") Q:(I<3)  S I=I-1,I2=I-2,A1=$E(A,I,999),A=$E(A,1,I2)_A1
	; F  S I=$L(A) S A1=$E(A,I) Q:(A1'=",")!(A="")  S A=$E(A,1,(I-1))
	I (A="")&(D="") G COPY99 ; Exit if <RETURN> and no destination defined
	G:('T) COPY16
	;
	; Output message existence of ^A
	I ($D(@A)) W:(T) !!,A," exists." S B="COPY16" D  G @B
	. I ($E(A,1,1)'="^") S A1="^"_A D  
	.. I ($D(@A1)) W:(T) !!,A1," exists.",!
COPY16	;
	; Ask if you want ^A for destination
	S D=A
	I ('T) G COPY30 ; If BATCH (not Terminal) then skip input routine	
	I ($E(D,1,1)'="^") S D1="^"_D I (D1'=S) S B="COPY18" DO  G @B
	. W:(T) !,"This ",D," is not a ^ global array.",!,"Should I use ",D1,"? "
	. R:(T) "(Y/N) [No]: ",A:(DTYME) I '($T) S B="COPY99" G COPY17 ; Exit timeout
	. S A=$E(A,1,1) I (A="Y")!(A="y") S D=D1 S B="COPY18"
COPY17	. ;
COPY18	;
	W:(T) !!,"SET VALUE for data? ",V," "
	R:(T) A:(DTYME) I '($T) G COPY99 ; Exit if Timeout
	S:(A'="") V=A W:(C) !!," Substitute SET VALUE: ",V
	W:(V="")&(C) " There is no data substitution. I will copy source data."
COPY20	;
	; Are you sure for source and for destination?
	I ('T) G COPY30 ; If BATCH (not Terminal) TCH then skip input routine	
	W:(C) !,"      SOURCE array: ",S
	; Display destination name
	W:(C) !," DESTINATION array: ",D
	W:(C) !!,"Do you want to change anything? "
	R:(C) "(Y/N) [No]: ",A:(DTYME) I '($T) G COPY99 ; Exit if timeout
	S A=$E(A,1,1) I (A="Y")!(A="y") G COPY02
COPY30	;
	; Does the source have parenthesis, or keys?
	S S1=S,S2=S,S3="",S3L=0 ; Reset Source string variables
	S A1=$F(S,"("),A2=$F(S,")",A1) ; Find position of parenthesis
	;	W:(T) !,"Source parenthesis: ",A1,", ",A2
	I '(A1)&'(A2) G COPY50 ; No keys in source.
	I '(A1)!'(A2) W:(T) !,"Defective parenthesis ",S G COPY99
	S S3=$E(S,1,$L(S)-1),S3L=$L(S3)
COPY40	;
	; Section 40 intentionally left blank
COPY50	;
	; Does the destination have parenthesis, or keys?
	S D1=D,D2=D,D3="",D3F=0 ; Reset destination string variables
	S A1=$F(D,"("),A2=$F(D,")",A1) ; Find position of parenthesis
	;	W:(T) !,"Destination parenthesis: ",A1,", ",A2
	I '(A1)&'(A2) G COPY60 ; No keys in destination.
	I '(A1)!'(A2) W:(T) !,"Defective parenthesis ",S G COPY99
	; Check for ^ at first character only
	S D1=$P(D1,"(",1) S I=$F(D1,"^",2) I ($E(D,1)="^") S D1=$E(D,2,999)
	I ($F(D1,"^")>0) W:(T) !,"^ should be at first character only",D G COPY99
	I ($F(D1,"%",2)>0) W:(T) !,"% should be at first character only",D G COPY99
	I ($L($P(D1,"(",1))>8) D  
	. S E1=1 W:(T) !,"Warning - Name longer than 8 characters ",D
	I (A2'=($L(D)+1)) W:(T) !,"Right parenthesis should be at end ",D G COPY99
	S D3=$E(D,1,$L(D)-1)_",",D3F=1
COPY60	;
	; Initial COPY to get first node
	;	W:(T) !,"($D(@S)#10)=",($D(@S)#10)," S=",S
	I ($D(@S)#10) DO
	. I V'="" S @D=V W:(C) !!,MIN,"SET ",D,"=",V
	. I V="" S @D=@S W:(C) !!,MIN,"SET ",D,"=",S
	S LS=$L(S),LS1=LS+1,LS2=LS+2,LD=$L(D),LD1=LD+1,S1=S
	I (D3F&S3L) G COPY90 ; Both subscripted
	I (D3F) G COPY80 ; Only destination subscripted
	I (S3L) G COPY70 ; Only source subscripted
	; Continue if neither source nor destination is subscripted
COPY61	;
	; COPY to completion for no-subscript source, no-subscript destination
	S S1=S_"("""")"
	F  S S1=$Q(@S1) Q:(S1="")  DO  
	. S S2=$E(S1,LS1,999) S D1=D_S2
	. I '($D(@S1)#10) W:(T) !,S1," Source node has no value" G COPY68
	. I ($D(@S1)#10) DO
	. . I V'="" S @D1=V W:(C) !,MIN,"SET ",D1,"=",V
	. . I V="" S @D1=@S1 W:(C) !,MIN,"SET ",D1,"=",S1
COPY68	. ;
	G COPY97
COPY70	;
	; W:(T) !,"Subscripted source, No-subscript destination"
	; COPY to completion for subscripted source, no-subscript destination
COPY72	;
	F  S S1=$Q(@S1) Q:(S1="")!($E(S1,1,S3L)'=S3)  DO  
	. I '($D(@S1)#10) W:(T) !,S1," Source node has no value"
	. I ($E(S1,LS)'=",") D  
	. . W:(T) !,"source name error. ",LS," character of "
	. . W:(T) S1," is ",$E(S1,LS)," should be comma "","" ."
	. S S2="("_$E(S1,LS1,999) S D1=D_S2
	. I ($D(@S1)#10) DO
	. . I V'="" S @D1=V W:(C) !,MIN,"SET ",D1,"=",V
	. . I V="" S @D1=@S1 W:(C) !,MIN,"SET ",D1,"=",S1
COPY78	. ;
	G COPY97
COPY80	;
	; W:(T) !,"No-subscript source, Subscripted destination"
	; COPY to completion for no-subscript source, subscripted destination
	F  S S1=$Q(@S1) Q:(S1="")  DO  
	. S S2=$E(S1,LS2,999) S D1=D3_S2
	. I '($D(@S1)#10) W:(T) !,S1," Source node has no value" G COPY68
	. I ($D(@S1)#10) DO
	. . I V'="" S @D1=V W:(C) !,MIN,"SET ",D1,"=",V
	. . I V="" S @D1=@S1 W:(C) !,MIN,"SET ",D1,"=",S1
	G COPY97
COPY90	;
	; COPY to completion for subscripted source, subscripted destination
	; W:(T) !,"Subscript source, Subscript destination"
	F  S S1=$Q(@S1) Q:(S1="")!($E(S1,1,S3L)'=S3)  DO  
	. S S2=$E(S1,LS1,999) S D1=D3_S2
	. I '($D(@S1)#10) W !,S1," Source node has no value"
	. I ($E(S1,LS)'=",") D  
	. . W !,"source name error. ",LS," character of "
	. . W S1," is ",$E(S1,LS)," should be comma "",""."
	. S D2=D1_$E(S1,LS)
	. I ($D(@S1)#10) DO
	. . I V'="" S @D1=V W:(C) !,MIN,"SET ",D1,"=",V
	. . I V="" S @D1=@S1 W:(C) !,MIN,"SET ",D1,"=",S1
COPY97	;
	W:(T) !,"COPYSET is finished." G COPY99
COPY99	;
	W:(T) !,"The COPYSET utility thanks you.  Good bye.",!
	Q