/* $BACKUPGROUP procedure written by Rivkah Stabiner */
/* copyright Eye Research Institute January, 1986 */
procedure(dirname);
	call erase;
	errcount = 0;
	/* make sure you really want this procedure */
	type ' ';
	type '               RS/1 DIRECTORY ARCHIVAL SYSTEM   		 ';
	type '                 (c) Eye Research Institute		 ';
	type '-----------------------------------------------------------';
	type ' ';
	type 'This procedure backs up and deletes a GROUP subdirectory';
	type ' ';
	/* if the subdirectory's name was omitted, get it now */
	set #dir to '#@';
	if nargs < 1 then
	   	do;
	type ' ';
	type '-------------------------------------------------------------';
	type ' ';
	type 'Next, is a summary of your whole RS/1 group directory tree';
	type 'You may specify any group directory you want, but:';
	type 'The name of the RS/1 directory to backup must begin with #@';
	type 'Also, it must be a valid, existing directory';
	type ' ';
	type '-------------------------------------------------------------';
	if not yesanswer ('Do you want to continue? ',true) 
		then goto exit;
		   type $groupdirtree('#@','DIRS');
	type '-------------------------------------------------------------';
	type ' ';

tryagain:	           dirname = gettext(
	 'Please give name of RS/1 directory to backup, starting with #@:  ');
		end;
	/* if the subdirectory name is valid, set the subdirectory */
	call dirtables(dirname,testname);
	if tableexists(testname) then
	   set #directory to dirname;
	else do;
		type ' ';
	   	type "Not a valid sub-directory name.";
		errcount = errcount + 1;
		strikevar = cat("...and it's ",errcount,"...");
		type strikevar;
		if errcount = 3 then 
		   do;
			type "strikes, you're out!";
			goto exit;
		   end;
		type ' ';
		goto tryagain;
	end;
	rawvmsdir = ext(3,chars(dirname),dirname);
	repvmsdir = $replacetext('@','.',rawvmsdir,3);
	repvmsdir1 = $replacetext('@','__',repvmsdir);
	repvmsdir2 = $replacetext(' ', '$$', repvmsdir1);
	rawprefix = userfile();
	prefix = ext(1,chars(rawprefix)-8,rawprefix);
	vmsdir = cat (prefix, 'RSGRPBACK.', repvmsdir2, ']');
	if chars(rawvmsdir) = 0
		then vmsdir = cat(prefix,'RSGRPBACK]');
	createcom = cat ('$ create/dir ', vmsdir);
	call putfile (createcom,'createcom.com');
	chain '@createcom.com';
	call $$dir(groupdir,dirname);
	do i = 1 to lastrow(groupdir);
		dis row i of table(groupdir);
		rsvar = row i col 0 of table(groupdir);
		testvar = row i col 1 of table(groupdir);
		if loc('#',rsvar) = 1
			then vmsvar = ext(2,chars(rsvar),rsvar);
		vmsvarint = $replacetext(' ', '$$',vmsvar);
		vmsvarfin = cat (vmsdir, vmsvarint);
		if rsvar <> empty and testvar <> 'Directory' then
			call $archive(rsvar,vmsvarfin,'true','true');
	end;
	call erase;
	type '------------------------------------------------------------';
	type ' ';
	directoutcom = 
	cat('$ dir/brief/nodate/out=',vmsdir,'direct.out ',vmsdir,'*.ark');
	call putfile(directoutcom,'directout.com');
	type "Please wait...";
	chain '@directout.com';
	type "Almost done...";
	chain 'delete createcom.com;*';
	call sleep(1);
	chain 'delete directout.com;*';
exit:	type "That's all folks!";
end;