|
midrange.com
Hi:
This routine will calculate the check digit for UPC-A, UPC-E and EAN
numbers. The check digit is returned in ##CKDG after the appropriate
subroutine is called. You can ignore the code concerning the error messages
if you don't need them. They are there for the sake of the Progen code
generator validation code.
********************* START *******************************
/****************************************************************/
/* */
/* Copyright 1996 - H J M Systems, Inc. */
/* One Penn Plaza */
/* Suite 2812 */
/* New York, NY 10119 */
/* */
/* 212-714-1055 */
/* */
/****************************************************************/
F****************************************************************/
F* MAINTENANCE LOG
F****************************************************************/
XX/NNF* MM/DD/YY - DESCRIPTION
BL/01F* 02/04/97 - CHANGED TO RETURN UPC-A WHEN UPC-E ENTERED
F****************************************************************/
E #U 18 1 0
E #UX 18 1
E #NU 18 1
I 'Error: Invalid UPC C-C N$ERR1
I 'ode - Not Numeric.'
I 'Error: Invalid UPC C-C N$ERR2
I 'ode - Invalid Check -
I 'Digit.'
I 'Error: Invalid UPC n-C N$ERR3
I 'umber length.'
I 'Error: Invalid EAN C-C N$ERR4
I 'ode - Invalid Check -
I 'Digit.'
I 'Error: Invalid EAN C-C N$ERR5
I 'ode - Not Numeric.'
C *ENTRY PLIST
C PARM ##SKU 18 SKU
C PARM ##NSKU 18 NEW SKU
C PARM ##CKDG 10 CHECK DIGIT
C PARM ##ERCD 1 ERROR CODE
C PARM ##EMTX 78 ERROR TEXT
C*
C* Assume no error:
C CLEAR##ERCD
C CLEAR##EMTX
C CLEAR##CKDG
C MOVEA##SKU #UX
C MOVEA##SKU #NU
C* FIND LENGTH OF FIELD
C DO 18 L 30
C #UX,L IFLT '0'
C #UX,L ORGT '9'
C LEAVE
C ENDIF
C ENDDO
C/SPACE
C SUB 1 L
C SELEC
C/SPACE
C*-----------------------------------
C* UPC-A
C*-----------------------------------
C/SPACE
C L WHEQ 12
C EXSR $VAL12
C* BUILD NEW SKU NUMBER
C MOVE ##CKDG #NU,12
C/SPACE
C*-----------------------------------
C* EAN-13
C*-----------------------------------
C/SPACE
C L WHEQ 13
C EXSR $VAL13
C* BUILD NEW SKU NUMBER
C MOVE ##CKDG #NU,13
C/SPACE
C*-----------------------------------
C* UPC-E
C*-----------------------------------
C L WHEQ 7
C EXSR $CUPCE
C EXSR $VAL12
C* BUILD NEW SKU NUMBER
BL/01C*** MOVE ##CKDG #NU,7
BL/01C MOVEA#TWLVE #NU
BL/01C MOVE ##CKDG #NU,12
C OTHER
C/SPACE
C MOVEL'3' ##ERCD
C MOVELN$ERR3 ##EMTX P
C ENDSL
C/SPACE
C MOVEA#NU ##NSKU
C/SPACE
C RETRN
C/SPACE 3
C*-----------------------------------
C* $VAL12-VALIDATE 12 DIGIT UPC
C*-----------------------------------
C* PARMS IN - #UX
C* PARMS OUT- ##ERCD
C*-----------------------------------
C $VAL12 BEGSR
C* REVIEW ALL DIGITS FOR NUMBERS
C DO 12 J 30
C #UX,J IFLT '0'
C #UX,J ORGT '9'
C MOVE '1' ##ERCD
C MOVELN$ERR1 ##EMTX P
C ELSE
C MOVE #UX,J #U,J
C ENDIF
C ENDDO
C/SPACE
C ##ERCD IFEQ *BLANK
C Z-ADD0 ##HASH 30
C* ADD ODD DIGITS
C DO 11 J
C ADD #U,J ##HASH
C ENDDO2
C MULT 3 ##HASH
C* ADD EVEN DIGITS
C 2 DO 11 J
C ADD #U,J ##HASH
C ENDDO2
C/SPACE
C MOVE ##HASH ##CKDG
C 10 SUB ##CKDG ##CKDG
C #U,12 IFNE ##CKDG
C MOVE '2' ##ERCD
C MOVELN$ERR2 ##EMTX P
C ENDIF
C/SPACE
C END
C ENDSR
C/SPACE 3
C*-----------------------------------
C* $VAL13-VALIDATE 13 DIGIT EAN
C*-----------------------------------
C* PARMS IN - #UX
C* PARMS OUT- ##ERCD
C*-----------------------------------
C $VAL13 BEGSR
C* REVIEW ALL DIGITS FOR NUMBERS
C DO 13 J 30
C #UX,J IFLT '0'
C #UX,J ORGT '9'
C MOVE '1' ##ERCD
C MOVELN$ERR5 ##EMTX P
C ELSE
C MOVE #UX,J #U,J
C ENDIF
C ENDDO
C/SPACE
C ##ERCD IFEQ *BLANK
C Z-ADD0 ##HASH 30
C* ADD EVEN DIGITS
C 2 DO 12 J
C ADD #U,J ##HASH
C ENDDO2
C MULT 3 ##HASH
C* ADD ODD DIGITS
C DO 12 J
C ADD #U,J ##HASH
C ENDDO2
C/SPACE
C MOVE ##HASH ##CKDG
C 10 SUB ##CKDG ##CKDG
C #U,13 IFNE ##CKDG
C MOVE '2' ##ERCD
C MOVELN$ERR4 ##EMTX P
C ENDIF
C/SPACE
C END
C ENDSR
C/SPACE 3
C*-----------------------------------
C* $CUPCE-CONVERT UPC-E
C*-----------------------------------
C* PARMS IN - #UX
C* PARMS OUT- #UX
C*-----------------------------------
C $CUPCE BEGSR
C SELEC
C #UX,6 WHEQ '0'
C #UX,6 OREQ '1'
C #UX,6 OREQ '2'
C MOVEA#UX,1 #TWO 2 1ST 2 DIGITS
C '0' CAT #TWO:0 #TWLVE 12 P
C CAT #UX,6:0 #TWLVE COMPRES TYPE
C CAT '0000':0 #TWLVE
C MOVEA#UX,3 #THREE 3 LAST 3 DIGIT
C CAT #THREE:0 #TWLVE
C CAT #UX,7:0 #TWLVE CHECK DIGIT
C #UX,6 WHEQ '3'
C MOVEA#UX,1 #THREE 1ST 3 DIGITS
C '0' CAT #THREE:0 #TWLVE P
C CAT '00000':0 #TWLVE COMPRESS TYP
C MOVEA#UX,4 #TWO LAST 2 DIGIT
C CAT #TWO:0 #TWLVE
C CAT #UX,7:0 #TWLVE CHECK DIGIT
C #UX,6 WHEQ '4'
C MOVEA#UX,1 #FOUR 4 1ST 4 DIGITS
C '0' CAT #FOUR:0 #TWLVE P
C CAT '00000':0 #TWLVE COMPRESS TYP
C MOVEA#UX,5 #ONE 1 LAST DIGIT
C CAT #ONE:0 #TWLVE
C CAT #UX,7:0 #TWLVE CHECK DIGIT
C #UX,6 WHGE '5'
C MOVEA#UX,1 #FIVE 5 1ST 5 DIGITS
C '0' CAT #FIVE:0 #TWLVE P
C CAT '0000':0 #TWLVE COMPRESS TYP
C MOVEA#UX,6 #ONE LAST DIGIT
C CAT #ONE:0 #TWLVE
C CAT #UX,7:0 #TWLVE CHECK DIGIT
C ENDSL
C/SPACE
C MOVEA#TWLVE #UX
C ENDSR
*********************** END ********************************
HTH,
Brian Lawson
HJM Systems, Inc.
One Penn Plaza
Suite 2812
NY, NY 10119
Email: blawson@hjmsys.com
www.hjmsys.com
-----Original Message-----
From: Jeff Crosby <jlcrosby@fwi.com>
Newsgroups: as400.general,comp.sys.ibm.as400.misc
To: Midrange List Server (David Gibbs) <MIDRANGE-L@midrange.com>
Date: Tuesday, December 15, 1998 9:39 AM
Subject: UPC Check Digit Algorithm
>
>Does anyone know where I can find the algorithm to calculate a UPC check
>digit?
>
>Or better yet, already have the routine written in RPG?
>
>Thanks.
>
>--
>-Jeff
>
>jlcrosby@fwi.com
>+---
>| This is the Midrange System Mailing List!
>| To submit a new message, send your mail to MIDRANGE-L@midrange.com.
>| To subscribe to this list send email to MIDRANGE-L-SUB@midrange.com.
>| To unsubscribe from this list send email to
MIDRANGE-L-UNSUB@midrange.com.
>| Questions should be directed to the list owner/operator:
david@midrange.com
>+---
>
+---
| This is the Midrange System Mailing List!
| To submit a new message, send your mail to MIDRANGE-L@midrange.com.
| To subscribe to this list send email to MIDRANGE-L-SUB@midrange.com.
| To unsubscribe from this list send email to MIDRANGE-L-UNSUB@midrange.com.
| Questions should be directed to the list owner/operator: david@midrange.com
+---
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2024 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
