XLFUTL ;SFISC/RWF - Library Function, Check digit ;6/29/94 14:04
;;8.0;KERNEL;;Jul 10, 1995
Q
;
CCD(%X) ; Compute check digit and append to number
;see Taylor report Computerworld 1975
; X= integer, Return X with check digit
;
N %I,%N,%D,%S S %S=0,%D=1,%X=$G(%X) S:+%X'=%X (%X,%S)=""
F %I=$L(%X):-1:1 S %N=$E(%X,%I),%N=%N*(%D+1),%N=$E(%N)+$E(%N,2),%S=%S+%N,%D='%D
Q %X_$S(+%X:(-%S#10),1:"")
;
VCD(%X) ; -- Verify check digit (last digit)
; -- Pass X = integer with check digit appended
; -- rtns 0 if check not valid or 1 if valid
;
Q %X=$$CCD($E(%X,1,$L(%X)-1))
;
QL(X) ;$QLENGTH OF GLOBAL STRING
N %,%1
S %1="" F %=0:1 Q:%1=$NA(@X,%) S %1=$NA(@X,%)
Q %-1
;
QS(X1,X2) ;$QSUBSCRIPT OF GLOBAL STRING
N %,%1,Y
I X2=-1,X1?1"^"1"[".E1"]".E Q $TR($P($P($NA(@X1,0),"]"),"[",2),"""")
I X2=-1,X1?1"^"1"|".E1"|".E Q $TR($P($NA(@X1,0),"|",2,$L($NA(@X1,0),"|")-1),"""")
I X2=0,(X1'?1"^"1"[".E)&(X1'?1"^"1"|".E) Q $NA(@X1,X2)
I X2=0,X1?1"^"1"[".E1"]".E Q "^"_$P($NA(@X1,X2),"]",2,999)
I X2=0,X1?1"^"1"|".E Q "^"_$P($NA(@X1,X2),"|",$L($NA(@X1,X2),"|"))
S %1=$NA(@X1,X2-1)
I $E(%1,$L(%1))=")" S %1=$E(%1,1,$L(%1)-1)
S Y=$P($NA(@X1,X2),%1,2,999),Y=$E(Y,1,$L(Y)-1)
I X2=1,$E(Y)="(" S Y=$E(Y,2,999)
I X2>1,$E(Y)="," S Y=$E(Y,2,999)
I $A(Y)=34,$A(Y,$L(Y))=34 S Y=$E(Y,2,$L(Y)-1)
Q Y
BASE(%X1,%X2,%X3) ;Convert %X1 from %X2 base to %X3 base
I (%X2<2)!(%X2>16)!(%X3<2)!(%X3>16) Q -1
Q $$CNV($$DEC(%X1,%X2),%X3)
DEC(N,B) ;Cnv N from B to 10
Q:B=10 N N I,Y S Y=0
F I=1:1:$L(N) S Y=Y*B+($F("0123456789ABCDEF",$E(N,I))-2)
Q Y
CNV(N,B) ;Cnv N from 10 to B
Q:B=10 N N I,Y S Y=""
F I=1:1 S Y=$E("0123456789ABCDEF",N#B+1)_Y,N=N\B Q:N<1
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXLFUTL 1702 printed Oct 16, 2024@18:03:55 Page 2
XLFUTL ;SFISC/RWF - Library Function, Check digit ;6/29/94 14:04
+1 ;;8.0;KERNEL;;Jul 10, 1995
+2 QUIT
+3 ;
CCD(%X) ; Compute check digit and append to number
+1 ;see Taylor report Computerworld 1975
+2 ; X= integer, Return X with check digit
+3 ;
+4 NEW %I,%N,%D,%S
SET %S=0
SET %D=1
SET %X=$GET(%X)
if +%X'=%X
SET (%X,%S)=""
+5 FOR %I=$LENGTH(%X):-1:1
SET %N=$EXTRACT(%X,%I)
SET %N=%N*(%D+1)
SET %N=$EXTRACT(%N)+$EXTRACT(%N,2)
SET %S=%S+%N
SET %D='%D
+6 QUIT %X_$SELECT(+%X:(-%S#10),1:"")
+7 ;
VCD(%X) ; -- Verify check digit (last digit)
+1 ; -- Pass X = integer with check digit appended
+2 ; -- rtns 0 if check not valid or 1 if valid
+3 ;
+4 QUIT %X=$$CCD($EXTRACT(%X,1,$LENGTH(%X)-1))
+5 ;
QL(X) ;$QLENGTH OF GLOBAL STRING
+1 NEW %,%1
+2 SET %1=""
FOR %=0:1
if %1=$NAME(@X,%)
QUIT
SET %1=$NAME(@X,%)
+3 QUIT %-1
+4 ;
QS(X1,X2) ;$QSUBSCRIPT OF GLOBAL STRING
+1 NEW %,%1,Y
+2 IF X2=-1
IF X1?1"^"1"[".E1"]".E
QUIT $TRANSLATE($PIECE($PIECE($NAME(@X1,0),"]"),"[",2),"""")
+3 IF X2=-1
IF X1?1"^"1"|".E1"|".E
QUIT $TRANSLATE($PIECE($NAME(@X1,0),"|",2,$LENGTH($NAME(@X1,0),"|")-1),"""")
+4 IF X2=0
IF (X1'?1"^"1"[".E)&(X1'?1"^"1"|".E)
QUIT $NAME(@X1,X2)
+5 IF X2=0
IF X1?1"^"1"[".E1"]".E
QUIT "^"_$PIECE($NAME(@X1,X2),"]",2,999)
+6 IF X2=0
IF X1?1"^"1"|".E
QUIT "^"_$PIECE($NAME(@X1,X2),"|",$LENGTH($NAME(@X1,X2),"|"))
+7 SET %1=$NAME(@X1,X2-1)
+8 IF $EXTRACT(%1,$LENGTH(%1))=")"
SET %1=$EXTRACT(%1,1,$LENGTH(%1)-1)
+9 SET Y=$PIECE($NAME(@X1,X2),%1,2,999)
SET Y=$EXTRACT(Y,1,$LENGTH(Y)-1)
+10 IF X2=1
IF $EXTRACT(Y)="("
SET Y=$EXTRACT(Y,2,999)
+11 IF X2>1
IF $EXTRACT(Y)=","
SET Y=$EXTRACT(Y,2,999)
+12 IF $ASCII(Y)=34
IF $ASCII(Y,$LENGTH(Y))=34
SET Y=$EXTRACT(Y,2,$LENGTH(Y)-1)
+13 QUIT Y
BASE(%X1,%X2,%X3) ;Convert %X1 from %X2 base to %X3 base
+1 IF (%X2<2)!(%X2>16)!(%X3<2)!(%X3>16)
QUIT -1
+2 QUIT $$CNV($$DEC(%X1,%X2),%X3)
DEC(N,B) ;Cnv N from B to 10
+1 if B=10
QUIT N
NEW I,Y
SET Y=0
+2 FOR I=1:1:$LENGTH(N)
SET Y=Y*B+($FIND("0123456789ABCDEF",$EXTRACT(N,I))-2)
+3 QUIT Y
CNV(N,B) ;Cnv N from 10 to B
+1 if B=10
QUIT N
NEW I,Y
SET Y=""
+2 FOR I=1:1
SET Y=$EXTRACT("0123456789ABCDEF",N#B+1)_Y
SET N=N\B
if N<1
QUIT
+3 QUIT Y
