midrange.com code scratchpad
Name:
Link400 SDLC communications
Scriptlanguage:
Plain Text
Tabwidth:
4
Date:
04/03/2026 04:41:52 pm
IP:
Logged
Description:
Old Code not used for 10-15 years. Look for the CRTLINSDLC commands to create the dialing system (TEMPLCL) and answering system (TEMPRMT). This program if it works can start a passthru session or transfer or receive files
Code:
  1.              CMD        PROMPT('Link to another AS/400')
  2.              PARM       KWD(SYSTEM) TYPE(*CHAR) LEN(1) RSTD(*YES) +
  3.                           VALUES('S' 'T' 'D' 'P' 'Y') MIN(1) +
  4.                           PROMPT('Source,Target or Delivery')
  5.              PARM       KWD(FUNCTION) TYPE(*CHAR) LEN(1) RSTD(*YES) +
  6.                           VALUES('F' 'P' 'O') PROMPT('File +
  7.                           Tfr,PassThru,Send Objects')
  8.              PARM       KWD(RMTPHONE) TYPE(*CHAR) LEN(15) +
  9.                           SPCVAL((*SEARCH) (*S *SEARCH)) +
  10.                           PMTCTL(SYSTEM) PROMPT('Remote Phone#')
  11.              PARM       KWD(PASSWORD) TYPE(*CHAR) LEN(10) MIN(1) +
  12.                           PROMPT('Password for Remote AS/400')
  13.              PARM       KWD(OPTION) TYPE(*CHAR) LEN(1) RSTD(*YES) +
  14.                           VALUES('S' 'R') PROMPT('Option: S=Send, +
  15.                           R=Receive') PMTCTL(FUNCTION1)
  16.              PARM       KWD(FROMLIB) TYPE(*CHAR) LEN(10) +
  17.                           PROMPT('From Library Name') PMTCTL(FUNCTION)
  18.              PARM       KWD(FROMFILE) TYPE(*CHAR) LEN(10) +
  19.                           PROMPT('From Data Base Name') PMTCTL(FUNCTION)
  20.              PARM       KWD(FROMMBR) TYPE(*CHAR) LEN(10) +
  21.                           PROMPT('From Member Name') PMTCTL(FUNCTION)
  22.              PARM       KWD(TOLIB) TYPE(*CHAR) LEN(10) PROMPT('Target +
  23.                           Library (Dft FROMLIB)') PMTCTL(FUNCTION)
  24.              PARM       KWD(TOFILE) TYPE(*CHAR) LEN(10) +
  25.                           PROMPT('Target File (Dft FROMFILE)') +
  26.                           PMTCTL(FUNCTION)
  27.              PARM       KWD(TOMBR) TYPE(*CHAR) LEN(10) +
  28.                           PROMPT('Target File Mbr (Dft FROMMBR)') +
  29.                           PMTCTL(FUNCTION)
  30.              PARM       KWD(REPLACE) TYPE(*CHAR) LEN(1) RSTD(*YES) +
  31.                           VALUES('Y' 'N') PROMPT('Replace Member if +
  32.                           Exists?') PMTCTL(FUNCTION)
  33.              PARM       KWD(SBMJOB) TYPE(*CHAR) LEN(4) RSTD(*YES) +
  34.                           DFT(*NO) VALUES(*YES *NO) PROMPT('Submit +
  35.                           Job to Batch')  PMTCTL(FUNCTION)
  36.              PARM       KWD(SCDTIME) TYPE(*CHAR) LEN(9) +
  37.                           DFT(*CURRENT) SPCVAL((*CALLBACK) +
  38.                           (*CURRENT)) PROMPT('Time to Run Submitted +
  39.                           Job') PMTCTL(FUNCTION)
  40.              PARM       KWD(HANGUP) TYPE(*CHAR) LEN(4) RSTD(*YES) +
  41.                           DFT(*NO) VALUES(*YES *NO) +
  42.                           PMTCTL(FUNCTION) PROMPT('Hang up Phone +
  43.                           when done')
  44.              PARM       KWD(OBJFRMLIB) TYPE(*NAME) LEN(10) +
  45.                           PROMPT('Library')  PMTCTL(SNDOBJ)
  46.              PARM       KWD(OBJ) TYPE(*GENERIC) LEN(10) +
  47.                           SPCVAL((*ALL)) MAX(1) PMTCTL(SNDOBJ) +
  48.                           PROMPT('Objects')
  49.              PARM       KWD(OBJTYPE) TYPE(*CHAR) LEN(7) RSTD(*YES) +
  50.                           DFT(*ALL) VALUES(*CMD *DTAARA *FILE *JOBD +
  51.                           *JOBQ *JRN *JRNRCV *MENU *MSGF *MSGQ +
  52.                           *PGM) SPCVAL((*ALL)) CHOICE('*ALL, *CMD, +
  53.                           *DTAARA...') PMTCTL(SNDOBJ) +
  54.                           PROMPT('Object types')
  55.              PARM       KWD(FILEMBR) TYPE(*GENERIC) LEN(10) +
  56.                           DFT(*ALL) SPCVAL((*ALL)) PMTCTL(SNDOBJ) +
  57.                           PROMPT('File members')
  58.              PARM       KWD(TGTRLS) TYPE(*CHAR) LEN(8) RSTD(*YES) +
  59.                           DFT(*CURRENT) VALUES(*CURRENT *PRV) +
  60.                           MIN(0) PMTCTL(SNDOBJ) PROMPT('Target +
  61.                           Release')
  62.              PARM       KWD(OBJTOLIB) TYPE(*NAME) LEN(10) +
  63.                           PMTCTL(SNDOBJ) PROMPT('Restore to Library')
  64.  
  65.  SYSTEM:     PMTCTL     CTL(SYSTEM) COND((*EQ S)) NBRTRUE(*EQ 1)
  66.  FUNCTION:   PMTCTL     CTL(FUNCTION) COND((*EQ F)) NBRTRUE(*EQ 1)
  67.  FUNCTION1:  PMTCTL     CTL(FUNCTION) COND((*EQ F) (*EQ O)) +
  68.                           NBRTRUE(*EQ 1)
  69.  PASSTHRU:   PMTCTL     CTL(FUNCTION) COND((*EQ P)) NBRTRUE(*EQ 1)
  70.  SNDOBJ:     PMTCTL     CTL(FUNCTION) COND((*EQ O)) NBRTRUE(*EQ 1)
  71.               PGM        PARM(&SYSTEM &FUNCTION &RMTPHONE &PASSWORD +
  72.                           &OPTION &FROMLIB &FROMFILE &FROMMBR +
  73.                           &TOLIB &TOFILE &TOMBR &REPLACE &SBMJOB +
  74.                           &SCDTIME &HANGUP &OBJFRMLIB &OBJ &OBJTYPE +
  75.                           &FILEMBR &TGTRLS &OBJTOLIB)
  76.              DCL        VAR(&SYSTEM) TYPE(*CHAR) LEN(1)
  77.              DCL        VAR(&FUNCTION) TYPE(*CHAR) LEN(1)
  78.              DCL        VAR(&OPTION) TYPE(*CHAR) LEN(1)
  79.              DCL        VAR(&FROMLIB) TYPE(*CHAR) LEN(10)
  80.              DCL        VAR(&FROMFILE) TYPE(*CHAR) LEN(10)
  81.              DCL        VAR(&FROMMBR) TYPE(*CHAR) LEN(10)
  82.              DCL        VAR(&TYPE) TYPE(*CHAR) LEN(6) VALUE(' ')
  83.              DCL        VAR(&TOLIB) TYPE(*CHAR) LEN(10)
  84.              DCL        VAR(&TOFILE) TYPE(*CHAR) LEN(10)
  85.              DCL        VAR(&TOMBR) TYPE(*CHAR) LEN(10)
  86.              DCL        VAR(&TODATE) TYPE(*CHAR) LEN(6) VALUE(' ')
  87.              DCL        VAR(&REPLACE) TYPE(*CHAR) LEN(1)
  88.              DCL        VAR(&SBMJOB) TYPE(*CHAR) LEN(4)
  89.              DCL        VAR(&SCDTIME) TYPE(*CHAR) LEN(9)
  90.              DCL        VAR(&SVSCDTIME) TYPE(*CHAR) LEN(9)
  91.              DCL        VAR(&QTIME) TYPE(*CHAR) LEN(6)
  92.              DCL        VAR(&QTIMEN1) TYPE(*DEC) LEN(6)
  93.              DCL        VAR(&QTIMEN2) TYPE(*DEC) LEN(6)
  94.              DCL        VAR(&HANGUP) TYPE(*CHAR) LEN(4)
  95.              DCL        VAR(&OBJFRMLIB) TYPE(*CHAR) LEN(10)
  96.              DCL        VAR(&OBJ) TYPE(*CHAR) LEN(10)
  97.              DCL        VAR(&OBJTYPE) TYPE(*CHAR) LEN(7)
  98.              DCL        VAR(&FILEMBR) TYPE(*CHAR) LEN(10)
  99.              DCL        VAR(&TGTRLS) TYPE(*CHAR) LEN(8)
  100.              DCL        VAR(&OBJTOLIB) TYPE(*CHAR) LEN(10)
  101.  
  102.              DCL        VAR(&RMTPHONE) TYPE(*CHAR) LEN(15)
  103.              DCL        VAR(&RMTLOCNAME) TYPE(*CHAR) LEN(8)
  104.              DCL        VAR(&CNNDEV) TYPE(*CHAR) LEN(10)
  105.              DCL        VAR(&CNNDEVB4) TYPE(*CHAR) LEN(10)
  106.              DCL        VAR(&PASSWORD) TYPE(*CHAR) LEN(10)
  107.              DCL        VAR(&RCODE) TYPE(*CHAR) LEN(2)
  108.              DCL        VAR(&MSGNUM) TYPE(*CHAR) LEN(8)
  109.              DCL        VAR(&USERID) TYPE(*CHAR) LEN(10)
  110.              DCL        VAR(&RMTUSERID) TYPE(*CHAR) LEN(10)
  111.              DCL        VAR(&BATCHJOB) TYPE(*CHAR) LEN(1)
  112.              DCL        VAR(&CFGSTS) TYPE(*DEC) LEN(5 0)
  113.              DCL        VAR(&REPLY) TYPE(*CHAR) LEN(1)
  114.              DCL        VAR(&REPLY2) TYPE(*CHAR) LEN(1)
  115.              DCL        VAR(&REPLY3) TYPE(*CHAR) LEN(1)
  116.              DCL        VAR(&STRLEN) TYPE(*DEC) LEN(3) VALUE(10)
  117.              DCL        VAR(&STRPOS) TYPE(*DEC) LEN(3) VALUE(1)
  118.              DCL        VAR(&PATLEN) TYPE(*DEC) LEN(3) VALUE(1)
  119.              DCL        VAR(&RESULT) TYPE(*DEC) LEN(3)
  120.              DCL        VAR(&RTNMBR) TYPE(*CHAR) LEN(10)
  121.              DCL        VAR(&FROMGEN) TYPE(*CHAR) LEN(10)
  122.              DCL        VAR(&RECORDS) TYPE(*DEC) LEN(15 5)
  123.              DCL        VAR(&TOTALBYTE) TYPE(*DEC) LEN(15 5)
  124.              DCL        VAR(&SECONDS) TYPE(*DEC) LEN(15 5)
  125.              DCL        VAR(&MINUTES) TYPE(*DEC) LEN(15 2)
  126.              DCL        VAR(&MINUTESA) TYPE(*CHAR) LEN(10)
  127.              DCL        VAR(&SYSTEMO) TYPE(*CHAR) LEN(1)
  128.              DCL        VAR(&ERRORSW) TYPE(*LGL) /* Error +
  129.                           switch            */
  130.              DCL        VAR(&MSGID) TYPE(*CHAR) LEN(7) /* Message +
  131.                           ID              */
  132.              DCL        VAR(&MSGDTA) TYPE(*CHAR) LEN(100) /* Message +
  133.                           data area       */
  134.              DCL        VAR(&MSGF) TYPE(*CHAR) LEN(10) /* Message +
  135.                           file name       */
  136.              DCL        VAR(&MSGFLIB) TYPE(*CHAR) LEN(10) /* Message +
  137.                           library         */
  138.              DCL        VAR(&CMDMSG) TYPE(*CHAR) LEN(255)
  139.              DCL        VAR(&APOST) TYPE(*CHAR) LEN(1)
  140.              DCL        VAR(&TIME) TYPE(*CHAR) LEN(6)
  141.              DCL        VAR(&TIMEI) TYPE(*DEC) LEN(15)
  142.              DCL        VAR(&TIMEO) TYPE(*CHAR) LEN(22)
  143.              CHGVAR     VAR(&APOST) VALUE(X'7D')
  144.              ADDLIBLE   LIB(TAATOOL) POSITION(*LAST)
  145.              MONMSG     MSGID(CPF0000)
  146.              RTVUSRPRF  RTNUSRPRF(&RMTUSERID)
  147.              CHGVAR     VAR(&SVSCDTIME) VALUE(&SCDTIME)
  148.  
  149. /* IF *SEARCH SPECIFIED FOR PHONE NUMBER, GO TO IT */
  150.  
  151.              IF         COND(&RMTPHONE *EQ '*SEARCH        ') THEN(DO)
  152.              CALL       PGM(ECSSRCHR) PARM(&RMTPHONE)
  153.              IF         COND(&RMTPHONE *EQ '*SEARCH        ') THEN(DO)
  154.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('No +
  155.                           Phone Number selected.  Program +
  156.                           cancelled.') MSGTYPE(*ESCAPE)
  157.              GOTO       CMDLBL(ENDPROGRAM)
  158.              ENDDO
  159.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Setting +
  160.                           controller to dial' *BCAT &RMTPHONE) +
  161.                           TOPGMQ(*EXT) MSGTYPE(*STATUS)
  162.              ENDDO
  163.  
  164.              IF         COND(&RMTUSERID *EQ 'QUSER     ' *AND +
  165.                           &SCDTIME *NE '*CALLBACK') THEN(DO)
  166.              IF         COND(&SYSTEM *EQ 'T') THEN(CHGVAR +
  167.                           VAR(&RMTLOCNAME) VALUE('TEMPLCL'))
  168.              IF         COND(&SYSTEM *EQ 'S') THEN(CHGVAR +
  169.                           VAR(&RMTLOCNAME) VALUE('TEMPRMT'))
  170.  
  171. /* CHANGE MADE FOR LEASED LINE TO HANDLING */
  172.  
  173.              IF         COND(&SYSTEM *EQ 'D') THEN(CHGVAR +
  174.                           VAR(&RMTLOCNAME) VALUE('DYNDLV'))
  175.  
  176. /* CHANGE MADE FOR LEASED LINE TO HANDLING */
  177.  
  178.              IF         COND(&SYSTEM *EQ 'P') THEN(CHGVAR +
  179.                           VAR(&RMTLOCNAME) VALUE('PDSI'))
  180.              IF         COND(&SYSTEM *EQ 'Y') THEN(CHGVAR +
  181.                           VAR(&RMTLOCNAME) VALUE('DYNY2K'))
  182.  
  183.              CRTDDMF    FILE(QTEMP/RMTCMD) RMTFILE(*LIBL/PMENUS) +
  184.                           RMTLOCNAME(&RMTLOCNAME) TEXT('Temporary +
  185.                           DDM file to use SBM-RMTCMD')
  186.              ENDDO
  187.  
  188. /* ONLY DO THIS STUFF IF NOT RECEIVE OBJECT */
  189.  
  190.              IF         COND(&OPTION *EQ 'R' *AND &FUNCTION *EQ 'O') +
  191.                           THEN(DO)
  192.              GOTO       CMDLBL(SKIPSTUFF)
  193.              ENDDO
  194.  
  195.              IF         COND(&FUNCTION *NE ' ' *AND &FUNCTION *NE +
  196.                           'O' *AND &PASSWORD *EQ ' ') THEN(DO)
  197.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) +
  198.                           MSGDTA('Password cannot be Blank.  Please +
  199.                           re-try') MSGTYPE(*ESCAPE)
  200.              GOTO       CMDLBL(ENDPROGRAM)
  201.              ENDDO
  202.  
  203. /* GET USER PROFILE */
  204.  
  205.              RTVUSRPRF  RTNUSRPRF(&USERID)
  206.  
  207. /* GET USER PROFILE */
  208.  
  209.              RTVJOBA    TYPE(&BATCHJOB)
  210.  
  211. /* SETUP VARIABLES FOR SOURCE OR TARGET, AND FIGURE OUT THERE  +
  212.    CONFIGURATION STATUS */
  213.  
  214.              IF         COND(&SYSTEM *EQ 'D') THEN(DO)
  215.              CHGVAR     VAR(&RMTLOCNAME) VALUE('DYNDLV')
  216.              CHGVAR     VAR(&CNNDEV) VALUE('DYNDLV')
  217.              ENDDO
  218.  
  219.              IF         COND(&SYSTEM *EQ 'P') THEN(DO)
  220.              CHGVAR     VAR(&RMTLOCNAME) VALUE('PDSI')
  221.              CHGVAR     VAR(&CNNDEV) VALUE('PDSI')
  222.              ENDDO
  223.  
  224.              IF         COND(&SYSTEM *EQ 'Y') THEN(DO)
  225.              CHGVAR     VAR(&RMTLOCNAME) VALUE('DYNY2K')
  226.              CHGVAR     VAR(&CNNDEV) VALUE('DYNY2K')
  227.              ENDDO
  228.  
  229.              IF         COND(&SYSTEM *EQ 'S') THEN(DO)
  230.              CHGVAR     VAR(&RMTLOCNAME) VALUE('TEMPRMT')
  231.              CHGVAR     VAR(&CNNDEV) VALUE('TEMPLCL')
  232.              RTVCFGSTS  CFGD(TEMPLCL) CFGTYPE(*LIN) STSCDE(&CFGSTS)
  233.              MONMSG     MSGID(CPF0000) EXEC(DO)
  234.              CHGVAR     VAR(&CFGSTS) VALUE(99)
  235.              ENDDO
  236.  
  237. /* CHANGE MADE 10/17/94 BY ART TOSTAINE, JR. */
  238. /* IF *CALLBACK, PAUSE 3 MINUTES */
  239.  
  240.              IF         COND(&SCDTIME *EQ '*CALLBACK') THEN(DO)
  241.              VRYCFG     CFGOBJ(TEMPRMT) CFGTYPE(*LIN) STATUS(*OFF)
  242.              MONMSG     CPF0000
  243.              VRYCFG     CFGOBJ(TEMPRMT) CFGTYPE(*CTL) STATUS(*OFF)
  244.              MONMSG     CPF0000
  245.              DLYJOB     DLY(180)
  246.              CHGVAR     VAR(&SCDTIME) VALUE('*CURRENT')
  247.              ENDDO
  248.  
  249. /* IF SOURCE SYSTEM CONNECT PENDING AND PHONE NUMBER GIVEN, VARY IT +
  250.    OFF AND CHANGE THE PHONE NUMBER ON THE CONTROLLER */
  251.  
  252.              IF         COND(&CFGSTS *EQ 40 *AND &RMTPHONE *NE ' ') +
  253.                           THEN(DO)
  254.              VRYCFG     CFGOBJ(TEMPLCL) CFGTYPE(*LIN) STATUS(*OFF)
  255.              VRYCFG     CFGOBJ(TEMPLCL) CFGTYPE(*CTL) STATUS(*OFF)
  256.              CHGCTLAPPC CTLD(TEMPLCL) CNNNBR(&RMTPHONE)
  257.              GOTO       CMDLBL(SKPCRTLCL) /* Skip create local +
  258.                           configurations */
  259.              ENDDO
  260.  
  261. /* VARIED OFF, CHANGE PHONE NUMBER */
  262.  
  263.              IF         COND(&CFGSTS *EQ 0) THEN(DO)
  264.              CHGCTLAPPC CTLD(TEMPLCL) CNNNBR(&RMTPHONE)
  265.  
  266. /* CHECK IF TARGET CONFIGURATIONS ARE ACTIVE */
  267.  
  268.              RTVCFGSTS  CFGD(TEMPRMT) CFGTYPE(*LIN) STSCDE(&CFGSTS)
  269.              IF         COND(&CFGSTS *EQ 60) THEN(DO) /* Active */
  270.              SNDUSRMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Target +
  271.                           Configs currently active.  "C" to Cancel +
  272.                           Vary on, "G" to Vary on Device') VALUES(C +
  273.                           G) DFT(C) MSGRPY(&REPLY)
  274.              IF         COND(&REPLY *EQ 'C') THEN(DO)
  275.              GOTO       CMDLBL(ENDPROGRAM)
  276.              ENDDO      /* Reply *EQ C */
  277.              VRYCFG     CFGOBJ(TEMPRMT) CFGTYPE(*LIN) STATUS(*OFF)
  278.              MONMSG     MSGID(CPF0000)
  279.              VRYCFG     CFGOBJ(TEMPRMT) CFGTYPE(*CTL) STATUS(*OFF)
  280.              MONMSG     MSGID(CPF0000)
  281.              DLYJOB     DLY(2)
  282.              ENDDO      /* &CFGSTS *EQ 60 */
  283.  
  284.              IF         COND(&CFGSTS *EQ 40) THEN(DO) /* Connect +
  285.                           Pending */
  286.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Target +
  287.                           Communications VARIED ON.  VARYing Off +
  288.                           Target now.') TOPGMQ(*EXT) MSGTYPE(*STATUS)
  289.              VRYCFG     CFGOBJ(TEMPRMT) CFGTYPE(*LIN) STATUS(*OFF)
  290.              VRYCFG     CFGOBJ(TEMPRMT) CFGTYPE(*CTL) STATUS(*OFF)
  291.              DLYJOB     DLY(2)
  292.              ENDDO
  293.              GOTO       CMDLBL(SKPCRTLCL) /* Skip Create +
  294.                           Configurations */
  295.              ENDDO      /* CFGSTS *EQ 40 */
  296.  
  297.              IF         COND(&CFGSTS *EQ 60) THEN(DO) /* Active */
  298.              GOTO       CMDLBL(SKPCRTLCL)
  299.              ENDDO
  300.  
  301.              CRTLINSDLC LIND(TEMPLCL) RSRCNAME(LIN011) ONLINE(*NO) +
  302.                           ROLE(*PRI) CNN(*SWTPP) EXCHID(05600001) +
  303.                           LINESPEED(2400) AUTODIAL(*YES) +
  304.                           DIALCMD(*V25BIS) DUPLEX(*FULL) +
  305.                           TEXT('Local Line for PassThru & File +
  306.                           Transfer')
  307.              MONMSG     MSGID(CPF0000)
  308.              CRTCTLAPPC CTLD(TEMPLCL) LINKTYPE(*SDLC) ONLINE(*NO) +
  309.                           SWITCHED(*YES) APPN(*NO) +
  310.                           SWTLINLST(TEMPLCL) MAXFRAME(521) +
  311.                           RMTNETID(*NONE) EXCHID(05600002) +
  312.                           CNNNBR(&RMTPHONE) ROLE(*SEC) STNADR(01) +
  313.                           TEXT('Local Controller for PassThru & +
  314.                           File Transfer')
  315.              MONMSG     MSGID(CPF0000)
  316.              CRTDEVAPPC DEVD(TEMPLCL) RMTLOCNAME(TEMPRMT) +
  317.                           ONLINE(*NO) LCLLOCNAME(TEMPLCL) +
  318.                           RMTNETID(*NONE) CTL(TEMPLCL) MODE(BLANK) +
  319.                           APPN(*NO) TEXT('Local Device for PassThru +
  320.                           / File Transfer')
  321.              MONMSG     MSGID(CPF0000)
  322.  
  323.  SKPCRTLCL:  DLYJOB     DLY(1)
  324.              VRYCFG     CFGOBJ(TEMPLCL) CFGTYPE(*LIN) STATUS(*ON)
  325.              DLYJOB     DLY(4)
  326.              VRYCFG     CFGOBJ(TEMPLCL) CFGTYPE(*CTL) STATUS(*ON)
  327.              ENDDO      /* SYSTEM *EQ S */
  328.  
  329.              IF         COND(&SYSTEM *EQ 'T') THEN(DO)
  330.              RTVCFGSTS  CFGD(TEMPRMT) CFGTYPE(*LIN) STSCDE(&CFGSTS)
  331. /*           MONMSG     MSGID(CPF9801) EXEC(DO)                */
  332. /*           CHGVAR     &CFGSTS 99                             */
  333. /*           ENDDO                                             */
  334.              IF         COND(&CFGSTS *EQ 0) THEN(DO)
  335.              RTVCFGSTS  CFGD(TEMPLCL) CFGTYPE(*LIN) STSCDE(&CFGSTS)
  336. /*           MONMSG     MSGID(CPF9801) EXEC(DO)                */
  337. /*           CHGVAR     &CFGSTS 99                             */
  338. /*           ENDDO                                             */
  339.              IF         COND(&CFGSTS *EQ 60) THEN(DO) /* Active */
  340.              SNDUSRMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Source +
  341.                           Configs currently active.  Enter "C" to +
  342.                           Cancel Vary on, "G" to Ignore') VALUES(C +
  343.                           G) DFT(C) MSGRPY(&REPLY)
  344.  
  345.              IF         COND(&REPLY *EQ 'C') THEN(DO)
  346.              GOTO       CMDLBL(ENDPROGRAM)
  347.              ENDDO      /* Reply *EQ "C" */
  348.  
  349. /* VARY OFF SOURCE CONFIGURATIONS */
  350.  
  351.              VRYCFG     CFGOBJ(TEMPLCL) CFGTYPE(*LIN) STATUS(*OFF)
  352.              MONMSG     MSGID(CPF0000)
  353.              VRYCFG     CFGOBJ(TEMPLCL) CFGTYPE(*CTL) STATUS(*OFF)
  354.              MONMSG     MSGID(CPF0000)
  355.              ENDDO      /* TEMPLCL CFGSTS *EQ 60 */
  356.  
  357.              IF         COND(&CFGSTS *EQ 40) THEN(DO) /* Connect +
  358.                           Pending */
  359.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Source +
  360.                           Communications VARIED ON.  VARYing Off +
  361.                           Source now.') TOPGMQ(*EXT) MSGTYPE(*STATUS)
  362.              VRYCFG     CFGOBJ(TEMPLCL) CFGTYPE(*LIN) STATUS(*OFF)
  363.              VRYCFG     CFGOBJ(TEMPLCL) CFGTYPE(*CTL) STATUS(*OFF)
  364.              ENDDO      /* CFGSTS *EQ "40" */
  365.              ENDDO      /* TEMPRMT CFGSTS *EQ 0 */
  366.  
  367.              CHGVAR     VAR(&RMTLOCNAME) VALUE('TEMPLCL')
  368.              CHGVAR     VAR(&CNNDEV) VALUE('TEMPRMT')
  369.              CRTLINSDLC LIND(TEMPRMT) RSRCNAME(LIN011) ONLINE(*YES) +
  370.                           ROLE(*SEC) CNN(*SWTPP) EXCHID(05600002) +
  371.                           LINESPEED(2400) AUTODIAL(*YES) +
  372.                           DIALCMD(*V25BIS) STNADR(01) DUPLEX(*FULL) +
  373.                           TEXT('Remote Line for PassThru / File +
  374.                           Transfer')
  375.              MONMSG     MSGID(CPF0000)
  376.              CRTCTLAPPC CTLD(TEMPRMT) LINKTYPE(*SDLC) ONLINE(*YES) +
  377.                           SWITCHED(*YES) APPN(*NO) +
  378.                           SWTLINLST(TEMPRMT) MAXFRAME(521) +
  379.                           RMTNETID(*NONE) EXCHID(05600001) +
  380.                           INLCNN(*ANS) ROLE(*PRI) STNADR(01) +
  381.                           TEXT('Remote Controller for PassThru / +
  382.                           File Transfer')
  383.              MONMSG     MSGID(CPF0000)
  384.              CRTDEVAPPC DEVD(TEMPRMT) RMTLOCNAME(TEMPLCL) +
  385.                           ONLINE(*YES) LCLLOCNAME(TEMPRMT) +
  386.                           RMTNETID(*NONE) CTL(TEMPRMT) MODE(BLANK) +
  387.                           APPN(*NO) TEXT('Remote Device for +
  388.                           PassThru / File Transfer')
  389.              MONMSG     MSGID(CPF0000)
  390.              VRYCFG     CFGOBJ(TEMPRMT) CFGTYPE(*LIN) STATUS(*ON)
  391.              VRYCFG     CFGOBJ(TEMPRMT) CFGTYPE(*CTL) STATUS(*ON)
  392.              ENDDO      /* SYSTEM *EQ "T" */
  393.  
  394.              RMVMSG     MSGQ(*PGMQ) CLEAR(*ALL)
  395.  
  396. SKIPSTUFF:
  397.  
  398.              IF         COND(&FUNCTION *EQ 'F') THEN(DO)
  399.  
  400. /* DECIDE IF GENERIC NAME GIVEN */
  401.  
  402.              CALL       PGM(QCLSCAN) PARM(&FROMMBR &STRLEN &STRPOS +
  403.                           '*' &PATLEN '0' '0' ' ' &RESULT)
  404.              IF         COND(&RESULT *GT 0) THEN(DO)
  405.              CHGVAR     VAR(&RESULT) VALUE(&RESULT - 1)
  406.              GOTO       CMDLBL(GENERIC)
  407.              ENDDO
  408.  
  409. /* SET UP TO DEFAULTS IF NOT GIVEN */
  410.  
  411.              IF         COND(&TOLIB *EQ ' ') THEN(DO)
  412.              CHGVAR     VAR(&TOLIB) VALUE(&FROMLIB)
  413.              ENDDO
  414.              IF         COND(&TOFILE *EQ ' ') THEN(DO)
  415.              CHGVAR     VAR(&TOFILE) VALUE(&FROMFILE)
  416.              ENDDO
  417.              IF         COND(&TOMBR *EQ ' ') THEN(DO)
  418.              CHGVAR     VAR(&TOMBR) VALUE(&FROMMBR)
  419.              ENDDO
  420.  
  421. /* CHECK IF TO LIBRARY & TO FILE EXIST IF RECEIVE */
  422.  
  423.              IF         COND(&OPTION *EQ 'R') THEN(DO)
  424.              CHKOBJ     OBJ(&TOLIB) OBJTYPE(*LIB)
  425.              MONMSG     MSGID(CPF9801) EXEC(DO)
  426.              RMVMSG     PGMQ(*EXT) CLEAR(*ALL)
  427.              SNDUSRMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Library' +
  428.                           *BCAT &TOLIB *TCAT ' does not exist.  +
  429.                           Create it?  (Y/N)') VALUES(Y N) +
  430.                           MSGRPY(&REPLY2)
  431.              IF         COND(&REPLY2 *EQ 'N') THEN(DO)
  432.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('LINK400 +
  433.                           Receive cancelled by user') MSGTYPE(*ESCAPE)
  434.              GOTO       CMDLBL(ENDPROGRAM)
  435.              ENDDO
  436.              IF         COND(&REPLY2 *EQ 'Y') THEN(DO)
  437.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) +
  438.                           MSGDTA('Creating' *BCAT &TOLIB) +
  439.                           TOPGMQ(*EXT) MSGTYPE(*STATUS)
  440.              CRTLIB     LIB(&TOLIB) TEXT('Created by LINK400')
  441.              ENDDO
  442.  
  443. /* SOURCE FILE */
  444.  
  445.              IF         COND(%SST(&TOFILE 1 1) *EQ 'Q') THEN(DO)
  446.              CHKOBJ     OBJ(&TOFILE) OBJTYPE(*LIB)
  447.              MONMSG     MSGID(CPF9801) EXEC(DO)
  448.              RMVMSG     PGMQ(*EXT) CLEAR(*ALL)
  449.              SNDUSRMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Source +
  450.                           File' *BCAT &TOFILE *TCAT ' does not +
  451.                           exist.  Create it?  (Y/N)') VALUES(Y N) +
  452.                           MSGRPY(&REPLY2)
  453.              IF         COND(&REPLY2 *EQ 'N') THEN(DO)
  454.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('LINK400 +
  455.                           Receive cancelled by user') MSGTYPE(*ESCAPE)
  456.              GOTO       CMDLBL(ENDPROGRAM)
  457.              ENDDO
  458.              IF         COND(&REPLY2 *EQ 'Y') THEN(DO)
  459.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) +
  460.                           MSGDTA('Creating' *BCAT &TOFILE) +
  461.                           TOPGMQ(*EXT) MSGTYPE(*STATUS)
  462.              CRTSRCPF   FILE(&TOLIB/&TOFILE) TEXT('Created by LINK400')
  463.              ENDDO
  464.              ENDDO
  465.              ENDDO
  466.              ENDDO
  467.              ENDDO
  468.  
  469.              IF         COND(&SBMJOB *EQ '*YES') THEN(DO)
  470.              RTVSYSVAL  SYSVAL(QTIME) RTNVAR(&QTIME)
  471.  
  472.              SBMJOB     CMD(CALL PGM(LINK400S) PARM(&OPTION &FROMLIB +
  473.                           &FROMFILE &FROMMBR &TYPE &TOLIB &TOFILE +
  474.                           &TOMBR &TODATE &REPLACE &RMTLOCNAME +
  475.                           &PASSWORD &RCODE &MSGNUM &HANGUP)) +
  476.                           JOB(&FROMMBR) JOBPTY(8) SCDTIME(&SCDTIME)
  477.  
  478.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) +
  479.                           MSGDTA('Transfer' *BCAT &FROMLIB *TCAT +
  480.                           '/' *CAT &FROMFILE *TCAT '/' *CAT +
  481.                           &FROMMBR *TCAT ' Submitted') MSGTYPE(*COMP)
  482.              GOTO       CMDLBL(ENDPROGRAM)
  483.              ENDDO
  484.  
  485.              IF         COND(&SBMJOB *EQ '*NO ') THEN(DO)
  486.              CALL       PGM(QY2FTML) PARM(&OPTION &FROMLIB &FROMFILE +
  487.                           &FROMMBR &TYPE &TOLIB &TOFILE &TOMBR +
  488.                           &TODATE &REPLACE &RMTLOCNAME &PASSWORD +
  489.                           &RCODE &MSGNUM)
  490.              MONMSG     MSGID(CPF0000 CPD7A07 CPD7A03) EXEC(DO)
  491.              GOTO         CMDLBL(ERROR)
  492.              ENDDO
  493.              ENDDO
  494.              ENDDO
  495.  
  496.              IF         COND((&FUNCTION *EQ 'P')) THEN(DO)
  497.              STRPASTHR  RMTLOCNAME(*CNNDEV) CNNDEV(&CNNDEV) +
  498.                           RMTUSER(*CURRENT) RMTPWD(&PASSWORD)
  499.              MONMSG     MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
  500.              CHGVAR     VAR(&REPLY) VALUE(' ') /* clear out previous +
  501.                           replies */
  502.              IF         COND(&SYSTEM *NE 'D' *AND +
  503.                              &SYSTEM *NE 'Y' *AND +
  504.                              &SYSTEM *NE 'P') THEN(DO)
  505.              RMVMSG     PGMQ(*EXT) CLEAR(*ALL)
  506.              SNDUSRMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Do you +
  507.                           want to hang up the modem? (Y/N)') +
  508.                           VALUES(Y N) DFT(N) MSGRPY(&REPLY)
  509.              ENDDO
  510.              ENDDO
  511.  
  512. /* SEND OBJECT */
  513.  
  514.              IF         COND(&FUNCTION *EQ 'O') THEN(DO)
  515.              IF         COND(&OPTION *EQ 'S') THEN(DO)
  516.              CRTSAVF    FILE(QTEMP/SAVF) TEXT('Temporary Save file +
  517.                           for LINK400')
  518.              MONMSG     MSGID(CPF5813 CPF7302) /* Already Exists */
  519.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Saving +
  520.                           Objects in library' *BCAT &OBJFRMLIB) +
  521.                           TOPGMQ(*EXT) MSGTYPE(*STATUS)
  522.              SAVOBJ     OBJ(&OBJ) LIB(&OBJFRMLIB) DEV(*SAVF) +
  523.                           OBJTYPE(&OBJTYPE) SAVF(QTEMP/SAVF) +
  524.                           UPDHST(*NO) TGTRLS(&TGTRLS) CLEAR(*ALL) +
  525.                           FILEMBR((*ALL (&FILEMBR))) DTACPR(*YES)
  526. /*           MONMSG     MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))    */
  527.  
  528. /* MAKE SURE QUSRTOOLS EXISTS FOR COPY SAVE FILE */
  529.  
  530. /*           CHKOBJ     OBJ(CPYFRMSAVF) OBJTYPE(*CMD)         */
  531. /*           MONMSG     MSGID(CPF9801) EXEC(DO)               */
  532. /*           CRTTAATOOL TOOL(CPYFRMSAVF) CRTFILLIB(QGPL)      */
  533. /*           ENDDO                                            */
  534.  
  535.              CRTPF      FILE(QTEMP/CPYSAVF) RCDLEN(528) +
  536.                           TEXT('Temporary Save File Copy by Link400')
  537.              MONMSG     MSGID(CPF5813 CPF7302) /* Already Exists */
  538.  
  539. /* COPY SAVE FILE TO DATABASE FILE TO SEND IT */
  540.  
  541. /*           CPYFRMSAVF FRMSAVF(QTEMP/SAVF) TODBF(QTEMP/CPYSAVF)  */
  542.  
  543. /* CLEAR SAVE FILE (NO LONGER NEEDED) */
  544.  
  545.              CLRSAVF    FILE(QTEMP/SAVF)
  546.  
  547.              RMVMSG     PGMQ(*EXT) CLEAR(*ALL)
  548.  
  549. /* CALCULATE APPROXIMATE TIME TO SEND THIS FILE */
  550.  
  551.              GETNBRRCS  FILE(QTEMP/CPYSAVF) NBRRECS(&RECORDS)
  552.              CHGVAR     VAR(&TOTALBYTE) VALUE(&RECORDS * 528)
  553.              CHGVAR     VAR(&SECONDS) VALUE(&TOTALBYTE / 1200)
  554.              CHGVAR     VAR(&MINUTES) VALUE(&SECONDS / 60)
  555.              CHGVAR     VAR(&MINUTES) VALUE(&MINUTES + 1)
  556.              CHGVAR     VAR(&MINUTESA) VALUE(&MINUTES)
  557.              SNDUSRMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('File +
  558.                           will take' *BCAT &MINUTESA *BCAT 'minutes +
  559.                           to send at 9600.  Continue(Y/N)?') +
  560.                           VALUES(Y N) DFT(Y) MSGRPY(&REPLY3)
  561.              IF         COND(&REPLY3 *EQ 'N') THEN(DO)
  562.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Program +
  563.                           cancelled by user') MSGTYPE(*ESCAPE)
  564.              GOTO       CMDLBL(ENDPROGRAM)
  565.              ENDDO
  566.  
  567.              RTVSYSVAL  SYSVAL(QTIME) RTNVAR(&TIME)
  568.              CHGVAR     VAR(&TIMEI) VALUE(&TIME)
  569. /*           EDTVAR     CHROUT(&TIMEO) NUMINP(&TIMEI) EDTCDE(W)   */
  570.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Sending +
  571.                           Save file to Remote System. Started at' +
  572.                           *BCAT &TIMEO) TOPGMQ(*EXT) MSGTYPE(*STATUS)
  573.              CALL       PGM(QY2FTML) PARM('S' 'QTEMP' 'CPYSAVF' +
  574.                           'CPYSAVF' &TYPE 'QGPL' 'CPYSAVF' +
  575.                           'CPYSAVF' &TODATE 'Y' &RMTLOCNAME +
  576.                           &PASSWORD &RCODE &MSGNUM)
  577.              MONMSG     MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
  578.  
  579. /* WANT TO RESTORE OBJECTS ON REMOTE SYSTEM, CREATE DDM FILE TO */
  580. /* USE SBM-RMTCMD */
  581.  
  582.              CRTDDMF    FILE(QTEMP/RMTCMD) RMTFILE(*LIBL/PMENUS) +
  583.                           RMTLOCNAME(&RMTLOCNAME) TEXT('Temporary +
  584.                           DDM file to use SBM-RMTCMD')
  585.              RMVMSG     CLEAR(*ALL)
  586.              IF         COND(&OBJTOLIB *NE ' ') THEN(DO)
  587.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) +
  588.                           MSGDTA('Restoring Objects on Remote +
  589.                           System') TOPGMQ(*EXT) MSGTYPE(*STATUS)
  590.              IF         COND(&SYSTEM *EQ 'S') THEN(CHGVAR +
  591.                           VAR(&SYSTEMO) VALUE('T'))
  592.              IF         COND(&SYSTEM *EQ 'T') THEN(CHGVAR +
  593.                           VAR(&SYSTEMO) VALUE('S'))
  594.  
  595. /* CREATE DATA AREA WITH SENDERS USERID */
  596.  
  597.              CRTDTAARA  DTAARA(CCALIB/LINK400D) TYPE(*CHAR) LEN(10) +
  598.                           VALUE(&RMTUSERID)
  599.              MONMSG     MSGID(CPF1023) EXEC(DO)
  600.              CHGDTAARA  DTAARA(CCALIB/LINK400D (1 10)) +
  601.                           VALUE(&RMTUSERID)
  602.              ENDDO
  603.  
  604.              SBMRMTCMD  CMD('SBMJOB CMD(link400 system(' *CAT +
  605.                           &SYSTEMO *TCAT ') FUNCTION(O) OPTION(R) +
  606.                           objfrmlib(' *CAT &OBJFRMLIB *TCAT ') +
  607.                           objtolib(' *CAT &OBJTOLIB *TCAT ')) +
  608.                           JOB(RSTOBJ)') DDMFILE(QTEMP/RMTCMD)
  609.              RCVMSG
  610.              DLTF       FILE(QTEMP/RMTCMD)
  611.  
  612.              RCLRSC
  613.              ENDDO      /* OBJTOLIB *NE ' ' */
  614.              ENDDO      /* OPTION *EQ 'S' */
  615.  
  616.              IF         COND(&OPTION *EQ 'R') THEN(DO)
  617.  
  618. /* MAKE SURE QUSRTOOLS EXISTS FOR COPY SAVE FILE */
  619.  
  620. /*           CHKOBJ     OBJ(CPYFRMSAVF) OBJTYPE(*CMD)          */
  621. /*           MONMSG     MSGID(CPF9801) EXEC(DO)                */
  622. /*           ADDLIBLE   LIB(TAATOOL) POSITION(*LAST)           */
  623. /*           CRTTAATOOL TOOL(CPYFRMSAVF) CRTFILLIB(QGPL)       */
  624. /*           ENDDO                                             */
  625.  
  626. /* FIRST CREATE SAVE FILE */
  627.  
  628.              CRTSAVF    FILE(QTEMP/SAVF) TEXT('Temporary Save file +
  629.                           for LINK400')
  630.              MONMSG     MSGID(CPF5813 CPF7302) /* Already Exists */
  631. /*           CPYTOSAVF  FRMDBF(QGPL/CPYSAVF) TOSAVF(QTEMP/SAVF)  */
  632.  
  633. /* CHECK IF LIBRARY THERE */
  634.  
  635.              CHKOBJ     OBJ(&OBJTOLIB) OBJTYPE(*LIB)
  636.              MONMSG     MSGID(CPF9801) EXEC(DO)
  637.              CRTLIB     LIB(&OBJTOLIB) TEXT('Created by Link400 +
  638.                           Object Receive')
  639.              ENDDO
  640.  
  641.              RMVMSG     MSGQ(*PGMQ) CLEAR(*ALL)
  642.              RSTOBJ     OBJ(*ALL) SAVLIB(&OBJFRMLIB) DEV(*SAVF) +
  643.                           SAVF(QTEMP/SAVF) MBROPT(*ALL) +
  644.                           ALWOBJDIF(*ALL) RSTLIB(&OBJTOLIB)
  645.              MONMSG     MSGID(CPF0000) EXEC(GOTO CMDLBL(RTNGENERIC))
  646.              CLRSAVF    FILE(QTEMP/SAVF)
  647.              ENDDO
  648.              ENDDO
  649.  
  650. RTNGENERIC:  IF         COND(&SBMJOB *NE '*YES') THEN(DO)
  651.              IF         COND(&REPLY *EQ 'Y' *OR &HANGUP *EQ '*YES') +
  652.                           THEN(DO)
  653.              VRYCFG     CFGOBJ(&CNNDEV) CFGTYPE(*LIN) STATUS(*OFF)
  654.              MONMSG     MSGID(CPF0000)
  655.              VRYCFG     CFGOBJ(&CNNDEV) CFGTYPE(*CTL) STATUS(*OFF)
  656.              MONMSG     MSGID(CPF0000)
  657.              VRYCFG     CFGOBJ(TEMPRMT) CFGTYPE(*LIN) STATUS(*ON)
  658.              MONMSG     MSGID(CPF0000)
  659.              VRYCFG     CFGOBJ(TEMPRMT) CFGTYPE(*CTL) STATUS(*ON)
  660.              MONMSG     MSGID(CPF0000)
  661.              ENDDO
  662.              ENDDO
  663.  
  664.  PGMMSG:     RCVMSG     MSGTYPE(*ANY) MSGDTA(&MSGDTA) MSGID(&MSGID) +
  665.                           MSGF(&MSGF) MSGFLIB(&MSGFLIB)
  666.              IF         COND(&SVSCDTIME *EQ '*CALLBACK') THEN(GOTO +
  667.                           CMDLBL(ENDPROGRAM))
  668.              IF         COND(&MSGID *EQ '       ') THEN(GOTO +
  669.                           CMDLBL(ENDPROGRAM))
  670.              IF         COND(&MSGID *EQ 'CPI7A01') THEN(GOTO +
  671.                           CMDLBL(PGMMSG)) /* File Transfer Started */
  672.              IF         COND(&MSGID *EQ 'CPI7A02') THEN(GOTO +
  673.                           CMDLBL(PGMMSG)) /* File Transfer Started */
  674.              IF         COND(&MSGID *EQ 'CPC9150') THEN(GOTO +
  675.                           CMDLBL(PGMMSG)) /* Remote Commond +
  676.                           Completed */
  677.              IF         COND(&MSGID *EQ 'CPI9155') THEN(GOTO +
  678.                           CMDLBL(PGMMSG)) /* Remote Commond +
  679.                           Completed */
  680.  
  681. /* SPECIAL ERROR IF LIBRARY NOT FOUND */
  682.  
  683.              IF         COND(&MSGID *EQ 'CPD7A07') THEN(DO)
  684.              IF         COND(%SST(&MSGDTA 9 7) *EQ 'CPD7A50') THEN(DO)
  685.              SNDPGMMSG  MSGID(CPD7A50) MSGF(QCPFMSG) +
  686.                           MSGDTA(&FROMLIB) MSGTYPE(*ESCAPE)
  687.              GOTO       CMDLBL(PGMMSG)
  688.              ENDDO      /* MSGID CPD7A07 */
  689.  
  690. /* SPECIAL MESSAGE FOR FILE NOT FOUND */
  691.  
  692.              IF         COND(%SST(&MSGDTA 9 7) *EQ 'CPD7A36') THEN(DO)
  693.              CHGVAR     VAR(&MSGDTA) VALUE(' ')
  694.              CHGVAR     VAR(&MSGDTA) VALUE(&FROMLIB)
  695.              CHGVAR     VAR(%SST(&MSGDTA 33 10)) VALUE(&FROMFILE)
  696.              SNDPGMMSG  MSGID(CPD7A36) MSGF(QCPFMSG) +
  697.                           MSGDTA(&MSGDTA) +
  698.                           MSGTYPE(*ESCAPE)
  699.              GOTO       CMDLBL(PGMMSG)
  700.              ENDDO      /* MSGID CPD7A07 */
  701.  
  702. /* SPECIAL MESSAGE FOR MEMBER NOT FOUND */
  703.  
  704.              IF         COND(%SST(&MSGDTA 9 7) *EQ 'CPD7A53') THEN(DO)
  705.              CHGVAR     VAR(&MSGDTA) VALUE(' ')
  706.              CHGVAR     VAR(&MSGDTA) VALUE(&FROMLIB)
  707.              CHGVAR     VAR(%SST(&MSGDTA 33 10)) VALUE(&FROMFILE)
  708.              CHGVAR     VAR(%SST(&MSGDTA 43 10)) VALUE(&FROMMBR)
  709.              SNDPGMMSG  MSGID(CPD7A53) MSGF(QCPFMSG) MSGDTA(&MSGDTA) +
  710.                           MSGTYPE(*ESCAPE)
  711.              GOTO       CMDLBL(PGMMSG)
  712.              ENDDO      /* MSGID CPD7A07 */
  713.              ENDDO      /* MSGID CPD7A07 */
  714.  
  715.              IF         COND(&RMTUSERID *EQ 'QUSER     ' *AND +
  716.                           &SCDTIME *NE '*CALLBACK') THEN(DO)
  717.              CHGVAR     VAR(&CMDMSG) VALUE('CALL LINK400R PARM(' +
  718.                           *CAT &APOST *CAT &MSGID *CAT &APOST *BCAT +
  719.                           &APOST *CAT &MSGFLIB *CAT &APOST *BCAT +
  720.                           &APOST *CAT &MSGF *CAT &APOST *BCAT +
  721.                           &APOST *CAT &MSGDTA *CAT &APOST *CAT ')')
  722.              SBMRMTCMD  CMD(&CMDMSG) DDMFILE(QTEMP/RMTCMD)
  723.              MONMSG     MSGID(CPF0000)
  724.              ENDDO
  725.              SNDPGMMSG  MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
  726.                           MSGDTA(&MSGDTA) MSGTYPE(*INFO)
  727.              GOTO       CMDLBL(PGMMSG)
  728.              GOTO       CMDLBL(ENDPROGRAM)
  729.  
  730.  ERROR:
  731.  /*** Standard error handling routine  ***/
  732.              IF         &ERRORSW THEN(SNDPGMMSG MSGID(CPF9999) +
  733.                           MSGF(QCPFMSG) MSGTYPE(*ESCAPE))
  734.              CHGVAR     &ERRORSW '1'
  735.  ERRDIAG:    RCVMSG     MSGTYPE(*DIAG) MSGDTA(&MSGDTA) MSGID(&MSGID) +
  736.                           MSGF(&MSGF) MSGFLIB(&MSGFLIB)
  737.              IF         (&MSGID *EQ '       ') GOTO ESCAPE
  738.              IF         COND(&RMTUSERID *EQ 'QUSER     ') THEN(DO)
  739.              SBMRMTCMD  CMD('CALL PGM(LINK400R) PARM(&MSGID  +
  740.                           &MSGFLIB &MSGF &MSGDTA)') +
  741.                           DDMFILE(QTEMP/RMTCMD)
  742.              ENDDO
  743.              SNDPGMMSG  MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
  744.                           MSGDTA(&MSGDTA) MSGTYPE(*DIAG)
  745.              GOTO       ERRDIAG
  746.  ESCAPE:     RCVMSG     MSGTYPE(*EXCP) MSGDTA(&MSGDTA) MSGID(&MSGID) +
  747.                           MSGF(&MSGF) MSGFLIB(&MSGFLIB)
  748.              IF         COND(&RMTUSERID *EQ 'QUSER     ') THEN(DO)
  749.              SBMRMTCMD  CMD('CALL PGM(LINK400R) PARM(&MSGID  +
  750.                           &MSGFLIB &MSGF &MSGDTA)') +
  751.                           DDMFILE(QTEMP/RMTCMD)
  752.              ENDDO
  753.              SNDPGMMSG  MSGID(&MSGID) MSGF(&MSGFLIB/&MSGF) +
  754.                           MSGDTA(&MSGDTA) MSGTYPE(*ESCAPE)
  755.              GOTO       CMDLBL(ENDPROGRAM)
  756.  
  757. GENERIC:
  758.              CHGVAR     VAR(&FROMGEN) VALUE(&FROMMBR)
  759.              RTVMBRD    FILE(&FROMLIB/&FROMFILE) MBR(&FROMGEN *SAME) +
  760.                           RTNMBR(&RTNMBR)
  761. GENERIC1:    IF         COND(%SST(&RTNMBR 1 &RESULT) *EQ +
  762.                           %SST(&FROMMBR 1 &RESULT)) THEN(DO)
  763.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) +
  764.                           MSGDTA('Transmitting ' *CAT &FROMLIB *TCAT +
  765.                           '/' *TCAT &FROMFILE *TCAT '/' *TCAT +
  766.                           &RTNMBR) TOPGMQ(*EXT) MSGTYPE(*STATUS)
  767.  
  768. /* IF SUBMIT, CAN'T USE HANG-UP *YES FOR GENERIC */
  769.  
  770.              IF         COND(&SBMJOB *EQ '*YES') THEN(DO)
  771.              SBMJOB     CMD(CALL PGM(LINK400S) PARM(&OPTION &FROMLIB +
  772.                           &FROMFILE &RTNMBR &TYPE &TOLIB &TOFILE +
  773.                           &RTNMBR &TODATE &REPLACE &RMTLOCNAME +
  774.                           &PASSWORD &RCODE &MSGNUM '*NO ')) +
  775.                           JOB(&RTNMBR) JOBPTY(8)
  776.              SNDPGMMSG  MSGID(CPF9898) MSGF(QCPFMSG) +
  777.                           MSGDTA('Transfer' *BCAT &FROMLIB *TCAT +
  778.                           '/' *CAT &FROMFILE *TCAT '/' *CAT +
  779.                           &RTNMBR *TCAT ' Submitted') MSGTYPE(*COMP)
  780.              ENDDO
  781.              IF         COND(&SBMJOB *NE '*YES') THEN(DO)
  782.              CALL       PGM(QY2FTML) PARM(&OPTION &FROMLIB &FROMFILE +
  783.                           &RTNMBR &TYPE &TOLIB &TOFILE &RTNMBR +
  784.                           &TODATE &REPLACE &RMTLOCNAME &PASSWORD +
  785.                           &RCODE &MSGNUM)
  786.              ENDDO
  787.              CHGVAR     VAR(&FROMGEN) VALUE(&RTNMBR)
  788.              RTVMBRD    FILE(&FROMLIB/&FROMFILE) MBR(&FROMGEN *NEXT) +
  789.                           RTNMBR(&RTNMBR)
  790.              MONMSG     MSGID(CPF3049) EXEC(GOTO CMDLBL(DONGENERIC))
  791.              GOTO       CMDLBL(GENERIC1)
  792.              ENDDO
  793.  DONGENERIC: IF         COND(&SBMJOB *EQ '*YES' *AND &HANGUP *EQ +
  794.                           '*YES') THEN(DO)
  795.              SBMJOB     CMD(CALL PGM(LINK400S) PARM(' ' ' ' +
  796.                           ' ' ' ' ' ' ' ' ' ' +
  797.                           ' ' ' ' ' ' &RMTLOCNAME +
  798.                           ' ' ' ' ' ' '*YES')) +
  799.                           JOB(HANGUP) JOBPTY(8)
  800.              ENDDO
  801.              GOTO       CMDLBL(RTNGENERIC)
  802.  ENDPROGRAM:
  803.              ENDPGM
  804.  
  805.  
© 2004-2019 by midrange.com generated in 0.007s valid xhtml & css