C	Program DTORDR - Order Entry Sample Test Program
C	(offshoot of ORDENT.CBL)
C	Part of the UETP and verify test system for DBMS-20

C                     Copyright (C) 1984 by
C             Digital Equipment Corporation, Maynard, Mass.
C 
C      This software is furnished under a license, and may be used
C      or copied only in accordance with the terms of that license.

	PROGRAM DTORDR


C	CONVERSION FUNCTIONS
	CHARACTER CVT9*15,CVTD*10
	INTEGER GET9

C	INPUT RESPONSES
	CHARACTER RECTYP*6
	CHARACTER FUNCTN*8,FUNCOD*1
	EQUIVALENCE (FUNCTN(1:1),FUNCOD)
	CHARACTER REPLY*3,REPLYX*1
	EQUIVALENCE (REPLY(1:1),REPLYX)

C	DBKEY WORK VALUE
	INTEGER PKEY

C	ITEM WORK ITEMS
	INTEGER ITMLOR,ITMLNO

C	COUNTS
	INTEGER CUSTOT,ITMTOT,PURTOT

C	OLD STYLE TRANSACTION INDICES
	INTEGER CUSCNT,PRDCNT

*	DBMS
	INVOKE SUB-SCHEMA DTSSOF OF SCHEMA DTORD PRIVACY KEY FOR COMPILE
	IS ORDER1ENTRY-LOCK.

C	GENERAL INITS
1	CUSTOT=0
	ITMTOT=0
	PURTOT=0
	CUSCNT=1
	PRDCNT=1
	IDAREA='CUSAREA'

C	FIRST-START.
100	TYPE 105
105	FORMAT(' ENTER ''BEGIN'' TO START: ',$)
	ACCEPT 115,FUNCTN
115	FORMAT(A8)
	IF(FUNCOD.NE.'B')GO TO 100
	GO TO 1000

C	MAIN LOOP
C	START.
200	TYPE 205
205	FORMAT(' FUNCTIONS ARE: ENTER, CHANGE, INQUIRY, QUIT')

C	ACCEPT-FUNCTION.
210	TYPE 215
215	FORMAT(' ENTER FUNCTION: ',$)
	ACCEPT 115,FUNCTN
	IF(FUNCOD.EQ.'E')GO TO 2000
	IF(FUNCOD.EQ.'C')GO TO 4000
	IF(FUNCOD.EQ.'I')GO TO 5000
	IF(FUNCOD.EQ.'Q')GO TO 3000
	TYPE 225,FUNCTN
225	FORMAT(' %INVALID FUNCTION CODE: ',A8)
	GO TO 200


C	DATABASE INIT - ONE TIME INIT TO STORE INITIAL ORDER SUMMARY REC
C	BEGIN-ROUTINE.
*	DBMS
1000	OPEN AREA ORDAREA USAGE-MODE IS EXCLUSIVE UPDATE.
*	DBMS
	FIND FIRST ORDSUM RECORD OF ORDAREA AREA.
	IF(ERCNT.NE.0)GO TO 1010
*	DBMS
	CLOSE AREA ORDAREA.
	GO TO 200
1010	ORDSOR=0
	ORDSNO=CVT9(1,LEN(ORDSNO))
*	DBMS
	STORE ORDSUM.
*	DBMS
	CLOSE ALL.
	GO TO 200

C	ENTER FUNCTION
C	ENTER-ROUTINE.
*	DBMS
2000	OPEN ALL USAGE-MODE IS EXCLUSIVE UPDATE.
*	DBMS
	FIND FIRST ORDSUM RECORD OF ORDAREA AREA.
	IF(ERCNT.EQ.0)GO TO 2010
	TYPE 2005
2005	FORMAT(' %ORDER SUMMARY RECORD NOT FOUND',/,
	1 ' %ORDER ENTRY SYSTEM NOT INITIALIZED - KEY-IN BEGIN')
*	DBMS
	CLOSE ALL.
	GO TO 100
*	DBMS
2010	GET ORDSUM.

C	ENTER-TYPE
2020	CALL JRDATA(SYSCOM,34)
	CALL JRTEXT(' CHANGING ENTER MODES')
	TYPE 2025
2025	FORMAT(' RECORD TYPES ARE: PROD, SLSENG, CUSTOM, PURORD & ITEM')
	ACCEPT 2035,RECTYP
2035	FORMAT(A6)
	IF(RECTYP.EQ.' ')GO TO 2050
	IF(RECTYP.EQ.'PROD')GO TO 2060
	IF(RECTYP.EQ.'SLSENG')GO TO 2130
	IF(RECTYP.EQ.'CUSTOM') GO TO 2250
	IF(RECTYP.EQ.'PURORD') GO TO 2570
	IF(RECTYP.EQ.'ITEM')GO TO 2580
	TYPE 2045,RECTYP
2045	FORMAT(' %INVALID RECTYP: ',A6)
	GO TO 2020

C	ENTER-CLOSE
*	DBMS
2050	FIND FIRST ORDSUM RECORD OF ORDAREA AREA.
*	DBMS
	MODIFY ORDSUM; ORDSOR, ORDSNO.
*	DBMS
	CLOSE ALL.
	GO TO 210

C	ENTER-PROD
2060	CALL GETPRD(PRDNUM)
C	CHECK-PROD
	IF(PRDNUM.EQ.' ')GO TO 2020
	CALL JSTRAN('PROD',PRDCNT)
*	DBMS
	FIND PROD RECORD.
	IF(ERSTAT.EQ.326.OR.ERSTAT.EQ.307)GO TO 2090
	TYPE 2075,ERSTAT
2075	FORMAT(' ?ERROR-STATUS: ',I10)
	IF(ERCNT.EQ.0)TYPE 2085,PRDNUM
2085	FORMAT(' %PROD-NO: ',A8,' ALREADY EXISTS')
	CALL JETRAN('PROD',PRDCNT)
	PRDCNT=PRDCNT+1
	GO TO 2060

C	GET-PROD-INFO
2090	TYPE 2095
2095	FORMAT(' PROD DESC: ',$)
	ACCEPT 2105,PRDDSC
2105	FORMAT(A48)
	TYPE 2115
2115	FORMAT(' PRODUCT PRICE: ',$)
	ACCEPT 2125,INUM
2125	FORMAT(I6)
	PRDPRC=CVT9(INUM*100,LEN(PRDPRC))
	PRDTIM=CVT9(0,LEN(PRDTIM))
	PRDONH=CVT9(0,LEN(PRDONH))
	PRDINP=CVT9(0,LEN(PRDINP))
	PRDONO=CVT9(0,LEN(PRDONO))
	PRDINS=CVT9(0,LEN(PRDINS))
*	DBMS
	STORE PROD.
	CALL JETRAN('PROD',PRDCNT)
	PRDCNT=PRDCNT+1
	GO TO 2060

C	ENTER-SLSENG.
2130	CALL GETSLS(SLSNAM)
C	SLSENG-ACCEPTED.
	IF(SLSNAM.EQ.' ')GO TO 2020
*	DBMS
	FIND SLSENG RECORD.
	IF(ERSTAT.EQ.326 .OR. ERSTAT.EQ.307)GO TO 2160
	TYPE 2145,ERSTAT
2145	FORMAT(' ?ERROR-STATUS: ',I10)
	IF(ERCNT.EQ.0)TYPE 2155,SLSNAM
2155	FORMAT(' %SLSENG NAME: ',A30' ALREADY ON FILE')
	GO TO 2130

C	GET-SLSENG-INFO.
2160	TYPE 2165
2165	FORMAT(' SALES OFFICE: ',$)
	ACCEPT 2175,SLSOFF
2175	FORMAT(A24)
	TYPE 2185
2185	FORMAT(' PHONE - AREA CODE: ',$)
	ACCEPT 2195,SLSANO
2195	FORMAT(A3)
	TYPE 2205
2205	FORMAT(' PHONE NUMBER AS XXX-XXXX ',$)
	ACCEPT 2215,SLSPNO
2215	FORMAT(A8)
	TYPE 2225
2225	FORMAT(' EXTENSION: ',$)
	ACCEPT 2235,SLSEXT
2235	FORMAT(A4)
*	DBMS
	STORE SLSENG.
	IF(ERCNT.NE.0)TYPE 2245,ERSTAT
2245	FORMAT(' ?SLSENG NOT ENTERED - ERROR-STATUS: ',I10)
	GO TO 2130

C	ACCEPT-CUST-NAME
2250	CALL JSTRAN('CUSTOMER',CUSCNT)
	CALL GETCUS(CUSNAM)
      CALL JRTEXT ('THIS IS SUPPOSED TO BE A MULTI-BLOCK TEXT EXAMPLE, I
     * CERTAINLY HOPE THAT IT ACTUALLY IS LONG ENOUGH')
C	GOT-CUST-NAME.
*	DBMS
2270	FIND CUSTOM RECORD.
	IF(ERSTAT.EQ.326 .OR. ERSTAT.EQ.307)GO TO 2290
	TYPE 2275,ERSTAT
2275	FORMAT(' ?ERROR-STATUS: ',I10)
	IF(ERCNT.EQ.0)TYPE 2285,CUSNAM
2285	FORMAT(' %CUSTOMER-NAME: ',A30,'ALREADY EXISTS')
2287	CALL JETRAN('CUSTOMER',CUSCNT)
	CUSCNT=CUSCNT+1
	GO TO 2250

C	GET-CUST-INFO.
2290	TYPE 2295
2295	FORMAT(' STREET ADDRESS: ',$)
	ACCEPT 2305,STREET
2305	FORMAT(A36)
	TYPE 2315
2315	FORMAT(' CITY: ',$)
	ACCEPT 2325,CITY
2325	FORMAT(A34)
	TYPE 2335
2335	FORMAT(' STATE: ',$)
	ACCEPT 2345,STATE
2345	FORMAT(A14)
	TYPE 2355
2355	FORMAT(' ZIP: '$)
	ACCEPT 2365,ZIP
2365	FORMAT(A6)
*	DBMS
	STORE CUSTOM.
*	DBMS
	MOVE CURRENCY STATUS FOR RUN-UNIT TO PKEY.
	IF(ERCNT.EQ.0)GO TO 2380
	TYPE 2375,CUSNAM
2375	FORMAT(' ?CUSTOMER: ',A30,' NOT ENTERED')
	GO TO 2287
2380	CUSKEY=PKEY
	CUSTOT=CUSTOT+1

C	OBTAIN-SLSENG.
2390	TYPE 2385
2385	FORMAT(' SLSENG NAME (OR SPACE, IF NONE): ',$)
	ACCEPT 2395,SLSNAM
2395	FORMAT(A30)
	IF(SLSNAM.EQ.' ')GO TO 2440
*	DBMS
	FIND SLSENG RECORD.
	IF(ERCNT.EQ.0)GO TO 2420
	TYPE 2405,SLSNAM
2405	FORMAT(' %NO SLSENG OF THIS NAME ON FILE - 'A30)
	TYPE 2415,ERSTAT
2415	FORMAT(' ?ERROR-STATUS: ',I10)
	GO TO 2390
*	DBMS
2420	FIND CUSTOM RECORD.
*	DBMS
	INSERT CUSTOM INTO SLSCUS-SET.
	IF(ERCNT.EQ.0)GO TO 2440
	TYPE 2425
2425	FORMAT(' ?CUSTOM NOT ENTERED IN SLSCUS-SET')
	TYPE 2435,ERSTAT
2435	FORMAT(' ?ERROR-STATUS: ',I10)

C	OBTAIN-ORDNUM.
2440	CALL ASKORD(REPLY)
C	ORDNUM-REPLY.
	IF(REPLYX.EQ.'Y')GO TO 2460
	CALL JETRAN('CUSTOMER',CUSCNT)
	CUSCNT=CUSCNT+1
	GO TO 2020

C	GOT-ORDNUM
2460	ORDNUM=ORDSNO
*	DBMS
	FIND PURORD RECORD.
	IF(ERCNT.NE.0)GO TO 2470
	TYPE 2465,GET9(ORDNUM)
2465	FORMAT(' %ORDNUM: ',I6.6,'ALREADY EXISTS')
	GO TO 2570
2470	TYPE 2475,GET9(ORDSNO)
2475	FORMAT(' NEW ORDER NUMBER IS: ',I6.6)
	TYPE 2485
2485	FORMAT(' ORDER-DATE: ',$)
	ACCEPT 2495,ORDDAT
2495	FORMAT(A6)
	ORDNET=CVT9(0,LEN(ORDNET))
	ORDLIN=CVT9(0,LEN(ORDLIN))
*	DBMS
	STORE PURORD.
	IF(ERCNT.NE.0)GO TO 2500
	ORDSNO=CVT9(GET9(ORDSNO)+1,LEN(ORDSNO))
	ORDSOR=ORDSOR+1
	PURTOT=PURTOT+1
	ITMLOR=GET9(ORDNUM)
	ITMLNO=GET9(ORDLIN)
	GO TO 2520
2500	TYPE 2505,GET9(ORDNUM)
2505	FORMAT(' ?ORDER NUMBER: ',I6.6,'  NOT ENTERED')
	GO TO 2440

C	ENTER-ITEM-LINE.
2510	ORDLIN=CVT9(GET9(ORDLIN)+1,LEN(ORDLIN))
	ITMTOT=ITMTOT+1
	ORDNET=CVT9(GET9(ORDNET)+GET9(ITMNET),LEN(ORDNET))

C	ACCEPT-ITEM-LINE.
2520	TYPE 2525
2525	FORMAT(' PRODUCT NUMBER: ',$)
	ACCEPT 2535,ITMPRD
2535	FORMAT(A8)
	IF(ITMPRD.NE.' ')GO TO 2540
*	DBMS
	FIND PURORD RECORD.
*	DBMS
	MODIFY PURORD.
	CALL JETRAN('CUSTOMER',CUSCNT)
	CUSCNT=CUSCNT+1
	GO TO 2020
2540	ITMLNO=ITMLNO+1
	ITMLIN=CVT9(ITMLOR*1000+ITMLNO,LEN(ITMLIN))
	PRDNUM=ITMPRD
*	DBMS
	FIND PROD RECORD.
	IF(ERCNT.EQ.0)GO TO 2550
	TYPE 2545,ITMPRD
2545	FORMAT(' %INVALID PROD-NO: ',A8)
	GO TO 2520

C	GET-ITEM-INFO.
*	DBMS
2550	GET PROD.
	TYPE 2555
2555	FORMAT(' QUANTITY ORDERED: ',$)
	ACCEPT 2565,INUM
2565	FORMAT(I2)
	ITMQTY=CVT9(INUM,LEN(ITMQTY))
	ITMNET=CVT9(GET9(PRDPRC)*INUM,LEN(ITMNET))
	PRDONO=CVT9(GET9(PRDONO)+INUM,LEN(PRDONO))
*	DBMS
	MODIFY PROD; PRDONO.
*	DBMS
	STORE ITEM.
	GO TO 2510

C	ENTER-PURORD.
2570	CALL JSTRAN('CUSTOMER',CUSCNT)
	CALL GETCUS(CUSNAM)
      CALL JRTEXT ('THIS IS SUPPOSED TO BE A MULTI-BLOCK TEXT EXAMPLE, I
     * CERTAINLY HOPE THAT IT ACTUALLY IS LONG ENOUGH')
	IF(CUSNAM.NE.' ')GO TO 2572
	CALL JETRAN('CUSTOMER',CUSCNT)
	CUSCNT=CUSCNT+1
	GO TO 2020
*	DBMS
2572	FIND CUSTOM RECORD.
	IF(ERCNT.EQ.0)GO TO 2460
	TYPE 2575
2575	FORMAT(' %NO CUSTOMER OF THIS NAME ON FILE')
	CALL JETRAN('CUSTOMER',CUSCNT)
	CUSCNT=CUSCNT+1
	GO TO 2570

C	ENTER-ITEM.
2580	CALL JSTRAN('CUSTOMER',CUSCNT)
	CALL GETCUS(CUSNAM)
      CALL JRTEXT ('THIS IS SUPPOSED TO BE A MULTI-BLOCK TEXT EXAMPLE, I
     * CERTAINLY HOPE THAT IT ACTUALLY IS LONG ENOUGH')
	IF(CUSNAM.NE.' ')GO TO 2582
	CALL JETRAN('CUSTOMER',CUSCNT)
	CUSCNT=CUSCNT+1
	GO TO 2020
*	DBMS
2582	FIND CUSTOM RECORD.
	IF(ERCNT.EQ.0)GO TO 2590
	TYPE 2585
2585	FORMAT(' %NO CUSTOMER OF THIS NAME ON FILE')
	CALL JETRAN('CUSTOMER',CUSCNT)
	CUSCNT=CUSCNT+1
	GO TO 2580

C	ITEM-ACCEPT-ORDNUM.
2590	CALL GETORN(ORDNUM)
	IF(GET9(ORDNUM).NE.0)GO TO 2592
	CALL JETRAN('CUSTOMER',CUSCNT)
	CUSCNT=CUSCNT+1
	GO TO 2020
*	DBMS
2592	FIND PURORD RECORD.
	IF(ERCNT.NE.0)GO TO 2600
*	DBMS
	GET PURORD.
	GO TO 2520
2600	TYPE 2605
2605	FORMAT(' %ORDER NUMBER NOT IN DATA BASE')
	GO TO 2590

C	WRAPUP FUNCTION
3000	CONTINUE
C	TYPE 3005,CUSTOT
3005	FORMAT(' CUSTOM ENTRY COUNT: ',I10)
C	TYPE 3015,PURTOT
3015	FORMAT(' PURORD ENTRY COUNT: ',I10)
C	TYPE 3025,ITMTOT
3025	FORMAT(' ITEM ENTRY COUNT:   ',I10)
	TYPE 3035
3035	FORMAT(//,' THE FOLLOWING STATISTICS REPORT IS PRODUCED BY A ',
	1 'DBMS',/,' SUBROUTINE NAMED ''STATS'' WHICH MAY BE CALLED ',
	1 'AT ANY',/,' POINT IN A USER PROGRAM',//)
	CALL STATS
*	DBMS
	CLOSE RUN-UNIT.
	STOP

C	CHANGE FUNCTION - NOT IMPLEMENTED
4000	GO TO 210

C	INRUIRY FUNCTION
*	DBMS
5000	OPEN ALL USAGE-MODE IS RETRIEVAL.

C	INQUIRY-REQUEST.
5010	TYPE 5015
5015	FORMAT(' PROD, SLSENG, CUSTOM OR PURORD INQUIRY? ',$)
	ACCEPT 5025,RECTYP
5025	FORMAT(A6)
	IF(RECTYP.EQ.'PROD')GO TO 5040
	IF(RECTYP.EQ.'SLSENG')GO TO 5190
	IF(RECTYP.EQ.'CUSTOM') GO TO 5270
	IF(RECTYP.EQ.'PURORD')GO TO 5350
	IF(RECTYP.EQ.' ')GO TO 5370
	TYPE 5035,RECTYP
5035	FORMAT(' %INVALID INQUIRY TYPE - ',A6)
	GO TO 5010

C	INQUIRY-PROD.
5040	CALL GETPRD(PRDNUM)
	IF(PRDNUM.EQ.' ')GO TO 5010
*	DBMS
	FIND PROD RECORD.
	IF(ERCNT.NE.0)GO TO 5050
*	DBMS
	GET PROD.
	TYPE 5045,PRDNUM,PRDDSC,CVTD(PRDPRC),GET9(PRDONO)
5045	FORMAT(' PRDNUM:      ',A8,/,'   DESCR.      ',A48,/,
	1'   PRICE      ',A10,/,'   ON ORDER    ',I5.5,/)
	GO TO 5060
5050	TYPE 5055,PRDNUM
5055	FORMAT(' %PROD-NO: ',A8,' NOT IN DATA BASE')
	GO TO 5010

C	INQUIRY-PROD-ITEM.
5060	TYPE 5065
5065	FORMAT(' DISPLAY ORDER INFO FOR THIS PRDNUM? ',$)
	ACCEPT 5075,REPLY
5075	FORMAT(A3)
	IF(REPLYX.EQ.'Y')GO TO 5090
	IF(REPLYX.EQ.'N')GO TO 5010
	TYPE 5085
5085	FORMAT(' %YES OR NO PLEASE')
	GO TO 5060

C	INQUIRY-PROD-ITEM-PATH.
*	DBMS
5090	FIND NEXT ITEM RECORD OF PROD-ITEM-SET SET.
	IF(ERSTAT.NE.307)GO TO 5100
	TYPE 5095
5095	FORMAT(' NO PURORDS FOR THIS PRDNUM')
	GO TO 5010
5100	TYPE 5105
5105	FORMAT(' PURORD    LINE    QTY    CUSTOMER')
	GO TO 5120

C	INQUIRY-PROD-ITEM-NEXT.
*	DBMS
5110	FIND NEXT ITEM RECORD OF PROD-ITEM-SET SET.
	IF(ERSTAT.NE.307)GO TO 5120
	TYPE 5115
5115	FORMAT('  ')
	GO TO 5010

C	INQUIRY-GET-ITEM.
*	DBMS
5120	GET ITEM.
*	DBMS
	FIND OWNER RECORD OF ORDITM-SET SET.
	IF(ERCNT.EQ.0)GO TO 5140
	TYPE 5125
5125	FORMAT(' %PURORD NOT FOUND FOR THIS ITEM')
	TYPE 5135,ERSTAT
5135	FORMAT(' ?ERROR-STATUS: ',I10)
	GO TO 5110
*	DBMS
5140	GET PURORD.
*	DBMS
	FIND OWNER RECORD OF CUSORD-SET.
	IF(ERCNT.EQ.0)GO TO 5160
	TYPE 5145
5145	FORMAT(' %CUSTOM FOR THIS PURORD ITEM NOT FOUND')
	TYPE 5155,ERSTAT
5155	FORMAT(' ?ERROR-STATUS: ',I10)
	GO TO 5110
*	DBMS
5160	GET CUSTOM.
*	DBMS
	FIND OWNER RECORD OF SLSCUS-SET SET.
	IF(ERCNT.EQ.0)GO TO 5170
	SLSNAM='NONE'
	GO TO 5180
*	DBMS
5170	GET SLSENG.
5180	INUM=GET9(ITMLIN)
	ITMLNO=INUM-((INUM/1000)*1000)
	TYPE 5185,GET9(ORDNUM),ITMLNO,GET9(ITMQTY),CUSNAM
5185	FORMAT(' ',I6.6,4X,I3.3,5X,I2.2,5X,A30)
	GO TO 5110

C	INQUIRY-SLSENG.
5190	CALL GETSLS(SLSNAM)
	IF(SLSNAM.EQ.' ')GO TO 5010
*	DBMS
	FIND SLSENG RECORD.
	IF(ERCNT.NE.0)GO TO 5200
*	DBMS
	GET SLSENG.
	TYPE 5195,SLSNAM,SLSOFF,SLSANO,SLSPNO,SLSEXT
5195	FORMAT(' NAME:     ',A30,/,'   OFFICE: ',A24,/,
	1'    PHONE:  (',A3,')   ',A8,'   EXT: ',A4)
	GO TO 5210
5200	TYPE 5205,SLSNAM
5205	FORMAT(' %SLSENG: ',A30,' NOT IN DATA BASE')
	GO TO 5010

C	INQUIRY-SLSCUS.
5210	TYPE 5215
5215	FORMAT(' DISPLAY CUSTOMERS FOR THIS SLSENG? ',$)
	ACCEPT 5225,REPLY
5225	FORMAT(A3)
	IF(REPLYX.EQ.'Y')GO TO 5240
	IF(REPLYX.EQ.'N')GO TO 5010
	TYPE 5235
5235	FORMAT(' %YES OR NO PLEASE')
	GO TO 5210

C	INQUIRY-SLSCUS-PATH.
*	DBMS
5240	FIND NEXT CUSTOM RECORD OF SLSCUS-SET SET.
	IF(ERSTAT.NE.307)GO TO 5260
	TYPE 5245
5245	FORMAT(' NO CUSTOMERS FOR THIS SLSENG')
	GO TO 5010

C	INQUIRY-SLSCUS-NEXT.
*	DBMS
5250	FIND NEXT CUSTOM RECORD OF SLSCUS-SET SET.
	IF(ERSTAT.EQ.307)GO TO 5010

C	INQUIRY-GET-CUSTOM.
*	DBMS
5260	GET CUSTOM.
	TYPE 5265,CUSNAM,STREET,CITY,STATE,ZIP
5265	FORMAT(' NAME:   ',A30,/,'  ADDRESS: ',/,'   STREET: ',A36,/,
	1'   CITY:   ',A34,/,'   STATE:  ',A14,/,'   ZIP:    ',A6)
	GO TO 5250

C	INQUIRY-CUSTOM.
5270	CALL GETCUS(CUSNAM)
	IF(CUSNAM.EQ.' ')GO TO 5370
*	DBMS
	FIND CUSTOM RECORD.
	IF(ERCNT.NE.0)GO TO 5280
*	DBMS
	GET CUSTOM.
	TYPE 5275,CUSNAM,STREET,CITY,STATE,ZIP
5275	FORMAT(' NAME:   ',A30,/,'  ADDRESS: ',/,'   STREET: ',A36,/,
	1'   CITY:   ',A34,/,'   STATE:  ',A14,/,'   ZIP:    ',A6)
	GO TO 5290
5280	TYPE 5285,CUSNAM
5285	FORMAT(' %CUST-NAME:   ',A30,' NOT IN DATA BASE')
	GO TO 5010

C	INQUIRY-CUSORD.
5290	TYPE 5295
5295	FORMAT(' DISPLAY ORDER(S) FOR THIS CUSTOMER? ',$)
	ACCEPT 5305,REPLY
5305	FORMAT(A3)
	IF(REPLYX.EQ.'Y')GO TO 5320
	IF(REPLYX.EQ.'N')GO TO 5010
	TYPE 5315
5315	FORMAT(' %YES OR NO PLEASE!')
	GO TO 5290

C	INQUIRY-CUSORD-PATH.
*	DBMS
5320	FIND NEXT PURORD RECORD OF CUSORD-SET SET.
	IF(ERSTAT.NE.307)GO TO 5340
	TYPE 5325
5325	FORMAT(' NO ORDERS FOR THIS CUSTOMER')
	GO TO 5010

C	INQUIRY-CUSORD-NEXT.
*	DBMS
5330	FIND NEXT PURORD RECORD OF CUSORD-SET SET.
	IF(ERSTAT.EQ.307)GO TO 5010

C	INQUIRY-GET-PURORD.
*	DBMS
5340	GET PURORD.
	CALL PURDIS
	GO TO 5330

C	INQUIRY-PURORD.
5350	CALL GETORN(ORDNUM)
	IF(GET9(ORDNUM).EQ.0)GO TO 5010
*	DBMS
	FIND PURORD RECORD.
	IF(ERCNT.NE.0)GO TO 5360
*	DBMS
	GET PURORD.
	CALL PURDIS
	GO TO 5350
5360	TYPE 5365,GET9(ORDNUM)
5365	FORMAT(' %PURORD: ',I6.6,' IS NOT IN DATABASE')
	GO TO 5350

C	INQUIRY-END.
*	DBMS
5370	CLOSE ALL.
	GO TO 210
*	DBMS
	END	ORDENT.


	SUBROUTINE GETPRD(PRDNUM)
	CHARACTER PRDNUM*8
6000	TYPE 6005
6005	FORMAT(' KEY-IN PROD-NO: ',$)
	ACCEPT 6015,PRDNUM
6015	FORMAT(A8)
	RETURN
*	DBMS
	END	GETPRD.

	SUBROUTINE GETSLS(SLSNAM)
	CHARACTER SLSNAM*30
7000	TYPE 7005
7005	FORMAT(' KEY-IN SALESENG NAME :',$)
	ACCEPT 7015,SLSNAM
7015	FORMAT(A30)
	RETURN
*	DBMS
	END	GETSLS.

	SUBROUTINE GETCUS(CUSNAM)
	CHARACTER CUSNAM*30
8000	TYPE 8005
8005	FORMAT(' KEY-IN CUSTOMER NAME: ',$)
	ACCEPT 8015,CUSNAM
8015	FORMAT(A30)
	RETURN
*	DBMS
	END	GETCUS.

	SUBROUTINE GETORN(ORDNUM)
	CHARACTER ORDNUM*(*)
	CHARACTER CVT9*15
9000	TYPE 9005
9005	FORMAT(' ENTER ORDER-NUMBER: ',$)
	ACCEPT 9015,INUM
9015	FORMAT(I6)
	ORDNUM=CVT9(INUM,LEN(ORDNUM))
	RETURN
*	DBMS
	END	GETORN.

	SUBROUTINE ASKORD(REPLY)
	CHARACTER REPLY*3
10000	TYPE 10005
10005	FORMAT(' ANY ORDER TO BE ENTERED?  ',$)
	ACCEPT 10015,REPLY
10015	FORMAT(A3)
	RETURN
*	DBMS
	END	ASKORD.

	SUBROUTINE PURDIS
C	PURORD DISPLAY.

	INTEGER GET9
	CHARACTER CVTD*10
	CHARACTER REPLY*3,REPLYX*1
	EQUIVALENCE (REPLY(1:1),REPLYX)

*	DBMS
	ACCESS SUB-SCHEMA DTSSOF OF SCHEMA DTORD PRIVACY KEY FOR COMPILE
	IS ORDER1ENTRY-LOCK.

13000	TYPE 13005,GET9(ORDNUM),ORDDAT,GET9(ORDLIN),CVTD(ORDNET)
13005	FORMAT('   ORDER NUMBER: ',I6.6,/,'     ORDER DATE:   ',A6,/,
	1'     ORDER LINES:  ',I3.3,/,'     ORDER NET:    ',A10)

C	PURORD-DISPLAY-ITEMS.
13010	IF(GET9(ORDLIN).EQ.0)GO TO 13070
	TYPE 13015
13015	FORMAT(' DISPLAY ITEMS IN THIS ORDER? ',$)
	ACCEPT 13025,REPLY
13025	FORMAT(A3)
	IF(REPLYX.EQ.'Y')GO TO 13040
	IF(REPLYX.EQ.'N')GO TO 13070
	TYPE 13035
13035	FORMAT(' %YES OR NO PLEASE')
	GO TO 13010

C	INQUIRY-ITEM-PATH.
13040	TYPE 13045
13045	FORMAT('      PROD-NO.    QTY.    NET')

C	INQUIRY-ITEM-FIND.
*	DBMS
13050	FIND NEXT ITEM RECORD OF ORDITM-SET SET.
	IF(ERSTAT.EQ.307)GO TO 13070
	IF(ERCNT.EQ.0)GO TO 13060
	TYPE 13055,ERSTAT
13055	FORMAT(' ?ERROR-STATUS: ',I10)
	GO TO 13070
*	DBMS
13060	GET ITEM.
	TYPE 13065,ITMPRD,GET9(ITMQTY),CVTD(ITMNET)
13065	FORMAT('      ',A8,'    ',I2.2,'      ',A10)
	GO TO 13050
13070	RETURN
*	DBMS
	END	PURDIS.

	CHARACTER *15 FUNCTION CVT9(NUM,LENS)
	CHARACTER NUMSTR*10
	DATA NUMSTR/'0123456789'/
11000	INUM=NUM
	DO 11010 I=LENS,1,-1
	J=(INUM-((INUM/10)*10))+1
	INUM=INUM/10
11010	CVT9(I:I)=NUMSTR(J:J)
	RETURN
*	DBMS
	END	CVT9.

	INTEGER FUNCTION GET9(SRC)
	CHARACTER SRC*(*),NUMSTR*10
	DATA NUMSTR/'0123456789'/
12000	LENS=LEN(SRC)
	GET9=0
	DO 12010 I=1,LENS
	J=INDEX(NUMSTR,SRC(I:I))-1
12010	GET9=GET9*10+J
	RETURN
*	DBMS
	END	GET9.

	CHARACTER *10 FUNCTION CVTD(VAL)
	CHARACTER VAL*(*)
14000	LENS=LEN(VAL)
	J=10
	CVTD='          '
	DO 14020 I=LENS,1,-1
	CVTD(J:J)=VAL(I:I)
	IF(J.NE.9)GO TO 14010
	J=J-1
	CVTD(J:J)='.'
14010	J=J-1
14020	CONTINUE
	RETURN
*	DBMS
	END	CVTD.