Google
 

Trailing-Edge - PDP-10 Archives - BB-D867D-BM - uetp/lib/v4.fml
There are 16 other files named v4.fml in the archive. Click here to see a list.
*	DBMS
	INVOKE SUBS1 OF ORDTIN PRIVACY KEY COMPILE ORDER1.
	IF (ERCNT.NE.0) ACCEPT 101,J

	ACCEPT *,J
	IF (J.EQ.0) CALL JMNONE(0)
	IF (J.EQ.1) CALL JMBEF('AREA1')

*	DBMS
	OPEN AREA AREA1 USAGE-MODE IS EXCLUSIVE UPDATE.
	IF (ERCNT.NE.0) ACCEPT 101,J
	SLSOFF(1,1)='HOME'

	DO 11 I=1,50
*	DBMS
	STORE SLSENG.
	IF (ERCNT.NE.0) ACCEPT 101,J
	CUSKEY=I
*	DBMS
	STORE CUSTOM.
	IF (ERCNT.NE.0) ACCEPT 101,J
*	DBMS
	MOVE STATUS AREA1 AREA TO CUSDBK.
*	DBMS
	INSERT CUSTOM INTO SLSCUS-SET.
	IF (ERCNT.NE.0) ACCEPT 101,J

	CUSKEY=I
*	DBMS
	STORE CUSTOM.
	IF (ERCNT.NE.0) ACCEPT 101,J
*	DBMS
	MOVE STATUS AREA1 AREA TO CUSDBK.
*	DBMS
	INSERT CUSTOM INTO SLSCUS-SET.
	IF (ERCNT.NE.0) ACCEPT 101,J
11	CONTINUE


*	DBMS
	FIND FIRST RECORD OF AREA1 AREA.
	IF (ERCNT.NE.0) ACCEPT 101,J
*	DBMS
	GET.
	IF (ERCNT.NE.0) ACCEPT 101,J
	IF (KKK.EQ.7) TYPE 102,CUSKEY,CUSDBK

	DO 12 I=1,49
*	DBMS
	FIND NEXT SLSENG RECORD OF AREA1 AREA.
	IF (ERCNT.NE.0) ACCEPT 101,J
*	DBMS
	FIND NEXT RECORD OF SLSCUS-SET SET.
	IF (ERCNT.NE.0) ACCEPT 101,J
*	DBMS
	GET.
	IF (ERCNT .NE. 0) ACCEPT 101,J
	IF (KKK.EQ.7) 	TYPE 102,CUSKEY,CUSDBK
*	DBMS
	FIND NEXT RECORD OF SLSCUS-SET SET.
	IF (ERCNT.NE.0) ACCEPT 101,J
*	DBMS
	GET.
	IF (ERCNT .NE. 0) ACCEPT 101,J
	IF (KKK.EQ.7) 	TYPE 102,CUSKEY,CUSDBK
*	DBMS
	FIND NEXT RECORD OF SLSCUS-SET SET.
	IF (ERSTAT.NE.0307) ACCEPT 101,J
12	CONTINUE

*	DBMS
	CLOSE ALL.

	CALL STATS

101	FORMAT(I)
102	FORMAT (1X ,I8,2X,O12)
	END