Cpbltin
Aus Si:Wiki von Siegrist SystemLösungen - Informatik und Rezepte
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 ##BAL OPSYN ##BAS ##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
