PRCHUEI ;OI&T/LKG -Routine for testing ;1/21/22 12:04
;;5.1;IFCAP;**227**;Oct 20, 2000;Build 1
;Per VA Directive 6402, this routine should not be modified.
VALIDUEI(PRCSTR) ; Returns '1' if UEI is valid and '0' if not
N PRCVALID S PRCVALID=0
I PRCSTR'?12UN Q 0
I $E(PRCSTR)="0" Q 0
I PRCSTR["O" Q 0
I PRCSTR["I" Q 0
I $E(PRCSTR,12)=$$UEICHK(PRCSTR) S PRCVALID=1 ; Valid if checksums match
Q PRCVALID
;
UEICHK(PRCROOT) ; Calculates checksum
N PRCI,PRCJ,PRCLEN,PRCSUM,PRCVAL
S PRCLEN=11 ; Consider the initial 11 characters of the GSA Unique Entity Identifier; the 12th character is the checksum digit to be calculated
F PRCI=1:1 D Q:PRCSUM?1N ; Repeat the calculation until a single digit value has been calculated
. S PRCSUM=0
. F PRCJ=1:1:PRCLEN D ; Go down the length of the string to extract each character for processing
. . S PRCVAL=$E(PRCROOT,PRCJ) S:PRCI=1 PRCVAL=$A(PRCVAL) ; use the ASCII code value for characters in initial string but not sums
. . S PRCVAL=(PRCVAL*PRCJ)#10 ; Calculate modulo 10 of product value times position
. . S PRCSUM=PRCSUM+PRCVAL ; Sum up the modulo values
. S PRCROOT=PRCSUM,PRCLEN=$L(PRCROOT) ; The sum is the new string to process
Q PRCROOT ; Function returning the calculated checksum digit
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHUEI 1278 printed Oct 16, 2024@18:12:07 Page 2
PRCHUEI ;OI&T/LKG -Routine for testing ;1/21/22 12:04
+1 ;;5.1;IFCAP;**227**;Oct 20, 2000;Build 1
+2 ;Per VA Directive 6402, this routine should not be modified.
VALIDUEI(PRCSTR) ; Returns '1' if UEI is valid and '0' if not
+1 NEW PRCVALID
SET PRCVALID=0
+2 IF PRCSTR'?12UN
QUIT 0
+3 IF $EXTRACT(PRCSTR)="0"
QUIT 0
+4 IF PRCSTR["O"
QUIT 0
+5 IF PRCSTR["I"
QUIT 0
+6 ; Valid if checksums match
IF $EXTRACT(PRCSTR,12)=$$UEICHK(PRCSTR)
SET PRCVALID=1
+7 QUIT PRCVALID
+8 ;
UEICHK(PRCROOT) ; Calculates checksum
+1 NEW PRCI,PRCJ,PRCLEN,PRCSUM,PRCVAL
+2 ; Consider the initial 11 characters of the GSA Unique Entity Identifier; the 12th character is the checksum digit to be calculated
SET PRCLEN=11
+3 ; Repeat the calculation until a single digit value has been calculated
FOR PRCI=1:1
Begin DoDot:1
+4 SET PRCSUM=0
+5 ; Go down the length of the string to extract each character for processing
FOR PRCJ=1:1:PRCLEN
Begin DoDot:2
+6 ; use the ASCII code value for characters in initial string but not sums
SET PRCVAL=$EXTRACT(PRCROOT,PRCJ)
if PRCI=1
SET PRCVAL=$ASCII(PRCVAL)
+7 ; Calculate modulo 10 of product value times position
SET PRCVAL=(PRCVAL*PRCJ)#10
+8 ; Sum up the modulo values
SET PRCSUM=PRCSUM+PRCVAL
End DoDot:2
+9 ; The sum is the new string to process
SET PRCROOT=PRCSUM
SET PRCLEN=$LENGTH(PRCROOT)
End DoDot:1
if PRCSUM?1N
QUIT
+10 ; Function returning the calculated checksum digit
QUIT PRCROOT
