Batch Assembler program example

Document ID : KB000030733
Last Modified Date : 14/02/2018
Show Technical Document Details

In the IDMS DML Assembler Reference, the sample provided for the batch program contains errors. The 'Input to the Precompiler' section contains inaccuracies; while the 'Output from the Precompiler' section is correct.  

A corrected example has been placed in the v19.0 version of the manual. That source which can be input to the IDMSDMLA Assembler language precompiler is also provided here: 

*DMLIST

 SAMPLE1  START

           #REGEQU

          STM       R14,R12,12(R13)

          LR        R12,R15

          USING     SAMPLE1,R12,R11,R10

          LR        R11,R12

          LA        R11,4095(R11)

          LA        R11,1(R11)

          LA        R10,4095(R11)

          LA        R10,1(R10)

          ST        R13,SAVEAREA+4

          LA        R7,SAVEAREA

          ST        R7,8(R13)

          LA        R13,SAVEAREA

          B         BEGIN

          @MODE MODE=BATCH,DEBUG=YES

          @INVOKE SUBSCH=EMPSS01,SCHEMA=EMPSCHM,VERSION=100

          @COPY IDMS,SUBSCHEMA-CTRL

          @COPY IDMS,SUBSCHEMA-RECORDS

 BEGIN    DS        0F

          @COPY IDMS,SUBSCHEMA-BINDS

          @BIND SUBSCH='EMPSS01 ',SCB=SSCTRL,DICTNAM='APPLDICT'

          @BIND REC='OFFICE',IOAREA=OFFIC

          @BIND REC='EMPLOYEE',IOAREA=EMPLOYE

          @BIND REC='DEPARTMENT',IOAREA=DEPARTMT

          OPEN  (OUTFILE,OUTPUT)

          MVC   EDSW,=C'N'          SET SWITCHES

          MVC   DSW,=C'N'

          MVC   ESW,=C'N'

          LA    R5,MAIN000          LOAD ADDRESS OF MAINLINE ROUTINE

          B     PRTHEAD

 MAIN000  EQU   *

          @READY ALL,RDONLY=YES     READY ALL DATABASE AREAS

          CLC   ERRSTAT,STATOK      CHECK IF ERROR

          BNE   AREAERR             BRANCH TO ERROR ROUTINE

          @OBTAIN FIRST,AREA='ORG-DEMO-REGION',REC='OFFICE'

 NEWOFFC  CLC   ERRSTAT,STATOK      CHECK IF NO OFFICE

          BNE   AREAERR

          MVC   OCODE,OFFCODE

          MVC   OCITY,OFFCITY

          @OBTAIN FIRST,SET='OFFICE-EMPLOYEE',REC='EMPLOYEE'

          CLC   ERRSTAT,STATOK      CHECK IF NO EMPLOYEE

          BNE   OBERR1

          MVC   EID,EMPID           MOVE EMPLOYEE ID

          MVC   FNAME,EMPFNAME      MOVE EMPLOYEE FIRST NAME

          MVC   LNAME,EMPLNAME      MOVE EMPLOYEE LAST NAME

          MVC   WALK,EMPID          SAVE ID

          MVC   STATNUM,EMPSTATU    MOVE EMPLOYEE STATUS

          LA    R6,NEWDPT           LOAD ADDRESS OF NEW DEPT ROUTINE

          B     CKSTAT              BRANCH TO STATUS-CHECK RTN

 NEWDPT   EQU   *

          @OBTAIN OWNER,SET='DEPT-EMPLOYEE'

          CLC   ERRSTAT,STATOK      CHECK IF DEPARTMENT

          BNE   OBERR2

          MVC   DID,DEPTID

          MVC   DEPT,DEPTNAME

          LA    R5,MAIN020          LOAD ADDRESS OF SET-WALK RTN

          B     PRINTREC            PRINT DEPARTMENT INFORMATION

 MAIN020  EQU   *                   *

          @OBTAIN NEXT,SET='DEPT-EMPLOYEE',REC='EMPLOYEE'

          CLC   ERRSTAT,0307        CHECK IF END OF SET

          BE    MAIN030             BRANCH IF END OF SET

          CLC   ERRSTAT,STATOK      CHECK IF ERROR

          BNE   OBERR3

          MVC   EID,EMPID           MOVE EMPLOYEE ID

          MVC   FNAME,EMPFNAME      MOVE EMPLOYEE FIRST NAME

          MVC   LNAME,EMPLNAME      MOVE EMPLOYEE LAST NAME

          MVC   STATNUM,EMPSTATU    MOVE EMPLOYEE STATUS

          LA    R6,MAIN025          LOAD ADDRESS OF PRINT LINK

          B     CKSTAT

 MAIN025  EQU   *

          LA    R5,MAIN020

          B     PRINTREC

 MAIN030  EQU   *

          MVC   EMPID,WALK

          @FIND CALC,REC='EMPLOYEE' FIND NEXT EMPLOYEE

          CLC   ERRSTAT,STATOK      CHECK IF ERROR

          BNE   CALCERR

 REPEAT   EQU   *

          @OBTAIN NEXT,SET='OFFICE-EMPLOYEE',REC='EMPLOYEE'

          CLC   ERRSTAT,=C'0307'    END OF SET ?

          BE    MAIN040             BRANCH IF END OF SET

          CLC   ERRSTAT,STATOK

          BNE   OBERR1

          @IF   SET='DEPT-EMPLOYEE',MEMBER=YES,GOTO=REPEAT

          MVC   EID,EMPID           MOVE EMPLOYEE ID

          MVC   FNAME,EMPFNAME      MOVE EMPLOYEE FIRST NAME

          MVC   LNAME,EMPLNAME      MOVE EMPLOYEE LAST NAME

          MVC   WALK,EMPID

          MVC   STATNUM,EMPSTATU

          LA    R6,NEWDPT           ADDRESS OF DEPT ROUTINE

          B     CKSTAT

 MAIN040  EQU   *

          @OBTAIN NEXT,AREA='ORG-DEMO-REGION',REC='OFFICE'

          B     NEWOFFC

 EOF      EQU   *

          @FINISH                   *

          CLC   ERRSTAT,STATOK

          BNE   FINERR

          CLOSE (OUTFILE)

          L     R13,SAVEAREA+4

          LM    R14,R12,12(R13)

          BR    R14                 RETURN

 *   ERROR ROUTINES

 BSERROR  EQU   *

          MVI   ERRMSG,C' '

          MVC   ERRMSG+1(19),ERRMSG

          MVI   ERRNUM,C' '

          MVC   ERRNUM+1(3),ERRNUM

          MVC   ERRNUM,ERRSTAT

          MVC   ERRMSG,BSMSG

          B     PRINTERR

 BRERROR  EQU   *

          MVI   ERRMSG,C' '

          MVC   ERRMSG+1(19),ERRMSG

          MVI   ERRNUM,C' '

          MVC   ERRNUM+1(3),ERRNUM

          MVC   ERRNUM,ERRSTAT

          MVC   ERRMSG,BRMSG

          B     PRINTERR

 AREAERR  EQU   *

          MVI   ERRMSG,C' '

          MVC   ERRMSG+1(19),ERRMSG

          MVI   ERRNUM,C' '

          MVC   ERRNUM+1(3),ERRNUM

          MVC   ERRNUM,ERRSTAT

          MVC   ERRMSG,AREAMSG

          B     PRINTERR

 CALCERR  EQU   *

          MVI   ERRMSG,C' '

          MVC   ERRMSG+1(19),ERRMSG

          MVI   ERRNUM,C' '

          MVC   ERRNUM+1(3),ERRNUM

          MVC   ERRNUM,ERRSTAT

          MVC   ERRMSG,CALMSG

          B     PRINTERR

 FINERR   EQU   *

          MVI   ERRMSG,C' '

          MVC   ERRMSG+1(19),ERRMSG

          MVI   ERRNUM,C' '

          MVC   ERRNUM+1(3),ERRNUM

          MVC   ERRNUM,ERRSTAT

          MVC   ERRMSG,FINMSG

          B     PRINTERR

 OBERR1   EQU   *

          MVC   EDSW,=C'Y'

          LA    R5,MAIN040

          B     PRINTREC

 OBERR2   EQU   *

          MVC   DSW,=C'Y'

          LA    R5,REPEAT

          B     PRINTREC

 OBERR3   EQU   *

          MVC   ESW,=C'Y'

          LA    R5,MAIN030

          B     PRINTREC

 *   PRINT ROUTINES

 PRINTERR EQU   *

          MVC   ERRLINE,C' '

          MVC   ERRLINE+1(132),ERRLINE

          MVI   ERRLINE,C'0'

          PUT   OUTFILE,ERRLINE

          B     EOF

 PRINTREC EQU   *

          MVI   LINE1,C' '

          MVC   LINE1+1(132),LINE1

          MVI   LINE1,C'0'

          MVI   LINE2,C' '

          MVC   LINE2+1(132),LINE2

          CLC   EDSW,=C'Y'

          BE    SKIPED

          CLC   DSW,=C'Y'

          BE    SKIPD

          MVC   LINE1+27(45),DEPT

          MVC   LINE2+27(4),DID

          CLC   DSW,=C'Y'

          BE    SKIPED

 SKIPD    EQU   *

          MVC   LINE1+77(27),ENAME

          MVC   LINE2+77(4),EID

          MVC   LINE1+109(20),STAT

 SKIPED   EQU   *

          MVC   LINE1+7(15),OCITY

          MVC   LINE2+7(4),OCODE

          PUT   OUTFILE,LINE1

          PUT   OUTFILE,LINE2

          MVC   EDSW,=C'N'

          MVC   DSW,=C'N'

          MVC   ESW,=C'N'

          BR    R5

 *   CHECK STATUS ROUTINE           *

 CKSTAT   EQU   *

          CLC   STATNUM,=C'01'

          BE    ACT

          CLC   STATNUM,=C'02'

          BE    STD

          CLC   STATNUM,=C'03'

          BE    LTD

          CLC   STATNUM,=C'04'

          BE    LVO

          CLC   STATNUM,=C'05'

          BE    TRM

          MVC   STAT,=C' STATUS CODE ERROR  '

          BR    R6

 ACT      EQU   *

           MVC   STAT,=C' ACTIVE             '

           BR    R6

 STD      EQU   *

           MVC   STAT,=C' SHORT TERM DISABLED'

           BR    R6

 LTD      EQU   *

           MVC   STAT,=C' LONG TERM DISBALED '

           BR    R6

  LVO      EQU   *

           MVC   STAT,=C' LEAVE OF ABSENCE   '

           BR    R6

  TRM      EQU   *

           MVC   STAT,=C' TERMINATED         '

           BR    R6

 *   PRINT REPORT HEADING ROUTINE   *

 PRTHEAD  EQU   *

          MVI   LINE1,C' '

          MVC   LINE1+1(132),LINE1

          MVI   LINE1,C'1'

          MVC   LINE1+54(26),HEAD1

          PUT   OUTFILE,LINE1

          MVI   LINE1,C' '

          MVC   LINE1+1(132),LINE1

          MVI   LINE1,C'-'

          MVC   LINE1+6(18),HEAD2O

          MVC   LINE1+26(26),HEAD2D

          MVC   LINE1+76(20),HEAD2E

          MVC   LINE1+108(15),HEAD2S

          PUT   OUTFILE,LINE1

          BR    R5

 *

 WORKFLDS DC   C'WORK-FIELDS'

 SAVEAREA DC   18F'0'

 

STATNUM  DS    CL2

 STAT     DS    CL20

 STATOK   DC    CL4'0000'

 STATUS   DS    CL2

 OCODE    DS    CL3

 OCITY    DS    CL15

 EID      DS    CL4

 ENAME    DS    0CL27

 FNAME    DS    CL10

          DS    CL2

 LNAME    DS    CL15

 WALK     DS    CL4

 DID      DS    CL4

 DEPT     DS    CL45

 ERRLINE  DS    0CL133

          DS    CL1

          DC    CL48'* * * * * * * * * * * * * * * * * * * *   '

          DC    CL6'      '

 ERRMSG   DS    CL20

 ERRNUM   DS    CL4

          DC    CL6'      '

          DC    CL48'* * * * * * * * * * * * * * * * * * * *   '

          DC    CL5'     '

 BSMSG    DC    CL20'BIND SUBSCH ERROR # '

 BRMSG    DC    CL20'BIND RECORD ERROR # '

 AREAMSG  DC    CL20'READY AREA  ERROR # '

 CALMSG   DC    CL20'FIND CALC  ERROR  # '

 FINMSG   DC    CL20'@FINISH ERROR     # '

 EDSW     DS    CL1

 DSW      DS    CL1

 ESW      DS    CL1

 LINE1    DS    CL133

 LINE2    DS    CL133

 HEAD1    DC    CL26'OFFICE  PERSONNEL  LISTING'

 HEAD2O   DC    CL18'OFFICE/OFFICE CODE'

 HEAD2D   DC    CL26'DEPARTMENT/DEPARTMENT CODE'

 HEAD2E   DC    CL20'EMPLOYEE/EMPLOYEE ID'

 HEAD2S   DC    CL15'EMPLOYEE STATUS'

 *   OUTPUT FILE DCB INFO

 OUTFILE  DCB   DDNAME=OUTFILE,MACRF=PM,BLKSIZE=133,LRECL=133,          X

                DSORG=PS

          LTORG

 

          END   SAMPLE1