23-Nov-94 12:11 PM
Saved by ^%DAUROED from environment DSMMGR
RENUM
RENUM	;GFSALLEE,GL,GLG,GL;23-Nov-94 12:11 PM;Renumber a global subscript to increment, sequential, start with 1
	;DASL;;GL
	;; Ver.X94B2301 ; UTILSAL;; 23-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 replace a specified subscript with a numeric
	; subscript that is cardinal, integer, incrementing, and starting
	; at one (1). The routine expects a subscript to exist. If there is no
	; subscript, then the routine will copy one unsubscripted node. The 
	; subscript to be removed and replaces may be numeric or literal.
	;
	; RENUM may run as an interactive or a callable routine.
	;
	; The subscripts that are higher in order than the incrementing
	; subscripts may be changed in a specified systematic way.
	; This routine will COPY all or part of a local or global array to
	; a partially defined or whole global or local array.
	;
	; 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.
	;
	;
	; 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
	;
	;RENUM ;Copy an array and set a subscript to an increment    page 02
	;
	; S	Source array name (internal)
	; SEQND	Sequence number, Destination
	; SEQNS	Sequence number, Source
	; 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
	;
	;   This RENUM routine attempts to correct some typographical input
	; errors, 
	; i.e. double commas, missing right parenthesis, and imbedded spaces.
	;
	; The pass-in arguments are five variable names listed below:
	;
	; To set a default DEST, 		SET DEST=destination arrayname
	; To set a default SOURCE,		SET SOURCE=source array name
	; 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 RENUM: BATCH,
	; CONF(irm), DTIME, DEST(ination), and SOURCE. 
	;   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. They should be.
	;
	; 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.
	;
	;RENUM ;Copy an array and set a subscript to an increment    page 03
	;
	; SAMPLE interactive run of the RENUM routine is below:
	;
	; ODD>D ^RENUM
	; 
	; You may RENUM all or part of a global or local array.
	; The following questions will ask for necessary information.
	; 
	; SOURCE array name?  TMP8
	; 
	; TMP8 does exist.
	; 
	; DESTINATION array name?  TMP9("NEW"
	; This TMP9("NEW") is not a ^ global array.
	; Should I use ^TMP9("NEW")? (Y/N) [No]:
	;       SOURCE array: TMP8
	;  DESTINATION array: TMP9("NEW")
	; 
	; Do you want to change anything? (Y/N) [No]:
	; 
	; ?RENUM-I-SET TMP9("NEW",1,"X",6)=TMP8(4,"X",6)
	; ?RENUM-I-SET TMP9("NEW",2,"X",6,1)=TMP8(4,"X",6,1)
	; ?RENUM-I-SET TMP9("NEW",3,"X",6,2)=TMP8(4,"X",6,2)
	; ?RENUM-I-SET TMP9("NEW",4,"X",6,4)=TMP8(4,"X",6,4)
	; ?RENUM-I-SET TMP9("NEW",5,"Z",1)=TMP8(5,"Z",1)
	; ?RENUM-I-SET TMP9("NEW",6,"Z",2,1)=TMP8(5,"Z",2,1)
	; ?RENUM-I-SET TMP9("NEW",7,"Z",3,2)=TMP8(5,"Z",3,2)
	; ?RENUM-I-SET TMP9("NEW",8,"Z",4,4)=TMP8(5,"Z",4,4)
	; ?RENUM-I-SET TMP9("NEW",9,"X",4,6)=TMP8("Y","X",4,6)
	; ?RENUM-I-SET TMP9("NEW",10,"X",4,6,1)=TMP8("Y","X",4,6,1)
	; ?RENUM-I-SET TMP9("NEW",11,"X",4,6,2)=TMP8("Y","X",4,6,2)
	; ?RENUM-I-SET TMP9("NEW",12,"X",4,6,4)=TMP8("Y","X",4,6,4)
	; RENUM is finished.
	; 
	; 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(5,"Z",1)=33
	; TMP8(5,"Z",2,1)=22
	; TMP8(5,"Z",3,2)=44
	; TMP8(5,"Z",4,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
	; TMP9("NEW",1,"X",6)=33
	; TMP9("NEW",2,"X",6,1)=22
	; TMP9("NEW",3,"X",6,2)=44
	; TMP9("NEW",4,"X",6,4)=33
	; TMP9("NEW",5,"Z",1)=33
	; TMP9("NEW",6,"Z",2,1)=22
	; TMP9("NEW",7,"Z",3,2)=44
	; TMP9("NEW",8,"Z",4,4)=33
	; TMP9("NEW",9,"X",4,6)=33
	; TMP9("NEW",10,"X",4,6,1)=22
	; TMP9("NEW",11,"X",4,6,2)=44
	; TMP9("NEW",12,"X",4,6,4)=33
	; 
	; ODD>
	;
	;RENUM ;Copy an array and set a subscript to an increment    page 04
	NEW A,A1,A2,B,BA,C,D,D1,D2,D3,D3F,DTYME,E1,I,I2,J,LD,LD1,LS,LS1,LS2,LS3
	NEW MER,MIN,NCOMD,NCOMS,S,SEQND,SEQNS,S1,S2,S3,S3L,T,V
	SET (BA,SEQND,SEQNS)=0,C=1,T=1,DTYME=60 ; Init strings, flags, time-out
	SET (A,D,LS,S,V)="",B="RENM99" ; 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.
	S:(BA) BA=1,T=0,C=0 ; Flags for Batch, Terminal, Confirm
	S MER="?RENUM-E-",MIN="?RENUM-I-"
RENM02	;
	S A=""
	G:('T) RENM03 ; If BATCH (not Terminal), then skip input routine
	W:(T) !,"You may RENM all or part of a global or local array."
	W:(T) !,"The following questions will ask for necessary information."
	W:(T) !!,"SOURCE array name? ",S," "
	R:(T) A:(DTYME) I ('$T) G RENM99 ; Exit if timeout.
RENM03	;
	I (A="")&(S="") G RENM99 ; 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 RENM99 ; Exit if <RETURN> and no source defined.
	; Output message existence of A and ^A
	S B="RENM06"
	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="RENM02" S:('T) B="RENM99"
RENM06	;
	; Ask if ^A should be used for source
	S B="RENM08" S S=A G:(T) RENM10
	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="RENM99" G RENM07 ; Exit timeout
	. S A=$E(A,1,1) I (A="Y")!(A="y") S S="^"_S
RENM07	. ;
RENM08	;
	; Display source name
	W:(T) !,"      SOURCE array: ",S
RENM10	;
	; Double check existence for predefined source
	I '($D(@S)) W:(T) !,S," does not exist",! S S="ERRRENM10" G RENM02:(T),RENM99:('T)
	S A=""
	I ('T) G RENM13 ; If BATCH (not Terminal) then skip input routine	
RENM12	;
	W:(T) !!,"DESTINATION array name? ",D," "
	R:(T) A:(DTYME) I '($T) G RENM99 ; Exit if Timeout
RENM13	;
	I (A="")&(D="") G RENM99 ; Exit if <RETURN> and no destination defined
	S:(A="") A=D ; Test D if A is blank.
RENM15	;
	;
	; 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 RENM99 ; Exit if <RETURN> and no destination defined
	G:('T) RENM16
	;
	; Output message existence of ^A
	I ($D(@A)) W:(T) !!,A," exists." S B="RENM16" D  G @B
	. I ($E(A,1,1)'="^") S A1="^"_A D  
	.. I ($D(@A1)) W:(T) !!,A1," exists.",!
RENM16	;
	; Ask if you want ^A for destination
	S D=A
	I ('T) G RENM30 ; If BATCH (not Terminal) then skip input routine	
	I ($E(D,1,1)'="^") S D1="^"_D I (D1'=S) S B="RENM18" 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="RENM99" G RENM17 ; Exit timeout
	. S A=$E(A,1,1) I (A="Y")!(A="y") S D=D1 S B="RENM18"
RENM17	. ;
RENM18	;
	;
RENM20	;
	; Are you sure for source and for destination?
	I ('T) G RENM30 ; If BATCH (not Terminal) then skip input routine	
	W:(C) !,"      SOURCE array: ",S
	W:(C) !," DESTINATION array: ",D ; ; Display destination name
	W:(C) !!,"Do you want to change anything? "
	R:(C) "(Y/N) [No]: ",A:(DTYME) I '($T) G RENM99 ; Exit if timeout
	S A=$E(A,1,1) I (A="Y")!(A="y") G RENM02
RENM30	;
	S J=1,NCOMS=1 ; How many commas NCOMS in the source reference name?
	F I=1:1 S J=$F(S,",",J) Q:J=0  S NCOMS=NCOMS+1
	;
	; 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 RENM50 ; No keys in source.
	I '(A1)!'(A2) W:(T) !,"Defective parenthesis ",S G RENM99
	S S3=$E(S,1,$L(S)-1),S3L=$L(S3)
RENM40	;
	; Section 40 intentionally left blank
RENM50	;
	S J=1,NCOMD=1 ; How many commas NCOMD in the destination reference?
	F I=1:1 S J=$F(S,",",J) Q:J=0  S NCOMD=NCOMD+1
	;
	; Does the destination have parenthesis, or keys?
	S (D1,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 RENM60 ; No keys in destination.
	I '(A1)!'(A2) W:(T) !,"Defective parenthesis ",S G RENM99
	; 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 RENM99
	I ($F(D1,"%",2)>0) W:(T) !,"% should be at first character only",D G RENM99
	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 RENM99
	S D3=$E(D,1,$L(D)-1)_",",D3F=1
RENM60	;
	; Initial RENM to get first node
	;	W:(T) !,"($D(@S)#10)=",($D(@S)#10)," S=",S
	I ($D(@S)#10) DO
	. 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 RENM90 ; Both subscripted
	I (D3F) G RENM80 ; Only destination subscripted
	I (S3L) G RENM70 ; Only source subscripted
	; Continue if neither source nor destination is subscripted
RENM61	;
	; RENM to completion for no-subscript source, no-subscript destination
	S S1=S_"("""")"
	S (SEQND,SEQNS)=0
	F  S S1=$Q(@S1) Q:(S1="")  DO  
	. S S2=$E(S1,LS1,999),SEQNS=(1+S2-1),LS3=$F(S2,","),D1=S1
	. S:LS3 SEQND=SEQND+1,D1=D_"("_SEQND_","_$E(S2,LS3,999)
	. I 'LS3 S LS3=$F(S2,")") S:LS3 SEQND=SEQND+1,D1=D_"("_SEQND_")"
	. I '($D(@S1)#10) W !,MER,S1," Source node has no value"
	. I ($D(@S1)#10) DO
	. . S @D1=@S1 W:(C) !,MIN,"SET ",D1,"=",S1
RENM61	. ;
	G RENM97
RENM70	;
	; W:(T) !,"Subscripted source, No-subscript destination"
	; RENM to completion for subscripted source, no-subscript destination
	S (SEQND,SEQNS)=0
	F  S S1=$Q(@S1) Q:(S1="")!($E(S1,1,S3L)'=S3)  DO  
	. S S2=$E(S1,LS1,999),SEQNS=(1+S2-1),LS3=$F(S2,","),D1=S1
	. S:LS3 SEQND=SEQND+1,D1=D_"("_SEQND_","_$E(S2,LS3,999)
	. I 'LS3 S LS3=$F(S2,")") S:LS3 SEQND=SEQND+1,D1=D_"("_SEQND_")"
	. I '($D(@S1)#10) W !,MER,S1," Source node has no value"
	. I ($E(S1,LS)'=",") D  G RENM71
	. . W !,MER,"source name error. ",LS," character of "
	. . W S1," is ",$E(S1,LS)," should be comma "",""."
	. I ($D(@S1)#10) DO
	. . S @D1=@S1 W:(C) !,MIN,"SET ",D1,"=",S1
RENM71	. ;
	G RENM97
RENM80	;
	; W:(T) !,"No-subscript source, Subscripted destination"
	; RENM to completion for no-subscript source, subscripted destination
	S S1=S_"("""")"
	S (SEQND,SEQNS)=0
	F  S S1=$Q(@S1) Q:(S1="")  DO  
	. S S2=$E(S1,LS1,999),SEQNS=(1+S2-1),LS3=$F(S2,","),D1=S1
	. S:LS3 SEQND=SEQND+1,D1=D3_SEQND_","_$E(S2,LS3,999)
	. I 'LS3 S LS3=$F(S2,")") S:LS3 SEQND=SEQND+1,D1=D3_SEQND_")"
	. I '($D(@S1)#10) W !,MER,S1," Source node has no value"
	. I ($D(@S1)#10) DO
	. . S @D1=@S1 W:(C) !,MIN,"SET ",D1,"=",S1
RENM81	. ;
	G RENM97
RENM90	;
	; RENM to completion for subscripted source, subscripted destination
	; W:(T) !,MIN,"Subscript source, Subscript destination"
	S (SEQND,SEQNS)=0
	F  S S1=$Q(@S1) Q:(S1="")!($E(S1,1,S3L)'=S3)  DO  
	. S S2=$E(S1,LS1,999),SEQNS=(1+S2-1),LS3=$F(S2,","),D1=S1
	. S:LS3 SEQND=SEQND+1,D1=D3_SEQND_","_$E(S2,LS3,999)
	. I 'LS3 S LS3=$F(S2,")") S:LS3 SEQND=SEQND+1,D1=D3_SEQND_")"
	. I '($D(@S1)#10) W !,MER,S1," Source node has no value"
	. I ($E(S1,LS)'=",") D  G RENM91
	. . W !,MER,"source name error. ",LS," character of "
	. . W S1," is ",$E(S1,LS)," should be comma "",""."
	. I ($D(@S1)#10) DO
	. . S @D1=@S1 W:(C) !,MIN,"SET ",D1,"=",S1
RENM91	. ;
RENM97	;
	W:(T) !,"RENUM is finished." G RENM99
RENM99	;
	W:(T) !,"The RENUM utility thanks you.  Good bye.",!
	Q