H DATEDIT(*YMD)
F*
F*
F* Warning: This program does not set on the LR indicator
F*
F*
F*
FF4104_14 IF E K DISK RENAME(F4104:I4104)
F*
F*
*
* Parameter declarations
<---- SHORT PARM LIST HERE ---->
D DS
D WK_QTYN 1 15 5
D WK_WHOLE 1 10 0
D WK_DEC 11 15 0
DWRK1 S 1 DIM(15)
*
/EJECT
*****************************************************************
* Entry parameters
C *ENTRY PLIST
<--- ENTRY PARAMETERS HERE --->
*****************************************************************
*
* CASE: PAR.Code trans directions is Inward translation
C*
C KEY1 KLIST
C KFLD IVCITM
C KFLD IVXRT
C KFLD IVAN8
C*
C MOVEL *BLANK P0RTN *Return code
C*
C CALL 'EXT042C' *Return code
C*
C P1CDTT IFEQ 'I'
* Use Standard if non-blank; else use qualifier:
C P4Cdqd IFEQ 'PA8 ' Initialize 2nd Item
C MOVEL *BLANKS WK_PA8 8
C Z-ADD *ZEROS WK_PA8N 8 0
C MOVEL P3CDST WK_PA8
C MOVEL WK_PA8 WK_PA8N
C END
C P4Cdqd IFEQ 'QTY ' Initialize 2nd Item
C MOVEL *BLANKS WK_QTY 15
C Z-ADD *ZEROS WK_QTYN
C EVAL WK_QTY = %TRIMR(P3CDST)
C EVAL WK_QTY = %TRIMR(WK_QTY)
C MOVE WK_QTY WK_QTYN
C EVAL WK_QTY = %TRIMR(WK_QTY) + '.'
C MOVEA WK_QTY WRK1
C Z-ADD 1 E 2 0
C '.' LOOKUP WRK1(E) 25
C *IN25 IFEQ *ON
C 10 SUB E F 2 0
C ADD 1 F
C Z-ADD WK_QTYN HOLD 15 5
C DO F
C DIV 10 HOLD
C ENDDO
C END
C Z-ADD HOLD WK_QTYN
C MOVE *ZEROS WK_DEC
C END
C P4Cdqd IFEQ 'UOM ' Initialize 2nd Item
C MOVEL *BLANKS WK_UOM 2
C MOVEL P3CDST WK_UOM
C END
C P4Cdqd IFEQ 'ITEM' Initialize 2nd Item
C MOVEL *BLANKS WK_CITM 25
C MOVEL P3CDST WK_CITM
C*
C Z-ADD WK_PA8N IVAN8
C MOVEL WK_CITM IVCITM
C MOVEL 'C ' IVXRT
C*
C KEY1 CHAIN F4104_14 44
C *IN44 IFEQ *ON
C* MESSAGE FOR ITEM XREF NOT FOUND
C ELSE
C*
C Z-ADD WK_QTYN @QTY
C MOVE *BLANKS WK_MCU 12
C*
C MOVE 'CT' @TO
C CALL 'CONVERT'
C PARM IVLITM
C PARM WK_MCU
C PARM WK_UOM
C PARM @TO 2
C PARM @QTY 15 5
C*
C Z-ADD @QTY WK_QTYN
C WK_DEC IFNE *ZEROS
C MOVEL 'USR0028' P0RTN *Return code
C END
C*
C END
C MOVEL WK_CITM P5CDLC
C ELSE
C END
*
C ELSE
* CASE: PAR.Code trans directions is Outward translation
C P1CDTT IFEQ 'O'
* Use Local if non-blank; else use qualifier:
C P5CDLC IFNE *BLANKS
C MOVEL P5CDLC P3CDST
C ELSE
C MOVEL P4CDQD P3CDST
C END
*
C END
*
C END
*
* A "Return code" of non-blank will be logged as a translation error:
C*** MOVEL *BLANK P0RTN *Return code
* Exit program
C RETURN
