* IF YOU DON'T SEE RUSSIAN TEXT SET YOUR BROWSER'S ENCODING TO UTF-8
*	
         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 &REG,&AREA,&DBLWRK                                     00550000
&N       CVD   &REG,&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
