****************************************************************** * MICRO FOCUS VSE VSAM DOWNLOAD (RECEIVE) COBOL PROGRAM EXIT * ****************************************************************** * * * MODULE-NAME: CFTRMFDN * * ************ * * * * VERSION: COBOL * * ******** * * * * DESCRIPTION : * * ************* * * * * This is a MICRO FOCUS user program which is invoked during * * file transfer from the host to the PC (RECEIVE) in order to * * load data into a CICS temporary storage queue. * * To avoid destruction of other users' queues, this sample works * * only with the default queue associated with the user's * * terminal (CFTRxxxx where xxxx is the CICS terminal ID. * * This program is based on the sample inwsamc2 provided by IBM. * * * * FUNCTION * * ******** * * * * Program CFTRMFDN stores into the temporary storage queue, the * * records retrieved from the VSAM dataset specified as a * * parameter. * * * * The program checks if the queue name passed in the commarea is * * the default name associated with this terminal. If not, an * * error return code is moved to the commarea and processing is * * terminated. Otherwise, the program checks if a queue with the * * same name already exists and, if so, deletes this queue, unless* * a host filename of NODEL was specified (see EXTERNAL INTERFACE)* * * * The program then builds a new queue, with the header record * * containing the host filename, and the data records. * * * * EXTERNAL INTERFACE * * ****************** * * * * Issue from the PC the following RECEIVE command: * * * * RECEIVE pcfile hostfile (FILE=TS PROGRAM=CFTRMFDN * * * * pcfile = the name of the PC file that is to receive the * * data created by program CFTRMFDN * * hostfile = is the host filename; any name can be used. * * in this sample, if the name NODEL is used, this * * indicates that the queue, if one exists, is NOT * * to be deleted. * * * * INTERNAL INTERFACE * * ****************** * * * * CFTRMFDN is given control by the IWS file transfer program * * (EXEC CICS LINK) with the following communication area: * * * * COMMAREA DSECT COMMUNICATION AREA * * DS CL2 NOT USED * * URETCODE DS CL2 USER RETURN CODE * * UFILE DS CL8 HOST FILENAME * * UQUEUE DS CL8 TS QUEUE NAME * * UTYPE DS CL8 HOST FILETYPE (NOT USED) * * UHEADER DS CL160 HEADER RECORD INFO (NOT USED) * * * * URETCODE is initialized with hex zeros on entry to the user * * program. Any nonzero value returned to the IWS file transfer * * program will cause file transfer to be terminated with the * * return code displayed in message INW0027I. * * * * UFILE the host filename should be stored in the header record. * * By choosing a meaningful name, UFILE can be used to pass * * processing information to the user program. * * * * ERRORS * * ****** * * * * If an error situation is detected by this program, a return * * code is passed back to the caller which causes file transfer * * to be terminated. The return code is displayed in the error * * message: * * * * 0001 = INVALID QUEUE NAME * * 0002 = TEMPORARY STORAGE SPACE EXHAUSTED * * 0003 = QUEUE ALREADY EXISTS (NODEL WAS SPECIFIED) * * 0004 = UFILE NAME NOT SPECIFIED * * * * * * INSTALLATION * * ************ * * * * To run this program, first copy this member MFSAMC2 into * * your private library and rename it to CFTRMFDN. * * Compile and link the program (online) with the Compile Dialog. * * Add the following entry to the CICS PPT in DFHPPTSP: * * * * DFHPPT TYPE=ENTRY, * * PROGRAM=CFTRMFDN, * * PGMLANG=COBOL, * * RLS=PUBLIC * * * * Assemble and link the PPT and shutdown and restart CICS. * * (Unresolved ADCONs due to WXTRNs may be ignored.) * ****************************************************************** IDENTIFICATION DIVISION. PROGRAM-ID. CFTRMFDN. ENVIRONMENT DIVISION. DATA DIVISION. WORKING-STORAGE SECTION. ****************************************************************** * * * DEFINITION OF TS QUEUE HEADER RECORD * * ************************************ * * * * THE FIRST RECORD IN THE QUEUE MUST BE THE HEADER RECORD. * * FOR DOWNLOAD, ONLY THE HOST FILENAME MUST BE PROVIDED IN * * FIELD HDRFILE. IT IS TAKEN FROM THE COMMUNICATION AREA FIELD * * UFILE. * * OPTIONALLY, THE OPTION FIELDS HDROPT1 AND HDROPT2 COULD BE * * FILLED IN. ALL OTHER FIELDS ARE IGNORED FOR DOWNLOAD. * ****************************************************************** 01 HDRECORD. 02 HDRFILE PICTURE X(8). 02 FILLER PICTURE X. 02 HDRTIME PICTURE X(6). 02 FILLER PICTURE X. 02 HDRDATE PICTURE X(5). 02 FILLER PICTURE X(1). 02 HDRLPAR PICTURE X. 02 HDROPT1 PICTURE X(6). 02 FILLER PICTURE X. 02 HDROPT2 PICTURE X(6). 02 FILLER PICTURE X. 02 HDRTYPE PICTURE X(8). 02 FILLER PICTURE X. 02 HDRDCDF PICTURE X(8). 02 FILLER PICTURE X. 02 HDRUSID PICTURE X(8). 02 FILLER PICTURE X. 02 RESERVD PICTURE X(28). 02 FILLER PICTURE X. 02 HDRRPAR PICTURE X. 02 HDRCOMM. 03 HDRCOMM-PART1 PICTURE X(50). 03 HDRCOMM-PART2 PICTURE X(15). * 01 REC-WORK. 02 IMBEDDED-REC-LEN PIC S9(4) COMP. 02 REC-AREA PIC X(32700). * CVDA FIELDS 01 UOPST PIC S9(8) COMP. 01 UENST PIC S9(8) COMP. 01 UAM PIC S9(8) COMP. 01 UBLKFM PIC S9(8) COMP. 01 UESTATUS PIC S9(8) COMP. 01 URECFM PIC S9(8) COMP. * FIELDS USED FOR INQUIRE AND BROWSE PROCESSING OF INPUT FILE 01 BASENAME PIC X(44). 01 DSNAME PIC X(44). 01 KEYLEN PIC S9(8) COMP. 01 RKP PIC S9(8) COMP. 01 RECSIZE PIC S9(8) COMP. 01 RESPFLD PIC S9(8) COMP. 01 RID PIC S9(8) COMP. 01 REC-LENGTH PIC S9(8) COMP. * FIELDS USED FOR HEADER PROCESSING 77 RECLEN PICTURE 999 COMP VALUE 80. 77 RECNO PICTURE 999 USAGE IS COMP. 77 HDRLEN PICTURE 999 COMP VALUE 160. * LINKAGE SECTION. * ****************************************************************** * * * DEFINITION OF COMMUNICATION AREA * * ******************************** * * * * COMMUNICATION BETWEEN THE FILE TRANSFER PROGRAM AND THE USER * * APPLICATION IS ESTABLISHED BY A COMMAREA WITH THE FOLLOWING * * CONTENTS: * * - USER RETURN CODE : ON DOWNLOAD, IF THE USER PROGRAM RETURNS * * TO THE FILE TRANSFER PROGRAM WITH A NON- * * ZERO RETURN CODE, FILE TRANSFER IS * * TERMINATED WITH MESSAGE INW0027I. * * ON ENTRY TO THE USER PROGRAM, THIS FIELD * * IS SET TO HEX ZEROS. * * - HOST FILE NAME : HAS TO BE STORED IN THE HEADER RECORD * * - TS QUEUE NAME : SPECIFIES THE NAME OF THE TS QUEUE INTO * * WHICH THE DATA TO BE DOWNLOADED TO THE * * PC IS TO BE STORED. * * - HOST FILE TYPE : FILETYPE OR, IF COMMENTS WERE SPECIFIED, * * THE FIRST 8 BYTES OF THE COMMENTS * * - HEADER RECORD : CAN BE USED TO PASS INFORMATION TO THE * * USER PROGRAM FROM THE RECEIVE COMMAND * ****************************************************************** * 01 DFHCOMMAREA. 02 FILLER PICTURE XX. 02 URETCODE PICTURE 99 COMP. 02 UFILE PICTURE X(8). 02 UQUEUE PICTURE X(8). 02 TEST-TERMID REDEFINES UQUEUE. 03 FILLER PICTURE X(4). 03 TERMID PICTURE X(4). 02 UTYPE PICTURE X(8). 02 UHEADER PICTURE X(160). * * ***************************************************************** * * * START OF EXECUTION * * * ***************************************************************** * PROCEDURE DIVISION. * IF UFILE = SPACES THEN GO TO ERROR04. * EXEC CICS HANDLE CONDITION FILENOTFOUND(ERROR04) NOTAUTH(ERROR04) END-EXEC. * EXEC CICS INQUIRE FILE(UFILE) OPENSTATUS(UOPST) ENABLESTATUS(UENST) ACCESSMETHOD(UAM) END-EXEC. * * ***************************************************************** IF UOPST = DFHVALUE(CLOSED) EXEC CICS SET FILE(UFILE) OPEN END-EXEC. EXEC CICS INQUIRE FILE(UFILE) BASEDSNAME(BASENAME) BLOCKFORMAT(UBLKFM) DSNAME(DSNAME) EMPTYSTATUS(UESTATUS) KEYLENGTH(KEYLEN) KEYPOSITION(RKP) RECORDFORMAT(URECFM) RECORDSIZE(RECSIZE) END-EXEC. * * GET INFO ABOUT RECORDFORMAT FOR RECORD LEN IMBEDDING * ***************************************************************** * CHECK FOR STANDARD TS QUEUE NAME * ***************************************************************** * IF EIBTRMID NOT = TERMID THEN GO TO ERROR01. * ***************************************************************** * DELETE TS QUEUE, IF QUEUE ALREADY EXISTS * ***************************************************************** * * IF QUEUE DOES NOT EXIST GO TO WRITE-HEADER. * EXEC CICS HANDLE CONDITION QIDERR(WRITE-HEADER) END-EXEC. * * TRY TO READ THE QUEUE * MOVE 1 TO RECNO. EXEC CICS READQ TS QUEUE(UQUEUE) INTO(HDRECORD) ITEM(RECNO) LENGTH(HDRLEN) END-EXEC. * * DELETE THE QUEUE IF HOST FILENAME WAS NOT 'NODEL' * OTHERWISE TERMINATED WITH RETURN CODE * IF UFILE = 'NODEL' THEN GO TO ERROR03. * EXEC CICS DELETEQ TS QUEUE(UQUEUE) END-EXEC. * EXEC CICS SYNCPOINT END-EXEC. * ***************************************************************** * WRITE HEADER RECORD * ***************************************************************** * WRITE-HEADER. * EXEC CICS HANDLE CONDITION NOSPACE(ERROR02) END-EXEC. * MOVE SPACES TO HDRECORD. MOVE UFILE TO HDRFILE. MOVE 1 TO RECNO. ***************************************************************** * EXEC CICS WRITEQ TS QUEUE(UQUEUE) FROM(HDRECORD) ITEM(RECNO) LENGTH(HDRLEN) END-EXEC. * ***************************************************************** * READ RECORDS FROM THE DATASET AND WRITE TO USER TSQ * ***************************************************************** * MOVE ZERO TO RID EXEC CICS STARTBR DATASET(UFILE) RIDFLD(RID) END-EXEC. * CHECK STATUS, NOT OPEN ETC. * EXEC CICS HANDLE CONDITION NOTFND(INPUTEOF) END-EXEC. * COPY-REC-TO-TSQ. MOVE ZERO TO REC-LENGTH. EXEC CICS READNEXT DATASET(UFILE) INTO (REC-AREA) LENGTH(REC-LENGTH) RIDFLD(RID) END-EXEC. ***************************************************************** * WRITE NEXT RECORD * ***************************************************************** ADD 1 TO RECNO. * * IF RECORDS ARE VARIABLE, IMBED THE RECORD LENGTH + 2, ELSE * * WRITE THE RECORD TO THE TSQ AS IT IS. * IF URECFM = DFHVALUE(VARIABLE) MOVE REC-LENGTH TO IMBEDDED-REC-LEN ADD 2 TO IMBEDDED-REC-LEN EXEC CICS WRITEQ TS QUEUE(UQUEUE) FROM(REC-WORK) ITEM(RECNO) LENGTH(REC-LENGTH) END-EXEC ELSE EXEC CICS WRITEQ TS QUEUE(UQUEUE) FROM(REC-AREA) ITEM(RECNO) LENGTH(REC-LENGTH) END-EXEC. GO TO COPY-REC-TO-TSQ. * INPUTEOF. EXEC CICS ENDBR DATASET(UFILE) END-EXEC. * GO TO FINISH. * * ***************************************************************** * ERROR01: RC=0001 INVALID QUEUE NAME * ***************************************************************** * ERROR01. MOVE 1 TO URETCODE. GO TO FINISH. * ***************************************************************** * ERROR02: RC=0002 NO TEMPORARY STORAGE SPACE AVAILABLE * ***************************************************************** * ERROR02. MOVE 2 TO URETCODE. GO TO FINISH. * * ***************************************************************** * ERROR03: RC=0003 QUEUE ALREADY EXISTS * ***************************************************************** * ERROR03. MOVE 3 TO URETCODE. GO TO FINISH. * ***************************************************************** * ERROR04: RC=0004 DATASET ACCESS NOT AUTORISED * ***************************************************************** * IF NOT AUTHORIZED - ABEND CODE AEY7 * IF NOT FOUND - ABEND CODE AEIL * IF ANY OTHER ERROR - THEN PASS BACK GENERIC CODE * ERROR04. MOVE 4 TO URETCODE. GO TO FINISH. * ***************************************************************** * RETURN TO CALLING PROGRAM * ***************************************************************** * FINISH. EXEC CICS RETURN END-EXEC. GOBACK.