CIAUBCDA ;MSC/IND/PLS - Converts barcode CODABAR to HPCL-compatible format ;04-May-2006 08:19;DKM
;;1.2;CIA UTILITIES;;Mar 20, 2007
;;Copyright 2000-2006, Medsphere Systems Corporation
;=================================================================
; Inputs:
; TXT = Data string to print in bar code
; ORN = Orientation of bar code/Check digit
; 0 = portrait/no check digit(default)
; 1 = landscape/no check digit
; 2 = portrait/check digit
; 3 = landscape/check digit
; HGT = Height of bar code in dots (1/300 inch)
; HOR = Horizontal position on page in dots
; VER = Vertical position on page in dots
; WID = Width of bar in dots (3=default)
; SSC = Start/Stop characters (a/a = default)
; Purpose:
; Accepts a barcode CODABAR string and writes an HPCL-compatible
; string that will display the barcode on an HP laser printer.
; A barcode font cartridge is not required. The print position
; on entry is restored upon exit.
;=================================================================
BC(TXT,ORN,HGT,HOR,VER,WID,SSC) ;
N DD,CHK,CH,ZDD,C,P,Z,Z1,Z2,Z3,Z4,Z5,X
S X=0 X ^%ZOSF("RM")
S CHK=$S($G(ORN)>1:1,1:0),ORN=$S($G(ORN)#2:1,1:0)
S CH="0123456789-$:/.+"
S DD="" F ZDD=1:1:$L(TXT) S DD=DD_$S(CH[$E(TXT,ZDD):$E(TXT,ZDD),1:"") ;STRIP UNPRINTABLE CHARACTERS
S TXT=DD,TXT="a"_TXT_"a" ;ADD START AND STOP CODES
I +$G(CHK) S TXT=$$CHK(TXT)
S C=$C(27)_"*c",P=$C(27)_"*p+",WID=$G(WID,3),HGT=$G(HGT,60),ORN=''$G(ORN)+1
W $C(27),"&f0S" ;Push cursor position
W:$D(HOR) $C(27)_"*p"_+HOR_"X"
W:$D(VER) $C(27)_"*p"_+VER_"Y"
W C_HGT_$E("BA",ORN)
F Z=1:1:$L(TXT) D
.S Z1=$S("AaTt"[$E(TXT,Z):$P($T(16),";",4),"BbNn"[$E(TXT,Z):$P($T(17),";",4),"Cc*"[$E(TXT,Z):$P($T(18),";",4),"DdEe"[$E(TXT,Z):$P($T(19),";",4),1:$P($T(@($F(CH,$E(TXT,Z))-2)),";",4)),Z4=13,Z5=0
.F Z2=1:1:$L(Z1) D
..S Z3=+$E(Z1,Z2),Z4=Z4-Z3,Z3=Z3*WID
..Q:'Z3
..I Z2#2 W C_Z3_$E("ab",ORN)_"0P" S Z5=Z3
..E W P_(Z3+Z5)_$E("XY",ORN) S Z5=0
.S Z4=Z4*WID+Z5
.W P_(Z5+WID)_$E("XY",ORN)
W $C(27),"&f1S" ;Pop cursor position
Q ""
CHK(X) ;CALCULATE CHECK DIGIT AND RETURN STRING TO PRINT
Q:X="" ""
N Z1,Y,CHK,XX
S CHK=0,Y=X
S XX=$E(X,1)_$E(X,$L(X)) ;STRIP OFF S/S CODES AND CALCULATE CHECKSUM
F Z1=1:1:$L(XX) S CHK=CHK+$S("AaTt"[$E(XX,Z1):16,"BbNn"[$E(XX,Z1):17,"Cc*"[$E(XX,Z1):18,"DdEe"[$E(XX,Z1):19,1:0)
;ADD TO CHECKSUM THE VALUES OF THE DATA
S X=$E(X,2,$L(X)-1) F Q:X="" S CHK=$F(CH,$E(X))-2+CHK,X=$E(X,2,255)
S CHK=$E(CH,$S('CHK#16:1,1:16-CHK#16+1))
Q $E(Y,1,$L(Y)-1)_CHK_$E(Y,$L(Y))
0 ;;0;1111133
1 ;;1;1111331
2 ;;2;1113113
3 ;;3;3311111
4 ;;4;1131131
5 ;;5;3111131
6 ;;6;1311113
7 ;;7;1311311
8 ;;8;1331111
9 ;;9;3113111
10 ;;-;1113311
11 ;;$;1133111
12 ;;:;3111313
13 ;;/;3131113
14 ;;.;3131311
15 ;;+;1131313
16 ;;AaTt;1133131
17 ;;BbNn;1313113
18 ;;Cc*;1113133
19 ;;DdEe;1113331
CIAUBCDA ;MSC/IND/PLS - Converts barcode CODABAR to HPCL-compatible format ;04-May-2006 08:19;DKM
+1 ;;1.2;CIA UTILITIES;;Mar 20, 2007
+2 ;;Copyright 2000-2006, Medsphere Systems Corporation
+3 ;=================================================================
+4 ; Inputs:
+5 ; TXT = Data string to print in bar code
+6 ; ORN = Orientation of bar code/Check digit
+7 ; 0 = portrait/no check digit(default)
+8 ; 1 = landscape/no check digit
+9 ; 2 = portrait/check digit
+10 ; 3 = landscape/check digit
+11 ; HGT = Height of bar code in dots (1/300 inch)
+12 ; HOR = Horizontal position on page in dots
+13 ; VER = Vertical position on page in dots
+14 ; WID = Width of bar in dots (3=default)
+15 ; SSC = Start/Stop characters (a/a = default)
+16 ; Purpose:
+17 ; Accepts a barcode CODABAR string and writes an HPCL-compatible
+18 ; string that will display the barcode on an HP laser printer.
+19 ; A barcode font cartridge is not required. The print position
+20 ; on entry is restored upon exit.
+21 ;=================================================================
BC(TXT,ORN,HGT,HOR,VER,WID,SSC) ;
+1 NEW DD,CHK,CH,ZDD,C,P,Z,Z1,Z2,Z3,Z4,Z5,X
+2 SET X=0
XECUTE ^%ZOSF("RM")
+3 SET CHK=$SELECT($GET(ORN)>1:1,1:0)
SET ORN=$SELECT($GET(ORN)#2:1,1:0)
+4 SET CH="0123456789-$:/.+"
+5 ;STRIP UNPRINTABLE CHARACTERS
SET DD=""
FOR ZDD=1:1:$LENGTH(TXT)
SET DD=DD_$SELECT(CH[$EXTRACT(TXT,ZDD):$EXTRACT(TXT,ZDD),1:"")
+6 ;ADD START AND STOP CODES
SET TXT=DD
SET TXT="a"_TXT_"a"
+7 IF +$GET(CHK)
SET TXT=$$CHK(TXT)
+8 SET C=$CHAR(27)_"*c"
SET P=$CHAR(27)_"*p+"
SET WID=$GET(WID,3)
SET HGT=$GET(HGT,60)
SET ORN=''$GET(ORN)+1
+9 ;Push cursor position
WRITE $CHAR(27),"&f0S"
+10 IF $DATA(HOR)
WRITE $CHAR(27)_"*p"_+HOR_"X"
+11 IF $DATA(VER)
WRITE $CHAR(27)_"*p"_+VER_"Y"
+12 WRITE C_HGT_$EXTRACT("BA",ORN)
+13 FOR Z=1:1:$LENGTH(TXT)
Begin DoDot:1
+14 SET Z1=$SELECT("AaTt"[$EXTRACT(TXT,Z):$PIECE($TEXT(16),";",4),"BbNn"[$EXTRACT(TXT,Z):$PIECE($TEXT(17),";",4),"Cc*"[$EXTRACT(TXT,Z):$PIECE($TEXT(18),";",4),"DdEe"[$EXTRACT(TXT,Z):$PIECE($TEXT(19),";",4),1:$PIECE($TEXT(@($FIND(CH,...
... $EXTRACT(TXT,Z))-2)),";",4))
SET Z4=13
SET Z5=0
+15 FOR Z2=1:1:$LENGTH(Z1)
Begin DoDot:2
+16 SET Z3=+$EXTRACT(Z1,Z2)
SET Z4=Z4-Z3
SET Z3=Z3*WID
+17 IF 'Z3
QUIT
+18 IF Z2#2
WRITE C_Z3_$EXTRACT("ab",ORN)_"0P"
SET Z5=Z3
+19 IF '$TEST
WRITE P_(Z3+Z5)_$EXTRACT("XY",ORN)
SET Z5=0
End DoDot:2
+20 SET Z4=Z4*WID+Z5
+21 WRITE P_(Z5+WID)_$EXTRACT("XY",ORN)
End DoDot:1
+22 ;Pop cursor position
WRITE $CHAR(27),"&f1S"
+23 QUIT ""
CHK(X) ;CALCULATE CHECK DIGIT AND RETURN STRING TO PRINT
+1 IF X=""
QUIT ""
+2 NEW Z1,Y,CHK,XX
+3 SET CHK=0
SET Y=X
+4 ;STRIP OFF S/S CODES AND CALCULATE CHECKSUM
SET XX=$EXTRACT(X,1)_$EXTRACT(X,$LENGTH(X))
+5 FOR Z1=1:1:$LENGTH(XX)
SET CHK=CHK+$SELECT("AaTt"[$EXTRACT(XX,Z1):16,"BbNn"[$EXTRACT(XX,Z1):17,"Cc*"[$EXTRACT(XX,Z1):18,"DdEe"[$EXTRACT(XX,Z1):19,1:0)
+6 ;ADD TO CHECKSUM THE VALUES OF THE DATA
+7 SET X=$EXTRACT(X,2,$LENGTH(X)-1)
FOR
IF X=""
QUIT
SET CHK=$FIND(CH,$EXTRACT(X))-2+CHK
SET X=$EXTRACT(X,2,255)
+8 SET CHK=$EXTRACT(CH,$SELECT('CHK#16:1,1:16-CHK#16+1))
+9 QUIT $EXTRACT(Y,1,$LENGTH(Y)-1)_CHK_$EXTRACT(Y,$LENGTH(Y))
0 ;;0;1111133
1 ;;1;1111331
2 ;;2;1113113
3 ;;3;3311111
4 ;;4;1131131
5 ;;5;3111131
6 ;;6;1311113
7 ;;7;1311311
8 ;;8;1331111
9 ;;9;3113111
10 ;;-;1113311
11 ;;$;1133111
12 ;;:;3111313
13 ;;/;3131113
14 ;;.;3131311
15 ;;+;1131313
16 ;;AaTt;1133131
17 ;;BbNn;1313113
18 ;;Cc*;1113133
19 ;;DdEe;1113331
