SeanHoppe.com › ERP › VAI/S2K › R50MODS CL › CL :: EDUPDSC1
/*‚******************************************************************/
/*‚* DEVELOPED BY : VAI COMPUTER SYSTEMS INC. Copyright 1998, 2004 **/
/*‚* **/
/*‚* FOR : System 2000 **/
/*‚* PROGRAMMER : Chand Babu Log: 150054 **/
/*‚* DATE WRITTEN : 01/18/2005 **/
/*‚* MODULE : EDI **/
/*‚* **/
/*‚* MODIFIED BY : LARRY HAINES Log: 164919 G4919 **/
/*‚* DATE : 8/25/2005 **/
/*‚* DESCRIPTION : ADD F4 SEARCH FOR DOCUMENT ID **/
/*‚* **/
/*‚* MODIFIED BY : Bob Moloney Log: Rel 5.0 **/
/*‚* DATE : 08/06/2007 Scan: bm01 **/
/*‚* DESCRIPTION : Change company variables to 3 positions **/
/*‚* **/
/*‚* MODIFIED BY : James Lai Log: Rel 5.0 **/
/*‚* DATE : 09/04/2008 Scan: 235069 **/
/*‚* DESCRIPTION : Check user company authorization **/
/*‚* **/
/*‚*---------------------------------------------------------------**/
/*‚* SYSTEM NAME : AS/400 **/
/*‚*---------------------------------------------------------------**/
/*‚* DESCRIPTION : Extract EDI Documents to Send **/
/*‚*---------------------------------------------------------------**/
/*‚* *NOTE: If sending this program and customer does not have **/
/*‚* version of XASRVPG (service program) with log 236615 **/
/*‚* Then it will need to be sent, compiled & rebound to **/
/*‚* All Programs (XAUPPGCL). (all CL's in log 236615) **/
/*‚******************************************************************/
PGM
DCL VAR(&INKCKL) TYPE(*CHAR) LEN(1)
DCL VAR(&YYMM) TYPE(*CHAR) LEN(4)
DCL VAR(&RQSDTA) TYPE(*CHAR) LEN(256)
DCL VAR(&USER) TYPE(*CHAR) LEN(10) /* USER NME */
DCL VAR(&IN98) TYPE(*LGL) LEN(1) VALUE('1')
DCL VAR(&IN99) TYPE(*LGL) LEN(1) VALUE('1')
DCL VAR(&FLOC) TYPE(*CHAR) LEN(4)
DCL VAR(&TLOC) TYPE(*CHAR) LEN(4)
DCL VAR(&PGM) TYPE(*CHAR) LEN(10) +
VALUE('EDUPDSC1')
DCL VAR(&AUTYN) TYPE(*CHAR) LEN(1)
DCL VAR(&NRCPY) TYPE(*CHAR) LEN(2) VALUE('01')
DCL VAR(&ERR2) TYPE(*CHAR) LEN(1)
DCL VAR(&ERRFL) TYPE(*CHAR) LEN(1) VALUE('N')
DCL VAR(&APPL) TYPE(*CHAR) LEN(2) VALUE('AP')
DCL VAR(&PFILE) TYPE(*CHAR) LEN(8) +
VALUE('EDUPDSFM')
DCL VAR(&PREC1) TYPE(*CHAR) LEN(8) +
VALUE('EDUPDS01')
DCL VAR(&PREC2) TYPE(*CHAR) LEN(8)
DCL VAR(&PREC3) TYPE(*CHAR) LEN(8)
DCL VAR(&PEOJ) TYPE(*CHAR) LEN(1)
DCL VAR(&ERRDAT) TYPE(*CHAR) LEN(1)
DCL VAR(&ERRPID) TYPE(*CHAR) LEN(1)
DCL VAR(&ERRCOP) TYPE(*CHAR) LEN(1)
DCL VAR(&ERRMSG) TYPE(*CHAR) LEN(69) +
VALUE('Invalid data found! Please try +
again.')
DCL VAR(&ACCT) TYPE(*CHAR) LEN(7) VALUE('*ALL ')
DCL VAR(&FVEND) TYPE(*CHAR) LEN(6) VALUE(' ')
DCL VAR(&TVEND) TYPE(*CHAR) LEN(6) VALUE('999999')
DCL VAR(&FCUST) TYPE(*CHAR) LEN(7) VALUE(' ')
DCL VAR(&TCUST) TYPE(*CHAR) LEN(7) VALUE('9999999')
DCL VAR(&FREF) TYPE(*DEC ) LEN(9) VALUE(000000000)
DCL VAR(&TREF) TYPE(*DEC ) LEN(9) VALUE(999999999)
DCL VAR(&FORD) TYPE(*DEC) LEN(9) VALUE(000000000)
DCL VAR(&TORD) TYPE(*DEC ) LEN(9) VALUE(999999999)
DCL VAR(&FBOCD) TYPE(*DEC) LEN(3) VALUE(000)
DCL VAR(&TBOCD) TYPE(*DEC ) LEN(3) VALUE(999)
DCL VAR(&FAREF) TYPE(*CHAR) LEN(20) +
VALUE(' ')
DCL VAR(&TAREF) TYPE(*CHAR) LEN(20) +
VALUE('99999999999999999999')
DCL VAR(&FRDTE) TYPE(*DEC) LEN(6 0) VALUE(000000)
DCL VAR(&TRDTE) TYPE(*DEC) LEN(6 0) VALUE(999999)
DCL VAR(&EDST) TYPE(*CHAR) LEN(10) +
VALUE('*ALL ')
DCL VAR(&FD_A) TYPE(*CHAR) LEN(6)
DCL VAR(&TD_A) TYPE(*CHAR) LEN(6)
DCL VAR(&FREF_A) TYPE(*CHAR) LEN(9)
DCL VAR(&TREF_A) TYPE(*CHAR) LEN(9)
DCL VAR(&FORD_A) TYPE(*CHAR) LEN(9)
DCL VAR(&TORD_A) TYPE(*CHAR) LEN(9)
DCL VAR(&FBOCD_A) TYPE(*CHAR) LEN(3)
DCL VAR(&TBOCD_A) TYPE(*CHAR) LEN(3)
/**** WORKING FIELDS FOR SEARCH F4=IN04 ****/
DCL VAR(&COMP) TYPE(*CHAR) LEN(3) /* bm01 */
DCL VAR(&XCOMP) TYPE(*CHAR) LEN(3) /* bm01 */
DCL VAR(&XDESC) TYPE(*CHAR) LEN(30) VALUE(' ')
DCL VAR(&XVEND) TYPE(*CHAR) LEN(6)
DCL VAR(&XCUST) TYPE(*CHAR) LEN(7)
DCL VAR(&EOJ) TYPE(*CHAR) LEN(1)
DCL VAR(&XPO ) TYPE(*CHAR) LEN(9)
DCL VAR(&XINV) TYPE(*CHAR) LEN(12)
DCL VAR(&XPGM) TYPE(*CHAR) LEN(10) VALUE(EDUPDSC1)
DCL VAR(&ERR) TYPE(*CHAR) LEN(1)
DCL VAR(&ERRCMP) TYPE(*CHAR) LEN(3) /* bm01 */
DCL VAR(&CCYYMM) TYPE(*CHAR) LEN(6)
DCL VAR(&ERR_YEAR) TYPE(*CHAR) LEN(4)
DCL VAR(&APPLYL) TYPE(*CHAR) LEN(2)
DCL VAR(&CCYYPP) TYPE(*CHAR) LEN(6)
DCL VAR(&JOB) TYPE(*CHAR) LEN(10) /* Job Name */
DCL VAR(&SHP) TYPE(*CHAR) LEN(7)
DCL VAR(&ORD) TYPE(*CHAR) LEN(12)
DCL VAR(&INV) TYPE(*CHAR) LEN(9)
DCL VAR(&NETNAME) TYPE(*CHAR) LEN(30)
DCL VAR(&LGLHEAD) TYPE(*CHAR) LEN(10)
DCL VAR(&PNETY) TYPE(*CHAR) LEN(1) VALUE(' ')
DCL VAR(&XNETID) TYPE(*CHAR) LEN(15)
/* G4919 */ DCL VAR(&XEDST) TYPE(*CHAR) LEN(10)
/**** WORKING FIELDS FOR SEARCH F4=IN04 ****/
DCL VAR(&DISPLAY) TYPE(*CHAR) LEN(9)
DCL VAR(&SBMHOLD) TYPE(*CHAR) LEN(5) +
VALUE('*JOBD')
DCL VAR(&JOB_DATE ) TYPE(*CHAR) LEN(8)
DCL VAR(&JOB_TIME ) TYPE(*CHAR) LEN(8)
DCL VAR(&JOB_NAME ) TYPE(*CHAR) LEN(10)
DCL VAR(&JOB_USER ) TYPE(*CHAR) LEN(10)
DCL VAR(&JOB_NUMBER) TYPE(*CHAR) LEN(6)
DCL VAR(&RET_CODE) TYPE(*CHAR) LEN(3)
/*235069*/ DCL VAR(&CMP0) TYPE(*DEC) LEN(3 0)
/*235069*/ DCL VAR(&BAD) TYPE(*CHAR) LEN(1)
/*235069*/ DCL VAR(&RTN) TYPE(*CHAR) LEN(16)
DCLF FILE(EDUPDSFM)
RTVJOBA USER(&USER) OUTQ(&PRTID) DATE(&RPTDT) /*31777*/
/***************************************************************/
/**** CHECK IF USER IS AUTHORIZED ACCESS TO PROGRAM ****/
/***************************************************************/
CALL PGM(*LIBL/XACKSCC1) PARM(&USER &PGM &AUTYN)
IF COND(&AUTYN *EQ 'N') THEN(RETURN)
/* CHGVAR VAR(&CMP) VALUE('01') */
CALL PGM(XACHKCL) PARM(&USER &COMP &FLOC &IN98 +
&IN99)
CHGVAR VAR(&CMP) VALUE(&COMP)
IF COND(&IN98 *EQ '1') THEN(DO)
ENDDO
CHGVAR VAR(&XXPREV) VALUE('Y')
CHGVAR VAR(&XXTRANS) VALUE('Y')
CHGVAR VAR(&XXSEND) VALUE('Y')
/* RETRIEVE DEFAULT NETWORK FROM CONSTANTS FILE */
/* CALL PGM(EDNETW02) PARM(&XXNETW &NETNAME) */
CHGVAR VAR(&XXNETW) VALUE('*ALL')
PROMPT: SNDRCVF RCDFMT(EDUPDS01)
CHGVAR VAR(&$ERROR) VALUE(' ')
CHGVAR VAR(&$ERROR) +
VALUE(' ')
IF COND(&IN12 *EQ '1') THEN(DO)
RETURN
ENDDO
IF COND(&IN03 *EQ '1') THEN(DO)
RETURN
ENDDO
/* HELP */
IF COND(&IN95 = '1') THEN(DO)
CALL PGM(XAHLPPGM) PARM(&PFILE &PREC1 &PREC2 +
&PREC3) /* Call Help Program */
GOTO CMDLBL(PROMPT)
ENDDO
CHGVAR VAR(&IN80) VALUE('0')
CHGVAR VAR(&IN81) VALUE('0')
CHGVAR VAR(&IN82) VALUE('0')
CHGVAR VAR(&CROW) VALUE(000)
CHGVAR VAR(&CCOL) VALUE(000)
/********************************************************************/
/* PERFORM SEARCHES */
IF COND(&IN04 *EQ '1') THEN(DO) /* FIELD SEARCH */
/* SEARCH FROM COMPANY */
IF COND(&IN98 *EQ '0') THEN(DO)
IF COND(&CSRFLD *EQ 'CMP ') THEN(DO)
CHGVAR VAR(&CROW) VALUE(03)
CHGVAR VAR(&CCOL) VALUE(30)
CHGVAR VAR(&XCOMP) VALUE(' ')
CHGVAR VAR(&XDESC) VALUE(' ')
CALL PGM(SRCOMP) PARM(&XCOMP &XDESC &INKCKL)
IF COND(&INKCKL = 'C') THEN(DO)
RETURN
ENDDO
IF COND(&XCOMP *NE ' ') THEN(DO) /* bm01 */
CHGVAR VAR(&CMP ) VALUE(&XCOMP)
CHGVAR VAR(&CROW) VALUE(04)
CHGVAR VAR(&CCOL) VALUE(30)
ENDDO
GOTO CMDLBL(PROMPT)
ENDDO
ENDDO
/* SEARCH FROM VENDOR */
IF COND(&ATYP *EQ 'V' ) THEN(DO)
IF COND(&CSRFLD *EQ 'ACCT ') THEN(DO)
CHGVAR VAR(&CROW) VALUE(04)
CHGVAR VAR(&CCOL) VALUE(33)
CHGVAR VAR(&XVEND) VALUE(' ')
CHGVAR VAR(&EOJ) VALUE(' ')
CALL PGM(SPVEND) PARM(&CMP &XVEND &EOJ)
IF COND(&XVEND *NE ' ') THEN(DO)
CHGVAR VAR(&ACCT ) VALUE(&XVEND)
CHGVAR VAR(&CROW) VALUE(05)
CHGVAR VAR(&CCOL) VALUE(30)
ENDDO
GOTO CMDLBL(PROMPT)
ENDDO
ENDDO
IF COND(&ATYP *EQ 'C' ) THEN(DO)
/* SEARCH FROM CUSTOMER */
IF COND(&CSRFLD *EQ 'ACCT ') THEN(DO)
CHGVAR VAR(&CROW) VALUE(04)
CHGVAR VAR(&CCOL) VALUE(33)
CHGVAR VAR(&XCUST) VALUE(' ')
CHGVAR VAR(&EOJ) VALUE(' ')
CALL PGM(SRCUST) PARM(&CMP &XCUST &JOB &USER +
&PGM &SHP &ORD &INV)
IF COND(&XCUST = 'EOJ####') THEN(DO)
RETURN
ENDDO
IF COND(&XCUST *NE ' ') THEN(DO)
CHGVAR VAR(&ACCT ) VALUE(&XCUST)
CHGVAR VAR(&CROW) VALUE(05)
CHGVAR VAR(&CCOL) VALUE(30)
ENDDO
GOTO CMDLBL(PROMPT)
ENDDO
ENDDO
/* G4919 */ /* SEARCH DOCUMENT ID */
IF COND(&CSRFLD *EQ 'EDST ') THEN(DO)
CHGVAR VAR(&XEDST) VALUE(' ')
CHGVAR VAR(&CROW) VALUE(05)
CHGVAR VAR(&CCOL) VALUE(30)
CALL PGM(SRDOCID) PARM(&XEDST)
IF COND(&XEDST *NE ' ') THEN(DO)
CHGVAR VAR(&EDST) VALUE(&XEDST)
CHGVAR VAR(&CROW) VALUE(06)
CHGVAR VAR(&CCOL) VALUE(30)
ENDDO
GOTO CMDLBL(PROMPT)
/* G4919 */ ENDDO
/* SEARCH NETWORK ID */
IF COND(&CSRFLD *EQ 'XXNETW ') THEN(DO)
CHGVAR VAR(&XNETID) VALUE(' ')
CHGVAR VAR(&CROW) VALUE(06)
CHGVAR VAR(&CCOL) VALUE(30)
CALL PGM(SRNETW) PARM(&CMP &XNETID &NETNAME +
&LGLHEAD &PNETY) /*6KXN*/
IF COND(&XNETID *NE ' ') THEN(DO)
CHGVAR VAR(&XXNETW) VALUE(&XNETID)
CHGVAR VAR(&CROW) VALUE(07)
CHGVAR VAR(&CCOL) VALUE(30)
ENDDO
GOTO CMDLBL(PROMPT)
ENDDO
/* SEARCH PRINTER */
IF COND(&CSRFLD *EQ 'PRTID ') THEN(DO)
CHGVAR VAR(&CROW) VALUE(14)
CHGVAR VAR(&CCOL) VALUE(52)
CALL PGM(PRTSRH) PARM(&PRTID &INKCKL)
IF COND(&INKCKL = 'C') THEN(DO)
RETURN
ENDDO
IF COND(&PRTID *NE ' ') THEN(DO)
CHGVAR VAR(&CROW) VALUE(15)
CHGVAR VAR(&CCOL) VALUE(52)
ENDDO
ENDDO
GOTO CMDLBL(PROMPT)
ENDDO
/********************************************************************/
/*235069*/
/* EDIT COMPANY */
CHGVAR VAR(&CMP0) VALUE(&CMP)
/* 236615 CALLPRC PRC(SP_CMP_USR) PARM((&CMP0 *BYVAL) (&USER +
*BYVAL)) RTNVAL(&RTN) */
/* 236615 CHGVAR VAR(&BAD) VALUE(%SST(&RTN 1 1)) */
/* 236615 */ CALLPRC PRC(SP_CMP_USR) PARM((&CMP0 *BYVAL) (&USER +
*BYVAL)) RTNVAL(&BAD)
IF COND(&BAD *NE 'Y') THEN(DO)
CALLPRC PRC(SP_MSG_TXT) PARM(('XA00237' *BYVAL)) +
RTNVAL(&$ERROR)
GOTO CMDLBL(PROMPT)
ENDDO
/*235069*/
/* EDIT ACCOUNT type */
IF COND(&ATYP *NE 'C' *AND &ATYP *NE 'V' *AND +
&ACCT *NE '*ALL') THEN(DO)
CHGVAR VAR(&$ERROR) VALUE('Account Type must be +
C=Customer, V=Vendor.')
CHGVAR VAR(&CROW) VALUE(04)
CHGVAR VAR(&CCOL) VALUE(30)
GOTO CMDLBL(PROMPT)
ENDDO
IF COND(&ATYP *NE 'C' *AND &ATYP *NE 'V' *AND +
&ATYP *NE ' ') THEN(DO)
CHGVAR VAR(&$ERROR) VALUE('Account Type must be +
C=Customer, V=Vendor or blank')
CHGVAR VAR(&CROW) VALUE(04)
CHGVAR VAR(&CCOL) VALUE(30)
GOTO CMDLBL(PROMPT)
ENDDO
/* EDIT Send/Translation Flag */
/* IF COND(&XXTRANS *EQ 'N' *AND &XXSEND *EQ 'Y') + */
/* THEN(DO) */
/* CHGVAR VAR(&$ERROR) VALUE('Extracted Data must be + */
/* Translated to be Sent') */
/* CHGVAR VAR(&CROW) VALUE(15) */
/* CHGVAR VAR(&CCOL) VALUE(25) */
/* GOTO CMDLBL(PROMPT) */
/* ENDDO */
/********************************************************************/
CALL PGM(XACKPS) PARM(&RPTDT &PRTID &NRCPY +
&ERRDAT &ERRPID &ERRCOP)
IF COND(&ERRCOP *EQ 'E') THEN(DO)
CHGVAR VAR(&IN82) VALUE('1')
CHGVAR VAR(&$ERROR) VALUE(&ERRMSG)
ENDDO
IF COND(&ERRPID *EQ 'E') THEN(DO)
CHGVAR VAR(&IN81) VALUE('1')
CHGVAR VAR(&$ERROR) VALUE(&ERRMSG)
ENDDO
IF COND(&ERRDAT *EQ 'E') THEN(DO)
CHGVAR VAR(&IN80) VALUE('1')
CHGVAR VAR(&$ERROR) VALUE(&ERRMSG)
ENDDO
IF COND(&IN80 *EQ '1' *OR &IN81 *EQ '1' *OR +
&IN82 *EQ '1') THEN(DO)
GOTO CMDLBL(PROMPT)
ENDDO
CHGVAR VAR(&JOB_DATE) VALUE('*GETSYS')
CHGVAR VAR(&JOB_TIME) VALUE('*GETSYS')
CHGVAR VAR(&JOB_NAME) VALUE('*GETSYS')
CHGVAR VAR(&JOB_USER) VALUE('*GETSYS')
CHGVAR VAR(&JOB_NUMBER) VALUE('*GETSYS')
/* Allow the user to select batch here if docid = *NONE */
IF COND(&EDST = '*NONE') THEN(DO)
IF COND(&XXTRANS = 'Y') THEN(DO)
CALL PGM(EDSRNTFS) PARM(&JOB_DATE &JOB_TIME +
&JOB_NAME &JOB_USER &JOB_NUMBER 'F' &RET_CODE)
ENDDO
ELSE CMD(DO)
IF COND(&XXSEND = 'Y') THEN(DO)
CALL PGM(EDSRNTFS) PARM(&JOB_DATE &JOB_TIME +
&JOB_NAME &JOB_USER &JOB_NUMBER 'S' &RET_CODE)
ENDDO
ENDDO
IF COND(&RET_CODE = 'F12') THEN(GOTO +
CMDLBL(PROMPT))
IF COND(&IN03 *EQ '1') THEN(DO)
RETURN
ENDDO
ENDDO
CHGVAR VAR(&FD_A) VALUE(&FRDTE)
CHGVAR VAR(&TD_A) VALUE(&TRDTE)
CHGVAR VAR(&FREF_A) VALUE(&FREF )
CHGVAR VAR(&TREF_A) VALUE(&TREF )
CHGVAR VAR(&FORD_A) VALUE(&FORD )
CHGVAR VAR(&TORD_A) VALUE(&TORD )
CHGVAR VAR(&FBOCD_A) VALUE(&FBOCD)
CHGVAR VAR(&TBOCD_A) VALUE(&TBOCD)
IF COND(&IN06 *EQ '0') THEN(DO)
SUBMITJOB: SBMJOB CMD(CALL PGM(EDUPDSC2) PARM( +
&JOB_DATE +
&JOB_TIME +
&JOB_NAME +
&JOB_USER +
&JOB_NUMBER +
&CMP +
&ATYP +
&ACCT +
&EDST +
&XXNETW +
&FD_A +
&TD_A +
&FREF_A +
&TREF_A +
&FORD_A +
&TORD_A +
&FBOCD_A +
&TBOCD_A +
&FAREF +
&TAREF +
&XXPREV +
&XXTRANS +
&XXSEND +
&RPTDT +
&PRTID +
&NRCPY +
)) +
JOB(EDI_SEND)
ENDDO
IF COND(&IN06 *EQ '1') THEN(DO)
SNDF RCDFMT(EDUPDS02)
CALL PGM(EDUPDSC2) PARM( +
&JOB_DATE +
&JOB_TIME +
&JOB_NAME +
&JOB_USER +
&JOB_NUMBER +
&CMP +
&ATYP +
&ACCT +
&EDST +
&XXNETW +
&FD_A +
&TD_A +
&FREF_A +
&TREF_A +
&FORD_A +
&TORD_A +
&FBOCD_A +
&TBOCD_A +
&FAREF +
&TAREF +
&XXPREV +
&XXTRANS +
&XXSEND +
&RPTDT +
&PRTID +
&NRCPY +
)
ENDDO
ENDPGM
