tldm-universe/Ardent/UV/APP.PROGS/01AD

subroutine U01AD( proc, ibn, pib, sib, ip, obn, pob, sob )
*******************************************************************************
*
*	Perform a file translation from a ProVerb
*
*	Module	%M%	Version	%I% 	Date	%H%
*
*	(c) Copyright 1998 Ardent Software Inc. - All Rights Reserved
*	This is unpublished proprietary source code of Ardent Software Inc.
*	The copyright notice above does not evidence any actual or intended
*	publication of such source code.
*
*******************************************************************************
*
*	Maintenence log - insert most recent change descriptions at top
*
*	Date.... GTAR# WHO Description.........................................
*	10/14/98 23801 SAP Change copyrights. 
*	11/02/95 17595 SHJ Don't convert blanks when printing to terminal
*	04/15/92  9342 JWT Fix case for pib len = 0
*	01/03/92  8557 GMH Corrected placement in pib
*	07/25/88   -    -  Maintenence log purged at 5.2.1, see release 5.1.10.
*
*******************************************************************************
*
*	This "user-exit", called from a ProVerb, takes the filename,
*	item-ID, and translation attribute number specified and returns
*	the looked-up value to the named target.
*
*	Usage:
*		U01AD
*		file.ref item.ref amc.ref target
*		error return
*		success return
*
*	Where target can be:
*		T - terminal
*		S - Current output buffer
*		A - Alternate output buffer
*		P - Primary input buffer
*		V - Verify existence (produces no output)
*		VA - Verify nonnull attribute
*		
*	All references can be indirect through the proc buffers.
*	Work files are not supported.
*
*	Arguments to this subroutine are:
*	     proc - the text of the proc itself
*	     ibn  - the current input buffer number (0 = primary;
*						     1 = secondary)
*	     pib  - the primary input buffer
*	     sib  - the secondary input buffer
*	     ip   - the input buffer pointer (character count)
*	     obn  - the current output buffer number (0 = primary;
*						      1 = secondary)
*	     pob  - the primary output buffer
*	     sob  - the secondary output buffer
*
*******************************************************************************
*

*
*
    DIM words( 10 )
    REMOVE line FROM proc SETTING x
    line = TRIM( line )
    MATPARSE words FROM line," "
    CALL $INDIRECT( fileref, pib, sib, pob, sob, obn, words( 1 ))
    IF fileref[ 1,1 ] = "*" THEN
	Dstr = "DICT"
	fileref = fileref[ 2, 999 ]
    END ELSE
	Dstr = ""
    END
    CALL $INDIRECT( itemref, pib, sib, pob, sob, obn, words( 2 ))
    CALL $INDIRECT( amcref, pib, sib, pob, sob, obn, words( 3 ))
    CALL $INDIRECT( target, pib, sib, pob, sob, obn, words( 4 ))
    found = 1
    OPEN Dstr, fileref TO fvu01ad ELSE
	RETURN
    END
    READV item FROM fvu01ad, itemref, amcref ELSE
	found = 0
    END
    IF found THEN
*
*	If the target designation is prefaced with a "B", then we're
*	to replace all embedded blanks with backslashes.
*
	IF target[ 1, 1 ] = "B" THEN
	    CONVERT " " TO "\" IN item
	    target = target[ 2, LEN( target )]
	END ELSE
	    IF target[ 1, 1 ] # "T" THEN CONVERT " " TO @AM IN item
	END

	BEGIN CASE
	    CASE target = "T"
      		print item

	    CASE target = "T+"
		print item:

	    CASE target = "S"
		IF( obn ) THEN
		    sob := item
		END ELSE
		    pob := item
		END

	    CASE target = "A"
		IF ( obn ) THEN
		    pob = item
		END ELSE
		    sob = item
		END

	    CASE target = "P"
		pib.len = len(pib)
		IF ip = pib.len THEN
			IF pib[ip,1] # @AM AND pib.len THEN pib := @AM
			pib := item
		END ELSE
			IF pib[ ip, 1 ] = @AM THEN ip += 1
			first.part = pib[ 1, ip - 1 ] : item : @AM
			last.part = pib[ ip + 1, len( pib )]
			IF pib[ ip, 1 ] # @AM THEN DEL last.part< 1 >
			pib = first.part : last.part
		END

	    CASE target = "V"
		NULL

	    CASE target = "VA"
		IF item = "" THEN
		    found = 0
		END
	END CASE
    END

*
*   If we found an item, we must remove the error return line
*   from the proc.
*
    IF found THEN
	REMOVE line FROM proc SETTING x
    END

    RETURN

END