- 论坛徽章:
- 0
|
谁会用Cobol调用MQSeries
- 0001.00 IDENTIFICATION DIVISION.
- 0002.00 ****************************************************************
- 0003.00 * Program name: MQPUT001 *
- 0004.00 * *
- 0005.00 * Description: COBOL SUB PROGRAM THAT PUT MESSAGE TO A MESSAGE *
- 0006.00 * QUEUE. *
- 0007.00 *
- 0008.00 * WRITE BY JASON 1999/08/09 *
- 0008.01 * CHANGED 1: 2002/01/20 修改档案架构 DCAOCPP *
- 0009.00 * *
- 0010.00 ****************************************************************
- 0011.00 * *
- 0012.00 * Function: *
- 0013.00 * *
- 0014.00 * Program logic: *
- 0015.00 * 1.MQOPEN target queue for OUTPUT *
- 0016.00 * 2.MQPUT message with text to target queue *
- 0017.00 * 3.MQCLOSE target queue *
- 0018.00 * *
- 0019.00 ****************************************************************
- 0020.00 * AMQ0PUT4 has 3 parameter *
- 0021.00 * 1.NAME OF TARGET QUEUE(I) *
- 0022.00 * 2.BUFFER STARE THE DATA TO BE PUT INTO QUEUE(I) *
- 0023.00 * 3.DATA-LENGTH(I) LENGTH OF THE MESSAGE TO BE PUT *
- 0024.00 * 4.RETURN CODE *
- 0025.00 * --->;"Y":PUT MESSAGE OK.
- 0026.00 * --->;"N":PUT MESSAGE ERROR.
- 0027.00 *
- 0028.00 *****************************************************************
- 0029.00 * 使用说明
- 0030.00 * 将作业别写到 JOD-ID OF MSG-HEAD IN LK-BUFFER
- 0031.00 * 资料内容在ＭＳＧ－ＢＯＤＹ中
- 0032.00 * 资料长度放在 LK-DATA-LENGTH 中（不包括 MESSAGE HEAD)
- 0033.00 * 程序根据作业别自动获取使用的 MESSAGE QUEUE 名称，
- 0034.00 * 把相关信息自动写入 MESSAGE HEAD
- 0035.00 * 并将该 MESSAGE PUT 到对应的 MESSAGE QUEUE 中
- 0036.00 ****************************************************************
- 0037.00 PROGRAM-ID. MQPUT001.
- 0038.00
- 0039.00 ****************************************************************
- 0040.00 DATA DIVISION.
- 0041.00 ****************************************************************
- 0042.00 WORKING-STORAGE SECTION.
- 0043.00 ****************************************************************
- 0044.00 *
- 0045.00 ** Declare MQI structures needed
- 0046.00 * MQI named constants
- 0047.00 01 MY-MQ-CONSTANTS.
- 0048.00 COPY CMQV.
- 0049.00 * Object Descriptor
- 0050.00 01 OBJECT-DESCRIPTOR.
- 0051.00 COPY CMQODV.
- 0052.00 * Message Descriptor
- 0053.00 01 MESSAGE-DESCRIPTOR.
- 0054.00 COPY CMQMDV.
- 0055.00 * Put message options
- 0056.00 01 PMOPTIONS.
- 0057.00 COPY CMQPMOV.
- 0058.00 ** note, sample uses defaults where it can
- 0059.00 01 HCONN PIC S9(9) BINARY.
- 0060.00 01 Q-HANDLE PIC S9(9) BINARY.
- 0061.00 01 OPTIONS PIC S9(9) BINARY.
- 0062.00 01 COMPLETION-CODE PIC S9(9) BINARY.
- 0063.00 01 OPEN-CODE PIC S9(9) BINARY.
- 0064.00 01 REASON PIC S9(9) BINARY.
- 0065.00 01 WK-PGM-ID PIC X(10) VALUE "MQPUT001".
- 0066.00 01 WK-MSG-HEAD-LEN PIC S9(9) BINARY VALUE 256.
- 0067.00 01 WK-MSG-LENGTH PIC S9(9) BINARY.
- 0068.00
- 0069.00 * FOR GET QUEUE NAME BY JOB-ID
- 0070.00 01 WK-JOBID PIC X(13).
- 0071.00 01 WK-OUT-RETCD PIC X(7).
- 0072.00 01 WK-OUT-PARM.
- 0073.00 * 作业别代码
- 0074.00 03 OUT-JOBID PIC X(13).
- 0077.00 * ＭＱ－ＭＧＲ
- 0078.00 03 OUT-QMGR PIC X(10).
- 0079.00 * ＭＱ－名称
- 0080.00 03 OUT-QNAME PIC X(48).
- 0093.00
- 0094.00 ****************************************************************
- 0095.00 LINKAGE SECTION.
- 0096.00 ****************************************************************
- 0098.00 01 LK-BUFFER PIC X(4096).
- 0099.00 01 LK-BUFFER-DETAIL REDEFINES LK-BUFFER.
- 0100.00 03 MSG-HEAD PIC X(256).
- 0101.00 03 MSG-HEAD-DETAIL REDEFINES MSG-HEAD.
- 0101.01 *CHANGED
- 0102.00 COPY MQCPY001 OF FURCOPY.
- 0103.00 03 MSG-BODY PIC X(3840).
- 0104.00
- 0105.00 01 LK-DATA-LENGTH PIC S9(9) BINARY.
- 0106.00 01 LK-RTNCD PIC X(1).
- 0107.00
- 0108.00 ****************************************************************
- 0109.00 PROCEDURE DIVISION USING
- 0110.00 LK-BUFFER
- 0111.00 LK-DATA-LENGTH
- 0112.00 LK-RTNCD.
- 0113.00
- 0114.00 M010-INIT.
- 0115.00 MOVE "Y" TO LK-RTNCD.
- 0116.00 PERFORM S-040-GET-MQ-INFO THRU S-040-EXIT.
- 0117.00 PERFORM S-010-OPEN THRU S-010-EXIT.
- 0118.00 M020-MAIN.
- 0119.00 PERFORM S-020-PUT THRU S-020-EXIT.
- 0120.00 M030-FINISH.
- 0121.00 PERFORM S-030-CLOSE THRU S-030-EXIT.
- 0122.00 M040-EXIT.
- 0123.00 EXIT PROGRAM.
- 0124.00 STOP RUN.
- 0125.00
- 0126.00 ****************************************************************
- 0127.00 * OPEN QMGR AND QUEUE *
- 0128.00 ****************************************************************
- 0129.00 S-010-OPEN.
- 0130.00 ****************************************************************
- 0131.00 * MQCONN is implicit on OS/400; use the default *
- 0132.00 * connection handle for all MQI calls *
- 0133.00 ****************************************************************
- 0134.00 MOVE MQHC-DEF-HCONN to HCONN.
- 0135.00 ****************************************************************
- 0136.00 * Open the target message queue for output (and fail if *
- 0137.00 * MQM is quiescing) *
- 0138.00 ****************************************************************
- 0139.00 MOVE MESSAGE-QUEUE OF MSG-HEAD-DETAIL TO MQOD-OBJECTNAME.
- 0140.00 ADD MQOO-OUTPUT MQOO-FAIL-IF-QUIESCING
- 0141.00 GIVING OPTIONS.
- 0142.00 CALL "MQOPEN" USING
- 0143.00 HCONN, OBJECT-DESCRIPTOR,
- 0144.00 OPTIONS, Q-HANDLE,
- 0145.00 OPEN-CODE, REASON.
- 0146.00
- 0147.00 * report reason, if any; stop if failed
- 0148.00 IF REASON IS NOT EQUAL TO MQRC-NONE
- 0149.00 DISPLAY "MQOPEN ended with reason code " REASON
- 0150.00 DISPLAY "QNAME-->;" MQOD-OBJECTNAME
- 0151.00 DISPLAY "LK-BUFFER-->;" LK-BUFFER
- 0152.00 END-IF.
- 0153.00
- 0154.00 IF OPEN-CODE IS EQUAL TO MQCC-FAILED
- 0155.00 MOVE "E" TO LK-RTNCD
- 0156.00 DISPLAY "unable to open server queue for output"
- 0157.00 DISPLAY "QNAME-->;" MQOD-OBJECTNAME
- 0158.00 DISPLAY "LK-BUFFER-->;" LK-BUFFER
- 0159.00 GO TO M040-EXIT
- 0160.00 END-IF.
- 0161.00 S-010-EXIT.
- 0162.00
- 0163.00 *****************************************************************
- 0164.00 * PUT MESSAGE TO QUEUE *
- 0165.00 *****************************************************************
- 0166.00 S-020-PUT.
- 0167.00 MOVE LK-DATA-LENGTH TO WK-MSG-LENGTH.
- 0168.00 ADD WK-MSG-HEAD-LEN TO WK-MSG-LENGTH.
- 0169.00 * CALL "ZYMDSYS" USING SEND-DATE
- 0170.00 * WK-PGM-ID.
- 0171.00 * ACCEPT SEND-TIME FROM TIME.
- 0172.00 MOVE OPEN-CODE TO COMPLETION-CODE.
- 0173.00 * Set format to string so that the msg can be converted
- 0174.00 MOVE MQFMT-NONE to MQMD-FORMAT
- 0175.00 CALL "MQPUT" USING
- 0176.00 HCONN, Q-HANDLE,
- 0177.00 MESSAGE-DESCRIPTOR, PMOPTIONS,
- 0178.00 WK-MSG-LENGTH, LK-BUFFER,
- 0179.00 COMPLETION-CODE, REASON.
- 0180.00 * report reason, if any
- 0181.00 IF REASON IS NOT EQUAL TO MQRC-NONE
- 0182.00 DISPLAY "MQPUT ended with reason code " REASON
- 0183.00 MOVE "E" TO LK-RTNCD
- 0184.00 END-IF.
- 0185.00
- 0186.00 S-020-EXIT.
- 0187.00
- 0188.00 *****************************************************************
- 0189.00 * CLOSE QUEUE *
- 0190.00 *****************************************************************
- 0191.00 S-030-CLOSE.
- 0192.00 MOVE MQCO-NONE TO OPTIONS.
- 0193.00 CALL "MQCLOSE" USING
- 0194.00 HCONN, Q-HANDLE, OPTIONS,
- 0195.00 COMPLETION-CODE, REASON.
- 0196.00
- 0197.00 IF REASON IS NOT EQUAL TO MQRC-NONE
- 0198.00 DISPLAY "MQCLOSE ended with reason code " REASON
- 0199.00 END-IF.
- 0200.00 S-030-EXIT.
- 0201.00 *****************************************************************
- 0202.00 * 以作业别获取ＭＱ资料，并写入ＭＥＳＳＡＧＥ ＨＥＡＤ
- 0203.00 *****************************************************************
- 0204.00 S-040-GET-MQ-INFO.
- 0205.00 * 作业别代码
- 0206.00 MOVE JOB-ID OF MSG-HEAD-DETAIL TO WK-JOBID.
- 0207.00 * 以作业别获取 MESSAGE QUEUE 信息
- 0207.01 *CHANGED
- 0208.00 CALL "GETMQINF" USING WK-JOBID
- 0209.00 WK-OUT-RETCD
- 0210.00 WK-OUT-PARM.
- 0211.00 CANCEL "GETMQINF".
- 0211.01 * CALL "GETMQINF1" USING WK-JOBID
- 0211.02 * WK-OUT-RETCD
- 0211.03 * WK-OUT-PARM.
- 0211.04 * CANCEL "GETMQINF1".
- 0212.00 IF NOT WK-OUT-RETCD = SPACES
- 0213.00 DISPLAY " 以作业别获取 MESSAGE QUEUE 信息失败 "
- 0214.00 MOVE "E" TO LK-RTNCD
- 0215.00 GO TO M040-EXIT
- 0216.00 END-IF.
- 0217.00 * 将ＭＱ信息写入ＭＥＳＳＡＧＥ ＨＥＡＤ
- 0218.00 * 作业别代码
- 0219.00 MOVE OUT-JOBID TO JOB-ID OF MSG-HEAD-DETAIL.
- 0222.00 * ＭＱ－ＭＧＲ
- 0223.00 MOVE OUT-QMGR TO SOURCE-QMGR OF MSG-HEAD-DETAIL.
- 0224.00 * ＭＱ－名称
- 0225.00 MOVE OUT-QNAME TO MESSAGE-QUEUE OF MSG-HEAD-DETAIL.
- 0238.00 S-040-EXIT.
|
|
免费注册
发表于 2005-07-11 17:24
