         PROC  ,,IMSDISC=IMSPAC,NET=NETIMS6,LIB=$Y$SRC,LOAD=VSBST6,    X
         COM=IMS6,KCYL=(15),KNBLK=(3072,50),KLBLN=NAMEREC6,THR=ST,     X
         KJCS=(ALL),BEGIN=VSB01,END=VSB07,ALTER=NO
IMSVSB   NAME
// DVC 20   // LFD PRNTR
//  IF  ('&BEGIN' EQ 'VSB01')VSB01
//  IF  ('&BEGIN' EQ 'VSB02')VSB02
//  IF  ('&BEGIN' EQ 'VSB03')VSB03
//  IF  ('&BEGIN' EQ 'VSB04')VSB04
//  IF  ('&BEGIN' EQ 'VSB05')VSB05
//  IF  ('&BEGIN' EQ 'VSB06')VSB06
//  IF  ('&BEGIN' EQ 'VSB07')VSB07
//VSB01  NOP
// OPR ' <<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '
// OPR 'IMSVSB01 SINGLE OR MULTI THREAD CONFIGURATION '
// OPR ' <<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '
// DVC 50 // VOL &IMSDISC // LBL TCIDTF // LFD YYY // SCR YYY
// DVC 50 // VOL &IMSDISC
// EXT ST,C,,CYL,10
// LBL TCIDTF // LFD TCIDTF
//  IMSCONF &IMSDISC,,,,&NET,&LIB,INIT=SCRINT,CYL=&KCYL,               X
//1 LBLN=&KLBLN,CCA=&COM,LOADM=&LOAD,ZCNF=&THR,NBLK=&KNBLK,            X
//2 CNFJCS=&KJCS,ALTER=&ALTER
// IF ('&END' EQ 'VSB01')VSBEND
//VSB02  NOP
// OPR ' <<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '
// OPR ' IMSVSB02 - CREATE USER DATA FILE '
// OPR ' <<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '
//  DVC RES // LBL $Y$OBJ // LFD IMSOBJ
//  OPTION  SYSDUMP
// WORK1 BLK=4000
// WORK2 BLK=4000
// EXEC ASM
// PARAM LST=NC
//  PARAM  OUT=IMSOBJ
/$
         TITLE 'CUSTOMER FILE LOAD'
         MACRO
         EQUREGS
         LCLA  &A
&A       SETA  0
.TOP     ANOP
R&A.$    EQU   &A
&A       SETA  &A+1
         AIF   (&A EQ 17).DONE
         AGO   .TOP
.DONE    ANOP
RA$      EQU   10
RB$      EQU   11
RC$      EQU   12
RD$      EQU   13
RE$      EQU   14
RF$      EQU   15
         MEND
CUSFIL   START 0
         EQUREGS
         PRINT GEN
         BALR  RB$,0
         USING *,RB$
         LA    RD$,REGAREA
         OPEN  ZL#CUST
         SETFL ZL#CUST
         GETCS CRDBUF                   PASS FIRST CARD
CRDRED   GETCS CRDBUF
         LH    RA$,CRDBUF               CHECK FOR LAST CARD
         CH    RA$,SLHAMP
         BC    8,FINISH                 THE LAST CARD
         MVC   BUFOUT(60),CRDBUF        CUST ID, NAME, ETC TO OUTPUT
         PACK  BUFOUT+60(6),CRDBUF+60(6) BALANCE DUE TO OUTPUT
         PACK  BUFOUT+66(6),CRDBUF+66(6) VALUE DUE-IN TO OUTPUT
         MVC   BUFOUT+72(8),CRDBUF+72    YTD VOLUME
         WRITE ZL#CUST,NEWKEY
         B     CRDRED
FINISH   ENDFL ZL#CUST
         CLOSE ZL#CUST
         EOJ
PROBLM   SNAP  ZL#CUSTC,ZL#CUSTC+3
         SNAP  BUFOUT,BUFOUT+80
         DUMP
ZL#CUST  DTFIS IORT=LOAD,ERRO=PROBLM,INDA=INDX,INDS=256,BLKSIZE=767,   X
               IOA1=CUSTFL,KLEN=5,KLOC=1,PCYL=30,RCFM=FIXBLK,RCSZ=80,  X
               SAVE=REGAREA,WRK1=BUFOUT
CUSTFL   DS    768C
INDX     DS    256C
         CNOP  0,8
BUFOUT   DS    80C
CRDBUF   DS    80C
REGAREA  DS    18A
SLHAMP   DC    CL2'/*'
/*
//  DVC RES // LBL $Y$OBJ // LFD IMSOBJ
// WORK1
// EXEC LNKEDT
//  PARAM  OUT=$Y$LOD                                                   STI01060
/$
   LOADM ZL#CUS
         INCLUDE  CUSFIL,IMSOBJ
/*
// DVC 50 // VOL &IMSDISC // LBL CUSTOMER // LFD ZZZ // SCR ZZZ
// DVC 50 // VOL &IMSDISC // EXT IS,C,,CYL,5  // LBL CUSTOMER
// LFD ZL#CUST,,INIT
// EXEC ZL#CUS,$Y$LOD
/$
 BR8TLBRANNON'S BAR      86 TUMBLE LA.  PEMBROKE, PA.  16513000000000000
 CA1ESCARRIAGE TAVERN    137 ELM ST     POPULAR, N.J.  08613000000000000
 CL3MDCLOVER LEAF        35 MEADOW DR.  PASTURE, PA.   16161000000000000
 CR6HACREST PUB          6 HIGHLAND AVE CREST CITY, PA 16331000000000000
 CU1BACUMBERLAND CLUB    111 BAY AVE.   PORTSIDE, N.J. 08131000000000000
 DE1NSDEW DROP INN       13 NITEFALL ST LIGHTHOUSE, PA 16217007625000000
 FAILAFARRAH'S DEN       16 LION ALLEY  HILLSIDE, PA   16314000000000000
 HA6FRHANOVER HOUSE      66 FOUNTAIN RD GRAFTON, N.J.  08124000000000000
 JO2WCJOCKEYS JOINT      20 WINNER CIR. STRAITAWAY, PA 16519000000000000
 LA7HBLAST CHANCE SALOON 72 HOPE BLVD.  GOINGVILLE, PA 16111000000000000
 LO2BRLOGAN LIQUORS      21 BARREL ROAD POTTSBURG, PA. 16420000000000000
 LO2SCLOST CLIPPER       25 SAIL CIRCLE HARBOR, N.J.   08304000000000000
 PE1PSPERRY'S PUB        162 PLANK ST.  PERRYVILLE, PA 16212000000000000
 RE1BARED LANTERN        15 BACK ALLEY  LEGALTOWN, N.J 08412007535000000
 RI4CLRITTER'S ROOST     46 CHICKEN LA. BARNYARD, PA.  16013000000000000
 RO1CSROYAL NIGHTCLUB    147 CASTLE ST. BLUEBLOOD, PA. 16310008960000000
 SH1CASHAMROCK PALACE    121 CLANCY AVE IRISHTOWN, PA. 16225000000000000
 SU5MHSUPPER CLUB        57 MAIN HWY.   OVERTON, N.J.  08015000000000000
 TO1FRTOWNHOUSE CAFE     19 FRENCH RD.  SPURNBURG, PA. 16611000000000000
 TR2HSTRYTON TOWER       238 HIGH ST.   TINKERTOWN, PA 16663002583000000
 WO9BLWOODEN NICKEL      93 BUFFALO LA. MINTBURG, PA.  16621000000000000
 YD1RAYOUR DEMISE        100 REST AVE.  BOOTHILL, MD.  10640000000000000
/*
// IF ('&END' EQ 'VSB02')VSBEND
//VSB03  NOP
// OPR ' <<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '
// OPR ' IMSVSB03 - CREATE CUSTOMR DATA DEFINITION ON NAMEREC FILE '
// OPR ' <<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '
// DVC 20      // LFD PRNTR
// OPTION DUMP
// DVC 50 // VOL &IMSDISC  // LBL &KLBLN  // LFD ISAMNRF
// WORK1
// WORK2
// WORK3
// EXEC DT3DF
/$
       IDENTIFICATION DIVISION.
       PROGRAM-ID. CUSTOMER-FILE.
       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       SOURCE-COMPUTER. UNIVAC-9700.
       OBJECT-COMPUTER. UNIVAC-9700.
       DATA DIVISION.
       FILE SECTION.
       FD  CUSTFIL.
       01 CUSTOMER-RECORD.
      *  ISAM CUSTOMER FILE
      *  LBL CUSTOMER  FIXED-LENGTH BLOCKED
      *  RECORD SIZE=80   BLOCK SIZE=767
      *  KEYLENGTH=5  KEYLOC=1
      *
           05  FILLER              PIC X.
           05  CUST-ID                  PIC X(5).
           05  NAME                     PIC X(19).
           05  ADDRESS                  PIC X(15).
           05  CITY-STATE               PIC X(15).
           05  ZIP-CODE                 PIC X(5).
           05  FILLER                   PIC X(2).
           05  BALANCE-DUE              PIC S9(5)V99 COMP-3.
           05  FILLER                   PIC X(2).
           05  DUE-IN-VALUE             PIC S9(5)V99 COMP-3.
           05  YTD-VOLUME               PIC 9(6)V99.
       DEFINITION DIVISION.
       DEFINED FILE CUSTOMR PASSWORD.
       DEFINED RECORD CUSTOMR
           FROM CUSTOMER-RECORD;
           IDENTIFIER CUST-ID;
           ITEM NAME;
           ITEM ADDRESS;
           ITEM CITY-STATE;
           ITEM ZIP FROM ZIP-CODE;
           ITEM BALANCE-DUE;
           ITEM DUE-IN-VALUE;
           ITEM YTD-VOLUME.
/*
// IF ('&END' EQ 'VSB03')VSBEND
//VSB04  NOP
// OPR ' <<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '
// OPR ' IMSVSB04 - CREATE UPDATE1 DATA DEFINITION '
// OPR ' <<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '
// DVC 20      // LFD PRNTR
// OPTION DUMP
// DVC 50 // VOL &IMSDISC  // LBL &KLBLN  // LFD ISAMNRF
// WORK1
// WORK2
// WORK3
// EXEC DT3DF
/$
       IDENTIFICATION DIVISION.
       PROGRAM-ID. SGDEF9.
       REMARKS. CUSTFIL AND CATALOG ADD,DELETE, AND CHANGES TEST.
       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       SOURCE-COMPUTER. UNIVAC-9700.
       OBJECT-COMPUTER. UNIVAC-9700.
       DATA DIVISION.
       FILE SECTION.
       FD  CUSTFIL.
       01  CUST-RECORD.
      *  ISAM CUSTOMER FILE
      *  LBL CUSTOMER  FIXED-LENGTH BLOCKED
      *  RECORD SIZE=80   BLOCK SIZE=767
      *  KEYLENGTH=5  KEYLOC=1
      *
           05  FILLER              PIC X.
           05  CUST-ID                  PIC X(5).
           05  NAME                     PIC X(19).
           05  ADDRESS                  PIC X(15).
           05  CITY-STATE               PIC X(15).
           05  ZIP-CODE                 PIC X(5).
           05  FILLER                   PIC X(2).
           05  BALANCE-DUE              PIC S9(5)V99 COMP-3.
           05  FILLER                   PIC X(2).
           05  DUE-IN-VALUE             PIC S9(5)V99 COMP-3.
           05  YTD-VOLUME               PIC 9(6)V99.
       DEFINITION DIVISION.
       DEFINED FILE UPDATE1 PASSWORD
       DEFINED RECORD UPDATE-CUSTFIL
           FROM CUST-RECORD.
           ALLOW ADD AND DELETE OF RECORD
           IDENTIFIER CUST-ID
           VALUES ARE 'AA0AA' THROUGH 'ZZ9ZZ'
           ITEM NAME MUST ADD
           ITEM ADDR FROM ADDRESS
           ITEM CITY-STATE
           ITEM ZIP FROM ZIP-CODE MUST ADD
           VALUE IS 00000 THRU 55555, 55556 THRU 99999
           ITEM BALANCE-DUE ALLOW CHANGE
           ITEM DUE-IN-VALUE ALLOW CHANGE
           ITEM YTD-VOL FROM YTD-VOLUME
/*
// IF ('&END' EQ 'VSB04')VSBEND
//VSB05  NOP
// OPR ' <<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '
// OPR ' IMSVSB05 - CREATE USER COPY LIBRARY '
// OPR ' <<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '
// DVC 20      // LFD PRNTR
// DVC  RES // LBL  $Y$SRC // LFD  LIB0
// EXEC LIBS
/$
         FIL   D0=LIB0
         ELE.D D0,S,DICE
      *01  DICE COPY DICE.   *         *         *         *         *
      *    DICE SPECIAL CHARACTERS RLSE 1.5 CYCLE-1.
      *                                                              *
      *    FRMS CNTRL & CLR-CURS TO RW-Y CL-X & CLR SCRN X'10030201'.
           02  CURS-COORD.
               03  DICE-1               PIC X(2) VALUE ''.
               03  ROW-Y1               PIC X(1) VALUE ''.
               03  COL-X1               PIC X(1) VALUE ''.
      *
      *    POSIT CONTROL  NEW LINE X'10040000'.
       77  CR                          PIC X(4) VALUE '   '.
      *
      *    SET COORD-CURSOR TO HOME X'10010000'.
       77  CURS-HME                    PIC X(4) VALUE '  '.
      *    POSIT CNTRL & CLR-CLEAR TO END OF LINE & NEW LINE X'10050000'
       77  CLR-LINE                    PIC X(4) VALUE '	  '.
      *    APPENDING CODE FOR  U100 COP X'12'                        *
       77  DC2                          PIC X(1) VALUE ''.
      *    START OF ENTRY CHARACTER SOE  X'1E'                       *
       77  SOE                          PIC X(1) VALUE ''.
      *            *         *         *         *         *         *
         EOD
/*
// IF ('&END' EQ 'VSB05')VSBEND
//VSB06  NOP
// OPR ' <<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '
// OPR ' IMSVSB06 - CREATE ALTERNATE PASSWORDS '
// OPR ' <<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '
// DVC 20 // LFD PRNTR
// OPTION DUMP
// DVC 50 // VOL &IMSDISC  // LBL &KLBLN  // LFD ISAMNRF
// WORK1 BLK=4000
// WORK2 BLK=4000
// EXEC ZP#NRU
/$
PASSWORD       PID=CUST184,                                            X00000001
               DDN=CUSTOMR,                                            X00000002
               FN=CUSTOMR,                                             X00000003
               TID=TRM1                                                 00000004
PASSWORD       PID=CUST183,                                            X00000005
               DDN=CUSTOMR,                                            X00000006
               FN=CUSTOMR,                                             X00000007
               TID=TRM1                                                 00000008
PASSWORD       PID=CUST185,                                            X00000009
               DDN=CUSTOMR,                                            X00000010
               FN=CUSTOMR,                                             X00000011
               TID=TRM1                                                 00000012
/*
// IF ('&END' EQ 'VSB06')VSBEND
//VSB07  NOP
// OPR ' <<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '
// OPR ' IMSVSB07 - COMPILE AND LINK ACTION PROGRAM - DISP '
// OPR ' <<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> '
// DVC 20      // LFD PRNTR
// WORK1 BLK=4000
// WORK2 BLK=4000
// WORK3 BLK=4000
// DVC  RES // LBL  $Y$SRC // LFD  LIB1
// EXEC COBOL
// PARAM LST=(C,L,O,S)
// PARAM LIN=LIB1
/$
       IDENTIFICATION DIVISION.
       PROGRAM-ID. DISP.
       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       SOURCE-COMPUTER. UNIVAC-9030.
       OBJECT-COMPUTER. UNIVAC-9030.
       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  DICE COPY DICE.
       77  WORKP                       PIC 9(6)V99  COMP-3.
       77  CUSTFIL           PIC X(7) VALUE 'CUSTFIL'.
       77  TEXT-1  PIC X(32) VALUE 'PROCESSING ERROR, STATUS CODE = '.
       77  TEXT-2  PIC X(23) VALUE 'DETAILED STATUS CODE = '.
       01  CUSHDR1.
           02  CUSHD1   PIC A(6)  VALUE ' CODE '.
           02  CUSHD2   PIC A(20) VALUE 'CUSTOMER NAME       '.
           02  CUSHD3   PIC A(15) VALUE 'ADDRESS        '.
           02  CUSHD4   PIC A(15) VALUE 'CITY-STATE     '.
           02  CUSHD5   PIC A(5)  VALUE 'ZIP  '.
       01  CUSHDR2.
           02  CUSHD6   PIC A(15) VALUE '   BALANCE-DUE '.
           02  CUSHD7   PIC A(15) VALUE '       DUE-IN  '.
           02  CUSHD8   PIC A(15) VALUE ' YR-TO-DATE VOL'.
       LINKAGE SECTION.
       01  PROGRAM-INFORMATION-BLOCK COPY PIB.
       01  INPUT-MESSAGE-AREA COPY IMA.
           02  FILLER              PIC X(4).
           02  TRANSAC-CDE   PIC X(4).
           02  FILLER        PIC X.
           02  FILE-REQ      PIC A(7).
           02  FILLER        PIC X.
           02  REC-KEY       PIC X(5).
           02  REC-NO REDEFINES REC-KEY  PIC 9(5).
       01  WORK-AREA.
           02  CUS-REC.
               03  DEL-CODE        PIC X.
               03  CDE            PIC X(5).
               03  NAME            PIC X(19).
               03  ADDR           PIC X(15).
               03  CTY-STE        PIC X(15).
               03  ZIP            PIC 9(5).
               03  BLNCE-DUE      PIC S9(9)V99    COMP-3.
               03  DUE-IN         PIC S9(9)V99  COMP-3.
               03  YTD-VOL        PIC 9(6)V99.
           02  ERROR-MSGE.
               03  TXT-1     PIC X(32).
               03  STAT      PIC 9(4).
               03  TXT-2     PIC X(23).
               03  DSTAT     PIC 9(4).
           02  REC-COMP      PIC 9(10) COMP-4 SYNC RIGHT.
       01  OUTPUT-MESSAGE-AREA COPY OMA.
           02  LINE-0        PIC X(4).
           02  LINE-1        PIC X(64).
           02  CR-1          PIC X(4).
           02  LINE-2.
               03  CDE       PIC X(5).
               03  FILLER    PIC X.
               03  NAME      PIC X(19).
               03  ADDR      PIC X(15).
               03  CTY-STE   PIC X(15).
               03  ZIP       PIC X(10).
           02  CR-2          PIC X(4).
           02  LINE-3        PIC X(45).
           02  CR-3          PIC X(4).
           02  LINE-4.
               03  FILLER    PIC X.
               03  OUT-BAL   PIC ZZZ,ZZZ,ZZ9.99.
               03  FILLER    PIC X(5).
               03  OUT-DUE   PIC ZZZ,ZZZ,ZZZ.99.
               03  FILLER    PIC X(5).
               03  OUT-VOL   PIC   ZZZ,ZZZ.99.
           02  CR-4          PIC X(4).
           02  LINE-13       PIC X(4).
       PROCEDURE DIVISION USING PROGRAM-INFORMATION-BLOCK
           INPUT-MESSAGE-AREA WORK-AREA OUTPUT-MESSAGE-AREA.
       STRT-CDE-SECT.
           MOVE CURS-COORD TO LINE-0.
           MOVE CURS-HME TO LINE-13.
           MOVE CR      TO CR-1, CR-2, CR-3, CR-4.
       CUSTOMR-FILE-SECT.
           ENTER LINKAGE.
           CALL 'GET' USING CUSTFIL CUS-REC REC-KEY.
           ENTER COBOL.
           IF STATUS-CODE IS NOT = 0 GO TO PROCESS-ERROR.
           MOVE CUSHDR1 TO LINE-1.
           MOVE CORR CUS-REC TO LINE-2.
           MOVE CUSHDR2  TO LINE-3.
           MOVE BLNCE-DUE TO OUT-BAL.
           MOVE DUE-IN       TO OUT-DUE.
           MOVE YTD-VOL TO WORKP.
           MOVE WORKP TO OUT-VOL.
       NORMAL-TERM.
           ENTER LINKAGE.
           CALL 'RETURN'.
           ENTER COBOL.
       PROCESS-ERROR.
           MOVE TEXT-1 TO TXT-1.
           MOVE STATUS-CODE TO STAT.
           MOVE TEXT-2 TO TXT-2.
           MOVE DETAILED-STATUS-CODE TO DSTAT.
           MOVE ERROR-MSGE TO LINE-1.
           MOVE FILE-REQ TO NAME OF LINE-2.
           MOVE REC-KEY TO ADDR OF LINE-2.
           MOVE REC-COMP TO ZIP OF LINE-2.
           GO TO NORMAL-TERM.
/*
// DVC  RES // LBL  $Y$LOD // LFD  LIB1
// WORK1
// EXEC LNKEDT
// PARAM OUT=LIB1
/$
     LOADM   DISP
         INCLUDE DISP0000
         INCLUDE ZF#LINK,$Y$OBJ
         ENTER DISP
/*
//VSBEND  END
