FTN4 PROGRAM R2026(3),92080-16582 REV.2026 800205 C C NAME: R2026 C SOURCE: &R2026 92080-18582 C RELOC: %R2026 92080-16582 C C *************************************************************************** C * * C * THIS PROGRAM TAKES A 1936 VERSION DATACAP TRANSACTION AND REFORMATS THE * C * BUFFERS INTO A 2026 FORMAT. THE BINARY SECTION IS ONLY REFORMATTED TO * C * LOOK LIKE A 2026 TRANSACTION, BUT IN FACT SHOULD NOT BE EXECUTED. THE * C * TRANSACTIONS COMING OUT OF THIS PROGRAM SHOULD BE PASSED THROUGH 2026 * C * TGP IN MODIFY MODE TO RECREATE LEGITIMATE BINARIES. IT MAY BE NECESSARY* C * TO ADD INFORMATION DURING THE MODIFY, AS IS THE CASE WITH DATA BASE * C * ITEMS. AT THE END OF THE MODIFY IT WILL BE NECESSARY TO SPECIFY A NEW * C * LIBRARY OR TO CHANGE THE TRANSACTION NAME/NUMBER TO AVOID DUPLICATION. * C * * C * TO EXECUTE ENTER: 1) RU,R2026,P1,P2,P3 * C * P1: LOG LU * C * P2: NAMR OF LIBRARY TO BE REVISED * C * P3: NAMR OF NEW LIBRARY CREATED (VALID SOURCE) * C * * C * OR: 2) RU,R2026 * C * IN THIS CASE THE LOG/INPUT DEVICE WILL BE THE * C * TERMINAL RUN FROM. BOTH NAMRS WILL BE PROMPTED * C * FOR INTERACTIVELY. * C * * C * IN EITHER CASE, A LOG OF THE TRANSACTION NAMES OF * C * REVISED TRANSACTIONS WILL BE GIVEN. * C * * C *************************************************************************** C C DIMENSION IDCBO(144),IPARM(5),IDCBI(144), . IBUFI(127),IBUFO(127),ISIZE(2),IREG(2),INAME(3), . IBUFF(24),IPBUF(10) EQUIVALENCE (REG,IREG,IA),(IREG(2),IB) INTEGER PTR,PTR1 DATA IBLAN/2H / CALL RMPAR(IPARM) LU=IPARM(1) IF(LU.EQ.0) LU=1 ILU=IOR(LU,400B) ITYP36=36 ISIZE(1)=128 ISIZE(2)=127 C C OLD LIBRARY NAME C CALL BLAN(IBUFF,1,48) CALL EXEC(14,1,IBUFF,-48) IF(IGET1(IBUFF,12).EQ.1H .OR.IGET1(IBUFF,13).EQ.1H ) GO TO 200 DO 98 I=10,12 ITMP=IGET1(IBUFF,I) IF(ITMP.NE.1H,) GO TO 98 ISTRT=I+1 GO TO 99 98 CONTINUE 99 DO 100 I=ISTRT,ISTRT+18 ITMP=IGET1(IBUFF,I) IF(ITMP.NE.1H,) GO TO 100 LEN=I-1 GO TO 101 100 CONTINUE 200 WRITE(LU,1) 1 FORMAT(" ENTER NAMR OF LIBRARY TO BE REV'D UP") REG=EXEC(1,ILU,IBUFF,-20) CALL BLAN(IBUFF,IB+1,20-IB) ISTRT=1 LEN=20 101 CALL NAMR(IPBUF,IBUFF,LEN,ISTRT) C C OPEN THE FILE C CALL OPEN(IDCBI,IERR,IPBUF,0,IPBUF(5),IPBUF(6)) IF(IERR.GT.0) GO TO 3 WRITE(LU,2) IERR 2 FORMAT("ORIGINAL LIBRARY FILE COULD NOT BE OPENED IERR= ",I3) GO TO 42 C C NEW LIBRARY NAME C 3 IF(IGET1(IBUFF,12).EQ.1H .OR.IGET1(IBUFF,13).EQ.1H ) GO TO 201 ISTRT=LEN+2 DO 102 I=ISTRT,ISTRT+18 ITMP=IGET1(IBUFF,I) IF(ITMP.NE.1H ) GO TO 102 LEN=I-1 GO TO 103 102 CONTINUE 201 WRITE(LU,4) 4 FORMAT(" ENTER NAMR OF LIBRARY TO BE CREATED") REG=EXEC(1,ILU,IBUFF,-20) CALL BLAN(IBUFF,IB+1,20-IB) ISTRT=1 LEN=20 103 CALL NAMR(IPBUF,IBUFF,LEN,ISTRT) CALL OPEN(IDCBO,IERR,IPBUF,0,35,IPBUF(6)) C C TRY TO OPEN FILE C IF(IERR.EQ.-6) GO TO 6 WRITE(LU,5) IERR 5 FORMAT("NEW LIBRARY NAME ALREADY EXISTS ABT ",I3) GO TO 40 6 CALL CREAT(IDCBO,IERR,IPBUF,ISIZE,ITYP36,35,IPBUF(6),IDCBSO) IF(IERR.GE.0) GO TO 7 WRITE(LU,55)IERR 55 FORMAT("UNABLE TO CREATE NEW LIBRARY - ABORT ",I3) GO TO 40 C C READ THE LIBRARY HEADER C 7 CALL READF(IDCBI,IERR,IBUFI,127,LEN) IF(LEN.NE.15) GO TO 50 IF(IERR.GE.0) GO TO 9 50 WRITE(LU,8) IERR 8 FORMAT("ERROR IN READING HEADER RECORD ",I3) GO TO 38 C C WRITE NEW LIB HEADER C 9 CALL WRITF(IDCBO,IERR,IBUFI,15) IF(IERR.GE.0) GO TO 11 WRITE(LU,10) IERR 10 FORMAT("UNABLE TO WRITE NEW LIB HEADER ",I3) GO TO 38 C C READ THE BINARY SECTION C 11 CALL READF(IDCBI,IERR,IBUFI,127,LEN) IF(LEN.EQ.-1) GO TO 38 IF(LEN.NE.12) GO TO 12 IF(IERR.GE.0) GO TO 14 12 WRITE(LU,13) IERR 13 FORMAT("UNABLE TO READ LEGITIMATE 1936 BINARY REC #1 IERR= ",I3) GO TO 38 14 COUNT=IBUFI(1) DO 15 I=1,12 PTR=I+1 15 IBUFO(I)=IBUFI(I) COUNT=COUNT-12 23 IF(COUNT.GT.0) GO TO 16 COUNT=0 PTR=PTR-1 GO TO 19 16 CALL READF(IDCBI,IERR,IBUFI,127,LEN) IF(IERR.GE.0) GO TO 18 WRITE(LU,17) IERR 17 FORMAT("BAD BINARY READ ",I3) GO TO 38 18 IBUFO(PTR)=IBUFI(1) 19 CALL WRITF(IDCBO,IERR,IBUFO,PTR) IF(IERR.GE.O) GO TO 21 WRITE(LU,20) IERR 20 FORMAT("UNABLE TO WRITE BINARY REC ",I3) 21 IF(COUNT.EQ.0.OR.COUNT.EQ.1) GO TO 59 MAX=COUNT-1 IF(MAX.GT.126) MAX=126 DO 22 I=1,MAX PTR=I+1 22 IBUFO(I)=IBUFI(PTR) COUNT=COUNT-127 GO TO 23 C C END OF BINARY MOVE SECTION C C THIS SECTION REFORMATS IFORM. IN 1936 IFORM WAS 772 WORDS C LONG. THE 2026 PCO CALLS FOR IFORM TO BE 780 WORDS LONG. C WITHIN THE ORIGINAL 772 WORDS NOTHING HAS CHANGED. WORDS C 773-780 ARE AS FOLLOWS... C C WORD # LEFT BYTE RIGHT BYTE C C 773 AUTO-COMPLETING? (X) LIGHT # TO - C 774 -STAY LIT (0-14) MAGSTRIPE NEEDED? (X) C 775 BAR CODE NEEDED? (X) CRT NEEDED? (X) C 776-780 ------------------SPARE---------------------- C C 780/127=6+18/127. THIS MEANS THAT 6 RECORDS CAN READ/WRITTEN. C RECORD 7 OF 1936 CAN BE READ BUT THE ADDITION OF THE 8 WORDS C MUST BE MADE TO THE 2026 VERSION. THIS ADDITION IS IN THE FORM C OF WORDS 11-18 OF THE 7TH RECORD BEING WRITTEN OUT AS BLANKS. C 59 DO 26 I=1,6 CALL READF(IDCBI,IERR,IBUFI,127,LEN) IF(IERR.GE.0.AND.LEN.EQ.127) GO TO 24 WRITE(LU,60) IERR 60 FORMAT("BAD READ ON IFORM ",I3) GO TO 38 24 IF(I.NE.1) GO TO 4001 INAME(1)=IBUFI(29) INAME(2)=IBUFI(30) INAME(3)=IBUFI(31) DO 4000 I2=106,238,33 4000 IF(IGET1(IBUFI,I2).EQ.1HA) CALL PUTCA(IBUFI,1HS,I2) 4001 IF(I.NE.2) GO TO 4003 DO 4002 I2=17,248,33 4002 IF(IGET1(IBUFI,I2).EQ.IHA) CALL PUTCA(IBUFI,1HS,I2) 4003 IF(I.NE.3) GO TO 4005 DO 4004 I2=11,242,33 4004 IF(IGET1(IBUFI,I2).EQ.1HA) CALL PUTCA(IBUFI,1HS,I2) 4005 IF(I.NE.4) GO TO 4007 DO 4006 I2=21,153,33 4006 IF(IGET1(IBUFI,I2).EQ.1HA) CALL PUTCA(IBUFI,1HS,I2) 4007 CALL WRITF(IDCBO,IERR,IBUFI,127) IF(IERR.GE.0) GO TO 26 WRITE(LU,25) IERR 25 FORMAT("BAD WRITE ON IFORM ",I3) GO TO 38 26 CONTINUE CALL READF(IDCBI,IERR,IBUFI,127,LEN) C C REC 10^ C DO 27 I=1,10 27 IBUFO(I)=IBUFI(I) DO 28 I=11,18 28 IBUFO(I)=IBLAN C C THIS SECTION REFORMATS JFORM. IN 1936 JFORM WAS A 20 X 76 C BUFFER (TOTAL OF 1520). IN 2026 JFORM IS 20 X 85 (TOTAL OF C 1700). THE FOLLOWING IS A TABLE OF THE CHANGES. C C WORD # 1936 USE 2026 USE C LEFT BYTE/RIGHT BYTE LEFT BYTE/RIGHT BYTE C C 3 NON-KEY INPUT/ON-LINE DIS. NON-KEY INPUT/ L/S CHAR. C 4 SUMMARY DISP./ANS. LABEL SCROLL/CLEAR / SPARE C 5 LABEL FOR ANSWER ON-LINE PRINT/SUMMARY PRINT C 6-13 LABEL FOR ANSWER => LABEL ANSWER CHAR 1-16 C 14-16 SHIFTED IMAGE ITEM NAME 1 BYTE LEFT IN 2026 C 17 IMAGE ITEM NAM/IMAGE OPER IMAGE OPER / SPARE C 77-85 DID NOT EXIST USER WRITTEN DATA MODULE NAME C " BAR CODE INFORMATION C " MAGSTRIPE INFORMATION PTR=11 PTR1=19 DO 33 I=1,20 DO 33 J=1,85 IF(PTR1.LE.127) GO TO 62 CALL WRITF(IDCBO,IERR,IBUFO,127) PTR1=1 62 IF(J.GT.76) GO TO 1200 IF(PTR.LE.127) GO TO 29 CALL READF(IDCBI,IERR,IBUFI,127,LEN) PTR=1 29 IF(J.EQ.3) GO TO 150 IF(J.EQ.4) GO TO 175 IF(J.EQ.5) GO TO 300 IF(J.GE.6 .AND. J.LE.13) GO TO 400 IF(J.EQ.14) GO TO 500 IF(J.GE.15 .AND. J.LE.17) GO TO 550 IF(J.EQ.52) GO TO 700 IF(J.EQ.53) GO TO 800 IF(J.GE.54 .AND. J.LE.61) GO TO 800 IF(J.EQ.62) GO TO 1000 IF(J.EQ.63) GO TO 1100 IBUFO(PTR1)=IBUFI(PTR) GO TO 32 C C 3RD WORD OF JFORM. CHECK FOR O/S ON RIGHT HAND BYTE C BLANK RIGHT HAND BYTE AFTER CHECKING IT. C 150 IHOLD1=IGET1(IBUFI,PTR*2) CALL PUTCA(IBUFI,1H ,PTR*2) IBUFO(PTR1)=IBUFI(PTR) GO TO 32 C C 4TH WORD OF JFORM. CHECK FOR O/S ON LEFT HAND BYTE. HOLD C RIGHT HAND BYTE AND PUT INTO WORD 5. BLANK WORD 4 C 175 IHOLD2=IBUFI(PTR) IBUFO(PTR1)=2H GO TO 32 C C 5TH WORD OF JFORM. CHAR 2 AND 3 OF ANSWER LABEL. SAVE C THESE AND REPLACE WITH PRINTER INFORMATION HELD IN IHOLD1 C AND IHOLD2. THIS FREES IHOLD1 AND IHOLD2. C 300 IHOLD3=IBUFI(PTR) IBUFO(PTR1)=2H IF(IHOLD1.EQ.1HO .OR. IGET1(IHOLD2,1).EQ.1HO) . CALL PUTCA(IBUFO,1HX,PTR1*2-1) IF(IHOLD1.EQ.1HS .OR. IHOLD2.EQ.1HS) . CALL PUTCA(IBUFO,1HX,PTR1*2) GO TO 32 C C 6TH-13TH WORDS OF JFORM. SAVE LABEL CHAR FOR LATER USE C AND PICK UP AND PLACE PREVIOUS ONES. C 400 CALL PUTCA(IBUFO,IGET1(IHOLD2,2),PTR1*2-1) CALL PUTCA(IBUFO,IGET1(IHOLD3,1),PTR1*2) IHOLD2=IHOLD3 IHOLD3=IBUFI(PTR) GO TO 32 C C THIS SECTION MOVES IMAGE ITEM NAME UP 1 BYTE IN JFORM C 550 CALL PUTCA(IBUFO,IGET1(IBUFI,PTR*2-1),PTR1*2-2) 500 CALL PUTCA(IBUFO,IGET1(IBUFI,PTR*2),PTR1*2-1) IF(J.EQ.17) CALL BLAN(IBUFO,PTR1*2,1) GO TO 32 C C 52ND WORD OF JFORM. RIGHT BYTE CONTAINS O/S DISPLAY INFO C SAVE THIS AND BLANK THE WORD. C 700 IHOLD1=IGET1(IBUFI,PTR*2) CALL PUTCA(IBUFI,1H ,PTR*2) IBUFO(PTR1)=IBUFI(PTR) GO TO 32 C C 53RD WORD OF JFORM CONTAINS O/S INFO AND 1ST DISPLAY LABEL C CHAR. 53RD WORD BECOMES PRINTER INFO WITH DISPLAY LABEL C MOVING DOWN 1 BYTE. C 800 IHOLD2=IGET1(IBUFI,PTR*2) CALL PUTCA(IBUFO,IGET1(IBUFI,PTR*2-1),PTR1*2) IF(J.NE.53) GO TO 810 IHOLD3=2H IF(IHOLD1.EQ.1HO .OR. IGET1(IBUFI,PTR*2-1).EQ.1HO) . CALL PUTCA(IHOLD3,1HX,1) IF(IHOLD1.EQ.1HS .OR. IGET1(IBUFI,PTR*2-1).EQ.1HS) . CALL PUTCA(IHOLD3,1HX,2) IBUFO(PTR1)=IHOLD3 IHOLD1=IHOLD2 GO TO 32 810 CALL PUTCA(IBUFO,IHOLD1,PTR1*2-1) IHOLD1=IHOLD2 GO TO 32 C C WORD 62 NEEDS TO BE BLANKED OUT. FORMERLY THE 18 19TH C CHARACTERS IN LABEL, BUT LABEL IS NOW 16 CHAR LONG. C 1000 IBUFO(PTR1)=2H GO TO 32 C C LEFT BYTE IN WORD 63 GETS BLANKED. USED TO BE THE 20TH C CHARACTER OF THE LABEL. C 1100 IBUFO(PTR1)=IBUFI(PTR) CALL PUTCA(IBUFO,1H ,PTR1*2-1) GO TO 32 C C WORDS 77-85 OF JFORM ARE NEW. THEY NEED TO BE BLANK- C FILLED AS PLACE HOLDERS ON REVISED TRANSACTIONS. C 1200 IBUFO(PTR1)=2H GO TO 321 C C 32 PTR=PTR+1 321 PTR1=PTR1+1 33 CONTINUE C C*********************************************************** C C ALL OF JFORM HAS NOW BEEN REFORMATTED. THE REST OF THE C BUFFERS NEED TO BE MOVED WORD FOR WORD WITH THE EXCEPTION C THAT LFORM HAS BEEN INCRESED BY 3 WORDS IN LENGTH, THUS C THE CHECK FOR I.GE.68 .AND. I.LE.70 . C THE REMAINING BUFFERS TO BE MOVED ARE AS FOLLOWS... C C MFORM(28) C LFORM(42) (UP FORM 39 IN 1936) C ITT C IKEY(26,3) C IUMAX,IMMAX,IMODB C ILITE(15) C IMAI(45,5) C IMFLG,IMAS,IMDT,IMKY C C DO 37 I=1,396 IF(PTR1.LE.127) GO TO 34 CALL WRITF(IDCBO,IERR,IBUFO,127) PTR1=1 C C CHECK FOR WHEN I IS 68,69 OR 70 TO ADD 3 BLANK WORDS C 34 IF(I.GE.68.AND.I.LE.70) GO TO 36 IF(PTR.LE.127) GO TO 35 CALL READF(IDCBI,IERR,IBUFI,127,LEN) PTR=1 35 IBUFO(PTR1)=IBUFI(PTR) PTR1=PTR1+1 PTR=PTR+1 GO TO 37 36 IBUFO(PTR1)=2H PTR1=PTR1+1 37 CONTINUE CALL WRITF(IDCBO,IERR,IBUFO,PTR1-1) WRITE(LU,43) INAME 43 FORMAT(" TRANSACTION ",3A2," HAS BEEN SUCCESFULLY REFORMATTED") GO TO 11 C C LEGITIMATE STOP C 38 CALL CLOSE(IDCBO,IERR) IF(IERR.GE.0) GO TO 40 WRITE(LU,39) IERR 39 FORMAT("CLOSE ERROR ON NEW LIBRARY ",I3) 40 CALL CLOSE(IDCBI,IERR) IF(IERR.GE.0) GO TO 42 WRITE(LU,41) IERR 41 FORMAT("CLOSE ERROR ON LIB1 ",I3) 42 CONTINUE END END$