Trailing-Edge
-
PDP-10 Archives
-
BB-4148F-BM_1984
-
uetp/dtordr.fml
There is 1 other file named dtordr.fml in the archive. Click here to see a list.
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.