EXTOL RPG Program: EXQLOVZR

EXTOL RPG - External Call EXQLOVZR - Return input if not blank/zero; else return qualifier

     H/TITLE Return input if not blank/zero; else return qualifier
     H            Y
     Z* CRTRPGPGM
     Z* OPTION(*NOXREF) GENOPT(*OPTIMIZE)
      *
     W* Warning: This program does not set on the LR indicator
      *
     H* SYNOPSIS :
     H*  Example of external call code translation using the "long"
     H*  parameter list.
      *
     H*  Returns the "qualifier" input to the output if the "primary"
     H*  input is blank (if alpha) or zero (if numeric).
     H*  The "primary" input is "local" for outgoing, "standard" for
     H*  incoming.
      *
     H* Function type : Execute external function
      *
     H* Company       : ExtoL, Inc.
     H* System        : ExtoL EDI Integrator
     H* User name     : EXTOLOWN
     H* Date          : 11/16/94
     H* (C) Copyright : ExtoL, Inc. 1988,1994
      *
      *================================================================
     M* Maintenance   : Manually modified Synon program for demonstration.
      *================================================================
      *
     E                    EL         99100               99 elements x 100
     E                    ELN        99  3 0             99 el.lengths 3.0
     E                    SG       2006  1               segment buffer
     E                    SC         10 15 0             Segment counters
      * Data structures:
     IPGMDS     ESDSEXPGSDS
      * Program data structure
     IJBDTTM      DS
      * Job date/time
     I                                        1   60##JDT
     I                                        1   20##JYY
     I                                        3   40##JMM
     I                                        5   60##JDD
     I                                        7  120##JTM
     I                                        7   80##JHH
     I                                        9  100##JNN
     I                                       11  120##JSS
      * Named constants
      * Values in a numeric field:
     I              '0123456789'          C         DIGITS
      *
      /EJECT
      * Parameter declarations
     IP1PARM      DS
      * I :  Code trans directions
     I                                        1   1 P1CDTT
     IP2PARM      DS
      * FLD: #Code table test 2
      * I :  Code table reference
     I                                        1  10 P2TABL
      * B :  Code in standard form
     I                                       11  90 P2CDST
      * B :  Code qualifier data
     I                                       91 170 P2CDQD
      * B :  Code in local form
     I                                      171 250 P2CDLC
     IP3PARM      DS
      * FLD: XLT msg parm structure
      * I :  Connection log number
     I                                    P   1   40P3CNLN
      * I :  Network ID
     I                                        5  19 P3NWID
      * I :  Date/time start of call
     I                                    P  20  270P3DTM1
      * I :  Interchange log number
     I                                    P  28  320P3INLN
      * I :  Trading partner code
     I                                       33  38 P3TPCD
      * I :  Interchange date
     I                                       39  44 P3INDT
      * I :  Interchange time
     I                                       45  48 P3INTM
      * I :  Test indicator
     I                                       49  49 P3TSTI
      * I :  Group log number
     I                                    P  50  540P3GPLN
      * I :  Message log number
     I                                    P  55  600P3MSLN
      * I :  Message ID
     I                                       61  66 P3MSID
      * I :  Message class
     I                                       67  76 P3MSCL
      * I :  Message direction
     I                                       77  77 P3MSDI
      * I :  Application file name
     I                                       78  87 P3GFIL
      * I :  Record format name
     I                                       88  97 P3RCFM
      * I :  V-R Log of message
     I                                       98 103 P3VRLM
      * I :  Industry group ID log msg
     I                                      104 109 P3IGIM
      * I :  Application data log #
     I                                    P 110 1140P3APLN
      * I :  Application file set
     I                                      115 124 P3GFSN
      * I :  Msg queue - translation
     I                                      125 134 P3MSQT
      * I :  Trans job master control
     I                                    P 135 1400P3TJMC
      * I :  Segment position in msg
     I                                    P 141 1440P3SGPS
      * I :  Segment ID
     I                                      145 147 P3SGID
      * I :  Element pos in segment
     I                                    P 148 1490P3ELPS
      * I :  Component position
     I                                    P 150 1510P3CPOS
      * I :  Element ID
     I                                      152 155 P3ELID
      * I :  Field name
     I                                      156 165 P3FLNM
      * I :  Field length
     I                                    P 166 1680P3FLLN
      * I :  Field number of digits
     I                                    P 169 1700P3FLDD
      * I :  Field decimal positions
     I                                    P 171 1720P3FLDC
      * I :  Field type
     I                                      173 173 P3FLTY
      * I :  Field null value type
     I                                      174 174 P3NULT
      * I :  Field null value length
     I                                    P 175 1770P3NULL
      * I :  Field null value
     I                                      178 187 P3NULV
      * I :  Message area
     I                                      188 188 P3SGAR
      * I :  Segment sequence
     I                                      189 192 P3SGSQ
      * I :  Segment instance number
     I                                    P 193 1940P3SGNM
      * I :  Element mapping sequence
     I                                    P 195 1960P3MPSQ
      * I :  Nonwrapped record number
     I                                    P 197 2010P3NWRC
     IP4PARM      DS
      * FLD: XLT misc field parm str
      * I :  Field mapping sequence
     I                                    P   1   20P4FMSQ
      * I :  #XLT Line counter 1  7.0P
     I                                    P   3   60P4N1
      * I :  #XLT Line counter 2  7.0P
     I                                    P   7  100P4N2
      * I :  #XLT Segment length  5.0P
     I                                    P  11  130P4GDLP
      * I :  #XLT Last element    3.0P
     I                                    P  14  150P4MAX
      * I :  Sub-element delimiter
     I                                       16  16 P4SEDM
      * I :  Element delimiter
     I                                       17  17 P4ELDM
      * I :  Decimal notation
     I                                       18  18 P4DCNT
      * I :  Release indicator char
     I                                       19  19 P4RLIN
      * I :  Reserved space in UNA
     I                                       20  20 P4RSSP
      * I :  Segment delimiter
     I                                       21  21 P4SGDM
     IP4SCF       DS
      * FLD: XLT misc field parm str
      * I :  #XLT Sg counters 10x15.0P
     I                                    P   1  80 SC
     IP4ELNF      DS
      * FLD: XLT misc field parm str
      * I :  #XLT Elem lengths 99x3.0P
     I                                    P   1 198 ELN
     IP4SGF       DS
      * FLD: XLT misc field parm str
      * I :  #XLT Segment buffer 2006A
     I                                        12006 SG
     IWP0052      DS                           2006
     IP4ELF       DS
      * FLD: XLT misc field parm str
      * I :  #XLT Elem data    99x100
     I                                        19900 EL
     IWP0053      DS                           9900
      /EJECT
      *****************************************************************
      * Entry parameters
     C           *ENTRY    PLIST
     C                     PARM           P0RTN   7
     C           P1CDTT    PARM           WP0001  1        Code trans dire
     C           P2TABL    PARM           WP0002 10        Code table refe
     C           P2CDST    PARM P2CDST    WP0003 80        Code in standar
     C           P2CDQD    PARM P2CDQD    WP0004 80        Code qualifier
     C           P2CDLC    PARM P2CDLC    WP0005 80        Code in local f
     C           P3CNLN    PARM           WP0006  70       Connection log
     C           P3NWID    PARM           WP0007 15        Network ID
     C           P3DTM1    PARM           WP0008 150       Date/time start
     C           P3INLN    PARM           WP0009  90       Interchange log
     C           P3TPCD    PARM           WP0010  6        Trading partner
     C           P3INDT    PARM           WP0011  6        Interchange dat
     C           P3INTM    PARM           WP0012  4        Interchange tim
     C           P3TSTI    PARM           WP0013  1        Test indicator
     C           P3GPLN    PARM           WP0014  90       Group log numbe
     C           P3MSLN    PARM           WP0015 110       Message log num
     C           P3MSID    PARM           WP0016  6        Message ID
     C           P3MSCL    PARM           WP0017 10        Message class
     C           P3MSDI    PARM           WP0018  1        Message directi
     C           P3GFIL    PARM           WP0019 10        Application fil
     C           P3RCFM    PARM           WP0020 10        Record format n
     C           P3VRLM    PARM           WP0021  6        V-R Log of mess
     C           P3IGIM    PARM           WP0022  6        Industry group
     C           P3APLN    PARM           WP0023  90       Application dat
     C           P3GFSN    PARM           WP0024 10        Application fil
     C           P3MSQT    PARM           WP0025 10        Msg queue - tra
     C           P3TJMC    PARM           WP0026 110       Trans job maste
     C           P3SGPS    PARM           WP0027  70       Segment positio
     C           P3SGID    PARM           WP0028  3        Segment ID
     C           P3ELPS    PARM           WP0029  30       Element pos in
     C           P3CPOS    PARM           WP0030  30       Component posit
     C           P3ELID    PARM           WP0031  4        Element ID
     C           P3FLNM    PARM           WP0032 10        Field name
     C           P3FLLN    PARM           WP0033  50       Field length
     C           P3FLDD    PARM           WP0034  20       Field number of
     C           P3FLDC    PARM           WP0035  20       Field decimal p
     C           P3FLTY    PARM           WP0036  1        Field type
     C           P3NULT    PARM           WP0037  1        Field null valu
     C           P3NULL    PARM           WP0038  50       Field null valu
     C           P3NULV    PARM           WP0039 10        Field null valu
     C           P3SGAR    PARM           WP0040  1        Message area
     C           P3SGSQ    PARM           WP0041  4        Segment sequenc
     C           P3SGNM    PARM           WP0042  30       Segment instanc
     C           P3MPSQ    PARM           WP0043  30       Element mapping
     C           P3NWRC    PARM           WP0044  90       Nonwrapped reco
     C           P4FMSQ    PARM           WP0045  30       Field mapping s
     C           P4N1      PARM P4N1      WP0046  70       #XLT Line count
     C           P4N2      PARM P4N2      WP0047  70       #XLT Line count
     C           P4SCF     PARM           WP0048 80        #XLT Sg counter
     C           P4GDLP    PARM           WP0049  50       #XLT Segment le
     C           P4MAX     PARM           WP0050  30       #XLT Last eleme
     C           P4ELNF    PARM           WP0051198        #XLT Elem lengt
     C           P4SGF     PARM           WP0052           #XLT Segment bu
     C           P4ELF     PARM           WP0053           #XLT Elem data
     C           P4SEDM    PARM           WP0054  1        Sub-element del
     C           P4ELDM    PARM           WP0055  1        Element delimit
     C           P4DCNT    PARM           WP0056  1        Decimal notatio
     C           P4RLIN    PARM           WP0057  1        Release indicat
     C           P4RSSP    PARM           WP0058  1        Reserved space
     C           P4SGDM    PARM           WP0059  1        Segment delimit
      *****************************************************************
      * Initialise
     C                     EXSR ZZINIT
      *
      * External code process P2
     C                     MOVEL*BLANK    W0RTN            *Return code
      * CASE: PAR.Code trans directions is Inward translation
     C           P1CDTT    IFEQ 'I'                        *IF
      * Incoming function:
     C                     EXSR SARVGN
     C                     ELSE
      * CASE: PAR.Code trans directions is Outward translation
     C           P1CDTT    IFEQ 'O'                        *IF
      * Outgoing function:
     C                     EXSR SBRVGN
     C                     END                             *FI
     C                     END                             *FI
      * A "Return code" of non-blank will be logged as a translation error:
     C                     MOVELW0RTN     P0RTN            *Return code
     C                     EXSR ZYEXPG
      *================================================================
      /EJECT
     CSR         SARVGN    BEGSR
      *================================================================
      *        Incoming ("I") - Standard -> Application translation.
      *
     C                     MOVEL*BLANK    W0RTN   7
     C                     MOVEL*BLANK    OUT80  80
      * Use Standard if non-blank; else use qualifier:
     C           P2CDST    IFNE *BLANKS
     C                     MOVELP2CDST    P2CDLC           Code in local f
     C                     ELSE
     C                     MOVELP2CDQD    P2CDLC
     C                     END
      *
      *================================================================
     CSR         SAEXIT    ENDSR
      /EJECT
     CSR         SBRVGN    BEGSR
      *================================================================
      *        Outgoing ("O") - Application -> Standard translation.
      *
     C                     MOVEL*BLANK    W0RTN   7
      *
      * Use Local if non-blank/non-zero; else use qualifier:
      *
      * If character, check for blanks:
     C           P3FLTY    IFEQ 'A'
     C           P3FLTY    OREQ 'H'
      *
     C           P2CDLC    IFNE *BLANKS
     C                     MOVELP2CDLC    P2CDST
     C                     ELSE
     C                     MOVELP2CDQD    P2CDST
     C                     END
      *
     C                     ELSE
      * If numeric, check for any non-blank, non-zero character:
     C           ' 0'      CHECKP2CDLC    N       30       n=non' ',non'0'
     C           N         IFGT 0                          if found,
     C                     MOVELP2CDLC    P2CDST
     C                     ELSE
     C                     MOVELP2CDQD    P2CDST
     C                     END
      *
     C                     END
      *
      *================================================================
     CSR         SBEXIT    ENDSR
      /EJECT
     CSR         ZYEXPG    BEGSR
      *================================================================
      * Exit program: Direct
      *================================================================
      * Exit program
     C                     RETRN
      *
      *================================================================
     CSR         ZYEXIT    ENDSR
      /EJECT
     CSR         ZZINIT    BEGSR
      *================================================================
      * Initialisation
      *================================================================
     C                     MOVE *BLANK    P0RTN
     C                     MOVE *BLANK    W0RTN   7
     C                     MOVEL*BLANK    W0RSL   1
     C                     MOVEL*BLANK    W0RSF   1
      * Initialise indicators for re-entry
     C                     MOVE '0'       *IN
      * Setup job date/time
      *
     C                     Z-ADDUDATE     ##JDT
     C                     TIME           ##JTM
      * Update screen time
     C                     TIME           ##TME   60
      *================================================================
     CSR         ZZEXIT    ENDSR