Batch Assembler program example
Article ID: 30733
Updated On:
Products
Issue/Introduction
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
Environment
Component:
Feedback
