- XLFUTL ;SFISC/RWF - Library Function, Check digit ;6/29/94 14:04 [ 04/02/2003 8:29 AM ]
- ;;8.0;KERNEL;**1002,1003,1004,1005,1007**;APR 1, 2003
- ;;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
- XLFUTL ;SFISC/RWF - Library Function, Check digit ;6/29/94 14:04 [ 04/02/2003 8:29 AM ]
- +1 ;;8.0;KERNEL;**1002,1003,1004,1005,1007**;APR 1, 2003
- +2 ;;8.0;KERNEL;;Jul 10, 1995
- +3 QUIT
- +4 ;
- 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
