PRINT ON,GEN 00010001
*********************************************************************** 00020000
* * * C O U R I E R - C I C S (KAMA) * * * 00030006
*********************************************************************** 00040000
* ПPOГPAMMA COURIER - CICS PEAЛИЗУET ПPOTOKOЛ ПEPEДAЧИ ФAЙЛOB * 00050006
* KERMIT. COURIER - CICS PAБOTAET C ПCEBДOTEPMИHAЛOM EC-8570. * 00060006
* PEAЛИЗOBAH TOЛЬKO УДAЛEHHЫЙ BAPИAHT. HИЖE ПPИBEДEHЫ BOЗMOЖHOCTИ,* 00070000
* PEAЛИЗOBAHHЫE B BEPCИИ 2.20 ПPOГPAMMЫ COURIER - CICS. * 00080006
* * 00090000
* - ЛOKAЛЬHЫЙ BAPИAHT PAБOTЫ. * 00100000
* + УДAЛEHHЫЙ BAPИAHT. * 00110000
* + ПEPEДAЧA TEKCTOBЫX ФAЙЛOB. * 00120000
* + ПEPEДAЧA ДBOИЧHЫX ФAЙЛOB. * 00130000
* - ГPУППOBAЯ ПEPEДAЧA ФAЙЛOB. * 00140000
* - TAЙMAУT. * 00150000
* + ПPEФИKCAЦИЯ CTAPШEГO БИTA. * 00160000
* - CЖATИE ПOBTOPЯЮЩEЙCЯ ИHФOPMAЦИИ. * 00170000
* - AЛЬTEPHATИBHЫE KOHTPOЛЬHЫE CУMMЫ. * 00180000
* + AЛЬTEPHATИBHЫE TAБЛИЦЫ ПEPEKOДИPOBKИ. * 00190000
* - ПPEPЫBAHИE ПEPEДAЧИ. * 00200004
* - PAБOTA B PEЖИME CEPBEPA. * 00210000
* - УПPABЛEHИE ЛOKAЛЬHЫMИ ФAЙЛAMИ. * 00220000
* - OБPAБOTKA ATPИБУTOB ФAЙЛOB. * 00230000
* - MAKPOKOMAHДЫ. * 00240000
* - KOMAHДHЫE ФAЙЛЫ. * 00250000
* * 00260000
* COURIER - CICS (BEPCИЯ 2.20) * 00270001
* PAЗPAБOTAH B MEЖДУHAPOДHOM ЦEHTPE HAУЧHOЙ И TEXHИЧECKOЙ * 00280000
* ИHФOPMAЦИИ. * 00290000
* * 00300000
* MOCKBA, 1988 ГOД. * 00310000
*********************************************************************** 00320000
TITLE 'COURIER - CICS' 00330000
*********************************************************************** 00340000
MACRO 00350000
&N WRMESS &TEXT 00360000
LCLA &NUM 00370000
&NUM SETA K'&TEXT 00380000
&NUM SETA &NUM-2 00390000
&N MVI PACKAGE,&NUM 00400000
MVC PACKAGE+1(&NUM),=C&TEXT 00410000
L 14,=A(WRITMS) 00420000
BALR 15,14 00430000
MEND 00440000
*********************************************************************** 00450000
MACRO 00460000
&N WRTEXT &ADR,&LN 00470000
&N MVI PACKAGE,&LN 00480000
MVC PACKAGE+1(&LN),&ADR 00490000
L 14,=A(WRITMS) 00500000
BALR 15,14 00510000
MEND 00520000
*********************************************************************** 00530000
MACRO 00540000
&N BINCVRT ®,&AREA,&DBLWRK 00550000
&N CVD ®,&DBLWRK 00560000
MVC &AREA.(6),=X'402020202120' 00570000
ED &AREA.(6),&DBLWRK+5 00580000
MEND 00590000
*********************************************************************** 00600000
MACRO 00610000
&LABEL CALL &PROG 00620000
&LABEL L 14,=A(&PROG) 00630000
BALR 15,14 00640000
MEND 00650000
*********************************************************************** 00660000
MACRO 00670000
&LABEL SAVE 00680000
DS 0H 00690000
&LABEL ST 15,$ADDR$SV+4 00700000
L 15,$ADDR$SV 00710000
LA 15,36(15) 9 PEГИCTPOB (9 * 4 = 36) 00720000
ST 15,$ADDR$SV 00730000
ST BASE,0(15) 00740000
STM 0,6,8(15) 00750000
MVC 4(4,15),$ADDR$SV+4 00760000
MEND 00770000
*********************************************************************** 00780000
MACRO 00790000
&LABEL RETURN 00800000
&LABEL L 15,$ADDR$SV 00810000
LM 0,6,8(15) 00820000
MVC $ADDR$SV(8),0(15) 00830000
SH 15,=H'36' 9 PEГИCTPOB 00840000
L BASE,$ADDR$SV 00850000
ST 15,$ADDR$SV 00860000
L 15,$ADDR$SV+4 00870000
BR 15 00880000
MEND 00890000
*********************************************************************** 00900000
MACRO 00910000
&NAME BRTORC &RC0,&RC2,&RC4,&RC6,&RC8,&RC10,&RC12,&REST= 00920000
AIF (N'&SYSLIST NE 0).L010 00930000
.L000 MNOTE 8,'HEBEPHAЯ ЗAПИCЬ MAKPOKOMAHДЫ' 00940000
MEXIT 00950000
.L010 AIF (K'&REST EQ 0).L000 00960000
AIF (N'&SYSLIST NE 1).L020 00970000
LTR 14,14 00980000
BNZ &REST 00990000
B &RC0 01000000
MEXIT 01010000
.L020 AIF (N'&SYSLIST NE 2).L030 01020000
CH 14,=H'2' 01030000
AGO .L100 01040000
.L030 AIF (N'&SYSLIST NE 3).L040 01050000
CH 14,=H'4' 01060000
AGO .L100 01070000
.L040 AIF (N'&SYSLIST NE 4).L050 01080000
CH 14,=H'6' 01090000
AGO .L100 01100000
.L050 AIF (N'&SYSLIST NE 5).L060 01110000
CH 14,=H'8' 01120000
AGO .L100 01130000
.L060 AIF (N'&SYSLIST NE 6).L070 01140000
CH 14,=H'10' 01150000
AGO .L100 01160000
.L070 AIF (N'&SYSLIST NE 7).L000 01170000
CH 14,=H'12' 01180000
.L100 BH &REST 01190000
SLL R14,1 УMHOЖИM HA 2 01200000
LA 15,BR&SYSNDX 01210000
AR 15,14 01220000
BR 15 01230000
BR&SYSNDX B &RC0 01240000
B &RC2 01250000
AIF (N'&SYSLIST EQ 2).L200 01260000
B &RC4 01270000
AIF (N'&SYSLIST EQ 3).L200 01280000
B &RC6 01290000
AIF (N'&SYSLIST EQ 4).L200 01300000
B &RC8 01310000
AIF (N'&SYSLIST EQ 5).L200 01320000
B &RC10 01330000
AIF (N'&SYSLIST EQ 6).L200 01340000
B &RC12 01350000
.L200 MEXIT 01360000
MEND 01370000
*********************************************************************** 01380000
*====================================================================== 01390000
PRINT ON,NOGEN 01400000
*====================================================================== 01410000
* KOДЫ BOЗBPATA 01420000
E$OK EQU X'00' OШИБOK HET 01430000
E$CHECK EQU X'01' OШИБKA B KOHTPOЛЬHOЙ CУMME 01440000
E$LENG EQU X'02' HEBEPHAЯ ДЛИHA ПAKETA 01450000
E$LENA EQU X'02' HEBEPHЫЙ ATPИБУT ДЛИHЫ 01460000
E$INIT EQU X'03' HEBEPHЫE ПAPAMETPЫ INIT 01470000
E$NUM EQU X'04' HEBEPHЫЙ HOMEP ПAKETA 01480000
E$TYPE EQU X'05' * HEKOPPEKTHЫЙ TИП ПAKETA 01490005
E$ERR EQU X'06' * OБЛOMAЛCЯ ПAPTHEP 01500005
E$STATE EQU X'07' * HEPACПOЗHAHHOE COCTOЯHИE SEND 01510005
E$PIO EQU X'08' * PERMANENT I/O ERROR 01520005
E$BAD EQU X'09' УTEPЯH ПAKET OT ПAPTHEPA 01530000
E$NAK EQU X'0A' NAK OT ПAPTHEPA 01540000
E$B37 EQU X'0B' * SYSTEM CODE B37 01550005
E$HSTLEN EQU X'0C' * MOЯ ПPOГPAMMHAЯ OШИБKA 01560005
E$SPACE EQU X'0D' * HET MECTA B ФAЙЛE 01570005
E$CICS EQU X'0E' * HEПOHЯTHAЯ OШИБKA CICS 01580005
E$TRUNC EQU X'0F' ПEPEДAHHAЯ TEKCT. CTPOKA БЫЛA УCEЧ. 01590000
E$HSTNUM EQU X'10' * MOЯ ПPOГPAMMHAЯ OШИБKA 01600005
E$HSTTYP EQU X'11' * MOЯ ПPOГPAMMHAЯ OШИБKA 01610005
E$LIMIT EQU X'12' * MOЯ ПPOГPAMMHAЯ OШИБKA 01620005
* TИПЫ ПAKETOB 01630000
AA EQU X'41' 'A' B KO╨ÿ-7 01640000
AB EQU X'42' 'B' 01650000
AD EQU X'44' 'D' 01660000
AE EQU X'45' 'E' 01670000
AF EQU X'46' 'F' 01680000
AN EQU X'4E' 'N' 01690000
AS EQU X'53' 'S' 01700000
AY EQU X'59' 'Y' 01710000
AZ EQU X'5A' 'Z' 01720000
*====================================================================== 01730000
R0 EQU 0 01740000
R1 EQU 1 01750000
R2 EQU 2 01760000
R3 EQU 3 01770000
R4 EQU 4 01780000
PPTCBAR EQU 4 БAЗA 01790000
R5 EQU 5 01800000
DCTCBAR EQU 5 БAЗA 01810000
R6 EQU 6 01820000
TDOABAR EQU 7 БAЗA OБЛ. BЫBOДA DESTINATION 01830000
TDIABAR EQU 8 БAЗA OБЛ. BBOДA DESTINATION 01840000
TIOABAR EQU 9 БAЗA OБЛ. BBOДA/BЫBOДA TEPMИHAЛA 01850000
TCTTEAR EQU 10 БAЗA TAБЛ. УПPABЛEHИЯ TEPMИHAЛAMИ 01860000
BASE EQU 11 БAЗA ПPOГPAMMЫ 01870000
*TCACBAR EQU 12 01880000
CSACBAR EQU 13 01890000
R14 EQU 14 ! MOЖHO ИCПOЛЬЗOBATЬ KAK PAБOЧИE, HO ПPИ 01900000
R15 EQU 15 ! BЫЗOBE ПOДПPOГPAMM OHИ ПOPTЯTCЯ 01910000
* 01920000
* COPY DFHTCTTE TAБЛИЦA УПPABЛEHИЯ TEPMИHAЛAMИ (TCT) 01930000
* COPY DFHTIOA OБЛACTЬ BBOДA/BЫBOДA TEPMИHAЛA (TIOA) 01940000
* COPY DFHDCTDS TAБЛИЦA УПPABЛEHИЯ ПУHKTAMИ HAЗH. (DCT) 01950000
* COPY DFHTDIA OБЛACTЬ BBOДA TPAHЗИTHЫX ДAHHЫX (TDIA) 01960000
*UTDIA EQU * 01970000
* COPY DFHTDOA OБЛACTЬ BЫBOДA TPAHЗИTHЫX ДAHHЫX (TDOA) 01980000
* COPY DFHPPTDS 01990000
* COPY DFHCSADS OБЩAЯ CИCTEMHAЯ OБЛACTЬ (CSA) 02000000
* COPY DFHTCADS OБЛACTЬ УПPABЛEHИЯ ЗAДAЧEЙ (TCA) 02010000
* 02020000
PRINT OFF 02030000
COPY DFHTCTTE TAБЛИЦA УПPABЛEHИЯ TEPMИHAЛAMИ (TCT) 02040000
COPY DFHTIOA OБЛACTЬ BBOДA/BЫBOДA TEPMИHAЛA (TIOA) 02050000
COPY DFHDCTDS TAБЛИЦA УПPABЛEHИЯ ПУHKTAMИ HAЗH. (DCT) 02060000
COPY DFHTDIA OБЛACTЬ BBOДA TPAHЗИTHЫX ДAHHЫX (TDIA) 02070000
UTDIA EQU * 02080000
COPY DFHTDOA OБЛACTЬ BЫBOДA TPAHЗИTHЫX ДAHHЫX (TDOA) 02090000
COPY DFHPPTDS 02100000
COPY DFHCSADS OБЩAЯ CИCTEMHAЯ OБЛACTЬ (CSA) 02110000
COPY DFHTCADS OБЛACTЬ УПPABЛEHИЯ ЗAДAЧEЙ (TCA) 02120000
PRINT ON,NOGEN 02130000
*====================================================================== 02140000
* TWA COURIER - CICS 02150000
*====================================================================== 02160000
COURTWA EQU * 02170000
*::::::::::::::::: ONLY COURIER ::::::::::::::::::::::::::::::::::::::: 02180000
PROMPT DS CL24 "COURIER" INIT 02190000
TRTNAME DS CL8 ИMЯ TEKУЩEЙ TAБЛИЦЫ INIT 02200000
NEWTRT DS CL8 ИMЯ HOBOЙ TAБЛИЦЫ 02210000
* 02220000
PARSELST DS 3F CПИCOK AДPECOB ПAPAMETPOB 02230000
* 02240000
* SAVE AREA 02250000
* 02260000
$ADDR$SV DS 2F B 1 CЛOBE =A($SAVE$RG-36) INIT 02270000
ORG *-36 02280000
$ADDR$AS EQU * 02290000
ORG 02300000
$SAVE$RG DS 90F 10 УPOBHEЙ BЛOЖEHИЯ ПPOГPAMM ПO 9 REG 02310000
*:::::::::::::::: COURIER+COURRS :::::::::::::::::::::::::::::::::::::: 02320000
FILEDEST DS F ИMЯ ПУHKTA HAЗH. SEND/RECEIVE 02330000
DBGDEST DS F ИMЯ ПУHKTA HAЗH. DEBUG INIT 02340000
PACKDEST DS F ИMЯ TEPMИHAЛA INIT 02350000
* 02360000
PACKET DS H 26 <= ? <= 94 INIT 02370000
DELAY DS H 1 <= ? <= 32 767 INIT 02380000
RETRY DS H ЧИCЛO ПOBTOPOB ПAKETA INIT 02390000
QUOTE DS X ПPEФИKC CTRL INIT 02400000
PREF DS X ПPEФИKC 8 БИTA INIT 02410000
REPEAT DS X ПPEФИKC ПOBTOPЯЮЩИXCЯ ДAHHЫX INIT 02420000
R#EOT DS X EOL - RECEIVE INIT 02430000
S#EOT DS X EOL - SEND INIT 02440000
R#SOH DS X SOH - RECEIVE INIT 02450000
S#SOH DS X SOH - SEND INIT 02460000
#ERROR DS X HOMEP OШИБKИ INIT 02470004
RETCODE DS X HOMEP OШИБKИ ПPEД. KOMAHДЫ INIT 02480000
ERRTBL#A DS F AДPEC TAБЛИЦЫ ERROR-COOБЩEHИЙ 02490000
* 02500000
PGMSTAT DS X CTATУC П.H. ФAЙЛA INIT 02510004
* 1... .... SEND / RECEIVE 02520000
* .1.. .... TEXT / BINARY 02530000
* ..1. .... PREFIX ON / OFF 02540000
* ...1 .... REPEAT ON / OFF 02550000
* .... 1... BIGPACK ON / OFF 02560000
* .... .XXX RESERVED 02570000
FILSTAT DS X CTATУC П.H. ФAЙЛA INIT 02580000
* 01.. .... EXTRA 02590000
* 11.. .... INTRA 02600000
* ..1. .... INPUT / OUTPUT 02610000
* ...1 .... APPEND ON / OFF 02620000
* .... 10.. F 02630000
* .... 01.. V 02640000
* .... 11.. U 02650000
* .... ..X. RESERVED 02660000
* .... ...1 OPEN / CLOSE 02670000
DBGSTAT DS X CTATУC П.H. ФAЙЛA OTЛAДKИ INIT 02680000
* 01.. .... EXTRA 02690000
* 11.. .... INTRA 02700000
* ..1. .... INPUT / OUTPUT 02710000
* ...1 .... APPEND ON / OFF 02720000
* .... 10.. F 02730000
* .... 01.. V 02740000
* .... 11.. U 02750000
* .... ..X. RESERVED 02760000
* .... ...1 OPEN / CLOSE 02770000
PRMSTAT DS X CTATУC ПAPAMETPOB ПEPEДAЧИ INIT 02780000
* 00.. .... CHECK 1 02790000
* 01.. .... 2 02800000
* 11.. .... 3 02810000
* ..XX .... RESERVED 02820000
* .... 00.. DEBUG OFF 02830000
* .... 01.. PROTOCOL 02840000
* .... 10.. STATISTIC 02850000
* .... 11.. ON 02860000
* .... ..XX RESERVED 02870000
* SET TABLE 02880000
A#TRT#SI DS F AДPEC TAБЛ. ПEPEKOД. ИЗ ЛИHИИ INIT 02890000
A#TRT#SO DS F AДPEC TAБЛ. ПEPEKOД. B ЛИHИЮ INIT 02900000
A#TRT#EA DS F AДPEC TR TABL ПPИ ЧTEHИИ ДИCKA INIT 02910000
A#TRT#AE DS F AДPEC TRT ПPИ ЗAПИCИ HA ДИCK INIT 02920000
* 02930000
F#REC DS H MAKCИMAЛЬHAЯ ДЛИHA ЗAПИCИ FILE 02940000
D#REC DS H MAKCИMAЛЬHAЯ ДЛИHA ЗAПИCИ DEBUG 02950000
I#REC DS H MAKCИMAЛЬHAЯ ДЛИHA ЗAПИCИ FILE INTRA 02960000
*::::::::::::::::: ONLY COURRS :::::::::::::::::::::::::::::::::::::::: 02970000
* 02980000
* PSW - PACKET STATUS WORD 02990000
* 03000000
$PSW$CUR EQU * 03010000
$N$CUR DS H NUMBER 03020000
$S$CUR DS X SEND 03030000
$R$CUR DS X RECEIVE 03040000
$PSW$OLD EQU * 03050000
$N$OLD DS H NUMBER 03060000
$S$OLD DS X SEND 03070000
$R$OLD DS X RECEIVE 03080000
* 03090000
$FMA DS F FILE MEMORY ADDRESS 03100000
$DMA DS F DEBUG MEMORY ADDRESS 03110000
$SMA DS F SEND PACKET MEMORY ADDRESS 03120000
$RMA DS F RECEIVE PACKET MEMORY ADDRESS 03130000
* 03140000
$STATE DS X ПPEДЫДУЩEE COCTOЯHИE ПPOTOKOЛA 03150000
$DAT$A DS F 03160000
$TIME DS CL6 CTAPTOBOE BPEMЯ: HHMMSS 03170000
$SDAT$L DS H ДЛИHA ПOCЫЛAEMOГO ПAKETA 03180000
$RDAT$L DS H ДЛИHA ПPИHЯTOГO ПAKETA 03190000
$RETRY DS H ЧИCЛO ПOBTOPEHИЙ ПEPEДAЧИ 03200000
$WR$L DS H ДЛИHA ЗAПИCИ SEND/RECEIVE 03210000
$PUT$L DS H TEKУЩAЯ ПOЗИЦИЯ B ЗAПИCИ 03220000
$GET$L DS H TEKУЩAЯ ПOЗИЦИЯ B ЗAПИCИ 03230000
IND#CRLF DS X TEKУЩAЯ ПOЗИЦИЯ B ЗAПИCИ 03240000
* 03250000
* 03260000
DS 0D 03270000
DBLWRK DS D PAБOЧAЯ OБЛACTЬ 03280000
* 03290000
*--------------------- 03300000
PACKAGE DS CL130 ПAKET / COOБЩEHИЯ 03310000
*--------------------- 03320000
TWALEN EQU *-PROMPT 03330000
*********************************************************************** 03340000
COURIER CSECT 03350000
BALR BASE,0 ЗAГPУЗИTЬ БAЗOBЫЙ PEГИCTP 03360000
USING *,BASE УCTAHOBИTЬ AДPECAЦИЮ B ПPOГPAMME 03370000
* 03380000
L TCTTEAR,TCAFCAAA ЗAГPУЗИTЬ AДPEC TCTTE 03390000
MVC TCASCSA,TCTTEDA ЗAПИCATЬ AДPEC HAЧ. TIOA 03400000
DFHSC TYPE=FREEMAIN OCBOБOДИTЬ HAЧAЛЬHУЮ TIOA 03410000
* 03420000
XR R3,R3 ! 03430000
STC R3,PROMPT ! 03440000
LA R2,PROMPT ! 03450000
LA R3,1 ! OЧИCTИTЬ 03460000
LA R4,PROMPT+1 ! TWA 03470000
LA R5,TWALEN ! 03480000
MVCL R4,R2 ! 03490000
* 03500000
L R1,TCAFCAAA ЗAГPУЗИTЬ AДPEC TCTTE 03510000
MVC PACKDEST(4),0(R1) 03520000
L R6,=A(TOLAT) 03530000
TR PACKDEST(4),0(R6) PACKDEST 03540000
* 03550000
LA R14,$ADDR$AS УCTAHOBИTЬ AДPECAЦИЮ ПEPEXOДOB 03560000
ST R14,$ADDR$SV $ADDR$SV 03570000
* 03580000
L R14,=A(ERRTAB) 03590000
ST R14,ERRTBL#A ERRTBL#A 03600000
** 03610000
L PPTCBAR,CSAPPTBA ЗAГPУЗИTЬ AДPEC HAЧAЛA PPT 03620000
PRED02 CLC PPTPI(8),=C'COURSTND' HAШЛИ ИMЯ TAБЛИЦЫ B PPT ? 03630000
BE PRED05 ECЛИ COBПAЛИ, TO TRT HAЙДEHA 03640000
CLI PPTPI,X'FF' ДOШЛИ ДO KOHЦA PPT ? 03650000
BE PRED04 ECЛИ ДA, TO TAБЛИЦЫ HET 03660000
L R1,PPTNXTEN ЗAГPУЗИTЬ AДPEC CЛEД. PPT 03670000
LR PPTCBAR,R1 ЗAГPУЗИTЬ AДPEC CЛEД. PPT 03680000
B PRED02 И ИCKATЬ ДAЛЬШE 03690000
PRED04 WRMESS 'STANDARD TRANSLATE TABLE -COURSTND- IS NOT DEFINED!' 03700000
B THEEND 03710000
PRED05 EQU * 03720000
MVC TCAPCPI(8),=C'COURSTND' ЗAПИCATЬ ИMЯ ЗAГPУЖAEMOЙ TRT 03730000
DFHPC TYPE=LOAD ЗAГPУЗИTЬ TAБЛИЦЫ 03740000
L R5,TCAPCLA ЗAГPУЗИTЬ AДPEC TAБЛИЦ 03750000
ST R5,A#TRT#SO AДPEC TAБЛ. ПEPEKOД. B ЛИHИЮ (ATOE) 03760000
LA R5,256(,R5) ПOЛУЧИTЬ AДPEC TAБЛИЦЫ 03770000
ST R5,A#TRT#SI AДPEC TAБЛ. ПEPEKOД. ИЗ ЛИHИИ (ETOA) 03780000
** 03790000
CALL INITIATE 03800000
BRTORC COUR020,REST=COUR010 03810000
COUR010 WRMESS 'STANDARD TRANSLATE TABLE -COURTRTS- IS NOT DEFINED!' 03820000
COUR020 EQU * 03830000
* 03840000
MVC DBGDEST(4),=C'CSSL' DBGDEST 03850000
* 03860000
* ИHИЦИAЛИЗAЦИЯ ЗAKOHЧEHA 03870000
* 03880000
WRMESS 'KERMIT PROTOCOL PROGRAM FRANK DA KRUZ NEW YORK ' 03890007
WRMESS 'COURIER-CICS VERSION 2.20 ICSTI MOSCOW ' 03900007
*********************************************************************** 03910000
* OCHOBHOЙ ЦИKЛ OБPAБOTKИ KOMAHД * 03920000
*********************************************************************** 03930000
PROMPTS XR R14,R14 03940000
IC R14,PROMPT 03950000
EX R14,PROMPTMV 03960000
CALL WRITMS BЫBOД PROMPT 03970000
CALL RDTRM ЧИTATЬ C TEPMИHAЛA 03980000
LM R1,R3,PARSELST ЗAГPУЗИTЬ AДPECA OПEPAHДOB 03990000
* 04000000
CLI 0(R1),C' ' HИЧEГO HE BBEДEHO ? 04010000
BNE PRSET 04020000
WRMESS 'KERMIT PROTOCOL PROGRAM FRANK DA KRUZ NEW YORK ' 04030006
WRMESS 'COURIER-CICS VERSION 2.20 ICSTI MOSCOW ' 04040006
B PROMPTS 04050000
*---------------------------------------------------------------------* 04060000
PRSET CLC 0(3,R1),=C'SET' SET ? 04070000
BNE PRSTATUS УBЫ.. 04080000
CLI 0(R2),C' ' ECTЬ OПEPAHДЫ ? 04090000
BE PROMPTS УBЫ.. 04100000
CLI 0(R2),C'?' ЗAПPOШEH HELP ? 04110000
BNE PRSET01 УBЫ.. 04120000
WRMESS 'APPEND, DEBUG, DELAY, FILE, PACKET,' 04130003
WRMESS 'PREFIX, PROMPT, QUOTE, RECORD, RETRY, TRT.' 04140002
B PROMPTS 04150000
PRSET01 CALL SET 04160000
BRTORC PROMPTS,REST=PRSET02 ПPOBEPИTЬ KOД BOЗBPATA 04170000
PRSET02 WRMESS 'ILLEGAL SET COMMAND.' 04180000
B PROMPTS 04190000
*---------------------------------------------------------------------* 04200000
PRSTATUS CLC 0(3,R1),=C'STA' STATUS ? 04210000
BNE PRSHOW УBЫ.. 04220000
CLI 0(R2),C' ' ECTЬ OПEPAHДЫ ? 04230000
BE PRSTA01 УBЫ.. 04240000
CLI 0(R2),C'?' ЗAПPOШEH HELP ? 04250000
BNE PRSTA03 УBЫ.. 04260000
WRMESS 'CONFIRM WITH A CARRIAGE RETURN.' 04270000
B PROMPTS 04280000
PRSTA01 EQU * 04290000
CALL STATUS 04300000
B PROMPTS 04310000
PRSTA03 WRMESS 'ILLEGAL STATUS COMMAND.' 04320000
B PROMPTS 04330000
*---------------------------------------------------------------------* 04340000
PRSHOW CLC 0(3,R1),=C'SHO' SHOW ? 04350000
BNE PRREC 04360000
CLI 0(R2),C' ' ECTЬ OПEPAHДЫ ? 04370000
BE PROMPTS УBЫ.. 04380000
CLI 0(R2),C'?' ЗAПPOШEH HELP ? 04390000
BNE PRSHO01 УBЫ.. 04400000
WRMESS 'PARM OR TRT OR DESTINATION.' 04410000
B PROMPTS 04420000
PRSHO01 CALL SHOW 04430000
BRTORC PROMPTS,REST=PRSHO02 04440000
PRSHO02 WRMESS 'ILLEGAL SHOW COMMAND.' 04450000
B PROMPTS 04460000
*---------------------------------------------------------------------* 04470000
PRREC CLC 0(3,R1),=C'REC' RECEIVE ? 04480000
BNE PRSEND УBЫ.. 04490000
NI PGMSTAT,X'FF'-X'80' SET RECEIVE 04500000
B PRRS 04510000
PRSEND CLC 0(3,R1),=C'SEN' SEND ? 04520000
BNE PREXIT УBЫ.. 04530000
OI PGMSTAT,X'80' SET SEND 04540000
* 04550000
PRRS EQU * 04560000
CLI 0(R2),C'?' HELP ? 04570000
BNE PRRS010 УBЫ.. 04580000
WRMESS 'SPECIFY DESTINATION_NAME.' 04590000
B PROMPTS 04600000
* 04610000
PRRS010 CLI 0(R2),C' ' ECTЬ FILEDEST ? 04620000
BNE PRRS030 ДA 04630000
PRRS020 WRMESS 'ENTER DESTINATION_NAME: ' 04640000
CALL RDTRM CЧИTATЬ OTBET ПOЛЬЗOBATEЛЯ 04650000
LM R2,R3,PARSELST ЗAГPУЗИTЬ AДPECA OПEPAHДOB 04660000
CLI 0(R2),C' ' БЫЛO ЧTO-HИБУДЬ BBEДEHO ? 04670000
BE PRRS020 ECЛИ HET, TO CЧИTЫBATЬ CHOBA 04680000
* 04690000
PRRS030 EQU * 04700000
CLC QUOTE(1),PREF CИMBOЛЫ ПPEФИKCAЦИИ COBПAДAЮT ? 04710000
BNE PRRS035 HET 04720000
WRMESS 'QUOTE = PREF. ILLEGAL.' 04730000
B PROMPTS 04740000
PRRS035 EQU * 04750000
MVI #ERROR,E$OK CБPOCИTЬ ИHДИKATOP OШИБKИ 04760000
MVC FILEDEST(4),0(R2) ИMЯ ПУHKTA HAЗHAЧEHИЯ -> TWA 04770000
LA R1,=C'F' 04780000
CALL TSTDEST TEST FILE 04790000
BRTORC PRRS040,REST=PRRS100 04800000
PRRS040 EQU * 04810000
TM FILSTAT,X'C0' DEST INTRA ? 04820000
BO PRRS050 ДA 04830000
TM FILSTAT,X'01' FILE OPEN ? 04840000
BO PRRS041 ДA 04850000
WRMESS 'SORRY, BAT FILE IS CLOSE.' 04860000
B PROMPTS 04870000
PRRS041 TM PGMSTAT,X'80' SEND ? 04880000
BO PRRS042 ДA 04890000
TM FILSTAT,X'20' FILE OUTPUT ? 04900000
BZ PRRS060 ДA 04910000
WRMESS 'SORRY, BAT FILE IS READ ONLY.' 04920000
B PROMPTS 04930000
PRRS042 TM FILSTAT,X'20' FILE INPUT ? 04940000
BO PRRS060 ДA 04950000
WRMESS 'SORRY, BAT FILE IS WRITE ONLY.' 04960000
B PROMPTS 04970000
* 04980000
PRRS050 EQU * 04990000
TM FILSTAT,X'10' APPEND ON ? 05000000
BO PRRS060 ДA 05010000
TM PGMSTAT,X'80' SEND ? 05020000
BO PRRS060 ДA 05030000
MVC TCATDDI(4),FILEDEST 05040000
DFHTD TYPE=PURGE 05050000
* 05060000
PRRS060 TM PGMSTAT,X'0C' DEBUG OFF ? 05070000
BZ PRRS080 ДA 05080000
LA R1,=C'D' 05090000
CALL TSTDEST 05100000
BRTORC PRRS070,REST=PRRS100 05110000
* 05120000
PRRS070 EQU * 05130000
TM FILSTAT,X'01' FILE OPEN ? 05140000
BO PRRS075 ДA 05150000
WRMESS 'SORRY, BAT DEBUG FILE IS CLOSE.' 05160000
B PROMPTS 05170000
* 05180000
PRRS075 TM DBGSTAT,X'20' FILE OUTPUT ? 05190000
BZ PRRS080 ДA 05200000
WRMESS 'SORRY, BAT DEBUG FILE IS READ ONLY.' 05210000
B PROMPTS 05220000
* 05230000
PRRS080 CALL COURRS 05240000
LR R2,R14 05250000
CALL RDTRM 05260000
LR R14,R2 05270000
BRTORC PRRS200,REST=PRRS300 05280000
* 05290000
PRRS100 WRMESS 'DESTINATION NAME IS NOT DEFINED OR BAD.' 05300000
MVI #ERROR,E$OK 05310000
MVC RETCODE(1),#ERROR 05320000
B PROMPTS 05330000
PRRS200 TM PGMSTAT,X'80' SEND ? 05340000
BO PRRS220 ДA 05350000
WRMESS 'RECEIVING COMPLETE.' 05360000
B PRRS240 05370000
PRRS220 WRMESS 'SENDING COMPLETE.' 05380000
PRRS240 MVI #ERROR,E$OK 05390000
MVC RETCODE(1),#ERROR 05400000
B PROMPTS 05410000
PRRS300 TM PGMSTAT,X'80' SEND ? 05420000
BO PRRS320 ДA 05430000
WRMESS 'RECEIVING ERROR. TRY AGAIN.' 05440000
B PRRS340 05450000
PRRS320 WRMESS 'SENDING ERROR. TRY AGAIN.' 05460000
PRRS340 MVC RETCODE(1),#ERROR 05470000
B PROMPTS 05480000
*---------------------------------------------------------------------* 05490000
PREXIT CLI 0(R1),C'E' EXIT ? 05500000
BE PREXIT01 ДA 05510000
CLI 0(R1),C'Q' QUIT ? 05520000
BNE PRHELP УBЫ.. 05530000
PREXIT01 CLI 0(R2),C' ' ECTЬ OПEPAHДЫ ? 05540000
BE THEEND УBЫ.. 05550000
CLI 0(R2),C'?' ЗAПPOШEH HELP ? 05560000
BNE PREXIT02 УBЫ.. 05570000
WRMESS 'CONFIRM WITH A CARRIAGE RETURN.' 05580000
B PROMPTS 05590000
PREXIT02 WRMESS 'ILLEGAL EXIT OR QUIT COMMAND.' 05600000
B PROMPTS 05610000
THEEND WRMESS 'COURIER COMPLETED.' 05620000
DFHPC TYPE=RETURN 05630000
*---------------------------------------------------------------------* 05640000
PRHELP CLC 0(3,R1),=C'HEL' HELP ? 05650000
BNE PRQWEST УBЫ.. 05660000
CLI 0(R2),C'?' ЗAПPOШEH HELP HELP ? 05670000
BE PRHEL01 ECЛИ ДA, BЫДATЬ CONFIRM WITH... 05680000
WRMESS 'ENTER ? AT PROMPTS TO RECEIVE LIST OF COMMANDS.' 05690000
WRMESS 'ENTER ? AFTER COMMAND TO RECEIVE LIST OF OPERANDS.' 05700000
B PROMPTS 05710000
PRHEL01 WRMESS 'CONFIRM WITH A CARRIAGE RETURN.' 05720000
B PROMPTS 05730000
*---------------------------------------------------------------------* 05740000
PRQWEST CLC 0(1,R1),=C'?' HELP ? 05750000
BNE PRERROR УBЫ.. 05760000
WRMESS 'LEGAL COMMANDS ARE:' 05770000
WRMESS 'RECEIVE, SEND, HELP, QUIT,' 05780000
WRMESS 'EXIT, SET, STATUS, SHOW, ?.' 05790000
B PROMPTS 05800000
*---------------------------------------------------------------------* 05810000
PRERROR WRMESS 'ILLEGAL COMMAND. ENTER HELP ,PLEASE.' 05820000
B PROMPTS 05830000
*---------------------------------------------------------------------* 05840000
PROMPTMV MVC PACKAGE(0),PROMPT 05850000
ERRTAB DC CL30'PROCESS OK!' ERR MSG #00 05860000
DC CL30'BAD CHECKSUM' ERR MSG #01 05870000
DC CL30'ILLEGAL PACKET LENGHT' ERR MSG #02 05880000
DC CL30'BAD INIT PARM' ERR MSG #03 05890000
DC CL30'BAD PACKET NUMBER' ERR MSG #04 05900000
DC CL30'ILLEGAL PACKET TYPE' ERR MSG #05 05910000
DC CL30'MICRO COMPUTER ABORTED' ERR MSG #06 05920000
DC CL30'SEND TYPE ILLEGAL.' ERR MSG #07 05930000
DC CL30'PERMANENT I/O ERROR' ERR MSG #08 05940000
* 05950000
DC CL30'LOST A PACKET' ERR MSG #09 05960000
DC CL30'MICRO SENT A NAK' ERR MSG #0A 05970000
DC CL30'INTRA DESTINATION FULL' ERR MSG #0B 05980000
DC CL30'HOST PACKET ERROR. LENGHT' ERR MSG #0C 05990000
DC CL30'FILE IS FULL' ERR MSG #0D 06000000
DC CL30'CICS FANTASTIC ERROR' ERR MSG #0E 06010000
DC CL30'LINE HAS BEEN TRUNCATED' ERR MSG #0F 06020000
DC CL30'HOST PACKET ERROR. NUMBER' ERR MSG #10 06030000
DC CL30'HOST PACKET ERROR. TYPE' ERR MSG #11 06040000
DC CL30'LIMIT ERROR.' ERR MSG #12 06050005
TOLAT DC 256AL1(*-TOLAT) 06060000
ORG TOLAT+X'76' 06070000
DC C'U B' 06080000
ORG TOLAT+X'80' 06090000
DC C'CABCDEFGHID FG IJJKLMNOPQRKLM' 06100000
DC C'N PJ STUVWXYZ TUVWXYZSESCWU BCDEFG ' 06110000
ORG TOLAT+X'CB' 06120000
DC C'IJ L' 06130000
ORG TOLAT+X'DC' 06140000
DC C'PJ' 06150000
ORG TOLAT+X'EB' 06160000
DC C'UV XY' 06170000
ORG TOLAT+X'FA' 06180000
DC C'ZSESC' 06190000
*********************************************************************** 06200000
LTORG 06210000
DROP BASE 06220000
*********************************************************************** 06230000
* ПOДПPOГPAMMA INITIATE * 06240000
*********************************************************************** 06250000
* RETURN CODE = 0 - OK * 06260000
* RETURN CODE = 2 - HE HAЙДEH MOДУЛЬ COURTRTS B COURIER.LOADLIB * 06270000
*********************************************************************** 06280000
INITIATE SAVE 06290000
USING INITIATE,BASE 06300000
LR BASE,R14 06310000
* 06320000
MVC PROMPT+1(14),=C'COURIER-CICS> ' 06330006
LA R1,14 06340000
STC R1,PROMPT PROMPT 06350000
MVC PACKET(2),=H'94' PACKET = 94 BYTE 06360000
MVC DELAY(2),=H'30' DELAY = 30 SEC 06370000
MVC RETRY(2),=H'5' RETRY = 5 06380000
MVC I#REC(2),=H'4096' I#REC = 4K 06390000
* 06400000
MVI QUOTE,X'23' QUOTE = # ASCII 06410000
MVI PREF,X'26' PREF = & ASCII 06420000
MVI REPEAT,X'7E' REPEAT = Ч ASCII 06430000
MVI R#SOH,X'02' R#SOH CTRL-B 06440000
MVI R#EOT,X'04' R#EOT CTRL-D 06450000
MVI S#SOH,X'02' S#SOH CTRL-B 06460000
MVI S#EOT,X'04' S#EOT CTRL-D 06470000
* 06480000
MVI #ERROR,E$OK #ERROR 06490000
MVI RETCODE,E$OK RETCODE 06500000
* 06510000
OI PGMSTAT,X'40' SET FILE TEXT 06520000
* NI PGMSTAT,X'FF'-X'40' SET FILE BINARY 06530000
OI PGMSTAT,X'20' SET PREF ON 06540000
* NI PGMSTAT,X'FF'-X'20' SET PREF OFF 06550000
* OI PGMSTAT,X'10' SET REPEAT ON 06560000
NI PGMSTAT,X'FF'-X'10' SET REPEAT OFF 06570000
* OI PGMSTAT,X'08' SET BIGPACK ON 06580000
NI PGMSTAT,X'FF'-X'08' SET BIGPACK OFF 06590000
* OI FILSTAT,X'10' SET APPEND ON FILE 06600000
NI FILSTAT,X'FF'-X'10' SET APPEND OFF FILE 06610000
* OI DBGSTAT,X'10' SET APPEND ON DEBUG 06620000
NI DBGSTAT,X'FF'-X'10' SET APPEND OFF DEBUG 06630000
* 06640000
NI PRMSTAT,X'FF'-X'C0' SET CHECK 1 06650000
* OI PRMSTAT,X'40' SET CHECK 2 06660000
* NI PRMSTAT,X'FF'-X'80' SET CHECK 2 06670000
* OI PRMSTAT,X'C0' SET CHECK 3 06680000
* 06690000
MVC NEWTRT(8),=C'COURTRTS' 06700000
LA R3,=C'S' 06710000
CALL SETTRT 06720000
BRTORC INIT020,REST=INIT010 06730000
INIT010 LA R14,2 RC = 2 06740000
B INITRET 06750000
* 06760000
INIT020 XR R14,R14 RC = 0 06770000
INITRET RETURN 06780000
*********************************************************************** 06790000
LTORG 06800000
DROP BASE 06810000
*********************************************************************** 06820000
* ПOДПPOГPAMMA ЧTEHИЯ KOMAHД * 06830000
*********************************************************************** 06840000
* RETURN CODE = 0 - OK * 06850000
*********************************************************************** 06860000
RDTRM SAVE 06870000
USING RDTRM,BASE 06880000
LR BASE,R14 06890000
DFHTC TYPE=GET 06900000
L TIOABAR,TCTTEDA ЗAГPУЗИTЬ AДPEC TIOA 06910000
LH R1,TIOATDL ЗAГPУЗИTЬ ДЛИHУ TIOA 06920000
CH R1,=H'129' CPABHИTЬ C MAKCИM. ДЛИHOЙ 06930000
BNH RDT010 ECЛИ HE БOЛЬШE, OCTABИTЬ 06940000
LA R1,129 ЗAГPУЗИTЬ MAKCИM. ДЛИHУ 06950000
RDT010 MVI PACKAGE,C' ' CИMBOЛ - ЗAПOЛHИTEЛЬ 06960000
MVC PACKAGE+1(129),PACKAGE 06970000
LA R2,PACKAGE+129 ЗAГPУЗИTЬ AДPEC ПPOБEЛA 06980000
LR R3,R2 CKOПИPOBATЬ 06990000
LR R4,R2 EЩE PAЗ CKOПИPOBATЬ 07000000
STM R2,R4,PARSELST ЗAПИCATЬ BCE AДPECA B PARSELST 07010000
LTR R1,R1 ECTЬ ДAHHЫE B TIOA ? 07020000
BZ RDT200 ECЛИ HET, CPAЗУ OCBOБOДИTЬ 07030000
LA R3,TIOADBA AДPEC BXOДHOЙ OБЛACTИ 07040000
LA R4,PACKAGE AДPEC BЫXOДHOЙ OБЛACTИ 07050000
RDT020 CLI 0(R3),C' ' HУЖHЫ TOЛЬKO ПEЧATHЫE CИMBOЛЫ 07060000
BL RDT030 ECЛИ MEHЬШE, TO ПPOПУCTИTЬ 07070000
MVC 0(1,R4),0(R3) ЗAПИCATЬ CИMBOЛ 07080000
LA R4,1(,R4) ПEPEMECTИTЬ УKAЗATEЛЬ 07090000
RDT030 LA R3,1(,R3) ПEPEMECTИTЬ BXOДHOЙ УKAЗATEЛЬ 07100000
BCT R1,RDT020 И ПPOBEPЯTЬ CЛEДУЮЩИЙ 07110000
* PAЗДEЛИTЬ KOMAHДУ HA OПEPAHДЫ 07120000
LA R1,3 MAKCИM. ЧИCЛO OПEPAHДOB 07130000
LA R2,PARSELST AДPEC CПИCKA OПEPAHДOB 07140000
LA R5,PACKAGE AДPEC BXOДHOЙ OБЛACTИ 07150000
SR R4,R5 ПOЛУЧИTЬ ДЛИHУ ДAHHЫX 07160000
BZ RDT200 ECЛИ HET ДAHHЫX, TO BЫXOД 07170000
RDT100 CLI 0(R5),C' ' BCE ПPOБEЛЫ ПPOПУCKATЬ 07180000
BNE RDT120 ECЛИ HE ПPOБEЛ, TO HAЙДEH OПEPAHД 07190000
LA R5,1(,R5) ПEPEMECTИTЬ УKAЗATEЛЬ 07200000
BCT R4,RDT100 И CMOTPETЬ CЛEД. CИMBOЛ 07210000
B RDT200 BCE ДAHHЫE OБPAБOTAHЫ 07220000
RDT120 ST R5,0(,R2) ЗAПИCATЬ AДPEC OПEPAHДA 07230000
LA R2,4(,R2) ПEPEMECTИTЬ УKAЗATEЛЬ HA PARSELST 07240000
RDT140 LA R5,1(,R5) ПEPEMECTИTЬ УKAЗATEЛЬ 07250000
CLI 0(R5),C' ' HAЙДEH KOHEЦ OПEPAHДA ? 07260000
BE RDT160 ECЛИ ДA, ПPOПУCKATЬ ПPOБEЛЫ 07270000
BCT R4,RDT140 ПPOBEPЯTЬ CЛEД. CИMBOЛ 07280000
B RDT200 BCE ДAHHЫE OБPAБOTAHЫ 07290000
RDT160 BCT R1,RDT100 ECЛИ OПEPAHДOB < 3, ИCKATЬ CЛEД. 07300000
RDT200 ST TIOABAR,TCASCSA OCBOБOДИTЬ TIOA 07310000
DFHSC TYPE=FREEMAIN 07320000
L R6,=A(UPPER) 07330000
TR PACKAGE(130),0(R6) ПEPEBECTИ B BEPXHИЙ PEГИCTP 07340000
XR R14,R14 RC=0 07350000
RETURN 07360000
UPPER DC 256AL1(*-UPPER) 07370000
ORG UPPER+X'81' 07380000
DC C'ABCDEFGHI' 07390000
ORG UPPER+X'91' 07400000
DC C'JKLMNOPQR' 07410000
ORG UPPER+X'A2' 07420000
DC C'STUVWXYZ' 07430000
ORG UPPER+256 07440000
*********************************************************************** 07450000
LTORG 07460000
DROP BASE 07470000
*********************************************************************** 07480000
* BЫBOД COOБЩEHИЙ COURIER - CICS * 07490000
*********************************************************************** 07500000
* RETURN CODE = 0 - OK * 07510000
*********************************************************************** 07520000
WRITMS SAVE 07530000
USING WRITMS,BASE УCTAHOBИTЬ AДPECAЦИЮ 07540000
LR BASE,R14 ЗAГPУЗИTЬ БAЗOBЫЙ PEГИCTP 07550000
XR R2,R2 ДЛЯ ЗAГPУЗKИ ДЛИHЫ COOБЩEHИЯ 07560000
IC R2,PACKAGE ЗAГPУЗИTЬ ДЛИHУ 07570000
LA R3,2(,R2) ДЛИHA CR LF 07580000
STH R3,TCASCNB ЗAПИCATЬ ДЛИHУ TIOA 07590000
DFHSC TYPE=GETMAIN,CLASS=TERMINAL ЗAПPOCИTЬ TIOA 07600000
L TIOABAR,TCASCSA ЗAГPУЗИTЬ AДPEC TIOA 07610000
STH R3,TIOATDL ЗAПИCATЬ ДЛИHУ TIOA 07620000
MVC TIOADBA(2),=X'0D25' ЗAПИCATЬ CR LF 07630000
BCTR R2,0 BЫЧECTЬ 1 ДЛЯ MVC 07640000
EX R2,WRMSTXT ЗAПИCATЬ TEKCT COOБЩEHИЯ 07650000
ST TIOABAR,TCTTEDA ЗAПИCATЬ AДPEC TIOA B TCTTE 07660000
DFHTC TYPE=PUT BЫBECTИ COOБЩEHИE 07670000
XR R14,R14 RC=0 07680000
B WRI##010 07690000
WRMSTXT MVC TIOADBA+2(0),PACKAGE+1 07700000
WRI##010 RETURN 07710000
*********************************************************************** 07720000
LTORG 07730000
DROP BASE 07740000
*********************************************************************** 07750000
* ПOДПPOГPAMMA TSTDEST * 07760000
*********************************************************************** 07770000
* METOД ДOCTУПA QSAM * 07780000
* RETURN CODE = 0 - OK * 07790000
* RETURN CODE = 2 - DESTINATION NOT DEFINED IN DCT * 07800000
* RETURN CODE = 4 - INCORRECT DESTINATION * 07810000
* RETURN CODE = 6 - INCORRECT I/O REQUEST * 07820000
* RETURN CODE = 8 - INCORRECT TEST QUESTION * 07830000
*********************************************************************** 07840000
TSTDEST SAVE 07850000
USING TSTDEST,BASE 07860000
LR BASE,R14 07870000
XR R14,R14 07880000
CLI 0(R1),C'F' TEST FILE ? 07890000
BE TSTD010 ДA 07900000
CLI 0(R1),C'D' TEST DEBUG ? 07910000
BE TSTD020 ДA 07920000
LA R14,8 RC = 8 07930000
B TSTD900 07940000
TSTD010 LA R4,FILEDEST 07950000
LA R2,FILSTAT 07960000
LA R3,F#REC 07970000
B TSTD030 07980000
TSTD020 LA R4,DBGDEST 07990000
LA R2,DBGSTAT 08000000
LA R3,D#REC 08010000
* 08020000
TSTD030 EQU * 08030000
L DCTCBAR,CSADCTBA TOЧKA BXOДA 1-ГO DCT 08040000
TSTD040 CLI TDDCTDID,X'FF' ЭTO DCT ? 08050000
BE TSTD700 УBЫ.. 08060000
CLC TDDCTDID(4),0(R4) ИMЯ П.H. OПPEДEЛEHO B DCT ? 08070000
BE TSTD050 ДA 08080000
TM TDDCTDT,TDINDBM 08090000
BNO TSTD041 08100000
LA DCTCBAR,TDDCTIDD CЛEДУЮЩAЯ DCT 08110000
B TSTD040 08120000
TSTD041 TM TDDCTDT,TDINDTBM 08130000
BNO TSTD042 08140000
LA DCTCBAR,TDDCTIND CЛEДУЮЩAЯ DCT 08150000
B TSTD040 08160000
TSTD042 LA DCTCBAR,TDDCTEXD CЛEДУЮЩAЯ DCT 08170000
B TSTD040 08180000
* 08190000
TSTD050 TM TDDCTDT,TDINDTBM INTRA ? 08200000
BNO TSTD060 УBЫ.. 08210000
OI 0(R2),X'C0' SET INTRA (11.. ....) 08220000
OI 0(R2),X'01' SET OPEN (.... ...1) 08230000
OI 0(R2),X'04' SET V 08240000
NI 0(R2),X'FF'-X'08' SET V (.... 01..) 08250000
XR R15,R15 ! INTRA LRECL NOT DEFINED 08260000
STH R15,0(R3) ! ДЛИHA ЗAПИCИ -> ?#REC 08270000
XR R14,R14 RC = 0 08280000
B TSTD900 08290000
* 08300000
TSTD060 TM TDDCTDT,TDEXTRBM EXTRA ? 08310000
BO TSTD070 ДA 08320000
LA R14,4 RC = 4 08330000
B TSTD900 08340000
* 08350000
TSTD070 OI 0(R2),X'40' SET EXTRA 08360000
NI 0(R2),X'FF'-X'80' SET EXTRA (01.. ....) 08370000
XC PACKAGE(4),PACKAGE 08380000
MVC PACKAGE+1(3),TDDCTCBA+1 08390000
L R5,PACKAGE AДPEC DCB 08400000
TM 48(R5),X'10' OPEN ? 08410000
BO TSTD071 ДA 08420000
NI 0(R2),X'FF'-X'01' SET NOT OPEN (.... ...0) 08430000
XR R14,R14 RC = 0 08440000
B TSTD900 08450000
TSTD071 OI 0(R2),X'01' SET OPEN (.... ...1) 08460000
* 08470000
TSTD080 EQU * 08480000
LR R14,R5 08490000
S R14,=F'4' 08500000
CLI 0(R14),X'0F' OUTPUT ? 08510000
BE TSTD082 ДA 08520000
CLI 0(R14),X'00' INPUT ? 08530000
BE TSTD081 08540000
LA R14,6 RC = 6 08550000
B TSTD900 08560000
* 08570000
TSTD081 EQU * 08580000
OI 0(R2),X'20' SET INPUT (..1. ....) 08590000
B TSTD090 08600000
TSTD082 EQU * 08610000
NI 0(R2),X'FF'-X'20' SET OUTPUT (..0. ....) 08620000
B TSTD090 08630000
* 08640000
TSTD090 TM 26(R5),X'40' DSORG = PS ? 08650000
BO TSTD100 ДA 08660000
LA R14,4 RC = 4 08670000
B TSTD900 08680000
* 08690000
TSTD100 TM 36(R5),X'C0' RECFM = U ? 08700000
BNO TSTD110 HET 08710000
OI 0(R2),X'0C' SET U (.... 11..) 08720000
MVC 0(2,R3),82(R5) ! ДЛИHA БЛOKA -> ?#REC 08730000
XR R14,R14 RC = 0 08740000
B TSTD900 08750000
* 08760000
TSTD110 TM 36(R5),X'80' RECFM = F ? 08770000
BNO TSTD120 HET 08780000
OI 0(R2),X'08' SET F 08790000
NI 0(R2),X'FF'-X'04' SET F (.... 10..) 08800000
MVC 0(2,R3),82(R5) ! ДЛИHA ЗAПИCИ -> ?#REC 08810000
XR R14,R14 RC = 0 08820000
B TSTD900 08830000
* 08840000
TSTD120 OI 0(R2),X'04' SET V 08850000
NI 0(R2),X'FF'-X'08' SET V (.... 01..) 08860000
MVC 0(2,R3),82(R5) ! ДЛИHA ЗAПИCИ -> ?#REC 08870000
XR R14,R14 RC = 0 08880000
B TSTD900 08890000
* 08900000
TSTD700 LA R14,2 RC = 2 08910000
TSTD900 RETURN 08920000
*********************************************************************** 08930000
LTORG 08940000
DROP BASE 08950000
*********************************************************************** 08960000
* OБPAБOTKA KOMAHДЫ S T A T U S * 08970000
*********************************************************************** 08980000
* RETURN CODE = 0 - OK * 08990000
*********************************************************************** 09000000
STATUS SAVE 09010000
USING STATUS,BASE 09020000
LR BASE,R14 09030000
XR R3,R3 OЧИCTИTЬ 09040000
IC R3,RETCODE ЗAГPУЗИTЬ KOД OШИБKИ 09050000
MH R3,=H'30' УMHOЖИTЬ HA ДЛИHУ COOБЩEHИЯ 09060000
L R6,ERRTBL#A ПOЛУЧИTЬ AДPEC COOБЩEHИЙ 09070000
LA R3,0(R3,R6) ПOЛУЧИTЬ AДPEC COOБЩEHИЯ 09080000
WRTEXT 0(R3),30 BЫДATЬ COOБЩEHИE 09090000
XR R14,R14 RC = 0 09100000
RETURN 09110000
*********************************************************************** 09120000
LTORG 09130000
DROP BASE 09140000
*********************************************************************** 09150000
* OБPAБOTKA KOMAHДЫ S H O W * 09160000
*********************************************************************** 09170000
* RETURN CODE = 0 - OK * 09180000
* RETURN CODE = 2 - ILLEGAL SHOW COMMAND * 09190000
*********************************************************************** 09200000
SHOW SAVE 09210000
USING SHOW,BASE 09220000
LR BASE,R14 09230000
L R6,A#TRT#SO AДPEC TAБЛИЦЫ TRT ASCII EBCDIC 09240000
CLC 0(3,R2),=C'PAR' SHOW PARM ? 09250000
BNE SHO#200 ECЛИ HET, ПPOBEPИTЬ TRT 09260000
* 09270004
MVC PACKAGE(27),SHOWFIL FILE TEXT OR BINARY 09280004
TM PGMSTAT,X'40' ------------------------------- 09290004
BZ SHO#010 09300000
MVC PACKAGE+21(6),=C'TEXT ' 09310000
SHO#010 CALL WRITMS 09320000
MVC PACKAGE(31),SHOWTRX ИMЯ TAБЛИЦЫ TRT 09330004
MVC PACKAGE+29(1),TRTNAME+7 -------------------- 09340004
CALL WRITMS 09350000
MVC PACKAGE(21),SHOWQUO ПPEФИKC QUOTE 09360004
MVC PACKAGE+20(1),QUOTE ---------------------- 09370004
TR PACKAGE+20(1),0(R6) 09380000
CALL WRITMS 09390000
MVC PACKAGE(21),SHOWPRE ПPEФИKC PREF 09400004
MVC PACKAGE+20(1),PREF --------------------- 09410004
TR PACKAGE+20(1),0(R6) 09420000
CALL WRITMS 09430000
MVC PACKAGE(31),SHOWPAC ДЛИHA ПAKETOB PACKET 09440004
LH R1,PACKET ----------------------- 09450004
BINCVRT R1,PACKAGE+15,DBLWRK 09460000
CALL WRITMS 09470000
MVC PACKAGE(29),SHOWDEL ЗAДEPЖKA SEND DELAY 09480004
LH R1,DELAY ---------------------- 09490004
BINCVRT R1,PACKAGE+15,DBLWRK 09500000
CALL WRITMS 09510000
MVC PACKAGE(15),SHOWRET ЧИCЛO ПOBTOPOB RETRY 09520004
LH R1,RETRY ---------------------- 09530004
BINCVRT R1,PACKAGE+9,DBLWRK 09540000
CALL WRITMS 09550000
MVC PACKAGE(37),SHOWREC ДЛИHA INTRA RECORD 09560004
LH R1,I#REC ----------------------- 09570004
SH R1,=H'4' - L'RDW 09580000
BINCVRT R1,PACKAGE+25,DBLWRK 09590000
CALL WRITMS 09600000
MVC PACKAGE(14),SHOWAPP PEЖИM APPEND 09610004
TM FILSTAT,X'10' ----------------------- 09620004
BZ SHO#020 09630000
MVC PACKAGE+11(3),=C'ON ' 09640000
SHO#020 CALL WRITMS 09650000
MVC PACKAGE(13),SHOWDEB PEЖИM DEBUG 09660004
TM PRMSTAT,X'0C' ---------------------- 09670004
BZ SHO#030 09680000
MVC PACKAGE+10(3),=C'ON ' 09690000
SHO#030 CALL WRITMS 09700000
XR R14,R14 RC = 0 09710000
B SHORET 09720000
* 09730000
SHO#200 EQU * 09740000
CLC 0(3,R2),=C'DES' SHOW DEST ? 09750000
BNE SHO#400 HET 09760000
MVC FILEDEST(4),0(R3) ЗAПИCATЬ ИMЯ П.H. 09770000
LA R1,=C'F' TEST FILE 09780000
CALL TSTDEST 09790000
BRTORC SHO#210,SHO#330,REST=SHO#360 09800000
SHO#210 MVC PACKAGE+1(13),=C'DESTINATION: ' 09810000
MVC PACKAGE+14(4),FILEDEST 09820000
XR R14,R14 09830000
LA R14,17 09840000
STC R14,PACKAGE ДЛИHA COOБЩEHИЯ 09850000
CALL WRITMS BЫBOД 09860000
XR R14,R14 09870000
MVC PACKAGE+1(7),=C'STATE: ' 09880000
TM FILSTAT,X'C0' INTRA ? 09890000
BNO SHO#220 HET 09900000
MVC PACKAGE+8(10),=C'INTRA ' 09910000
LA R14,17 09920000
STC R14,PACKAGE ДЛИHA COOБЩEHИЯ 09930000
CALL WRITMS BЫBOД 09940000
B SHO#300 RETURN 09950000
* 09960000
SHO#220 TM FILSTAT,X'01' OPEN ? 09970000
BO SHO#230 ДA 09980000
MVC PACKAGE+8(12),=C'EXTRA CLOSE' 09990000
LA R14,19 10000000
STC R14,PACKAGE 10010000
CALL WRITMS 10020000
B SHO#300 10030000
* 10040000
SHO#230 MVC PACKAGE+8(13),=C'EXTRA OPEN ' 10050000
TM FILSTAT,X'20' INPUT ? 10060000
BO SHO#240 ДA 10070000
MVC PACKAGE+21(6),=C'OUTPUT' 10080000
B SHO#250 10090000
SHO#240 MVC PACKAGE+21(6),=C'INPUT ' 10100000
SHO#250 LA R14,26 10110000
STC R14,PACKAGE ДЛИHA COOБЩEHИЯ 10120000
CALL WRITMS BЫBOД 10130000
MVC PACKAGE+1(8),=C'FORMAT: ' 10140000
TM FILSTAT,X'0C' 10150000
BO SHO#260 FORMAT U 10160000
TM FILSTAT,X'08' 10170000
BO SHO#270 FORMAT F 10180000
MVC PACKAGE+9(31),=C'V RECORD LENGHT = ' 10190000
B SHO#280 10200000
SHO#260 MVC PACKAGE+9(31),=C'U RECORD LENGHT = ' 10210000
B SHO#280 10220000
SHO#270 MVC PACKAGE+9(31),=C'F RECORD LENGHT = ' 10230000
SHO#280 LH R14,F#REC 10240000
BINCVRT R14,PACKAGE+30,DBLWRK 10250000
XR R14,R14 10260000
LA R14,39 10270000
STC R14,PACKAGE ДЛИHA COOБЩEHИЯ 10280000
CALL WRITMS BЫBOД 10290000
SHO#300 XR R14,R14 10300000
ST R14,FILEDEST ЗATEPETЬ ИMЯ П.H. 10310000
B SHORET 10320000
* 10330000
SHO#330 MVC PACKAGE+1(13),=C'DESTINATION: ' 10340000
MVC PACKAGE+14(4),FILEDEST 10350000
XR R14,R14 10360000
LA R14,17 10370000
STC R14,PACKAGE ДЛИHA COOБЩEHИЯ 10380000
CALL WRITMS BЫBOД 10390000
XR R14,R14 10400000
WRMESS 'IS NOT DEFINED.' 10410000
B SHO#300 10420000
* 10430000
SHO#360 MVC PACKAGE+1(23),=C'TSTDEST ERROR: ' 10440000
BINCVRT R14,PACKAGE+15,DBLWRK 10450000
LA R14,23 10460000
STC R14,PACKAGE 10470000
CALL WRITMS 10480000
B SHO#300 10490000
* 10500000
SHO#400 CLC 0(3,R2),=C'TRT' SHOW TRT ? 10510000
BE SHO#410 ДA 10520000
LA R14,2 RC = 2 10530000
B SHORET 10540000
SHO#410 WRMESS 'OUTPUT DISK TRANSLATE TABLE IS:' 10550000
L R1,A#TRT#AE 10560000
BAL R2,SHO#600 BЫBECTИ BXOДHУЮ TAБЛИЦУ 10570000
WRMESS 'TYPE <CR>' 10580000
CALL RDTRM 10590000
WRMESS 'INPUT DISK TRANSLATE TABLE IS:' 10600000
L R1,A#TRT#EA 10610000
BAL R2,SHO#600 BЫBECTИ BЫXOДHУЮ TAБЛИЦУ 10620000
XR R14,R14 RC = 0 10630000
B SHORET 10640000
* 10650000
SHO#600 LA R3,16 CЧETЧИK CTPOK 10660000
SHO#620 LA R5,16 CЧETЧИK CИMBOЛOB B CTPOKE 10670000
SR R14,R14 ДЛЯ ПPEOБPAЗOBAHИЯ ДAHHЫX 10680000
MVI PACKAGE,32 ДЛИHA ДAHHЫX 10690000
LA R4,PACKAGE+1 AДPEC ПEPBOГO БAЙTA BЫX. ПOЛЯ 10700000
SHO#640 IC R14,0(,R1) ЗAГPУЗИTЬ OЧEPEДHOЙ БAЙT 10710000
STC R14,1(,R4) ЗAПИCATЬ BTOPУЮ TETPAДУ 10720000
NI 1(R4),X'0F' CБPOCИTЬ CTAPШУЮ TETPAДУ 10730000
SRL R14,4 УДAЛИTЬ MЛAДШУЮ TETPAДУ 10740000
STC R14,0(,R4) ЗAПИCATЬ CTAPШУЮ ПOЛOBИHУ 10750000
TR 0(2,R4),TRBYTE ПEPEBECTИ B CИMBOЛЬHЫЙ BИД 10760000
LA R1,1(,R1) ПEPEMECTИTЬ BXOДHOЙ УKAЗATEЛЬ 10770000
LA R4,2(,R4) ПEPEMECTИTЬ BЫXOДHOЙ УKAЗATEЛЬ 10780000
BCT R5,SHO#640 И ДAMПИPOBATЬ CЛEД. БAЙT 10790000
* CTPOKA ЗAПOЛHEHA 10800000
CALL WRITMS 10810000
BCT R3,SHO#620 ДAMПИPOBATЬ CЛEДУЮЩУЮ CTPOKУ 10820000
BR R2 BOЗBPAT 10830000
* 10840000
TRBYTE DC C'0123456789ABCDEF' 10850000
SHOWQUO DC AL1(20),C'QUOTE CHARACTER IS .' 10860000
SHOWPRE DC AL1(20),C'PREF CHARACTER IS .' 10870000
SHOWPAC DC AL1(30),C'PACKET SIZE IS ..... (DECIMAL)' 10880000
SHOWDEL DC AL1(28),C'DELAY VALUE IS ..... SECONDS' 10890000
SHOWDEB DC AL1(12),C'DEBUG IS OFF' 10900000
SHOWFIL DC AL1(26),C'FILE TYPE IS SET TO BINARY' 10910000
SHOWTRX DC AL1(30),C'CURRENT TRANSLATE TABLE IS - -' 10920000
SHOWAPP DC AL1(13),C'APPEND IS OFF' 10930000
SHOWREC DC AL1(36),C'INTRA RECORD SIZE SET IS ..... BYTE.' 10940000
SHOWRET DC AL1(14),C'RETRY IS .....' 10950000
* 10960000
SHORET RETURN 10970000
*********************************************************************** 10980000
LTORG 10990000
DROP BASE 11000000
*********************************************************************** 11010000
* ПOДПPOГPAMMA OБPAБOTKИ KOMAHДЫ S E T * 11020000
*********************************************************************** 11030000
* RETURN CODE = 0 - OK * 11040000
* RETURN CODE = 2 - ILLEGAL SET COMMAND * 11050000
*********************************************************************** 11060000
SET SAVE 11070000
USING SET,BASE 11080000
LR BASE,R14 ЗAГPУЗИTЬ БAЗOBЫЙ PEГИCTP 11090000
CLC 0(3,R2),=C'APP' SET APPEND ? 11100000
BNE SET#010 УBЫ.. 11110000
CLI 0(R3),C' ' ECTЬ 3-ИЙ OПEPAHД ? 11120000
BE SETERR УBЫ.. 11130000
CLI 0(R3),C'?' SET APPEND HELP ? 11140000
BE SET#005 ДA 11150000
CALL SETAPEND 11160000
B SETOK 11170000
SET#005 WRMESS 'ON ! OFF (ENABLE OR DISABLE APPEND MODE).' 11180000
B SETOK 11190000
SET#010 CLC 0(3,R2),=C'QUO' SET QUOTE ? 11200000
BNE SET#030 УBЫ.. 11210000
CLI 0(R3),C' ' ECTЬ 3-ИЙ OПEPAHД ? 11220000
BE SETERR УBЫ.. 11230000
CLI 0(R3),C'?' SET QUOTE HELP ? 11240000
BE SET#020 ДA 11250000
CALL SETQUOTE 11260000
B SETOK 11270000
SET#020 WRMESS 'A SINGLE CHARACTER.' 11280000
B SETOK 11290000
SET#030 CLC 0(3,R2),=C'PAC' SET PACKET-SIZE ? 11300000
BNE SET#050 УBЫ.. 11310000
CLI 0(R3),C' ' ECTЬ OПEPAHД ? 11320000
BE SETERR УBЫ.. 11330000
CLI 0(R3),C'?' SET PAC HELP ? 11340000
BE SET#040 ДA 11350000
CALL SETPACK 11360000
B SETOK 11370000
SET#040 WRMESS 'PACKET-SIZE (RANGE: 26-94 DECIMAL).' 11380000
B SETOK 11390000
SET#050 CLC 0(3,R2),=C'DEL' SET DELAY ? 11400000
BNE SET#070 УBЫ.. 11410000
CLI 0(R3),C' ' ECTЬ OПEPAHД ? 11420000
BE SETERR УBЫ.. 11430000
CLI 0(R3),C'?' SET DELAY HELP ? 11440000
BE SET#060 ДA 11450000
CALL SETDELAY 11460000
B SETOK 11470000
SET#060 WRMESS 'DELAY INTERVAL BEFORE SENDING A FILE.' 11480000
B SETOK 11490000
SET#070 CLC 0(3,R2),=C'DEB' DEBUG ? 11500000
BNE SET#090 УBЫ.. 11510000
CLI 0(R3),C' ' ECTЬ OПEPAHД ? 11520000
BE SETERR УBЫ.. 11530000
CLI 0(R3),C'?' SET DEBUG HELP ? 11540000
BE SET#080 ДA 11550000
CALL SETDEBUG 11560000
B SETOK 11570000
SET#080 WRMESS 'ON ! OFF (ENABLE OR DISABLE DEBUG MODE).' 11580000
B SETOK 11590000
SET#090 CLC 0(3,R2),=C'TRT' SET TRT ? 11600000
BNE SET#120 УBЫ.. 11610000
CLI 0(R3),C' ' ECTЬ OПEPAHД ? 11620000
BE SETERR УBЫ.. 11630000
CLI 0(R3),C'?' ЗAПPOШEH HELP ? 11640000
BE SET#100 ДA 11650000
CALL SETTRT 11660000
BRTORC SETOK,REST=SET#110 11670000
SET#100 WRMESS 'A SINGLE CHARACTER.' 11680000
WRMESS 'S (STANDARD) ! X (TR TABLE SUFFIX).' 11690000
B SETOK 11700000
SET#110 WRMESS 'TRANSLATE TABLE IS NOT DEFINED.' 11710000
B SETOK 11720000
SET#120 CLC 0(3,R2),=C'FIL' SET FILE ? 11730000
BNE SET#150 УBЫ.. 11740000
CLI 0(R3),C' ' ECTЬ OПEPAHД ? 11750000
BE SETERR УBЫ.. 11760000
CLI 0(R3),C'?' SET FILE HELP ? 11770000
BE SET#130 ДA 11780000
CALL SETFILE 11790000
BRTORC SETOK,REST=SET#140 11800000
SET#130 WRMESS 'TEXT ! BINARY.' 11810000
B SETOK 11820000
SET#140 WRMESS 'COMMAND IS SET FILE TEXT ! BINARY' 11830000
B SETOK 11840000
SET#150 CLC 0(3,R2),=C'PRE' SET PREF ? 11850000
BNE SET#170 УBЫ.. 11860000
CLI 0(R3),C' ' ECTЬ 3-ИЙ OПEPAHД ? 11870000
BE SETERR УBЫ.. 11880000
CLI 0(R3),C'?' SET PREF HELP ? 11890000
BE SET#160 ДA 11900000
CALL SETPREF 11910000
B SETOK 11920000
SET#160 WRMESS 'A SINGLE CHARACTER.' 11930000
B SETOK 11940000
SET#170 CLC 0(3,R2),=C'REC' SET RECORD ? 11950000
BNE SET#190 УBЫ.. 11960000
CLI 0(R3),C' ' ECTЬ 3-ИЙ OПEPAHД ? 11970000
BE SETERR УBЫ.. 11980000
CLI 0(R3),C'?' SET RECORD HELP ? 11990000
BE SET#180 ДA 12000000
CALL SETRECRD 12010000
B SETOK 12020000
SET#180 WRMESS 'RECORD-LENGHT FOR INTRA DESTINATION.' 12030000
WRMESS '(RANGE: 80-4096. SET IS 4096.)' 12040000
B SETOK 12050000
SET#190 CLC 0(3,R2),=C'PRO' SET PROMPT ? 12060000
BNE SET#210 УBЫ.. 12070002
CLI 0(R3),C' ' ECTЬ 3-ИЙ OПEPAHД ? 12080000
BE SETERR УBЫ.. 12090000
CLI 0(R3),C'?' SET PROMPT HELP ? 12100000
BE SET#200 ДA 12110000
CALL SETPRMPT 12120000
B SETOK 12130000
SET#200 WRMESS 'PROMPT STRING. (LENGHT 1-22).' 12140000
B SETOK 12150000
SET#210 CLC 0(3,R2),=C'RET' SET RETRY ? 12160002
BNE SETERROR УBЫ.. 12170002
CLI 0(R3),C' ' ECTЬ OПEPAHД ? 12180002
BE SETERR УBЫ.. 12190002
CLI 0(R3),C'?' SET RET HELP ? 12200002
BE SET#220 ДA 12210002
CALL SETRETRY 12220002
B SETOK 12230002
SET#220 WRMESS 'PACKET RETRY. (RANGE: 1-63 DECIMAL).' 12240002
B SETOK 12250002
* 12260000
SETERR WRMESS '? NOT CONFIRMED' 12270000
SETOK XR R14,R14 RC = 0 12280000
B SETRET 12290000
SETERROR LA R14,2 RC = 2 12300000
SETRET RETURN 12310000
*********************************************************************** 12320000
LTORG 12330000
DROP BASE 12340000
*********************************************************************** 12350000
* SET RECORD * 12360000
*********************************************************************** 12370000
* RETURN CODE = 0 - OK * 12380000
* RETURN CODE = 2 - ILLEGAL SET COMMAND * 12390000
*********************************************************************** 12400000
SETRECRD SAVE 12410000
USING SETRECRD,BASE 12420000
LR BASE,R14 12430000
XC DBLWRK,DBLWRK OЧИCTИTЬ PAБOЧУЮ OБЛACTЬ 12440000
LR R2,R3 CKOПИPOBATЬ AДPEC HAЧAЛA OПEPAHДA 12450000
LA R1,4 MAKCИMAЛЬHAЯ ДЛИHA OПEPAHДA 12460000
SETRECLP CLI 0(R2),C'0' ДOЛЖHA БЫTЬ ЦИФPA 12470000
BL SETREC01 ЦИФP MEHЬШE 0 HE БЫBAET 12480000
CLI 0(R2),C'9' 12490000
BH SETREC01 TAK ЖE KAK И БOЛЬШE 9 12500000
CLI 1(R2),C' ' KOHEЦ OПEPAHДA ? 12510000
BE SETREC02 ECЛИ ДA, BЫXOД ИЗ ЦИKЛA 12520000
LA R2,1(R2) ПEPEMECTИTЬ УKAЗATEЛЬ 12530000
BCT R1,SETRECLP И ПPOBEPЯTЬ CЛEДУЮЩИЙ CИMBOЛ 12540000
SETREC01 WRMESS 'MUST BE BETWEEN 80-4092' 12550000
LA R14,2 RC = 2 12560000
B SETRECR 12570000
PCKREC PACK DBLWRK(8),0(0,R3) 12580000
SETREC02 SR R2,R3 ПOЛУЧИTЬ ДЛИHУ OПEPAHДA - 1 12590000
EX R2,PCKREC УПAKOBATЬ 12600000
CVB R2,DBLWRK 12610000
CH R2,=H'80' ECЛИ MEHЬШE, OTBEPГHУTЬ 12620000
BL SETREC01 12630000
CH R2,=H'4092' 12640000
BH SETREC01 ECЛИ БOЛЬШE, OTBEPГHУTЬ 12650000
LA R2,4(R2) + RDW 12660000
STH R2,I#REC 12670000
XR R14,R14 RC = 0 12680000
SETRECR RETURN 12690000
*********************************************************************** 12700000
LTORG 12710000
DROP BASE 12720000
*********************************************************************** 12730000
* SET PROMPT * 12740000
*********************************************************************** 12750000
* RETURN CODE = 0 - OK * 12760000
* RETURN CODE = 2 - ILLEGAL SET COMMAND * 12770000
*********************************************************************** 12780000
SETPRMPT SAVE 12790000
USING SETPRMPT,BASE 12800000
LR BASE,R14 12810000
LR R2,R3 CKOПИPOBATЬ AДPEC HAЧAЛA OПEPAHДA 12820000
LA R1,22 MAKCИMAЛЬHAЯ ДЛИHA OПEPAHДA 12830000
SETPRMP1 EQU * 12840000
CLI 1(R2),C' ' KOHEЦ OПEPAHДA ? 12850000
BE SETPRMP3 ECЛИ ДA, BЫXOД ИЗ ЦИKЛA 12860000
LA R2,1(R2) ПEPEMECTИTЬ УKAЗATEЛЬ 12870000
BCT R1,SETPRMP1 И ПPOBEPЯTЬ CЛEДУЮЩИЙ CИMBOЛ 12880000
SETPRMP2 WRMESS 'LENGHT MUST BE BETWEEN 1-22.' 12890000
LA R14,2 RC = 2 12900000
B SETPRMPR 12910000
PRMPT#99 MVC 1(0,R15),0(R3) 12920000
SETPRMP3 SR R2,R3 ПOЛУЧИTЬ ДЛИHУ OПEPAHДA - 1 12930000
LA R15,PROMPT 12940000
EX R2,PRMPT#99 ПEPECЛATЬ 12950000
LA R2,2(R2) ДЛИHA + 1 (SPACE) 12960000
STC R2,0(R15) 12970000
AR R15,R2 12980000
MVI 0(R15),C' ' 12990000
XR R14,R14 RC = 0 13000000
SETPRMPR RETURN 13010000
*********************************************************************** 13020000
LTORG 13030000
DROP BASE 13040000
*********************************************************************** 13050000
* SET QUOTE * 13060000
*********************************************************************** 13070000
* RETURN CODE = 0 - OK * 13080000
* RETURN CODE = 2 - ILLEGAL SET COMMAND * 13090000
*********************************************************************** 13100000
SETQUOTE SAVE 13110000
USING SETQUOTE,BASE 13120000
LR BASE,R14 13130000
CLI 1(R3),C' ' OДИH CИMBOЛ ? 13140000
BE SETQU01 ECЛИ ДA, ПPOBEPЯTЬ QUOTE 13150000
WRMESS 'ONE CHARACTER ONLY' 13160000
LA R14,2 RC = 2 13170000
B SETQR 13180000
SETQU01 EQU * 13190000
L R6,A#TRT#SI AДPEC TAБЛИЦЫ TRT EBCDIC -> ASCII 13200000
TR 0(1,R3),0(R6) ПEPEBECTИ B ASCII 13210000
CLI 0(R3),X'21' HE MOЖET БЫTЬ MEHЬШE 32 13220000
BL SETQE ECЛИ MEHЬШE, TO OШИБKA 13230000
CLI 0(R3),X'7E' HE MOЖET БЫTЬ БOЛЬШE 126 13240000
BH SETQE ECЛИ БOЛЬШE, TO OШИБKA 13250000
CLI 0(R3),X'3E' ДOЛЖEH БЫTЬ B ИHTEPBAЛE 32-62 13260000
BNH SETQO 13270000
CLI 0(R3),X'60' ИЛИ B ИHTEPBAЛE 96-126 13280000
BNL SETQO ECЛИ HE MEHЬШE, OK 13290000
SETQE WRMESS 'MUST FALL BETWEEN 41-76, 140 OR 173-176 (OCTAL)' 13300000
LA R14,2 RC = 2 13310000
B SETQR 13320000
SETQO MVC QUOTE(1),0(R3) ЗAПИCATЬ CИMBOЛ 13330000
XR R14,R14 RC = 0 13340000
SETQR RETURN 13350000
*********************************************************************** 13360000
LTORG 13370000
DROP BASE 13380000
*********************************************************************** 13390000
* SET PREF * 13400000
*********************************************************************** 13410000
* RETURN CODE = 0 - OK * 13420000
* RETURN CODE = 2 - ILLEGAL SET COMMAND * 13430000
*********************************************************************** 13440000
SETPREF SAVE 13450000
USING SETPREF,BASE 13460000
LR BASE,R14 13470000
CLI 1(R3),C' ' OДИH CИMBOЛ ? 13480000
BE SETPR01 ECЛИ ДA, ПPOBEPЯTЬ PREF 13490000
WRMESS 'ONE CHARACTER ONLY' 13500000
LA R14,2 RC = 2 13510000
B SETPRRET 13520000
SETPR01 EQU * 13530000
L R6,A#TRT#SI AДPEC TAБЛИЦЫ TRT EBCDIC -> ASCII 13540000
TR 0(1,R3),0(R6) ПEPEBECTИ B ASCII 13550000
CLI 0(R3),X'21' HE MOЖET БЫTЬ MEHЬШE 32 13560000
BL SETPRER ECЛИ MEHЬШE, TO OШИБKA 13570000
CLI 0(R3),X'7E' HE MOЖET БЫTЬ БOЛЬШE 126 13580000
BH SETPRER ECЛИ БOЛЬШE, TO OШИБKA 13590000
CLI 0(R3),X'3E' ДOЛЖEH БЫTЬ B ИHTEPBAЛE 32-62 13600000
BNH SETPROK 13610000
CLI 0(R3),X'60' ИЛИ B ИHTEPBAЛE 96-126 13620000
BNL SETPROK ECЛИ HE MEHЬШE, OK 13630000
SETPRER WRMESS 'MUST FALL BETWEEN 41-76, 140 OR 173-176 (OCTAL)' 13640000
LA R14,2 RC = 2 13650000
B SETPRRET 13660000
SETPROK MVC PREF(1),0(R3) ЗAПИCATЬ CИMBOЛ 13670000
XR R14,R14 RC = 0 13680000
SETPRRET RETURN 13690000
*********************************************************************** 13700000
LTORG 13710000
DROP BASE 13720000
*********************************************************************** 13730000
* SET PACKET-SIZE * 13740000
*********************************************************************** 13750000
* RETURN CODE = 0 - OK * 13760000
* RETURN CODE = 2 - ILLEGAL SET COMMAND * 13770000
*********************************************************************** 13780000
SETPACK SAVE 13790000
USING SETPACK,BASE 13800000
LR BASE,R14 13810000
CLI 0(R3),C'0' ДOЛЖEH БЫTЬ >= 0 13820000
BL SETKE ECЛИ MEHЬШE, OШИБKA 13830000
CLI 0(R3),C'9' ДOЛЖEH БЫTЬ <= 9 13840000
BH SETKE ECЛИ БOЛЬШE, TO TOЖE OШИБKA 13850000
XC DBLWRK,DBLWRK OЧИCTИTЬ PAБOЧУЮ OБЛACTЬ 13860000
CLI 1(R3),C' ' HE ДOЛЖEH БЫTЬ KOHEЦ 13870000
BE SETKE ECЛИ 1 ЦИФPA, TO ЭTO OШИБKA 13880000
CLI 2(R3),C' ' A ЗДECЬ ДOЛЖEH БЫTЬ KOHEЦ OПEPAHДA 13890000
BNE SETKE ECЛИ HE KOHEЦ, TO ЭTO OШИБKA 13900000
PACK DBLWRK(8),0(2,R3) УПAKOBATЬ OПEPAHД 13910000
CVB R14,DBLWRK ЗAГPУЗИTЬ PAЗMEP ПAKETA 13920000
CH R14,=H'26' MИHИMAЛЬHOE ЗHAЧEHИE ДЛИHЫ 13930000
BL SETKE ECЛИ MEHЬШE, OTBEPГHУTЬ 13940000
CH R14,=H'94' MAKCИMAЛЬHAЯ ДЛИHA ПAKETA 13950000
BH SETKE ECЛИ БOЛЬШE MAKCИMУMA, TO HE ГOДИTCЯ 13960000
STH R14,PACKET ЗAПИCATЬ ПAPAMETP B TWA 13970000
XR R14,R14 RC = 0 13980000
B SETKR 13990000
SETKE WRMESS 'MUST BE BETWEEN 26-94 (DECIMAL)' 14000000
LA R14,2 RC = 2 14010000
SETKR RETURN 14020000
*********************************************************************** 14030000
LTORG 14040000
DROP BASE 14050000
*********************************************************************** 14060000
* SET DELAY * 14070000
*********************************************************************** 14080000
* RETURN CODE = 0 - OK * 14090000
* RETURN CODE = 2 - ILLEGAL SET COMMAND * 14100000
*********************************************************************** 14110000
SETDELAY SAVE 14120000
USING SETDELAY,BASE 14130000
LR BASE,R14 14140000
XC DBLWRK,DBLWRK OЧИCTИTЬ PAБOЧУЮ OБЛACTЬ 14150000
LR R2,R3 CKOПИPOBATЬ AДPEC HAЧAЛA OПEPAHДA 14160000
LA R1,5 MAKCИMAЛЬHAЯ ДЛИHA OПEPAHДA 14170000
SETDLOOP CLI 0(R2),C'0' ДOЛЖHA БЫTЬ ЦИФPA 14180000
BL SETDE ЦИФP MEHЬШE 0 HE БЫBAET 14190000
CLI 0(R2),C'9' 14200000
BH SETDE TAK ЖE KAK И БOЛЬШE 9 14210000
CLI 1(R2),C' ' KOHEЦ OПEPAHДA ? 14220000
BE SETD1 ECЛИ ДA, BЫXOД ИЗ ЦИKЛA 14230000
LA R2,1(R2) ПEPEMECTИTЬ УKAЗATEЛЬ 14240000
BCT R1,SETDLOOP И ПPOBEPЯTЬ CЛEДУЮЩИЙ CИMBOЛ 14250000
SETDE WRMESS 'MUST BE BETWEEN 1-32767' 14260000
LA R14,2 RC = 2 14270000
B SETDR 14280000
PCK PACK DBLWRK(8),0(0,R3) 14290000
SETD1 SR R2,R3 ПOЛУЧИTЬ ДЛИHУ OПEPAHДA - 1 14300000
EX R2,PCK УПAKOBATЬ 14310000
CVB R2,DBLWRK ЗAГPУЗИTЬ ЗHAЧEHИE ЗAДEPЖKИ 14320000
LTR R2,R2 ECЛИ HOЛЬ, TO HE ГOДИTCЯ 14330000
BNP SETDE 14340000
CH R2,=H'32767' MAKCИMAЛЬHAЯ BEЛИЧИHA ЗAДEPЖKИ 14350000
BH SETDE ECЛИ БOЛЬШE, OTBEPГHУTЬ 14360000
STH R2,DELAY ЗAПИCATЬ ЗAДEPЖKУ B TWA 14370000
XR R14,R14 RC = 0 14380000
SETDR RETURN 14390000
*********************************************************************** 14400000
LTORG 14410000
DROP BASE 14420000
*********************************************************************** 14430002
* SET RETRY * 14440002
*********************************************************************** 14450002
* RETURN CODE = 0 - OK * 14460002
* RETURN CODE = 2 - ILLEGAL SET COMMAND * 14470002
*********************************************************************** 14480002
SETRETRY SAVE 14490002
USING SETRETRY,BASE 14500002
LR BASE,R14 14510002
XC DBLWRK,DBLWRK OЧИCTИTЬ PAБOЧУЮ OБЛACTЬ 14520002
LR R2,R3 CKOПИPOBATЬ AДPEC HAЧAЛA OПEPAHДA 14530002
LA R1,2 MAKCИMAЛЬHAЯ ДЛИHA OПEPAHДA 14540002
SETRLOOP CLI 0(R2),C'0' ДOЛЖHA БЫTЬ ЦИФPA 14550002
BL SETRE ЦИФP MEHЬШE 0 HE БЫBAET 14560002
CLI 0(R2),C'9' 14570002
BH SETRE TAK ЖE KAK И БOЛЬШE 9 14580002
CLI 1(R2),C' ' KOHEЦ OПEPAHДA ? 14590002
BE SETR1 ECЛИ ДA, BЫXOД ИЗ ЦИKЛA 14600002
LA R2,1(R2) ПEPEMECTИTЬ УKAЗATEЛЬ 14610002
BCT R1,SETRLOOP И ПPOBEPЯTЬ CЛEДУЮЩИЙ CИMBOЛ 14620002
SETRE WRMESS 'MUST BE BETWEEN 1-63' 14630002
LA R14,2 RC = 2 14640002
B SETRR 14650002
RETRYPK PACK DBLWRK(8),0(0,R3) 14660002
SETR1 SR R2,R3 ПOЛУЧИTЬ ДЛИHУ OПEPAHДA - 1 14670002
EX R2,RETRYPK УПAKOBATЬ 14680002
CVB R2,DBLWRK ЗAГPУЗИTЬ ЗHAЧEHИE RETRY 14690002
LTR R2,R2 ECЛИ HOЛЬ, TO HE ГOДИTCЯ 14700002
BNP SETRE 14710002
CH R2,=H'63' MAKCИMAЛЬHAЯ BEЛИЧИHA RETRY 14720002
BH SETRE ECЛИ БOЛЬШE, OTBEPГHУTЬ 14730002
STH R2,RETRY ЗAПИCATЬ RETRY B TWA 14740002
XR R14,R14 RC = 0 14750002
SETRR RETURN 14760002
*********************************************************************** 14770002
LTORG 14780002
DROP BASE 14790002
*********************************************************************** 14800000
* SET APPEND * 14810000
*********************************************************************** 14820000
* RETURN CODE = 0 - OK * 14830000
* RETURN CODE = 2 - ILLEGAL SET COMMAND * 14840000
*********************************************************************** 14850000
SETAPEND SAVE 14860000
USING SETAPEND,BASE 14870000
LR BASE,R14 14880000
CLC 0(2,R3),=C'ON' SET APPEND ON ? 14890000
BE SETAON ECЛИ ДA, УCTAHOBИTЬ 14900000
CLC 0(2,R3),=C'OF' SET APPEND OFF ? 14910000
BE SETAOFF ECЛИ ДA, CHЯTЬ PEЖИM 14920000
WRMESS 'COMMAND IS SET APPEND ON ! OFF' 14930000
LA R14,2 RC = 2 14940000
B SETAPPR 14950000
SETAON OI FILSTAT,X'10' SET APPEND ON 14960000
WRMESS 'APPEND ON.' 14970000
B SETAA 14980000
SETAOFF NI FILSTAT,X'FF'-X'10' SET APPEND OFF 14990000
WRMESS 'APPEND OFF.' 15000000
SETAA XR R14,R14 RC = 0 15010000
SETAPPR RETURN 15020000
*********************************************************************** 15030000
LTORG 15040000
DROP BASE 15050000
*********************************************************************** 15060000
* SET DEBUG * 15070000
*********************************************************************** 15080000
* RETURN CODE = 0 - OK * 15090000
* RETURN CODE = 2 - ILLEGAL SET COMMAND * 15100000
*********************************************************************** 15110000
SETDEBUG SAVE 15120000
USING SETDEBUG,BASE 15130000
LR BASE,R14 15140000
CLC 0(2,R3),=C'ON' SET DEBUG ON ? 15150000
BE SETGON ECЛИ ДA, УCTAHOBИTЬ 15160000
CLC 0(2,R3),=C'OF' SET DEBUG OFF ? 15170000
BE SETGOFF ECЛИ ДA, CHЯTЬ PEЖИM 15180000
WRMESS 'COMMAND IS SET DEBUG ON ! OFF' 15190000
LA R14,2 RC = 2 15200000
B SETGR 15210000
SETGON TM PRMSTAT,X'0C' DEBUG ON ? 15220000
BO SETGA ECЛИ ДA, CPAЗУ BЫXOД 15230000
LA R1,=C'D' 15240000
CALL TSTDEST 15250000
LTR R14,R14 15260000
BZ SETGEXOK 15270000
WRMESS 'DEBUG OFF.' 15280000
B SETGA 15290000
SETGEXOK UNPK DBLWRK(7),CSATODP(4) 15300000
MVC $TIME(6),DBLWRK ЗAПИCATЬ BPEMЯ 15310000
OI PRMSTAT,X'0C' BЫCTABИTЬ ПPИЗHAK DEBUG ON 15320000
B SETGA И HOPMAЛЬHЫЙ BЫXOД 15330000
SETGOFF TM PRMSTAT,X'0C' DEBUG OFF ? 15340000
BZ SETGA ECЛИ ДA, CPAЗУ BЫXOД 15350000
NI PRMSTAT,X'FF'-X'0C' CБPOCИTЬ ПPИЗHAK DBG 15360000
SETGA XR R14,R14 RC = 0 15370000
SETGR RETURN 15380000
*********************************************************************** 15390000
LTORG 15400000
DROP BASE 15410000
*********************************************************************** 15420000
* SET TRANSLATE TABLE * 15430000
*********************************************************************** 15440000
* RETURN CODE = 0 - OK * 15450000
* RETURN CODE = 2 - ILLEGAL SET COMMAND * 15460000
*********************************************************************** 15470000
SETTRT SAVE 15480000
USING SETTRT,BASE 15490000
LR BASE,R14 15500000
MVC NEWTRT+7(1),0(R3) ЗAПPOШEHA TRT ПOЛЬЗOBATEЛЯ 15510000
CLC NEWTRT(8),TRTNAME CPABHИTЬ C ИMEHEM TEKУЩEЙ TAБЛИЦЫ 15520000
BE SETTOK ECЛИ ИMEHA COBПAЛИ, TO CPAЗУ BЫXOД 15530000
L PPTCBAR,CSAPPTBA ЗAГPУЗИTЬ AДPEC HAЧAЛA PPT 15540000
SETT02 CLC PPTPI(8),NEWTRT HAШЛИ ИMЯ TAБЛИЦЫ B PPT ? 15550000
BE SETT05 ECЛИ COBПAЛИ, TO TRT HAЙДEHA 15560000
CLI PPTPI,X'FF' ДOШЛИ ДO KOHЦA PPT ? 15570000
BE SETT04 ECЛИ ДA, TO TAБЛИЦЫ HET 15580000
L R1,PPTNXTEN ЗAГPУЗИTЬ AДPEC CЛEД. PPT 15590000
LR PPTCBAR,R1 ЗAГPУЗИTЬ AДPEC CЛEД. PPT 15600000
B SETT02 И ИCKATЬ ДAЛЬШE 15610000
SETT04 LA R14,2 RC = 2 15620000
B SETTR 15630000
SETT05 EQU * 15640000
CLI TRTNAME,X'00' ECTЬ ЗAГPУЖEHHAЯ TAБЛИЦA ? 15650000
BE SETT06 HET 15660000
MVC TCAPCPI(8),TRTNAME ЗAПИCATЬ ИMЯ УДAЛЯEMOЙ TAБЛИЦЫ 15670000
L R5,A#TRT#AE ЗAГPУЗИTЬ AДPEC УДAЛЯEMOЙ TAБЛИЦЫ 15680000
ST R5,TCAPCLA ЗAПИCATЬ AДPEC УДAЛЯEMOЙ TAБЛИЦЫ 15690000
DFHPC TYPE=DELETE УДAЛИTЬ TEKУЩУЮ TRT 15700000
SETT06 EQU * 15710000
MVC TCAPCPI(8),NEWTRT ЗAПИCATЬ ИMЯ ЗAГPУЖAEMOЙ TRT 15720000
DFHPC TYPE=LOAD ЗAГPУЗИTЬ TAБЛИЦЫ 15730000
L R5,TCAPCLA ЗAГPУЗИTЬ AДPEC TAБЛИЦ 15740000
ST R5,A#TRT#AE ЗAПИCATЬ AДPEC BXOДHOЙ TAБЛИЦЫ 15750000
LA R5,256(,R5) ПOЛУЧИTЬ AДPEC BЫXOДHOЙ TAБЛИЦЫ 15760000
ST R5,A#TRT#EA ЗAПИCATЬ AДPEC BЫXOДHOЙ TAБЛИЦЫ 15770000
MVC TRTNAME(8),NEWTRT ЗAПИCATЬ ИMЯ HOBOЙ TAБЛИЦЫ 15780000
SETTOK XR R14,R14 RC = 0 15790000
SETTR RETURN 15800000
*********************************************************************** 15810000
LTORG 15820000
DROP BASE 15830000
*********************************************************************** 15840000
* SET FILE * 15850000
*********************************************************************** 15860000
* RETURN CODE = 0 - OK * 15870000
* RETURN CODE = 2 - ILLEGAL SET COMMAND * 15880000
*********************************************************************** 15890000
SETFILE SAVE 15900000
USING SETFILE,BASE 15910000
LR BASE,R14 15920000
CLC 0(3,R3),=C'BIN' SET FILE BINARY ? 15930000
BE SETF01 ECЛИ ДA, BЫCTABИTЬ BIN 15940000
CLC 0(3,R3),=C'TEX' SET FILE TEXT ? 15950000
BE SETF02 ECЛИ ДA, УCTAHOBИTЬ TXT 15960000
LA R14,2 RC = 2 15970000
B SETFR 15980000
SETF01 NI PGMSTAT,X'FF'-X'40' BЫCTABИTЬ ПPИЗHAK ДBOИЧHЫX ФAЙЛOB 15990000
B SETFOK 16000000
SETF02 OI PGMSTAT,X'40' BЫCTABИTЬ ПPИЗHAK TEKCTOBOГO ФAЙЛA 16010000
SETFOK XR R14,R14 RC = 0 16020000
SETFR RETURN 16030000
*********************************************************************** 16040000
LTORG 16050000
DROP BASE 16060000
*********************************************************************** 16070000
* ПOДПPOГPAMMA COURRS * 16080000
*********************************************************************** 16090000
* RETURN CODE = 0 - OK * 16100000
* RETURN CODE = 2 - BAD * 16110000
*********************************************************************** 16120000
COURRS SAVE 16130000
USING COURRS,BASE 16140000
LR BASE,R14 16150000
* 16160000
XC $RMA(4),$RMA 16170000
XC $SMA(4),$SMA 16180000
XC $FMA(4),$FMA 16190000
XC $DMA(4),$DMA 16200000
MVI #ERROR,E$OK 16210000
MVI RETCODE,E$OK 16220000
XC IND#CRLF(1),IND#CRLF 16230000
* 16240000
TM PRMSTAT,X'0C' DEBUG OFF ? 16250000
BZ COURRS00 ДA 16260000
MVC TCASCNB(2),D#REC DEBUG RECORD LENGHT 16270000
DFHSC TYPE=GETMAIN,CLASS=TRANSDATA 16280000
L TDOABAR,TCASCSA 16290000
ST TDOABAR,$DMA SAVE DEBUG MEMORY ADDRESS 16300000
* 16310000
COURRS00 EQU * 16320000
TM PGMSTAT,X'80' SEND ? 16330000
BZ COURRS10 HET 16340000
******** SEND ********************************************************* 16350000
LH R1,PACKET MAX ДЛИHA ПAKETA 16360000
LA R1,10(R1) +CHK +LEN +EOL +HA BCЯKИЙ CЛУЧAЙ 16370000
STH R1,TCASCNB PAЗMEP ЗAПPAШИBAEMOЙ ПAMЯTИ 16380000
DFHSC TYPE=GETMAIN,CLASS=TERMINAL 16390000
L TIOABAR,TCASCSA 16400000
ST TIOABAR,$SMA SAVE SEND PACKET MEMORY ADDRESS 16410000
* 16420000
CALL SEND COURIER SEND 16430000
* 16440000
L TIOABAR,$SMA 16450000
ST TIOABAR,TCASCSA 16460000
DFHSC TYPE=FREEMAIN 16470000
* 16480000
B COURRS20 16490000
* 16500000
******** RECEIVE ****************************************************** 16510000
COURRS10 EQU * 16520000
TM FILSTAT,X'C0' INTRA ? 16530000
BNO COURRS12 УBЫ.. 16540000
MVC F#REC(2),I#REC INTRA RECORD LRECL 16550000
COURRS12 EQU * 16560000
LH R1,F#REC 16570000
LA R1,10(R1) + HA BCЯKИЙ CЛУЧAЙ 16580000
STH R1,TCASCNB PAЗMEP ЗAПPAШ. ПAMЯTИ 16590000
DFHSC TYPE=GETMAIN,CLASS=TRANSDATA 16600000
L TDOABAR,TCASCSA 16610000
ST TDOABAR,$FMA SAVE FILE MEMORY ADDRESS 16620000
* 16630000
DFHSC TYPE=GETMAIN,CLASS=TERMINAL,NUMBYTE=80 16640000
L TIOABAR,TCASCSA 16650000
ST TIOABAR,$SMA SAVE SEND PACKET MEMORY ADDRESS 16660000
* 16670000
CALL RECEIVE COURIER RECEIVE 16680000
* 16690000
L TIOABAR,$RMA 16700000
LTR TIOABAR,TIOABAR 16710000
BZ COURRS15 16720000
ST TIOABAR,TCASCSA 16730000
DFHSC TYPE=FREEMAIN 16740000
* 16750000
COURRS15 EQU * 16760000
L TIOABAR,$SMA 16770000
ST TIOABAR,TCASCSA 16780000
DFHSC TYPE=FREEMAIN 16790000
* 16800000
L TDOABAR,$FMA 16810000
ST TDOABAR,TCASCSA 16820000
LA R14,TDOAVRL 16830000
ST R14,TCATDAA 16840000
MVC TCATDDI(4),FILEDEST 16850000
DFHSC TYPE=FREEMAIN 16860000
* 16870000
COURRS20 EQU * 16880000
TM PRMSTAT,X'0C' DEBUG OFF ? 16890000
BZ COURRS30 ДA 16900000
L TDOABAR,$DMA 16910000
ST TDOABAR,TCASCSA 16920000
LA R14,TDOAVRL 16930000
ST R14,TCATDAA 16940000
MVC TCATDDI(4),DBGDEST 16950000
DFHSC TYPE=FREEMAIN 16960000
* 16970000
COURRS30 EQU * 16980000
CLI #ERROR,E$OK RETCODE OK ? 16990000
BE COURRS40 ДA 17000000
LA R14,2 RC = 2 17010000
B COURRS50 17020000
COURRS40 XR R14,R14 RC = 0 17030000
COURRS50 RETURN 17040000
*********************************************************************** 17050000
LTORG 17060000
DROP BASE 17070000
*********************************************************************** 17080000
* ПOДПPOГPAMMA OБPAБOTKИ KOMAHДЫ SEND * 17090000
*********************************************************************** 17100000
* RETURN CODE = 0 - OK * 17110000
* RETURN CODE = 8 - ILLEGAL SEND COMMAND * 17120000
*********************************************************************** 17130000
SEND SAVE 17140000
USING SEND,BASE 17150000
LR BASE,R14 17160000
MVC PACKAGE+1(37),=C'WAITING ..... SECONDS BEFORE SENDING.' 17170000
MVI PACKAGE,37 17180000
LH R1,DELAY ЗAГPУЗИTЬ ЗHAЧEHИE ЗAДEPЖKИ 17190000
BINCVRT R1,PACKAGE+8,DBLWRK 17200000
CALL WRS BЫДATЬ COOБЩEHИE 17210000
CVD R1,DBLWRK ПOЛУЧИTЬ УПAKOBAHHOE ДECЯTИЧHOE 17220000
MVC TCAICRT(4),DBLWRK+4 ЗAПИCATЬ ЗHAЧEHИE INTRVAL 17230000
DFHIC TYPE=WAIT,INTRVAL=YES 17240000
XC $GET$L(2),$GET$L TEKУЩAЯ ПOЗИЦИЯ B ЗAПИCИ - 0 17250000
XC $RETRY(2),$RETRY ЧИCЛO ПOBTOPOB ПEPEДAЧИ => 0 17260000
XC $N$OLD(2),$N$OLD HOMEP ПAKETA => 0 17270000
MVI $STATE,C'S' SEND_INIT 17280000
MVI IND#CRLF,X'00' 17290000
*********************************************************************** 17300000
* OCHOBHOЙ ЦИKЛ SEND * 17310000
*********************************************************************** 17320000
SLOOP CLI $STATE,C'D' SEND_DATA ? 17330000
BNE SLOOP1 17340000
CALL SDATA 17350000
BRTORC SLOOP,REST=SLOOPER 17360000
SLOOP1 CLI $STATE,C'F' SEND_FILE_HEADER ? 17370000
BNE SLOOP2 17380000
CALL SFILE 17390000
BRTORC SLOOP,REST=SLOOPER 17400000
SLOOP2 CLI $STATE,C'S' SEND_INIT ? 17410000
BNE SLOOP3 17420000
CALL SINIT 17430000
BRTORC SLOOP,REST=SLOOPER 17440000
SLOOP3 CLI $STATE,C'Z' SEND_EOF ? 17450000
BNE SLOOP4 17460000
CALL SEOF 17470000
BRTORC SLOOP,REST=SLOOPER 17480000
SLOOP4 CLI $STATE,C'B' SEND_BREAK ? 17490000
BNE SLOOP5 17500000
CALL SBREAK 17510000
BRTORC SLOOP,REST=SLOOPER 17520000
SLOOP5 CLI $STATE,C'C' COMPLETE ? 17530000
BNE SLOOP6 17540000
BE COMPLETE 17550000
SLOOP6 CLI $STATE,C'A' SEND_ERR ? 17560000
BNE SLOOP7 17570000
SLOOPER CALL SABORT 17580000
B SENDRET 17590000
SLOOP7 MVI #ERROR,E$STATE HEPACПOЗHAHHOE COCTOЯHИE 17600000
CALL SABORT 17610000
B SENDRET 17620000
*********************************************************************** 17630000
* ПEPEДAЧA ЗAKOHЧEHA * 17640000
*********************************************************************** 17650000
COMPLETE XR R14,R14 RC = 0 17660000
SENDRET RETURN 17670000
*********************************************************************** 17680000
LTORG 17690000
DROP BASE 17700000
*********************************************************************** 17710000
* SEND_ERROR ПAKET "A" * 17720000
*********************************************************************** 17730000
* RETURN CODE = 0 - OK * 17740000
*********************************************************************** 17750000
SABORT SAVE 17760000
USING SABORT,BASE 17770000
LR BASE,R14 17780000
CLI #ERROR,E$ERR OБЛOMAЛCЯ ПAPTHEP ? 17790000
BE SAB100 ECЛИ ДA, ПAKET HE ПOCЫЛATЬ 17800000
MVI $S$CUR,AE TИП ПAKETA - ERROR 17810000
MVC $SDAT$L(2),=H'30' ДЛИHA COOБШEHИЯ 17820000
MVC $N$OLD(2),$N$CUR CИHXPOHИЗИPOBATЬ HOMEPA ПAKETOB 17830000
XR R2,R2 17840000
IC R2,#ERROR ЗAГPУЗИTЬ HOMEP OШИБKИ 17850000
MH R2,=H'30' УMHOЖИTЬ HA ДЛИHУ COOБЩEHИЯ 17860000
L R3,ERRTBL#A AДPEC TAБЛИЦЫ ERROR COOБЩEHИЙ 17870000
LA R3,0(R3,R2) ПOЛУЧИTЬ AДPEC COOБЩEHИЯ 17880000
L TIOABAR,$SMA 17890000
LA R1,TIOADBA 17900000
LA R1,3(R1) 17910000
MVC 0(30,R1),0(R3) ЗAПИCATЬ TEKCT COOБЩEHИЯ 17920000
L R2,A#TRT#EA AДPEC TAБЛИЦЫ ПEPEKOДИPOBKИ B ASCII 17930000
TR 0(30,R1),0(R2) ПEPEBECTИ B ASCII 17940000
CALL SPACK 17950000
SAB100 XR R14,R14 RC = 0 17960000
RETURN 17970000
*********************************************************************** 17980000
LTORG 17990000
DROP BASE 18000000
*********************************************************************** 18010000
* SEND_INIT ПAKET "S" * 18020000
*********************************************************************** 18030000
* RETURN CODE = 0 - OK * 18040000
* RETURN CODE = 2 - ПPEBЫШEHO ЧИCЛO ПOBTOPOB ПEPEДAЧИ. HУЖEH E-ПAKET* 18050000
*********************************************************************** 18060000
SINIT SAVE 18070000
USING SINIT,BASE 18080000
LR BASE,R14 18090000
* 18100000
L TIOABAR,$SMA 18110000
LA R1,TIOADBA 18120000
LA R5,32 X'20' - ПPOБEЛ B ASCII 18130000
LR R14,R5 CKOПИPOBATЬ 18140000
AH R5,PACKET ПPИБABИTЬ ДЛИHУ ПPИHИMAEMOГO ПAKETA 18150000
STC R5,3(R1) ПEPBЫЙ БAЙT SEND_INIT 18160000
LA R5,8(,R14) TIMEOUT = 8 18170000
STC R5,4(R1) BTOPOЙ БAЙT SEND_INIT 18180000
STC R14,5(R1) NPAD = 0 18190000
MVI 6(R1),X'40' PADC = NULL 18200000
IC R5,R#EOT 18210000
AR R5,R14 CДEЛATЬ ПEЧATHЫM 18220000
STC R5,7(R1) ПЯTЫЙ БAЙT SEND_INIT 18230000
MVC 8(1,R1),QUOTE QUOTE CHARACTER 18240000
* 18250000
MVC $SDAT$L(2),=H'7' ДЛИHA ПAKETA 18260000
MVC 9(1,R1),PREF ПPEФИKC BOCЬMOГO БИTA 18270000
SINIT030 EQU * 18280000
CLC $RETRY(2),RETRY MOЖHO ПOBTOPЯTЬ ПEPEДAЧУ ? 18290000
BNL SINIT810 18300000
MVI $S$CUR,AS TИП ПAKETA - SEND_INIT 18310000
CALL SPACK ПOДПPOГPAMMA ПOCЫЛKИ ПAKETA 18320000
BRTORC SINIT110,REST=SINIT810 18330000
SINIT110 CALL GETACK ЧИTATЬ OTBET ПAPTHEPA 18340000
BRTORC SINIT120,SINIT030,REST=SINIT810 18350000
SINIT120 CLI $RDAT$L+1,X'00' ECTЬ ДAHHЫE B ПAKETE ? 18360000
BE SINIT300 ECЛИ HET, BCE ПO УMOЛЧAHИЮ 18370000
SR R4,R4 OЧИCTИTЬ PAБOЧИЙ 18380000
* 18390000
L TIOABAR,$RMA AДPEC БУФEPA ПPИHЯTOГO ПAKETA 18400000
LA R2,TIOADBA 18410000
IC R4,3(R2) ЗAГPУЗИTЬ ДЛИHУ ПAKETA ПAPTHEPA 18420000
CH R4,=H'32' SPACE ?ПO УMOЛЧAHИЮ ? 18430000
BE SINIT140 18440000
SH R4,=H'32' BЫЧECTЬ ПPOБEЛ 18450000
CH R4,=H'26' ДOЛЖHA БЫTЬ HE MEHЬШE 26 18460000
BL SINIT800 18470000
CH R4,=H'94' HE MOЖET БЫTЬ БOЛЬШE PACKET 18480000
BH SINIT800 ECЛИ БOЛЬШE, OШИБKA 18490000
STH R4,PACKET ЗAПИCATЬ ДЛИHУ ПAKETA ДЛЯ ПAPTHEPA 18500000
SINIT140 CLC $RDAT$L(2),=H'5' ECTЬ EOL ? 18510000
BNH SINIT300 ECЛИ HET, HE MEHЯTЬ CTAPЫЙ 18520000
IC R4,7(R2) ЗAГPУЗИTЬ EOL 18530000
SH R4,=H'32' BЫЧECTЬ ПPOБEЛ 18540000
STC R4,S#EOT ЗAПИCATЬ EOL ДЛЯ ПAPTHEPA 18550000
CLI $RDAT$L+1,7 ECTЬ ПPEФИKC BOCЬMOГO БИTA ? 18560000
BL SINIT300 ECЛИ HET, HET ПPEФИKCAЦИИ 8 БИTA 18570000
CLC 9(1,R2),PREF COBПAЛ C HAШИM ПPEФИKCOM ? 18580000
BE SINIT400 ECЛИ ДA, OCTABИTЬ 18590000
SINIT300 NI PGMSTAT,X'FF'-X'20' HET ПPEФИKCAЦИИ 8-ГO БИTA 18600000
SINIT400 MVI $STATE,C'F' FILE_HEADER 18610000
LH R3,$N$OLD ЗAГPУЗИTЬ HOMEP ПAKETA 18620000
LA R3,1(,R3) УBEЛИЧИTЬ HOMEP HA 1 18630000
STH R3,$N$OLD ЗAПИCATЬ OБPATHO 18640000
NC $N$OLD(2),=X'003F' $N$OLD MOD 64 18650000
XR R14,R14 RC = 0 18660000
B SINITRET 18670000
SINIT800 MVI #ERROR,E$LENG HEBEPHAЯ ДЛИHA ПAKETA 18680000
SINIT810 MVI $STATE,C'A' A B O R T 18690000
LA R14,2 RC = 2 18700000
SINITRET RETURN 18710000
*********************************************************************** 18720000
LTORG 18730000
DROP BASE 18740000
*********************************************************************** 18750000
* SEND_FILE ПAKET "F" * 18760000
*********************************************************************** 18770000
* RETURN CODE = 0 - OK * 18780000
* RETURN CODE = 2 - ПOCЛATЬ ERROR ПAKET * 18790000
* RETURN CODE = 4 - ПPИHЯЛИ ERROR ПAKET, BЫXOД БEЗ ERROR ПAKETA * 18800000
*********************************************************************** 18810000
SFILE SAVE 18820000
USING SFILE,BASE 18830000
LR BASE,R14 18840000
L TIOABAR,$SMA 18850000
LA R1,TIOADBA AДPEC HAЧAЛA ПAKETA 18860000
LA R1,3(R1) AДPEC ДAHHЫX ПAKETA 18870000
L R3,A#TRT#EA AДPEC TAБЛИЦЫ TRT EBCDIC -> ASCII 18880000
* ФOPMИPOBAHИE ИMEHИ ФAЙЛA ПO ПPOTOKOЛУ COURIER 18890000
MVC 0(4,R1),FILEDEST ЗAПИCATЬ ИMЯ 18900000
MVC 4(8,R1),=C'0001.KER' 18910000
LA R2,12 ПOЛУЧИTЬ ДЛИHУ ИMEHИ 18920000
STH R2,$SDAT$L ЗAПИCATЬ ДЛИHУ ДAHHЫX ПAKETA 18930000
BCTR R2,0 18940000
EX R2,SFILE600 ПEPEKOДИPOBATЬ B ASCII 18950000
SFILE050 EQU * 18960000
CLC $RETRY,RETRY MOЖHO EЩE ПOCЫЛATЬ ? 18970000
BNL SFILE800 HET 18980000
MVI $S$CUR,AF TИП ПAKETA - FILE_HEADER 18990000
CALL SPACK ПOДПPOГPAMMA ПOCЫЛKИ ПAKETA 19000000
BRTORC SFILE100,REST=SFILE800 19010000
SFILE100 CALL GETACK ЧИTATЬ OTBET ПAPTHEPA 19020000
BRTORC SFILE120,SFILE050,REST=SFILE800 19030000
SFILE120 MVI $STATE,C'D' D A T A 19040000
LH R3,$N$OLD ЗAГPУЗИTЬ HOMEP ПAKETA 19050000
LA R3,1(,R3) УBEЛИЧИTЬ HA 1 19060000
STH R3,$N$OLD ЗAПИCATЬ OБPATHO 19070000
NC $N$OLD(2),=X'003F' $N$OLD MOD 64 19080000
CALL GTCHR ЗAПOЛHИTЬ БУФEP ДAHHЫMИ 19090000
BRTORC SFILE700,REST=SFILE800 19100000
SFILE700 XR R14,R14 RC = 0 19110000
B SFILERET 19120000
* 19130000
SFILE600 TR 0(0,R1),0(R3) ПEPEKOДИPOBKA B ASCII 19140000
* 19150000
SFILE800 MVI $STATE,C'A' ПPEBЫШEHO ЧИCЛO ПOBTOPOB ПEPEДAЧИ 19160000
SFILE900 LA R14,2 RC = 2 19170000
SFILERET RETURN 19180000
*********************************************************************** 19190000
LTORG 19200000
DROP BASE 19210000
*********************************************************************** 19220000
* SEND_DATA ПAKET "D" * 19230000
*********************************************************************** 19240000
* RETURN CODE = 0 - OK * 19250000
* RETURN CODE = 2 - ПOCЛATЬ ERROR ПAKET * 19260000
*********************************************************************** 19270000
SDATA SAVE 19280000
USING SDATA,BASE 19290000
LR BASE,R14 19300000
* 19310000
SDATA030 EQU * 19320000
CLC $RETRY,RETRY MOЖHO ПOBTOPЯTЬ ПEPEДAЧУ ? 19330000
BNL SDATA800 19340000
MVI $S$CUR,AD TИП ПAKETA - D A T A 19350000
CALL SPACK ПOДПPOГPAMMA ПOCЫЛKИ ПAKETA 19360000
BRTORC SDATA060,REST=SDATA800 19370000
SDATA060 CALL GETACK ЧИTATЬ OTBET ПAPTHEPA 19380000
BRTORC SDATA100,SDATA030,REST=SDATA800 19390000
SDATA100 EQU * 19400000
XC $SDAT$L(2),$SDAT$L ПAKET ПOCЛAH И ПOДTBEPЖДEH 19410000
LH R3,$N$OLD ЗAГPУЗИTЬ HOMEP ПAKETA 19420000
LA R3,1(,R3) УBEЛИЧИTЬ HA 1 19430000
STH R3,$N$OLD ЗAПИCATЬ OБPATHO 19440000
NC $N$OLD(2),=X'003F' $N$OLD MOD 64 19450000
CALL GTCHR ЗAПOЛHИTЬ ПAKET ДAHHЫMИ 19460000
BRTORC SDATA700,REST=SDATA800 19470000
SDATA700 XR R14,R14 RC = 0 19480000
B SDATARET 19490000
SDATA800 MVI $STATE,C'A' ПPEBЫШEHO ЧИCЛO ПOBTOPOB ПEPEДAЧИ 19500000
LA R14,2 RC = 2 19510000
SDATARET RETURN 19520000
*********************************************************************** 19530000
LTORG 19540000
DROP BASE 19550000
*********************************************************************** 19560000
* SEND_EOF ПAKET "Z" * 19570000
*********************************************************************** 19580000
* RETURN CODE = 0 - OK * 19590000
* RETURN CODE = 2 - ПOCЛATЬ ERROR ПAKET * 19600000
*********************************************************************** 19610000
SEOF SAVE 19620000
USING SEOF,BASE 19630000
LR BASE,R14 19640000
* 19650000
LH R1,$SDAT$L 19660000
LTR R1,R1 19670000
BZ SEOF430 19680000
* 19690000
SEOF030 EQU * 19700000
CLC $RETRY,RETRY MOЖHO ПOCЫЛATЬ ПAKET ? 19710000
BNL SEOF800 HET 19720000
MVI $S$CUR,AD TИП ПAKETA - D A T A 19730000
MVI $STATE,C'D' TИП ПAKETA - D A T A 19740000
CALL SPACK ПOДПPOГPAMMA ПOCЫЛKИ ПAKETA 19750000
BRTORC SEOF060,REST=SEOF800 19760000
SEOF060 CALL GETACK ЧИTATЬ OTBET ПAPTHEPA 19770000
BRTORC SEOF100,SEOF030,REST=SEOF800 19780000
SEOF100 EQU * 19790000
LH R3,$N$OLD ЗAГPУЗИTЬ HOMEP ПAKETA 19800000
LA R3,1(,R3) УBEЛИЧИTЬ HA 1 19810000
STH R3,$N$OLD ЗAПИCATЬ OБPATHO 19820000
NC $N$OLD(2),=X'003F' $N$OLD MOD 64 19830000
XC $SDAT$L(2),$SDAT$L ДЛИHA ПAKETA = 0 19840000
MVI $STATE,C'Z' 19850000
XR R14,R14 RC = 0 19860000
B SEOFRET 19870000
* 19880000
SEOF430 EQU * 19890000
CLC $RETRY,RETRY MOЖHO ПOCЫЛATЬ ПAKET ? 19900000
BNL SEOF800 HET 19910000
MVI $S$CUR,AZ TИП ПAKETA - EOF 19920000
XC $SDAT$L(2),$SDAT$L ДЛИHA ПAKETA = 0 19930000
CALL SPACK ПOДПPOГPAMMA ПOCЫЛKИ ПAKETA 19940000
BRTORC SEOF460,REST=SEOF800 19950000
SEOF460 CALL GETACK ЧИTATЬ OTBET ПAPTHEPA 19960000
BRTORC SEOF500,SEOF430,REST=SEOF800 19970000
SEOF500 EQU * 19980000
LH R3,$N$OLD ЗAГPУЗИTЬ HOMEP ПAKETA 19990000
LA R3,1(,R3) УBEЛИЧИTЬ HA 1 20000000
STH R3,$N$OLD ЗAПИCATЬ OБPATHO 20010000
NC $N$OLD(2),=X'003F' $N$OLD MOD 64 20020000
MVI $STATE,C'B' COCTOЯHИE BREAK - ПEPEДAETCЯ 1 ФAЙЛ 20030000
XR R14,R14 RC = 0 20040000
B SEOFRET 20050000
SEOF800 MVI $STATE,C'A' ПOCЛATЬ ERROR ПAKET 20060000
LA R14,2 RC = 2 20070000
SEOFRET RETURN 20080000
*********************************************************************** 20090000
LTORG 20100000
DROP BASE 20110000
*********************************************************************** 20120000
* SEND_BREAK ПAKET "B" * 20130000
*********************************************************************** 20140000
* RETURN CODE = 0 - OK * 20150000
* RETURN CODE = 2 - ПOCЛATЬ ERROR ПAKET * 20160000
*********************************************************************** 20170000
SBREAK SAVE 20180000
USING SBREAK,BASE 20190000
LR BASE,R14 20200000
MVI $S$CUR,AB TИП ПAKETA - BREAK 20210000
XC $SDAT$L(2),$SDAT$L ДЛИHA ПAKETA = 0 20220000
SBRE030 EQU * 20230000
CLC $RETRY,RETRY MOЖHO ПOCЫЛATЬ ПAKET ? 20240000
BNL SBRE800 20250000
CALL SPACK ПOДПPOГPAMMA ПOCЫЛKИ ПAKETA 20260000
BRTORC SBRE060,REST=SBRE800 20270000
SBRE060 CALL GETACK ЧИTATЬ OTBET ПAPTHEPA 20280000
BRTORC SBRE100,SBRE030,REST=SBRE800 20290000
SBRE100 MVI $STATE,C'C' $STATE COMPLETE 20300000
XR R14,R14 RC = 0 20310000
B SBRKRET 20320000
SBRE800 MVI $STATE,C'A' ПOCЛATЬ ERROR ПEPEДAЧ 20330000
LA R14,2 RC = 2 20340000
SBRKRET RETURN 20350000
*********************************************************************** 20360000
LTORG 20370000
DROP BASE 20380000
*********************************************************************** 20390000
* ПOДПPOГPAMMA ЧTEHИЯ OTBETA ПAPTHEPA * 20400000
*********************************************************************** 20410000
* RETURN CODE = 0 - OK * 20420000
* RETURN CODE = 2 - УTEPЯH ПAKET (HУЖHO ПOBTOPИTЬ ПOCЛ. ПAKET) 20430000
* RETURN CODE = 4 - OБЛOMAЛCЯ ПAPTHEP * 20440000
*********************************************************************** 20450000
GETACK SAVE 20460000
USING GETACK,BASE 20470000
LR BASE,R14 20480000
* 20490000
GACK010 CALL RPACK ПOДПPOГPAMMA ЧTEHИЯ ПAKETOB ПAPTHEPA 20500000
BRTORC GACK020,REST=GACK050 20510000
GACK020 EQU * 20520000
CLI $R$CUR,AE ПPИHЯT ERROR ПAKET ? 20530000
BE GACK100 ДA, OБBAЛИЛCЯ ПAPTHEP 20540000
CLI $R$CUR,AY ACK ? 20550000
BE GACK200 ДA 20560000
CLI $R$CUR,AN NAK ? 20570000
BE GACK300 ДA 20580000
MVI #ERROR,E$TYPE 20590000
GACK050 MVI $S$CUR,AN ПOBTOPИTЬ ПOCЛEДHИЙ ПAKET 20600000
LA R14,2 RC = 2 20610000
B GACKR 20620000
GACK100 MVI #ERROR,E$ERR 20630000
MVI $STATE,C'A' 20640000
LA R14,4 RC = 4 20650000
B GACKR 20660000
* 20670000
GACK200 CLC $N$OLD,$N$CUR CPABHИTЬ HOMEPA ПAKETOB 20680000
BE GACK800 20690000
MVI #ERROR,E$BAD УTEPЯH ПAKET 20700000
B GACK700 ПOBTOPИTЬ ПOCЛEДHИЙ ПAKET 20710000
* 20720000
GACK300 MVI #ERROR,E$NAK NAK OT ПAPTHEPA 20730000
LH R5,$N$CUR ЗAГPУЗИTЬ HOMEP ПPИHЯTOГO ПAKETA 20740000
BCTR R5,0 20750000
N R5,=X'0000003F' $N$CUR MOD 64 20760000
CH R5,$N$OLD CPABHИTЬ C HOMEPOM ПOCЛEДH. ПAKETA 20770000
BNE GACK700 OБЫЧHЫЙ NAK, ПOBTOPИTЬ ПOCЛ. ПAKET 20780000
* NAK C HOMEPOM N+1 => БЫЛ ACK C HOMEPOM N 20790000
MVI $R$CUR,AY ЗAПИCATЬ TИП ПAKETA ACK 20800000
MVI $RDAT$L+1,X'00' ЗAПИCATЬ ДЛИHУ ДAHHЫX = 0 20810000
STH R5,$N$CUR ЗAПИCATЬ HOMEP ПAKETA 20820000
B GACK800 20830000
GACK700 MVI $S$CUR,AN 20840000
LA R14,2 RC = 2 20850000
B GACKR 20860000
GACK800 XR R14,R14 RC = 0 20870000
GACKR RETURN 20880000
*********************************************************************** 20890000
LTORG 20900000
DROP BASE 20910000
*********************************************************************** 20920000
* ПOДПPOГPAMMA ЗAПOЛHEHИЯ ПAKETA ДAHHЫMИ * 20930000
*********************************************************************** 20940000
* RETURN CODE = 0 - OK * 20950000
* RETURN CODE = 2 - ERROR (HУЖEH ERROR-ПAKET) * 20960000
*********************************************************************** 20970000
GTCHR SAVE 20980000
USING GTCHR,BASE 20990000
LR BASE,R14 21000000
* 21010000
L TIOABAR,$SMA 21020000
LA R2,TIOADBA+3 AДPEC CBOБOДHOГO MECTA B ПAKETE 21030000
XR R3,R3 УKAЗATEЛЬ CMEЩEHИЯ/ДЛИHA ПAKETA 21040000
* 21050000
GCHR010 LH R1,$GET$L 21060000
LTR R1,R1 ЗAПИCЬ FILE ПOЛHOCTЬЮ OБPAБOTAHA ? 21070000
BNZ GCHR300 HET 21080000
TM PGMSTAT,X'40' TEXT ? 21090000
BNO GCHR100 HET 21100000
* 21110000
CLI IND#CRLF,X'00' CRLF УCПEЛИ BЫBECTИ ? 21120000
BE GCHR100 ДA 21130000
CLI IND#CRLF,X'4D' CR УCПEЛИ BЫBECTИ ? 21140000
BNE GCHR040 ДA 21150000
LH R15,PACKET 21160000
SH R15,=H'3' 21170000
SH R15,=H'2' 21180000
CR R3,R15 ПOMECTИTЬCЯ <QUOTE><CR> ? 21190000
BH GCHR700 HET 21200000
LA R15,0(R3,R2) AДPEC CBOБOДHOГO MECTA B ПAKETE 21210000
MVC 0(1,R15),QUOTE 21220000
MVI 1(R15),X'4D' PUT CR 21230000
LA R3,2(R3) 21240000
MVI IND#CRLF,X'4A' 21250000
GCHR040 LH R15,PACKET 21260000
SH R15,=H'3' 21270000
SH R15,=H'2' 21280000
CR R3,R15 ПOMECTИTЬCЯ <QUOTE><LF> ? 21290000
BH GCHR700 HET 21300000
LA R15,0(R3,R2) AДPEC CBOБOДHOГO MECTA B ПAKETE 21310000
MVC 0(1,R15),QUOTE 21320000
MVI 1(R15),X'4A' PUT LF 21330000
LA R3,2(R3) 21340000
MVI IND#CRLF,X'00' 21350000
* 21360000
GCHR100 CALL GTREC ПOДПPOГPAMMA ЧTEHИЯ ЗAПИCИ 21370000
BRTORC GCHR120,GCHR800,GCHR820,REST=GCHR840 21380000
GCHR120 L R4,$FMA AДPEC HEOБPAБOTAHHЫX ДAHHЫX FILE 21390000
LH R1,$GET$L ДЛИHУ HEOБPAБOTAHHЫX ДAHHЫX FILE 21400000
TM PGMSTAT,X'40' TEXT ? 21410000
BNO GCHR300 HET. HE ПEPEKOДИPOBATЬ. 21420000
* 21430000
L R6,A#TRT#EA AДPEC TAБЛИЦЫ ПEPEKOДИPOBKИ 21440000
LR R15,R4 AДPEC RECORD FILE DATA 21450000
LR R14,R1 ДЛИHA RECORD FILE DATA 21460000
GCHR200 CH R14,=H'256' 21470000
BNH GCHR240 21480000
TR 0(256,R15),0(R6) ПEPEKOДИPOBATЬ B ASCII 21490000
SH R14,=H'256' 21500000
LA R15,256(R15) 21510000
B GCHR200 21520000
* 21530000
GCHR220 TR 0(0,R15),0(R6) ПEPEKOДИPOBATЬ B ASCII 21540000
* 21550000
GCHR240 BCTR R14,0 ДЛЯ TR 21560000
EX R14,GCHR220 21570000
LA R14,0(R1,R4) AДPEC ПOCЛEДHEГO БAЙTA ЗAПИCИ 21580000
BCTR R14,0 21590000
* 21600000
GCHR260 CLI 0(R14),X'20' ПPOБEЛ ? 21610000
BNE GCHR280 ECЛИ HET, TO BЫXOД 21620000
BCTR R14,0 ПEPEMECTИTЬ HA 1 БAЙT HAЗAД 21630000
CR R14,R4 ПOПAЛИ HA HAЧAЛO ЗAПИCИ ? 21640000
BH GCHR260 HET, ПPOBEPЯTЬ ДAЛEE 21650000
XC $GET$L(2),$GET$L ЗAПИCЬ HУЛEBOЙ ДЛИHЫ 21660000
MVI IND#CRLF,X'4D' 21670000
B GCHR010 21680000
* 21690000
GCHR280 LA R1,1(R14) 21700000
SR R1,R4 21710000
STH R1,$GET$L ДЛИHA ДAHHЫX БEЗ KOHEЧHЫX ПPOБEЛOB 21720000
B GCHR310 21730000
* 21740000
GCHR300 L R4,$FMA AДPEC HEOБPAБOTAHHЫX ДAHHЫX FILE 21750000
GCHR310 LH R1,$GET$L ДЛИHA HEOБPAБOTAHHЫX ДAHHЫX FILE 21760000
XR R5,R5 CMEЩEHИE CИMBOЛA B FILE 21770000
GCHR400 EQU * 21780000
LA R6,0(R5,R4) AДPEC OЧEPEДHOГO CИMBOЛA 21790000
IC R0,0(R6) ЗAГPУЗИTЬ OЧEPEДHOЙ CИMBOЛ 21800000
TM PGMSTAT,X'20' ECTЬ ПPEФИKCAЦИЯ 8-ГO БИTA ? 21810000
BZ GCHR440 HET 21820000
TM 0(R6),X'80' ECTЬ 8-OЙ БИT ? 21830000
BZ GCHR420 HET 21840000
* CИMBOЛ C 8-M БИTOM 21850000
LH R15,PACKET ЗAГPУЗИTЬ MAKC. ДЛИHУ ПAKETA 21860000
SH R15,=H'3' ДЛИHA - 3 УПPABЛ. CИMBOЛA ПAKETA 21870000
SH R15,=H'3' 21880000
CR R3,R15 ПOMECTИTЬCЯ 3 CИMBOЛA ? 21890000
BH GCHR700 HET, BЫДATЬ ПAKET 21900000
N R0,=X'0000007F' CБPOCИTЬ 8-OЙ БИT 21910000
STC R0,0(R6) ЗAПИCATЬ OБPATHO БEЗ 8-ГO БИTA 21920000
LA R15,0(R3,R2) 21930000
MVC 0(1,R15),PREF ЗAПИCATЬ ПPEФИKC B ПAKET 21940000
LA R3,1(R3) ПEPEMECTИTЬ УKAЗATEЛЬ B ПAKETE 21950000
* 21960000
GCHR420 XR R14,R14 21970000
IC R14,PREF 21980000
CR R0,R14 ПOЛУЧИЛCЯ PREF ? 21990000
BE GCHR460 ECЛИ ДA, HУЖHA ПPEФИKCAЦИЯ 22000000
GCHR440 XR R14,R14 22010000
IC R14,QUOTE 22020000
CR R0,R14 CPABHИTЬ C QUOTE 22030000
BE GCHR460 ECЛИ COBПAЛИ, TO HУЖHA ПPEФИKCAЦИЯ 22040000
CH R0,=H'127' D E L ? 22050000
BE GCHR460 DEL TOЖE CПEЦCИMBOЛ 22060000
CH R0,=H'32' CPABHИTЬ C ПPOБEЛOM 22070000
BNL GCHR500 ECЛИ HE MEHЬШE, TO OБЫЧHЫЙ CИMBOЛ 22080000
GCHR460 LH R15,PACKET ЗAГPУЗИTЬ MAKC. ДЛИHУ ПAKETA 22090000
SH R15,=H'3' BЫЧECTЬ ДЛИHУ УПPABЛЯЮЩИX CИMBOЛOB 22100000
SH R15,=H'2' 22110000
CR R3,R15 ПOMECTИTЬCЯ 2 CИMBOЛA ? 22120000
BH GCHR700 ECЛИ HET, BЫДATЬ ПAKET 22130000
LA R15,0(R3,R2) ЗAПИCATЬ QUOTE 22140000
MVC 0(1,R15),QUOTE ЗAПИCATЬ QUOTE 22150000
LA R3,1(R3) ПEPEMECTИTЬ УKAЗATEЛЬ B ПAKETE 22160000
IC R14,PREF 22170000
CR R0,R14 PREF ? 22180000
BE GCHR500 ECЛИ ДA, 100 HE ПPИБABЛЯTЬ 22190000
IC R14,QUOTE 22200000
CR R0,R14 QUOTE ? 22210000
BE GCHR500 ECЛИ ДA, 100 HE ПPИБABЛЯTЬ 22220000
X R0,=X'00000040' BЫПOЛHИTЬ ФУHKЦИЮ CHAR 22230000
* 22240000
GCHR500 EQU * 22250000
LH R15,PACKET ЗAГPУЗИTЬ MAKC. ДЛИHУ ПAKETA 22260000
SH R15,=H'3' BЫЧECTЬ ДЛИHУ УПPABЛЯЮЩИX CИMBOЛOB 22270000
BCTR R15,0 ECTЬ MECTO 22280000
CR R3,R15 ДЛЯ 1 CИMBOЛA ? 22290000
BH GCHR700 HET 22300000
STC R0,0(R3,R2) ЗAПИCATЬ CИMBOЛ B SDAT 22310000
LA R3,1(R3) ПEPEMECTИTЬ УKAЗATEЛЬ B ПAKETE 22320000
LA R5,1(R5) ПEPEMECTИTЬ BXOДHOЙ УKAЗATEЛЬ 22330000
BCT R1,GCHR400 KOHEЦ ЗAПИCИ ? 22340000
XC $GET$L(2),$GET$L ДA 22350000
TM PGMSTAT,X'40' TEXT ? 22360000
BNO GCHR010 HET 22370000
MVI IND#CRLF,X'4D' ДA 22380000
B GCHR010 22390000
* 22400000
GCHR700 LA R15,0(R5,R4) 22410000
ST R15,$FMA ЗAПИCATЬ AДPEC HEOБPAБOT. ДAHHЫX 22420000
STH R1,$GET$L ЗAПИCATЬ ДЛИHУ HEOБPAБOT. ДAHHЫX 22430000
STH R3,$SDAT$L ЗAПИCATЬ ДЛИHУ ДAHHЫX B ПAKETE 22440000
XR R14,R14 RC = 0 22450000
B GCHRRET И BOЗBPAT 22460000
* 22470000
GCHR800 MVI $STATE,C'Z' COCTOЯHИE EOF 22480000
STH R3,$SDAT$L ЗAПИCATЬ ДЛИHУ ДAHHЫX B ПAKETE 22490000
XR R14,R14 RC = 0 22500000
B GCHRRET И BOЗBPAT 22510000
GCHR820 MVI #ERROR,E$PIO ПOCTOЯHHAЯ OШИБKA B/B 22520000
B GCHR850 И BЫXOД 22530000
GCHR840 MVI #ERROR,E$CICS HEПOHЯTHAЯ OШИБKA CICS 22540000
GCHR850 MVI $STATE,C'A' COCTOЯHИE ABORT 22550000
LA R14,2 RC = 2 22560000
GCHRRET RETURN 22570000
*********************************************************************** 22580000
LTORG 22590000
DROP BASE 22600000
*********************************************************************** 22610000
* ЧTEHИE OЧEPEДHOЙ ЗAПИCИ ИЗ BX. H.Д. * 22620000
*********************************************************************** 22630000
* RETURN CODE = 0 - OK * 22640000
* RETURN CODE = 2 - KOHEЦ H.Д. * 22650000
* RETURN CODE = 4 - I/O ERROR * 22660000
* RETURN CODE = 6 - HEPACПOЗHAHHAЯ ERROR * 22670000
*********************************************************************** 22680000
GTREC SAVE 22690000
USING GTREC,BASE 22700000
LR BASE,R14 22710000
XC $GET$L(2),$GET$L 22720000
* 22730000
GTR030 MVC TCATDDI(4),FILEDEST 22740000
DFHTD TYPE=GET,IOERROR=GTR300,QUEZERO=GTR200,NORESP=GTR050 22750000
LA R14,6 RC = 6 22760000
B GTRRET 22770000
* 22780000
GTR050 L TDIABAR,TCATDAA 22790000
TM FILSTAT,X'C0' INTRA ? 22800000
BNO GTR070 HET 22810000
LH R2,TDIAIRL 22820000
SH R2,=H'4' - L'RDW 22830000
LA R1,TDIADBA 22840000
B GTR100 22850000
* 22860000
GTR070 TM FILSTAT,X'08' 22870000
BNZ GTR090 HE V 22880000
TM FILSTAT,X'04' 22890000
BNO GTR090 HE V 22900000
LH R2,0(TDIABAR) 22910000
SH R2,=H'4' - L'RDW 22920000
LA R1,4(TDIABAR) 22930000
B GTR100 22940000
* 22950000
GTR090 LH R2,F#REC 22960000
LR R1,TDIABAR 22970000
* 22980000
GTR100 STH R2,$GET$L ДЛИHA 22990000
ST R1,$FMA AДPEC HAЧAЛA ДAHHЫX 23000000
XR R14,R14 RC = 0 23010000
B GTRRET 23020000
GTR200 XR R1,R1 23030000
ST R1,$FMA 23040000
LA R14,2 RC = 2 23050000
B GTRRET 23060000
GTR300 LA R14,4 RC = 4 23070000
GTRRET RETURN 23080000
*********************************************************************** 23090000
LTORG 23100000
DROP BASE 23110000
*********************************************************************** 23120000
* ПOДПPOГPAMMA OБPAБOTKИ ЗAПPOCA HA ПOCЫЛKУ ПAKETA * 23130000
*********************************************************************** 23140000
* RETURN CODE = 0 - OK * 23150000
* RETURN CODE = 2 - ERROR HOST PROGRAMM (HУЖEH ERROR ПAKET) * 23160000
*********************************************************************** 23170000
* ДAHHЫE ДЛЯ ПAKETA УЖE ДOЛЖHЫ HAXOДИTЬCЯ B TIOADBA+3 ($SMA) * 23180000
*********************************************************************** 23190000
SPACK SAVE 23200000
USING SPACK,BASE 23210000
LR BASE,R14 23220000
XR R15,R15 KOHTPOЛЬHAЯ CУMMA 23230000
LH R4,$SDAT$L ЗAГPУЗИTЬ ДЛИHУ ДAHHЫX 23240000
LA R4,3(R4) +NUM +TYPE +CHECK 23250000
CH R4,PACKET ПPOBEPИTЬ MAKCИMAЛЬHУЮ ДЛИHУ ДAHHЫX 23260000
BH SPACK700 ERROR HOST PROGRAMM 23270000
L TIOABAR,$SMA 23280000
LA R1,TIOADBA AДPEC OБЛACTИ BЫBOДA 23290000
XR R5,R5 23300000
XR R15,R15 23310000
* ФOPMИPOBAHИE ПAKETA 23320000
LA R4,35 X'20' +NUM +TYPE +CHECK 23330000
AH R4,$SDAT$L ПPИБABИTЬ ДЛИHУ ДAHHЫX 23340000
* ЗAПИCЬ ДЛИHЫ ПAKETA 23350000
STC R4,0(R5,R1) ЗAПИCATЬ ДЛИHУ ПAKETA 23360000
LA R5,1(R5) 23370000
AR R15,R4 ПPИБABИTЬ K KOHTPOЛЬHOЙ CУMME 23380000
CLC $N$OLD(2),=H'0' CPABHИTЬ HOMEP ПAKETA C HУЛEM 23390000
BL SPACK690 ERROR HOST PROGRAMM 23400000
CLC $N$OLD(2),=H'64' HE MOЖET БЫTЬ БOЛЬШE 64 23410000
BH SPACK690 ERROR HOST PROGRAMM 23420000
LA R4,32 X'20' 23430000
AH R4,$N$OLD ПPИБABИTЬ HOMEP ПAKETA 23440000
* ЗAПИCЬ HOMEPA ПAKETA 23450000
STC R4,0(R5,R1) ЗAПИCATЬ HOMEP ПAKETA 23460000
LA R5,1(R5) 23470000
AR R15,R4 ПPИБABИTЬ K KC 23480000
CLI $S$CUR,AA ASCII 'A', HE MOЖET БЫTЬ MEHЬШE 23490000
BL SPACK680 ERROR HOST PROGRAMM 23500000
CLI $S$CUR,AZ ASCII 'Z', БOЛЬШE БЫTЬ HE ДOЛЖEH 23510000
BH SPACK680 ERROR HOST PROGRAMM 23520000
XR R2,R2 OЧИCTИTЬ ДЛЯ $S$CUR 23530000
IC R2,$S$CUR ЗAГPУЗИTЬ TИП ПAKETA 23540000
AR R15,R2 ПPИБABИTЬ K KC 23550000
CLI $R$CUR,AN ПPИHЯЛИ NAK ? 23560000
BE SPACK030 ДA 23570000
CLI $S$CUR,AN ПOCЫЛAEM NAK ? 23580000
BNE SPACK050 HET 23590000
SPACK030 LR R0,R1 23600000
LH R1,$RETRY 23610000
LA R1,1(R1) 23620000
STH R1,$RETRY 23630000
LR R1,R0 23640000
SPACK050 EQU * 23650000
* ЗAПИCЬ TИПA ПAKETA 23660000
STC R2,0(R5,R1) ЗAПИCATЬ TИП ПAKETA 23670000
LA R5,1(R5) 23680000
LH R3,$SDAT$L ЗAГPУЗИTЬ ДЛИHУ ДAHHЫX 23690000
LTR R3,R3 ПPOBEPИTЬ ДЛИHУ 23700000
BZ SPACK200 ECЛИ HOЛЬ, OБPAБOTKA HE TPEБУETCЯ 23710000
* 23720000
SPACK100 IC R2,0(R5,R1) ЗAГPУЗИTЬ OЧEPEДHOЙ CИMBOЛ 23730000
AR R15,R2 ПPИБABИTЬ K KC 23740000
LA R5,1(,R5) ПEPEMECTИTЬ ИHДEKC 23750000
BCT R3,SPACK100 И OБPAБOTATЬ CЛEД. CИMBOЛ 23760000
* 23770000
SPACK200 ST R15,DBLWRK CKOPO ПOTPEБУETCЯ 23780000
N R15,=X'000000C0' R15 MOD 192 23790000
M R14,=F'1' ПEPEHECTИ ЗHAKOBЫЙ БИT 23800000
D R14,=F'64' R15 DIV 64 23810000
A R15,DBLWRK ПPИБABИTЬ ИCX. ЗHAЧ. KC 23820000
N R15,=X'0000003F' R15 MOD 64 23830000
LA R15,32(,R15) ПPИБABИTЬ ПPOБEЛ 23840000
STC R15,0(R5,R1) ЗAПИCATЬ KC ПOCЛE ДAHHЫX 23850000
L R14,A#TRT#SO AДPEC BЫXOДHOЙ TAБЛИЦЫ 23860000
EX R5,SPACK600 ПEPEДAЧA БУДET B KOДE ДKOИ 23870000
LA R5,1(,R5) ПEPEMECTИTЬ ИHДEKC (+ L'CHECK) 23880000
* 23890000
TM PRMSTAT,X'0C' DEBUG OFF ? 23900000
BZ SPACK300 ДA 23910000
*********DEBUG ********* 23920000
L TDOABAR,$DMA 23930000
MVC TDOADBA(11),=C'SEND PACKET' 23940000
MVC TDOAVRL(2),=H'15' 23950000
XC TDOAVRL+2(2),TDOAVRL+2 23960000
MVC TCATDDI(4),DBGDEST 23970000
LA R14,TDOAVRL 23980000
ST R14,TCATDAA 23990000
DFHTD TYPE=PUT,NORESP=SPDB01 24000000
NI PRMSTAT,X'FF'-X'0C' CБPOCИTЬ ПPИЗHAK DEBUG 24010000
B SPDB03 24020000
* 24030000
SPACK620 MVC TDOADBA(0),0(R1) 24040000
* 24050000
SPDB01 EQU * 24060000
LA R2,4(R5) +RDW 24070000
STH R2,TDOAVRL 24080000
XC TDOAVRL+2(2),TDOAVRL+2 24090000
SH R2,=H'5' BЫЧECTЬ 1 ДЛЯ MVC 24100000
EX R2,SPACK620 ЗAПИCATЬ ДAHHЫE 24110000
LA R14,TDOAVRL 24120000
ST R14,TCATDAA 24130000
DFHTD TYPE=PUT,NORESP=SPDB03 24140000
NI PRMSTAT,X'FF'-X'0C' CБPOCИTЬ ПPИЗHAK DEBUG 24150000
SPDB03 EQU * 24160000
*********DEBUG ********* 24170000
SPACK300 EQU * 24180000
L TIOABAR,$SMA 24190000
ST TIOABAR,TCTTEDA ЗAПИCATЬ B TCTTE 24200000
STH R5,TIOATDL ЗAПИCATЬ ДЛИHУ TIOA 24210000
DFHTC TYPE=(PUT,SAVE) BЫBECTИ ПAKET 24220000
L R14,A#TRT#SI AДPEC TRT ИЗ ЛИHИИ 24230000
BCTR R5,0 24240000
EX R5,SPACK600 BEPHУTЬ B KOД ASCII 24250000
XR R14,R14 RC = 0 24260000
B SPRET И BOЗBPAT 24270000
SPACK680 MVI #ERROR,E$HSTTYP 24280000
B SPACK750 24290000
SPACK690 MVI #ERROR,E$HSTNUM 24300000
B SPACK750 24310000
SPACK700 MVI #ERROR,E$HSTLEN HEBEPHAЯ ДЛИHA ПAKETA 24320000
SPACK750 MVI $STATE,C'A' COCTOЯHИE ABORT 24330000
LA R14,2 RC = 2 24340000
B SPRET И BOЗBPAT 24350000
SPACK600 TR 0(0,R1),0(R14) ПEPEДAЧA БУДET B KOДE ДKOИ 24360000
SPRET RETURN 24370000
*********************************************************************** 24380000
LTORG 24390000
DROP BASE 24400000
*********************************************************************** 24410000
* ПOДПPOГPAMMA ЧTEHИЯ ПAKETOB OT ПAPTHEPA * 24420000
*********************************************************************** 24430000
* RETURN CODE = 0 - OK * 24440000
* RETURN CODE = 2 - BAD PACKET OT ПAPTHEPA (HУЖEH NAK) * 24450000
*********************************************************************** 24460000
RPACK SAVE 24470000
USING RPACK,BASE 24480000
LR BASE,R14 24490000
* 24500000
L R1,$RMA 24510000
LTR R1,R1 БЫЛИ УЖE ПAKETЫ ? 24520000
BZ RPACK010 HET 24530000
ST R1,TCASCSA 24540000
DFHSC TYPE=FREEMAIN OCBOБOДИTЬ ПPEДЫДУЩУЮ TIOA 24550000
XC $RMA(4),$RMA 24560000
* 24570000
RPACK010 DFHTC TYPE=(GET,SAVE) ЧИTATЬ ДAHHЫE C TEPMИHAЛA 24580000
L TIOABAR,TCTTEDA 24590000
ST TIOABAR,$RMA 24600000
LH R2,TIOATDL ЗAГPУЗИTЬ ДЛИHУ TIOA 24610000
LH R1,PACKET ЗAГPУЗИTЬ MAX ДЛИHУ ПAKETA 24620000
LA R1,5(R1) MAXLEN +MARK +LEN +EOL +2 HA BCЯKИЙ 24630000
CR R2,R1 ДЛИHA TIOA > MAX ДЛИHЫ ПAKETA ? 24640000
BH RPACK700 ERROR PACKET LENGHT 24650000
LTR R2,R2 ECTЬ ДAHHЫE B TIOA ? 24660000
BZ RPACK700 ERROR PACKET LENGHT 24670000
LA R1,TIOADBA AДPEC ПPИШEДШИX ДAHHЫX 24680000
* 24690000
TM PRMSTAT,X'0C' DEBUG OFF ? 24700000
BZ RPACK200 ДA 24710000
*********DEBUG ********* 24720000
L TDOABAR,$DMA LOAD AДPECA ПAMЯTИ DEBUG 24730000
MVC TDOADBA(10),=C'REC PACKET' 24740000
MVC TDOAVRL(2),=H'14' 24750000
XC TDOAVRL+2(2),TDOAVRL+2 24760000
MVC TCATDDI(4),DBGDEST 24770000
LA R14,TDOAVRL 24780000
ST R14,TCATDAA 24790000
DFHTD TYPE=PUT,NORESP=RPDB01 24800000
NI PRMSTAT,X'FF'-X'0C' CБPOCИTЬ ПPИЗHAK DEBUG 24810000
B RPDB03 24820000
* 24830000
RPACK600 MVC TDOADBA(0),0(R1) 24840000
* 24850000
RPDB01 EQU * 24860000
LA R5,4(R2) + RDW 24870000
STH R5,TDOAVRL 24880000
XC TDOAVRL+2(2),TDOAVRL+2 24890000
SH R5,=H'5' BЫЧECTЬ 1 ДЛЯ MVC 24900000
EX R5,RPACK600 ЗAПИCATЬ ДAHHЫE 24910000
LA R14,TDOAVRL 24920000
ST R14,TCATDAA 24930000
DFHTD TYPE=PUT,NORESP=RPDB03 24940000
NI PRMSTAT,X'FF'-X'0C' CБPOCИTЬ ПPИЗHAK DEBUG 24950000
* 24960000
RPDB03 EQU * 24970000
*********DEBUG ********* 24980000
RPACK200 L R14,A#TRT#SI AДPEC BXOДHOЙ TAБЛИЦЫ ПEPEKOДИPOBKИ 24990000
LR R5,R2 25000000
BCTR R5,0 25010000
EX R5,RPACK640 25020000
XR R2,R2 ИHДEKCHЫЙ ДЛЯ 25030000
LR R5,R1 AДPEC HAЧAЛA ПAKETA 25040000
B RPACK220 25050000
* 25060000
RPACK640 TR 0(0,R1),0(R14) ПEPEKOДИPOBATЬ B ASCII 25070000
* 25080000
RPACK210 LA R2,1(,R2) ПEPEMECTИTЬ ИHДEKC 25090000
RPACK220 XR R15,R15 KOHTPOЛЬHAЯ CУMMA 25100000
LA R5,0(R2,R1) AДPEC TEKУЩEГO CИMBOЛA 25110000
CLI 0(R5),X'20' S O H ? 25120000
BL RPACK210 ECЛИ SOH, TO BCE HAЧATЬ CHAЧAЛA 25130000
* 25140000
CLI 0(R5),X'23' ДЛИHA ДOЛЖHA БЫTЬ HE MEHEE 3 25150000
BL RPACK700 ECЛИ >=, TO BCE B ПOPЯДKE 25160000
IC R15,0(,R5) HAЧATЬ ПOCЧET KC 25170000
LR R5,R15 ЗAГPУЗИTЬ ДЛИHУ ПAKETA 25180000
* ====================== 25190000
SH R5,=H'35' X'20' +NUM +TYPE +CHECK 25200000
STH R5,$RDAT$L ЗAПИCATЬ ДЛИHУ ПPИHЯTЫX ДAHHЫX 25210000
LA R2,1(,R2) ПEPEMECTИTЬ ИHДEKC 25220000
IC R5,0(R2,R1) ЗAГPУЗИTЬ HOMEP ПAKETA 25230000
* ====================== 25240000
XR R0,R0 ДЛЯ ЗAГPУЗKИ SOH 25250000
LA R0,X'20' ЗAГPУЗИTЬ SOH 25260000
CR R5,R0 S O H ? 25270000
BL RPACK210 ECЛИ SOH, TO BCE HAЧATЬ CHAЧAЛA 25280000
* 25290000
AR R15,R5 ПPИБABИTЬ K KC 25300000
SH R5,=H'32' OTHЯTЬ ПPOБEЛ 25310000
STH R5,RPACK800 ЗAПИCATЬ HOMEP ПAKETA 25320000
LA R2,1(,R2) ПEPEMECTИTЬ ИHДEKC 25330000
IC R5,0(R2,R1) ЗAГPУЗИTЬ TИП ПAKETA 25340000
* ==================== 25350000
CR R5,R0 S O H ? 25360000
BL RPACK210 ECЛИ SOH, TO BCE HAЧATЬ CHAЧAЛA 25370000
* 25380000
AR R15,R5 ПPИБABИTЬ K KC 25390000
STC R5,RPACK810 ЗAПИCATЬ TИП ПAKETA 25400000
LA R2,1(,R2) ПEPEMECTИTЬ ИHДEKC 25410000
* OБPAБOTKA ДAHHЫX ПAKETA 25420000
LA R3,0(R2,R1) ИHДEKCHЫЙ ДЛЯ RDAT 25430000
ST R3,$DAT$A COXPAHИTЬ AДPEC ДAHHЫX 25440000
LH R4,$RDAT$L ДЛИHA ДAHHЫX B ПAKETE 25450000
LTR R4,R4 ECTЬ ДAHHЫE ? 25460000
BZ RPACK320 ECЛИ HET, HE OБPAБATЫBATЬ 25470000
* 25480000
RPACK300 IC R5,0(R2,R1) ЗAГPУЗИTЬ CИMBOЛ 25490000
CR R5,R0 S O H ? 25500000
BL RPACK210 ECЛИ SOH, TO BCE HAЧATЬ CHAЧAЛA 25510000
AR R15,R5 ПPИБABИTЬ K KC 25520000
LA R2,1(,R2) ПEPEMECTИTЬ ИHДEKC 25530000
BCT R4,RPACK300 И OБPAБOTATЬ CЛEДУЮЩИЙ CИMBOЛ 25540000
* 25550000
RPACK320 XR R5,R5 OЧИCTИTЬ 25560000
IC R5,0(R2,R1) ЗAГPУЗИTЬ CHECK 25570000
CR R5,R0 S O H ? 25580000
BL RPACK210 ECЛИ SOH, TO BCE HAЧATЬ CHAЧAЛA 25590000
ST R15,DBLWRK CKOPO ПOTPEБУETCЯ 25600000
N R15,=X'000000C0' R15 MOD 192 25610000
M R14,=F'1' ПEPEHECTИ ЗHAKOBЫЙ БИT 25620000
D R14,=F'64' R15 DIV 64 25630000
A R15,DBLWRK ПPИБABИTЬ KC 25640000
N R15,=X'0000003F' R15 MOD 64 25650000
LA R15,32(,15) ПPИБABИTЬ ПPOБEЛ 25660000
CR R15,R5 PABHЫ KOHTPOЛЬHЫE CУMMЫ 25670000
BE RPACK720 ECЛИ ДA, HOPMAЛЬHЫЙ BЫXOД 25680000
MVI #ERROR,E$CHECK OШИБKA B KOHTPOЛЬHOЙ CУMME 25690000
B RPACK710 25700000
RPACK700 MVI #ERROR,E$LENG 25710000
RPACK710 LA R14,2 RC = 2 25720000
MVI $R$CUR,AN ЗAПИCATЬ NAK 25730000
B RPACKRET 25740000
RPACK800 DS H HOMEP ПAKETA 25750000
RPACK810 DS H TИП ПAKETA 25760000
RPACK720 MVC $N$CUR(2),RPACK800 25770000
MVC $R$CUR(1),RPACK810 25780000
XR R14,R14 RC = 0 25790000
RPACKRET RETURN 25800000
*********************************************************************** 25810000
LTORG 25820000
DROP BASE 25830000
*********************************************************************** 25840000
* ПOДПPOГPAMMA OБPAБOTKИ KOMAHДЫ RECEIVE * 25850000
*********************************************************************** 25860000
* RETURN CODE = 0 - OK * 25870000
*********************************************************************** 25880000
RECEIVE SAVE 25890000
USING RECEIVE,BASE 25900000
LR BASE,R14 25910000
MVC PACKAGE+1(18),=C'RECEIVE WAITING...' 25920000
MVI PACKAGE,18 25930000
CALL WRS BЫДATЬ COOБЩEHИE 25940000
XC $PUT$L(2),$PUT$L TEKУЩAЯ ПOЗИЦИЯ B ЗAПИCИ - 0 25950000
XC $RETRY(2),$RETRY ЧИCЛO ПOBTOPOB ПEPEДAЧИ => 0 25960000
XC $N$OLD(2),$N$OLD HOMEP ПAKETA => 0 25970000
MVI $STATE,C'R' ЖДATЬ SEND_INIT 25980000
*********************************************************************** 25990000
* OCHOBHOЙ ЦИKЛ OБPAБOTKИ RECEIVE * 26000000
*********************************************************************** 26010000
RLOOP CLI $STATE,C'D' D A T A ? 26020000
BNE RLOOP1 26030000
CALL RDATA 26040000
BRTORC RLOOP,REST=RLOOPERR 26050000
RLOOP1 CLI $STATE,C'F' FILE_HEADER ? 26060000
BNE RLOOP2 26070000
CALL RFILE 26080000
BRTORC RLOOP,REST=RLOOPERR 26090000
RLOOP2 CLI $STATE,C'R' SEND_INIT ? 26100000
BNE RLOOP3 26110000
CALL RINIT 26120000
BRTORC RLOOP,REST=RLOOPERR 26130000
RLOOP3 CLI $STATE,C'C' COMPLETE ? 26140000
BNE RLOOP4 26150000
B RECRET 26160000
RLOOP4 CLI $STATE,C'A' ABORT ? 26170000
BNE RLOOP5 26180000
RLOOPERR CALL RABORT 26190000
B RECRET 26200000
RLOOP5 MVI #ERROR,E$STATE HEPACПOЗHAHHOE COCTOЯHИE 26210000
CALL RABORT 26220000
* ЗABEPШEHИE ПPИEMA ФAЙЛA * 26230000
RECRET XR R14,R14 HУЛEBOЙ KOД BOЗBPATA 26240000
RETURN 26250000
*********************************************************************** 26260000
LTORG 26270000
DROP BASE 26280000
*********************************************************************** 26290000
* A B O R T * 26300000
*********************************************************************** 26310000
* RETURN CODE = 0 - OK * 26320000
*********************************************************************** 26330000
RABORT SAVE 26340000
USING RABORT,BASE 26350000
LR BASE,R14 26360000
CLI #ERROR,E$ERR OБЛOMAЛCЯ ПAPTHEP ? 26370000
BE RAB100 ECЛИ ДA, ПAKET HE ПOCЫЛATЬ 26380000
MVI $S$CUR,AE TИП ПAKETA - ERROR 26390000
MVC $SDAT$L(2),=H'30' ДЛИHA COOБШEHИЯ 26400000
MVC $N$OLD(2),$N$CUR CИHXPOHИЗИPOBATЬ HOMEPA ПAKETOB 26410000
XR R2,R2 26420000
IC R2,#ERROR ЗAГPУЗИTЬ HOMEP OШИБKИ 26430000
MH R2,=H'30' УMHOЖИTЬ HA ДЛИHУ COOБЩEHИЯ 26440000
L R3,ERRTBL#A AДPEC TAБЛИЦЫ ERROR COOБЩEHИЙ 26450000
LA R3,0(R3,R2) ПOЛУЧИTЬ AДPEC COOБЩEHИЯ 26460000
L TIOABAR,$SMA 26470000
LA R1,TIOADBA 26480000
LA R1,3(R1) 26490000
MVC 0(30,R1),0(R3) ЗAПИCATЬ TEKCT COOБЩEHИЯ 26500000
L R2,A#TRT#EA AДPEC TAБЛИЦЫ ПEPEKOДИPOBKИ B ASCII 26510000
TR 0(30,R1),0(R2) ПEPEBECTИ B ASCII 26520000
CALL SPACK 26530000
RAB100 XR R14,R14 RC = 0 26540000
RETURN 26550000
*********************************************************************** 26560000
LTORG 26570000
DROP BASE 26580000
*********************************************************************** 26590000
* OБPAБOTKA SEND_INIT * 26600000
*********************************************************************** 26610000
* RETURN CODE = 0 - OK * 26620000
* RETURN CODE = 2 - ERROR (HУЖEH ERROR ПAKET) * 26630000
*********************************************************************** 26640000
RINIT SAVE 26650000
USING RINIT,BASE 26660000
LR BASE,R14 26670000
CALL RPACK ЧИTATЬ ПAKET OT ПAPTHEPA 26680000
BRTORC RINIT010,REST=RINIT600 26690000
RINIT010 CLI $R$CUR,AS SEND_INIT ? 26700000
BE RINIT015 26710000
CLI $R$CUR,AE ERROR ? 26720000
BE RINIT990 26730000
BNE RINIT600 ПOCЛATЬ NAK 26740000
* OБPAБOTKA ПOЛЯ MAXLEN 26750000
RINIT015 XR R1,R1 26760000
XR R3,R3 26770000
L R2,$DAT$A 26780000
IC R1,0(R3,R2) ЗAГPУЗИTЬ ДЛИHУ ПAKETA 26790000
SH R1,=H'32' OTHЯTЬ ПPOБEЛ 26800000
LTR R1,R1 26810000
BNZ RINIT020 26820000
LH R1,PACKET ЗAПPOШEHA ДЛИHA ПO УMOЛЧAHИЮ 26830000
B RINIT030 26840000
* 26850000
RINIT020 EQU * 26860000
CH R1,=H'94' CPABHИTЬ C MAKCИMAЛЬHOЙ ДЛИHOЙ 26870000
BNH RINIT030 ECЛИ <=, TO BCE B ПOPЯДKE 26880000
B RINIT700 ERROR INIT PARM 26890000
* 26900000
RINIT030 STH R1,PACKET ЗAПИCATЬ MAKC. ДЛИHУ ПAKETOB 26910000
LA R3,4(R3) 26920000
* OБPAБOTKA ПOЛЯ EOL 26930000
CH R3,$RDAT$L ECTЬ EЩE ПAPAMETPЫ ? 26940000
BNH RINIT500 HET 26950000
IC R1,0(R3,R2) ЗAГPУЗИTЬ EOL 26960000
SH R1,=H'32' BЫЧECTЬ ПPOБEЛ 26970000
CH R1,=H'32' 26980000
BNL RINIT700 26990000
STC R1,S#EOT ЗAПИCATЬ EOL 27000000
LA R3,1(R3) 27010000
* OБPAБOTKA ПOЛЯ QUOTE 27020000
CH R3,$RDAT$L ECTЬ EЩE ПAPAMETPЫ ? 27030000
BNH RINIT500 HET 27040000
IC R1,0(R3,R2) ЗAГPУЗИTЬ QUOTE 27050000
CH R1,=H'32' 27060000
BNH RINIT700 ERROR INIT PARM 27070000
CH R1,=H'126' 27080000
BH RINIT700 ERROR INIT PARM 27090000
CH R1,=H'62' 27100000
BNH RINIT110 27110000
CH R1,=H'96' 27120000
BL RINIT700 ERROR INIT PARM 27130000
RINIT110 STC R1,QUOTE ЗAПИCATЬ QUOTE 27140000
LA R3,1(R3) 27150000
* OБPAБOTKA ПOЛЯ PREF 27160000
CH R3,$RDAT$L ECTЬ EЩE ПAPAMETPЫ ? 27170000
BNH RINIT500 HET 27180000
LA R1,0(R3,R2) ЗAГPУЗИTЬ QUOTE 27190000
CLC QUOTE(1),0(R1) QUOTE = PREF ? 27200000
BE RINIT700 ERROR INIT PARM 27210000
IC R1,0(R3,R2) ЗAГPУЗИTЬ PREF 27220000
CH R1,=H'32' 27230000
BNH RINIT700 ERROR INIT PARM 27240000
CH R1,=H'126' 27250000
BH RINIT700 ERROR INIT PARM 27260000
CH R1,=H'62' 27270000
BNH RINIT210 27280000
CH R1,=H'96' 27290000
BL RINIT700 ERROR INIT PARM 27300000
RINIT210 STC R1,PREF ЗAПИCATЬ PREF 27310000
CLI $RDAT$L+1,7 ECTЬ PREF ? 27320000
LA R3,1(R3) 27330000
* OБPAБOTKA ПOЛЯ CHECK 27340000
CH R3,$RDAT$L ECTЬ EЩE ПAPAMETPЫ ? 27350000
BNH RINIT500 HET 27360000
RINIT500 MVC $N$OLD,$N$CUR CИHXPOHИЗИPOBATЬ HOMEPA ПAKETOB 27370000
MVI $S$CUR,AY TИП ПAKETA - ACK 27380000
MVC $SDAT$L(2),=H'7' ДЛИHA ДAHHЫX = 7 27390000
* 27400000
L TIOABAR,$SMA 27410000
LA R1,TIOADBA AДPEC HAЧAЛA ПAKETA 27420000
LA R1,3(R1) AДPEC ДAHHЫX B ПAKETE 27430000
* 27440000
LA R15,32 ПPOБEЛ ( X'20' ) 27450000
LH R2,PACKET ДЛИHA ПPИHИMAEMЫX ПAKETOB 27460000
AR R2,R15 ПPИБABИTЬ ПPOБEЛ 27470000
* ЗAПИCATЬ ДЛИHУ ПAKETA 27480000
STC R2,0(R1) ЗAПИCATЬ ДЛИHУ 27490000
MVC 1(3,R1),=X'282020' TAЙMAУT, NPAD, PADC 27500000
IC R2,R#EOT EOL 27510000
AR R2,R15 ПPИБABИTЬ ПPOБEЛ 27520000
STC R2,4(R1) 27530000
MVC 5(1,R1),QUOTE ЗAПИCATЬ QUOTE 27540000
MVC 6(1,R1),PREF ЗAПИCATЬ PREF 27550000
CALL SPACK ПOCЛATЬ ACK 27560000
BRTORC RINIT550,REST=RINIT700 27570000
RINIT550 MVI $STATE,C'F' ПEPEXOД B COCTOЯHИE FILE_HEADER 27580000
LH R3,$N$OLD ЗAГPУЗИTЬ HOMEP ПAKETA 27590000
LA R3,1(,R3) УBEЛИЧИTЬ HA 1 27600000
N R3,=X'0000003F' R3 MOD 63 27610000
STH R3,$N$OLD ЗAПИCATЬ HOMEP OБPATHO 27620000
XR R14,R14 RC = 0 27630000
B RINIRET И ЖДATЬ FILE_HEADER 27640000
RINIT600 EQU * 27650000
CLC $RETRY(2),RETRY ПPEBЫШEH ЛИMИT HA ПOBTOP ? 27660000
BH RINIT700 ДA 27670000
MVI $S$CUR,AN TИП ПAKETA - NAK 27680000
XC $SDAT$L(2),$SDAT$L ДЛИHA ДAHHЫX = 0 27690000
CALL SPACK ПOCЛATЬ NAK 27700000
XR R14,R14 RC = 0 27710000
B RINIRET И ЖДATЬ CЛEД. ПAKET 27720000
RINIT700 EQU * 27730000
MVI $STATE,C'A' ПEPEXOД B COCTOЯHИE ABORT 27740000
LA R14,2 RC = 2 27750000
B RINIRET ПOCЛATЬ ERROR И ЗABEPШИTЬ RECEIVE 27760000
RINIT990 MVI #ERROR,E$ERR ПPИШEЛ ERROR ПAKET 27770000
MVI $STATE,C'A' ПEPEXOД B COCTOЯHИE ABORT 27780000
LA R14,2 RC = 2 27790000
B RINIRET ПOCЛATЬ ERROR И ЗABEPШИTЬ RECEIVE 27800000
RINIRET RETURN 27810000
*********************************************************************** 27820000
LTORG 27830000
DROP BASE 27840000
*********************************************************************** 27850000
* OБPAБOTKA FILE_HEADER * 27860000
*********************************************************************** 27870000
* RETURN CODE = 0 - OK * 27880000
* RETURN CODE = 2 - ERROR (HУЖEH ERROR ПAKET) * 27890000
*********************************************************************** 27900000
RFILE SAVE 27910000
USING RFILE,BASE 27920000
LR BASE,R14 27930000
* 27940000
CALL RPACK ЧИTATЬ ПAKET OT ПAPTHEPA 27950000
BRTORC RFILE010,REST=RFILE700 27960000
RFILE010 CLI $R$CUR,AS ПPИШEЛ OПЯTЬ SEND_INIT ? 27970000
BE RFILE100 27980000
CLI $R$CUR,AZ ПPИШEЛ EOF ? 27990000
BE RFILE200 28000000
CLI $R$CUR,AF ПPИШEЛ FILE_HEADER ? 28010000
BE RFILE300 28020000
CLI $R$CUR,AB ПPИШEЛ BREAK - ПAKET ? 28030000
BE RFILE400 28040000
CLI $R$CUR,AE ПPИШEЛ ERROR - ПAKET ? 28050000
BE RFILE990 28060000
B RFILE700 ПOCЛATЬ NAK 28070000
* 28080000
RFILE100 CLC $RETRY,RETRY MOЖHO ПOCЫЛATЬ EЩE ? 28090000
BL RFILE150 ECЛИ MOЖHO, ПOCЛATЬ ACK 28100000
MVI $STATE,C'A' BCE, ЛИMИT ИCЧEPПAH 28110000
B RFILE900 ПOCЛATЬ ERROR ПAKET 28120000
RFILE150 EQU * 28130000
LH R3,$N$OLD ЗAГPУЗИTЬ HOMEP ПAKETA 28140000
BCTR R3,1 BЫЧECTЬ 1 - ПPEДЫДУЩИЙ HOMEP 28150000
CH R3,$N$CUR COBПAДAЮT HOMEPA ? 28160000
BE RFILE160 ECЛИ ДA, TO BCE B ПOPЯДKE 28170000
MVI #ERROR,E$BAD ПOTEPЯH ПAKET 28180000
B RFILE800 ПOCЛATЬ NAK 28190000
RFILE160 MVI $S$CUR,AY TИП ПAKETA - ACK 28200000
STH R3,$N$OLD ЗAПИCATЬ HOMEP ПAKETA 28210000
MVC $SDAT$L(2),=H'7' ДЛИHA ДAHHЫX - 7 БAЙT 28220000
CALL SPACK ПOCЛATЬ ACK 28230000
BRTORC RFILE180,REST=RFILE900 28240000
RFILE180 LH R4,$N$OLD ЗAГPУЗИTЬ HOMEP ПAKETA 28250000
LA R4,1(,R4) УBEЛИЧИTЬ HA 1 28260000
STH R4,$N$OLD И ЗAПИCATЬ OБPATHO 28270000
XR R14,R14 RC = 0 28280000
B RFILERET И ЖДATЬCЛEДУЮЩEГO ПAKETA 28290000
* ПPИШEЛ ПAKET 'Z' 28300000
RFILE200 CLC $N$OLD,$N$CUR COBПAДAЮT HOMEPA ПAKETOB ? 28310000
BE RFILE230 ECЛИ ДA, ПOCЛATЬ ACK HA FILE_HEADER 28320000
MVI #ERROR,E$BAD ПOTEPЯH ПAKET 28330000
B RFILE800 ПOCЛATЬ NAK 28340000
RFILE230 CALL SACK ПOCЛATЬ ACK 28350000
MVI $STATE,C'F' ЖДATЬ ПPИXOДA ПAKETA 'F' ИЛИ 'B' 28360000
XR R14,R14 RC = 0 28370000
B RFILERET 28380000
* ПPИШEЛ ПAKET 'F' 28390000
RFILE300 CLC $N$OLD,$N$CUR COBПAДAЮT HOMEPA ПAKETOB ? 28400000
BE RFILE330 ECЛИ ДA, ПOCЛATЬ ACK HA FILE_HEADER 28410000
MVI #ERROR,E$BAD ПOTEPЯH ПAKET 28420000
B RFILE800 ПOCЛATЬ NAK 28430000
RFILE330 CALL SACK ПOCЛATЬ ACK 28440000
MVI $STATE,C'D' ЖДATЬ ПPИXOДA ДAHHЫX 28450000
XR R14,R14 RC = 0 28460000
B RFILERET 28470000
* ПPИШEЛ ПAKET 'B' 28480000
RFILE400 CLC $N$OLD,$N$CUR COBПAДAЮT HOMEPA ПAKETOB ? 28490000
BE RFILE430 ECЛИ ДA, ПOCЛATЬ ACK HA FILE_HEADER 28500000
MVI #ERROR,E$BAD ПOTEPЯH ПAKET 28510000
B RFILE800 ПOCЛATЬ NAK 28520000
RFILE430 CALL SACK ПOCЛATЬ ACK 28530000
MVI $STATE,C'C' ЗABEPШEHИE PAБOTЫ 28540000
XR R14,R14 RC = 0 28550000
B RFILERET 28560000
* 28570000
RFILE700 CLC $RETRY,RETRY MOЖHO ПOCЫЛATЬ EЩE ? 28580000
BL RFILE800 28590000
MVI $STATE,C'A' BCE, ЛИMИT ИCЧEPПAH 28600000
B RFILE900 ПOCЛATЬ ERROR ПAKET 28610000
RFILE800 MVI $S$CUR,AN TИП ПAKETA - NAK 28620000
XC $SDAT$L(2),$SDAT$L ДЛИHA ДAHHЫX = 0 28630000
CALL SPACK ПOCЛATЬ NAK 28640000
BRTORC RFILE880,REST=RFILE900 28650000
RFILE880 XR R14,R14 RC = 0 28660000
B RFILERET И ЖДATЬ CЛEД. ПAKET 28670000
RFILE900 LA R14,2 RC = 2 28680000
B RFILERET 28690000
RFILE990 MVI #ERROR,E$ERR ПPИШEЛ ERROR ПAKET 28700000
MVI $STATE,C'A' ПEPEXOД B COCTOЯHИE ABORT 28710000
LA R14,2 RC = 2 28720000
RFILERET RETURN 28730000
*********************************************************************** 28740000
LTORG 28750000
DROP BASE 28760000
*********************************************************************** 28770000
* ПPИEM ПAKETOB ДAHHЫX * 28780000
*********************************************************************** 28790000
* RETURN CODE = 0 - OK * 28800000
* RETURN CODE = 2 - ERROR (HУЖEH ERROR ПAKET) * 28810000
*********************************************************************** 28820000
RDATA SAVE 28830000
USING RDATA,BASE 28840000
LR BASE,R14 28850000
CALL RPACK CЧИTATЬ ПAKET OT ПAPTHEPA 28860000
BRTORC RDATA010,REST=RDATA800 28870000
RDATA010 CLI $R$CUR,AD ПPИШEЛ ПAKET ДAHHЫX ? 28880000
BE RDATA100 28890000
CLI $R$CUR,AF ПPИШEЛ ЗAГOЛOBOK ФAЙЛA ? 28900000
BE RDATA200 28910000
CLI $R$CUR,AZ ПPИШEЛ EOF ? 28920000
BE RDATA300 28930000
CLI $R$CUR,AE ПPИШEЛ ERROR ? 28940000
BE RDATA990 28950000
B RDATA400 28960000
* 28970000
RDATA100 CLC $N$OLD,$N$CUR CPABHИTЬ HOMEPA ПAKETOB 28980000
BNE RDATA200 ECЛИ HE COBПAЛИ, ПOCЛATЬ ACK HA ПPEД 28990000
CALL PTCHR ПOДПPOГPAMMA OБPAБOTKИ ДAHHЫX 29000000
BRTORC RDATA110,REST=RDATA910 29010000
RDATA110 CALL SACK ПOCЛATЬ ACK HA ПAKET ДAHHЫX 29020000
B RDATRET И ЖДATЬ CЛEД. ПAKET 29030000
* 29040000
RDATA200 CLC $RETRY,RETRY MOЖHO ПOCЛATЬ ПAKET ? 29050000
BL RDATA220 ECЛИ MOЖHO, TO ПOCЛATЬ 29060000
MVI $STATE,C'A' ИCЧEPПAH ЛИMИT 29070000
LA R14,8 RC = 8 29080000
B RDATRET ПPEKPATИTЬ ПPИEM ФAЙЛA 29090000
RDATA220 EQU * 29100000
LH R4,$N$OLD ЗAГPУЗИTЬ HOMEP ПAKETA 29110000
BCTR R4,0 BЫЧECTЬ 1 - ACK HA ПPEД. ПAKET 29120000
N R4,=X'0000003F' $N$OLD MOD 64 29130000
CH R4,$N$CUR TEПEPЬ COBПAЛИ HOMEPA ? 29140000
BE RDATA240 ECЛИ ДA, ПOCЛATЬ ACK 29150000
MVI #ERROR,E$BAD ПOTEPЯH ПAKET 29160000
B RDATA800 ПOCЛATЬ NAK 29170000
RDATA240 STH R4,$N$OLD ЗAПИCATЬ HOMEP ПAKETA 29180000
CALL SACK ПOCЛATЬ ACK 29190000
B RDATRET И ЖДATЬ, ЧTO ПOЛУЧИЛOCЬ 29200000
* 29210000
RDATA300 CLC $N$OLD,$N$CUR COBПAДAЮT HOMEPA ПAKETOB ? 29220000
BE RDATA320 ECЛИ ДA, ПOCЛATЬ ACK HA EOF 29230000
MVI #ERROR,E$BAD ПOTEPЯH ПAKET 29240000
B RDATA800 ПOCЛATЬ HAK HA EOF 29250000
RDATA320 LH R15,$PUT$L ЗAГPУЗИTЬ ДЛИHУ ПOCЛEДHEЙ ЗAПИCИ 29260000
LTR R15,R15 ECTЬ ДAHHЫE ? 29270000
BZ RDATA340 ECЛИ HET, HEЧEГO BЫBOДИTЬ 29280000
STH R15,$WR$L ДЛИHA ПOCЛEДHEЙ ЗAПИCИ 29290000
CALL WRITEX BЫBECTИ ЗAПИCЬ B ФAЙЛ 29300000
LTR R14,R14 29310000
BNZ RDATA900 29320000
RDATA340 CALL SACK ПOCЛATЬ ACK HA EOF 29330000
MVI $STATE,C'F' ЖДATЬ BREAK ИЛИ FILE_HEADER 29340000
XR R14,R14 RC = 0 29350000
B RDATRET И ЗA CЛEДУЮЩИM ПAKETOM 29360000
* 29370000
RDATA400 EQU * 29380000
CLC $RETRY,RETRY ПPEBЫШEH ЛИMИT HA ПOBTOP ? 29390000
BL RDATA420 HET 29400000
MVI $STATE,C'A' 29410000
LA R14,8 RC = 8 29420000
B RDATRET 29430000
RDATA420 CLI $R$CUR,AN ПPИШEЛ NAK ? 29440000
BE RDATA800 ECЛИ ДA, OTBETИTЬ NAK'OM 29450000
MVI $STATE,C'A' KOHЧИTЬ ПPИEM ФAЙЛA 29460000
MVI #ERROR,E$TYPE HEBEPHЫЙ TИП ПAKETA 29470000
B RDATRET И ЗABEPШИTЬ 29480000
RDATA800 MVI $S$CUR,AN TИП ПAKETA - NAK 29490000
XC $SDAT$L(2),$SDAT$L ДЛИHA ДAHHЫX = 0 29500000
CALL SPACK ПOCЛATЬ NAK 29510000
XR R14,R14 RC = 0 29520000
B RDATRET 29530000
RDATA900 MVI $STATE,C'A' HEИCПPABИMЫE OШИБKИ 29540000
LA R14,2 RC = 2 29550000
B RDATRET 29560000
RDATA910 EQU * 29570000
MVI $STATE,C'A' ПEPEXOД B COCTOЯHИE ABORT 29580000
LA R14,2 RC = 2 29590000
B RDATRET 29600000
RDATA990 MVI #ERROR,E$ERR ПPИШEЛ ERROR ПAKET 29610000
MVI $STATE,C'A' ПEPEXOД B COCTOЯHИE ABORT 29620000
LA R14,2 RC = 2 29630000
RDATRET RETURN 29640000
*********************************************************************** 29650000
LTORG 29660000
DROP BASE 29670000
*********************************************************************** 29680000
* ПOДПPOГPAMMA ПOCЫЛKИ ACK * 29690000
*********************************************************************** 29700000
* RETURN CODE = 0 - OK * 29710000
* RETURN CODE = 2 - ERROR (HУЖEH ERROR ПAKET) * 29720000
*********************************************************************** 29730000
SACK SAVE 29740000
USING SACK,BASE 29750000
LR BASE,R14 29760000
MVI $S$CUR,AY TИП ПAKETA - ACK 29770000
XC $SDAT$L(2),$SDAT$L ПAKET БEЗ ДAHHЫX 29780000
CALL SPACK ПOCЛATЬ ПAKET 29790000
BRTORC SACK010,REST=SACKERR 29800000
SACK010 LH R4,$N$OLD ЗAГPУЗИTЬ HOMEP ПOCЛAH. ПAKETA 29810000
LA R4,1(,R4) УBEЛИЧИTЬ HA 1 29820000
N R4,=X'0000003F' $N$OLD MOD 64 29830000
STH R4,$N$OLD ЗAПИCATЬ HOMEP OБPATHO 29840000
XR R14,R14 RC = 0 29850000
B SACKRET 29860000
SACKERR LA R14,2 RC = 2 29870000
SACKRET RETURN 29880000
*********************************************************************** 29890000
LTORG 29900000
DROP BASE 29910000
*********************************************************************** 29920000
* ПOДПPOГPAMMA OБPAБOTKИ ПPИШEДШИX B ПAKETE ДAHHЫX * 29930000
*********************************************************************** 29940000
* RETURN CODE = 0 - OK * 29950000
* RETURN CODE = 2 - ERROR WRITE (HУЖEH ERROR ПAKET) * 29960000
*********************************************************************** 29970000
PTCHR SAVE 29980000
USING PTCHR,BASE 29990000
LR BASE,R14 30000000
XR R0,R0 30010000
IC R0,QUOTE ЗAГPУЗИTЬ QUOTE 30020000
XR R1,R1 30030000
IC R1,PREF 30040000
L R2,$DAT$A AДPEC IN DATA 30050000
LH R3,$RDAT$L ЗAГPУЗИTЬ ДЛИHУ IN DATA 30060000
LH R4,$PUT$L CMEЩEHИE/ДЛИHA OUT DATA 30070000
L TDOABAR,$FMA AДPEC OUT DATA 30080000
LA R5,TDOADBA AДPEC OUT DATA 30090000
* 30100000
PTC#010 EQU * 30110000
LTR R3,R3 ECTЬ ДAHHЫE ? 30120000
BNZ MOR ECЛИ ECTЬ, OБPAБOTATЬ 30130000
STH R4,$PUT$L 30140000
XR R14,R14 RC = 0 30150000
B PTCRET 30160000
* 30170000
MOR EQU * 30180000
LH R15,F#REC ДЛИHA ЗAПИCИ ФAЙЛA 30190000
TM FILSTAT,X'08' 30200000
BNZ PTC#510 HE V 30210000
TM FILSTAT,X'04' 30220000
BNO PTC#510 HE V 30230000
SH R15,=H'4' 30240000
PTC#510 EQU * 30250000
CR R4,R15 ECTЬ MECTO B БУФEPE ДЛЯ 1 CИMB. ? 30260000
BNL PTC#600 HET 30270000
XR R14,R14 ДЛЯ ЗAГPУЗKИ OЧEPEДHOГO CИMBOЛA 30280000
IC R14,0(R2) ЗAГPУЗИTЬ OЧEPEДHOЙ CИMBOЛ 30290000
TM PGMSTAT,X'20' BEДETCЯ ПPEФИKCAЦИЯ 8-ГO БИTA ? 30300000
BZ PTC#130 ECЛИ HET, HE ПPOBEPЯTЬ 30310000
* 30320000
CR R14,R1 ПOЛУЧEH PREF ? 30330000
BNE PTC#130 ECЛИ HET, ПPOBEPЯTЬ ДAЛЬШE 30340000
* ПOЛУЧEH ПPEФИKC BOCЬMOГO БИTA 30350000
LA R2,1(,R2) ПEPEMECTИTЬ УKAЗATEЛЬ 30360000
BCTR R3,0 BЫЧECTЬ 1 ИЗ CЧETЧИKA 30370000
IC R14,0(R2) ЗAГPУЗИTЬ CИMBOЛ 30380000
CR R14,R0 PREF QUOTE ? 30390000
BE PTC#110 ECЛИ ДA, BЫCTABИTЬ HA CЛEД. 30400000
O R14,=X'00000080' BЫCTABИTЬ 8-OЙ БИT 30410000
B PTC#500 ЗAПИCATЬ CИMBOЛ 30420000
* 30430000
PTC#110 EQU * 30440000
LA R2,1(,R2) ПEPEMECTИTЬ УKAЗATEЛЬ 30450000
BCTR R3,0 BЫЧECTЬ 1 ИЗ CЧETЧИKA 30460000
IC R14,0(R2) ЗAГPУЗИTЬ CИMBOЛ 30470000
CR R14,R0 QUOTE ? 30480000
BE PTC#120 30490000
CR R14,R1 PREF ? 30500000
BE PTC#120 30510000
X R14,=X'00000040' CTL(R14) 30520000
PTC#120 O R14,=X'00000080' 30530000
B PTC#500 30540000
* 30550000
PTC#130 CR R14,R0 QUOTE ? 30560000
BNE PTC#500 ECЛИ HET, OБЫЧHЫЙ CИMBOЛ 30570000
LA R2,1(,R2) ПEPEMECTИTЬ УKAЗATEЛЬ HA CЛEД. CИMB. 30580000
BCTR R3,0 BЫЧECTЬ EЩE 1 ИЗ CЧETЧИKA 30590000
IC R14,0(R2) ЗAГPУЗИTЬ CПEЦCИMBOЛ 30600000
TM PGMSTAT,X'40' ИДET ПPИEM TEXT ФAЙЛA ? 30610000
BZ PTC#360 HET. HE ИCKATЬ CR LF 30620000
* 30630000
C R14,=X'0000004D' C R ? 30640000
BNE PTC#200 ECЛИ HET, ПPOBEPИTЬ L F 30650000
LA R2,1(,R2) ПEPEMECTИTЬ BXOДHOЙ УKAЗATEЛЬ 30660000
BCTR R3,0 BЫЧECTЬ EЩE 1 ИЗ CЧETЧИKA 30670000
B PTC#250 И BЫBECTИ ЗAПИCЬ 30680000
* 30690000
PTC#200 C R14,=X'0000004A' L F ? 30700000
BNE PTC#360 ECЛИ HET, ПPOBEPИTЬ QUOTE 30710000
LA R2,1(,R2) ПEPEMECTИTЬ BXOДHOЙ УKAЗATEЛЬ 30720000
BCTR R3,0 BЫЧECTЬ EЩE 1 ИЗ CЧETЧИKA 30730000
B PTC#010 30740000
* 30750000
PTC#250 EQU * 30760000
TM PGMSTAT,X'40' ИДET ПPИEM TEXT ФAЙЛA ? 30770000
BZ PTC#320 HET. HE ПEPEKOДИPOBATЬ 30780000
* 30790000
LTR R4,R4 ECTЬ ДAHHЫE B ЗAПИCИ ? 30800000
BZ PTC#320 ECЛИ HET, HE ПEPEKOДИPOBATЬ 30810000
* 30820000
L R14,A#TRT#AE 30830000
LR R15,R5 COXPAHИTЬ PEГИCTP 30840000
LR R0,R4 COXPAHИTЬ PEГИCTP 30850000
* 30860000
PTC#280 CH R4,=H'256' 30870000
BNH PTC#300 30880000
TR 0(256,R5),0(R14) ПEPEBECTИ B ДKOИ 30890000
SH R4,=H'256' 30900000
LA R5,256(R5) 30910000
B PTC#280 30920000
* 30930000
PTC#800 TR 0(0,R5),0(R14) ПEPEBECTИ B ДKOИ 30940000
* 30950000
PTC#300 BCTR R4,0 ДЛЯ TR 30960000
EX R4,PTC#800 30970000
LR R5,R15 BOCCTAHOBИTЬ PEГИCTP 30980000
LR R4,R0 BOCCTAHOBИTЬ PEГИCTP 30990000
XR R0,R0 31000000
IC R0,QUOTE ЗAГPУЗИTЬ QUOTE 31010000
* 31020000
PTC#320 XC $PUT$L(2),$PUT$L ЗAПИCЬ ПУCTAЯ 31030000
STH R4,$WR$L 31040000
CALL WRITEX BЫBECTИ ЗAПИCЬ B БЛOK 31050000
L TDOABAR,$FMA BOCCTAHOBИTЬ AДPEC OUT DATA 31060000
LA R5,TDOADBA AДPEC OUT DATA 31070000
LTR R14,R14 OK ? 31080000
BZ PTC#340 ДA 31090000
LA R14,2 RC = 2 31100000
B PTCRET 31110000
* 31120000
PTC#340 EQU * 31130000
XR R4,R4 CБPOCИTЬ ДЛИHУ ЗAПИCИ 31140000
B PTC#010 И ПPOBEPЯTЬ CЛEДУЮЩИЙ CИMBOЛ 31150000
* 31160000
PTC#360 EQU * 31170000
CR R14,R0 QUOTE ? 31180000
BE PTC#500 31190000
TM PGMSTAT,X'20' BEДETCЯ ПPEФИKCAЦИЯ 8-ГO БИTA ? 31200000
BZ PTC#380 HET 31210000
CR R14,R1 PREF ? 31220000
BE PTC#500 31230000
PTC#380 X R14,=X'00000040' CTL(R14) 31240000
* 31250000
PTC#500 EQU * 31260000
STC R14,0(R5,R4) ЗAПИCATЬ CИMBOЛ 31270000
LA R4,1(,R4) ПEPEMECTИTЬ BЫXOДHOЙ ИHДEKC 31280000
LA R2,1(,R2) AДPEC CЛEД. CИMBOЛA IN DATA 31290000
BCT R3,PTC#010 ПEPEXOД ECЛИ OБPAБOTAH HE BECЬ ПAKET 31300000
B PTC#700 31310000
* OБPAБOTKA ЗAПOЛHEHHOГO OUT БУФEPA 31320000
PTC#600 EQU * 31330000
TM PGMSTAT,X'40' ИДET ПPИEM TEXT ФAЙЛA ? 31340000
BZ PTC#650 HET 31350000
* OБPAБOTKA ЗAПOЛHEHHOГO OUT БУФEPA 31360000
* B TEKCTOBOM PEЖИME 31370000
PTC#620 XR R14,R14 ДЛЯ ЗAГPУЗKИ OЧEPEДHOГO CИMBOЛA 31380000
IC R14,0(R2) ЗAГPУЗИTЬ OЧEPEДHOЙ CИMBOЛ 31390000
CR R14,R0 QUOTE ? 31400000
BNE PTC#640 HET - ERROR 31410000
LA R2,1(,R2) ПEPEMECTИTЬ УKAЗATEЛЬ HA CЛEД. CИMB. 31420000
BCTR R3,0 BЫЧECTЬ EЩE 1 ИЗ CЧETЧИKA 31430000
IC R14,0(R2) ЗAГPУЗИTЬ CПEЦCИMBOЛ 31440000
* 31450000
C R14,=X'0000004D' C R ? 31460000
BNE PTC#630 ECЛИ HET, ПPOBEPИTЬ L F 31470000
LA R2,1(,R2) ПEPEMECTИTЬ BXOДHOЙ УKAЗATEЛЬ 31480000
BCTR R3,0 BЫЧECTЬ EЩE 1 ИЗ CЧETЧИKA 31490000
B PTC#250 И BЫBECTИ ЗAПИCЬ 31500000
* 31510000
PTC#630 C R14,=X'0000004A' L F ? 31520000
BNE PTC#640 ECЛИ HET, ERROR 31530000
LA R2,1(,R2) ПEPEMECTИTЬ BXOДHOЙ УKAЗATEЛЬ 31540000
BCT R3,PTC#620 ПEPEXOД ECЛИ OБPAБOTAH HE BECЬ ПAKET 31550000
B PTC#700 31560000
* 31570000
PTC#640 MVI #ERROR,E$TRUNC 31580000
LA R14,2 RC = 2 31590000
B PTCRET 31600000
* OБPAБOTKA ЗAПOЛHEHHOГO OUT БУФEPA 31610000
* B PEЖИME BINARY 31620000
PTC#650 XC $PUT$L(2),$PUT$L ЗAПИCЬ ПУCTAЯ 31630000
STH R4,$WR$L 31640000
CALL WRITEX BЫBECTИ ЗAПИCЬ 31650000
L TDOABAR,$FMA BOCCTAHOBИTЬ AДPEC OUT DATA 31660000
LA R5,TDOADBA AДPEC OUT DATA 31670000
XR R4,R4 CБPOCИTЬ ДЛИHУ ЗAПИCИ 31680001
LTR R14,R14 OK ? 31690000
BZ PTC#010 ДA 31700001
LA R14,2 RC = 2 31710000
B PTCRET 31720000
* 31730000
* KOHEЦ OБPAБOTKИ ЗAПOЛHEHHOГO БУФEPA 31740000
* 31750001
PTC#700 STH R4,$PUT$L 31760000
XR R14,R14 RC = 0 31770000
B PTCRET 31780000
* 31790000
PTCRET RETURN 31800000
*********************************************************************** 31810000
LTORG 31820000
DROP BASE 31830000
*********************************************************************** 31840000
* ПOДПPOГPAMMA BЫBOДA ДAHHЫX HA ДИCK * 31850000
*********************************************************************** 31860000
* RETURN CODE = 0 - OK * 31870000
* RETURN CODE = 2 - ERROR * 31880000
* RETURN CODE = 4 - HEPACПOЗHAHHAЯ OШИБKA BЫBOДA * 31890000
*********************************************************************** 31900000
WRITEX SAVE 31910000
USING WRITEX,BASE УCTAHOBИTЬ AДPECAЦИЮ 31920000
LR BASE,R14 ЗAГPУЗИTЬ БAЗOBЫЙ PEГИCTP 31930000
L TDOABAR,$FMA 31940000
LH R3,$WR$L ЗAГPУЗИTЬ ДЛИHУ BЫBOДИMOЙ ЗAПИCИ 31950000
LTR R3,R3 ДЛИHA = 0 ? 31960000
BNZ WRT000 HET 31970000
LA R3,1 31980000
LA R14,64 ПPOБEЛ B KOДE EBCDIC 31990000
STC R14,TDOADBA 32000000
* 32010000
WRT000 EQU * 32020000
TM FILSTAT,X'08' 32030000
BNZ WRT012 HE V 32040000
TM FILSTAT,X'04' 32050000
BNO WRT012 HE V 32060000
* 32070000
LA R3,4(R3) ДЛИHA ДAHHЫX + ДЛИHA RDW 32080000
CH R3,F#REC ДЛИHA CTPOKИ < ДЛИHЫ OUT ЗAПИCИ ? 32090000
BL WRT010 ДA 32100000
LH R3,F#REC 32110000
SH R3,=H'4' ДЛИHA ДAHHЫX БEЗ RDW 32120000
B WRT020 32130000
WRT010 LA R14,=F'0' 32140000
SH R3,=H'4' ДЛИHA ДAHHЫX БEЗ RDW 32150000
ST R3,0(R14) 32160000
LA R15,64 ПPOБEЛ B KOДE EBCDIC 32170000
STC R15,0(R14) 32180000
L R3,0(R14) ДЛИHA И CИMBOЛ ЗAПOЛHИTEЛЬ 32190000
B WRT020 32200000
* 32210000
WRT012 CH R3,F#REC ДЛИHA CTPOKИ < ДЛИHЫ OUT ЗAПИCИ ? 32220000
BL WRT014 ДA 32230000
LH R3,F#REC 32240000
B WRT020 32250000
WRT014 LA R14,=F'0' ЗAГPУЗИTЬ AДPEC CЛOBA 32260000
ST R3,0(R14) ЗAПИCATЬ B HEГO ДЛИHУ 32270000
LA R15,64 ПPOБEЛ B KOДE EBCDIC 32280000
STC R15,0(R14) ЗAПИCATЬ ПPOБEЛ B CTAPШ. БAЙT CЛOBA 32290000
L R3,0(R14) ДЛИHA И CИMBOЛ ЗAПOЛHИTEЛЬ 32300000
* 32310000
WRT020 LA R2,TDOADBA AДPEC БУФEPA PACПAKOBKИ 32320000
LA R4,TDOAVRL AДPEC БУФEPA BЫBOДA (!) 32330000
LH R5,F#REC ДЛИHA БУФEPA BЫBOДA 32340000
TM FILSTAT,X'08' 32350000
BNZ WRT030 HE V 32360000
TM FILSTAT,X'04' 32370000
BNO WRT030 HE V 32380000
LR R14,R3 32390000
LA R14,4(R14) LENGHT + L'RDW 32400000
STH R14,0(R4) RECORD DESCRIPTOR WORD 32410000
XC 2(2,R4),2(R4) RDW 32420000
LA R4,4(R4) AДPEC ДAHHЫX B БУФEPE BЫBOДA 32430000
SH R5,=H'4' ДЛИHA ДAHHЫX B БУФEPE BЫBOДA 32440000
WRT030 EQU * 32450000
MVCL R4,R2 ЗAПOЛHEHИE БУФEPA BЫBOДA 32460000
MVC TCATDDI(4),FILEDEST ИMЯ ПУHKTA HAЗHAЧEHИЯ 32470000
LA R14,TDOAVRL AДPEC БУФEPA BЫBOДA 32480000
ST R14,TCATDAA 32490000
DFHTD TYPE=PUT,IOERROR=WRT100,NOSPACE=WRT200,NORESP=WRT700 32500000
MVI #ERROR,E$CICS 32510000
LA R14,4 RC = 4 32520000
B WRTRET 32530000
WRT100 EQU * 32540000
MVI #ERROR,E$PIO 32550000
LA R14,2 RC = 2 32560000
B WRTRET 32570000
WRT200 EQU * 32580000
MVI #ERROR,E$SPACE 32590000
LA R14,2 RC = 2 32600000
B WRTRET 32610000
WRT700 EQU * 32620000
XC $WR$L(2),$WR$L 32630000
XR R14,R14 RC = 0 32640000
WRTRET RETURN 32650000
*********************************************************************** 32660000
LTORG 32670000
DROP BASE 32680000
*********************************************************************** 32690000
* BЫBOД COOБЩEHИЙ COURIER - CICS * 32700000
*********************************************************************** 32710000
* RETURN CODE = 0 - OK * 32720000
*********************************************************************** 32730000
WRS SAVE 32740000
USING WRS,BASE УCTAHOBИTЬ AДPECAЦИЮ 32750000
LR BASE,R14 ЗAГPУЗИTЬ БAЗOBЫЙ PEГИCTP 32760000
XR R2,R2 ДЛЯ ЗAГPУЗKИ ДЛИHЫ COOБЩEHИЯ 32770000
IC R2,PACKAGE ЗAГPУЗИTЬ ДЛИHУ 32780000
LA R3,2(R2) ДЛИHA CR LF 32790000
L TIOABAR,$SMA ЗAГPУЗИTЬ AДPEC TIOA 32800000
STH R3,TIOATDL ЗAПИCATЬ ДЛИHУ TIOA 32810000
MVC TIOADBA(2),=X'0D25' ЗAПИCATЬ CR LF 32820000
BCTR R2,0 BЫЧECTЬ 1 ДЛЯ MVC 32830000
EX R2,WRS600 ЗAПИCATЬ TEKCT COOБЩEHИЯ 32840000
ST TIOABAR,TCTTEDA ЗAПИCATЬ AДPEC TIOA B TCTTE 32850000
DFHTC TYPE=(PUT,SAVE) BЫBECTИ COOБЩEHИE 32860000
XR R14,R14 RC=0 32870000
B WRS##010 32880000
WRS600 MVC TIOADBA+2(0),PACKAGE+1 32890000
WRS##010 RETURN 32900000
*********************************************************************** 32910000
LTORG 32920000
DROP BASE 32930000
END 32940000