Cpbltin

<syntaxhighlight lang="asm">

CPBLTIN CSECT

• *
• COPYRIGHT (C) SIEMENS AG 1988 *
• COPYRIGHT (C) SIEMENS NIXDORF INFORMATIONSSYSTEME AG 1991 *
• ALL RIGHTS RESERVED *
• *

        PRINT NOGEN

R0 EQU 0 R1 EQU 1 R2 EQU 2 R3 EQU 3 R4 EQU 4 R5 EQU 5 R6 EQU 6 R7 EQU 7 R8 EQU 8 R9 EQU 9 R10 EQU 10 R11 EQU 11 R12 EQU 12 R13 EQU 13 R14 EQU 14 R15 EQU 15

• ---------------------------------------------------------------------*

        GPARMOD 31

CPBLTIN AMODE ANY CPBLTIN RMODE ANY

1. 1. BAL OPSYN ##BAS
   2. BALR OPSYN ##BASR

• ---------------------------------------------------------------------*
• R14 RUECKSPRUNGADRESSE
• R15 ANSPRUNGADRESSE BASR R14,15
• R3 STATEIN
• R4 USEREIN
• R5 BASIS REGISTER
• ---------------------------------------------------------------------*

        USING *,R15
        STM   R8,R12,SAVTAB
        ST    R14,SAV14
        USING CPBLTINA,R5    

CPBLTINA BASR R5,0

        BCTR  R5,R0
        BCTR  R5,R0
        DROP  15
        B     BEG

SAV14 DS F SAVTAB DS 5F

        USING STATEIN,R3
        USING USEREIN,R4

• ---------------------------------------------------------------------*
• E X T R N S
• ---------------------------------------------------------------------*
• ---------------------------------------------------------------------*

        DS    0F

BEG EQU *

        LA    R6,24             24 ZEILEN
        LA    R7,BLTNBER1       STATISCH           

BLTCL EQU *

        MVC   0(80,R7),=CL80' ' LOESCHEN BEREICH AUF BLANK
        BCT   R6,BLTCL
        OPEN  BULLETIN          

BLTGET EQU *

        LA    R6,24             24 ZEILEN
        LA    R7,BLTNBER1       STATISCH           

BLTLOOP EQU *

        GET   BULLETIN,INBER 
        LH    R8,INBER          LENGTH OF RECORD
        SH    R8,=H'5'          -4 (SL)  -1 (MVC)
        EX    R8,MVCREC
        LA    R7,80(R7)         + 80 (1 SATZ)
        BCT   R6,BLTLOOP
        B     BLTEOF            END OF FILE

• --------------------------------

BLTOPN EQU *

        LA    R6,BULLETIN
        USING ID1FCB,R6
        CLC   ID1ECB(2),=X'0D33'          NO EXIST
        BE    RETCOB                      NO MESSAGE
        UNPK  DMSERR(5),ID1ECB(3)
        TR    DMSERR,HXTAB-240
        MVC   DMSERRO(4),DMSERR
        MVC   DMSECD(4),=C'OPEN'
        WROUT BLTEOUT,RETCOB
        B     RETCOB

BLTCOM EQU *

        LA    R6,BULLETIN
        USING ID1FCB,R6
        UNPK  DMSERR(5),ID1ECB(3)
        TR    DMSERR,HXTAB-240
        MVC   DMSERRO(4),DMSERR
        MVC   DMSECD(4),=C'READ'
        WROUT BLTEOUT,RETCOB
        CLOSE BULLETIN
        B     RETCOB

• ----------------------------------------------------------------------*

BLTEOF EQU * END OF FILE

        CLOSE BULLETIN
        LA    R8,BLTNBER              ADDR OF AREA
        LH    R6,BLTNBERL             LENGTH

BLTSEND EQU *

        LA    R2,STATEI
        L     R4,STAIDCP  
        L     R9,STATCID
        L     R14,STATRPBA
        YSEND RPB=(R14),CID=(R9),AREA=(R8),AREALN=(R6),AID=(R4),      -
              EID=(R2)
        CLM   R15,B'1001',=X'0000'
        BE    BLTRET
        CLM   R15,B'1110',=X'10040C'
        BNE   BLTERR
        SOLSIG EIID=(R2),COND=UNCOND,LIFETIM=3 
        CLM   R15,B'0001',=X'00'
        BE    BLTSEND
        MVC   ERRTEXT(20),=CL20'S/BLTN/SOLSIG'  
        BAS   R14,FEHLER
        B     RETCOB

BLTERR EQU *

        MVC   ERRTEXT(20),=CL20'S/BLTN/YSEND'   
        BAS   R14,FEHLER
        B     RETCOB

BLTRET EQU *

        LM    R8,R12,SAVTAB
        L     R14,SAV14
        BR    R14

RETCOB EQU *

        L     R14,=V(PUTMASKE)
        LM    R8,R12,SAVTAB
        BR    R14

• ---------------------------------------------------------------------*

FEHLER EQU *

        ST    R15,ERR15
        UNPK  ERRR15,ERR15(5)
        TR    ERRR15,HX-240
        WROUT ERRMSG,BLTRET
        BR    R14

• ---------------------------------------------------------------------*

        DS    0F

ERRMSG DC Y(ERRMSGE-ERRMSG)

        DC    C'   %  ZCP0006 CP-ERROR AT:'

ERRTEXT DS CL20

        DC    C'  RC:'

ERRR15 DS L9 ERRMSGE EQU *-1

        ORG

ERR15 DS F HX DC C'0123456789ABCDEF'

        DS    0F

• ----------------------------------------------------------------------*

        DS    0F

BULLETIN FCB FCBTYPE=SAM, -

              EXIT=BLTNEX,                                            -
              LINK=BULLETIN,                                          -
              OPEN=INPUT,                                             -
              RECFORM=V,                                              -
              RECSIZE=84 

BLTNEX EXLST EOFADDR=BLTEOF,COMMON=BLTCOM,OPENER=BLTOPN,OPENC=BLTOPN

• -----------------------------------------------------------------

        DS    0F

BLTNBER EQU *

        DC    X'10401B20614040455165005040004121'
        DC    X'27822784'
        DC    X'1ED81D7C'     NP   HELL GESCHUETZT

BLTNBER1 DC 1920C' ' BLTNBERE EQU *

        DS    0F

BLTNBERL DC Y(BLTNBERE-BLTNBER)

        DS    0F

• -----------------------------------------------------------------

DMSERR DS CL4 FELD FUER UNPK

        DS    CL2           RESTFELD FUER UNPK
        DS    0F

INBER DS CL84 INPUT BEREICH + SL MVCREC MVC 0(0,R7),INBER+4

        DS    0F

HXTAB DC C'0123456789ABCDEF'

        DS    0F

BLTEOUT DC Y(BLTEOUTE-BLTEOUT)

        DC    C'   %  ZCP0021 '                   

DMSECD DS CL4 OPEN / READ

        DC    C'-ERROR DMS'

DMSERRO DS CL4

        DC    C ON FILE  BULLETIN .'

BLTEOUTE EQU *

        LTORG              <<<<<<<<<<<<<<<<<

• ---------------------------------------------------------------------*
• D S E C T ' S
• ---------------------------------------------------------------------*

        PRINT GEN
        IDFCB D,I

        STATEIN
        EJECT
        USEREIN

• ---------------------------------------------------------------------*

        END