- CIAUBC39 ;MSC/IND/PLS - Converts barcode 39 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)
- ; Purpose:
- ; Accepts a barcode 39 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) ;
- N DD,CHK,CH,ZDD,C,P,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 TXT=$TR(TXT,"*",""),CH="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+Z"
- 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 I +$G(CHK) S TXT=$$CHK(TXT) ;ADD CHECKSUM CHARACTER
- S TXT="*"_TXT_"*" ;ADD START AND STOP CODES
- 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($E(TXT,Z)="*":$P($T(99),";",4),1:$P($T(@($F(CH,$E(TXT,Z))-2)),";",4)),Z4=15,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 CHK,Y
- S CHK=0,Y=X
- F Q:X="" S CHK=$F(CH,$E(X))-2+CHK,X=$E(X,2,255)
- S CHK=$E(CH,CHK#43+1)
- Q Y_CHK
- 0 ;;0;111331311
- 1 ;;1;311311113
- 2 ;;2;113311113
- 3 ;;3;313311111
- 4 ;;4;111331113
- 5 ;;5;311331111
- 6 ;;6;113331111
- 7 ;;7;111311313
- 8 ;;8;311311311
- 9 ;;9;113311311
- 10 ;;A;311113113
- 11 ;;B;113113113
- 12 ;;C;313113111
- 13 ;;D;111133113
- 14 ;;E;311133111
- 15 ;;F;113133111
- 16 ;;G;111113313
- 17 ;;H;311113311
- 18 ;;I;113113311
- 19 ;;J;111133311
- 20 ;;K;311111133
- 21 ;;L;113111133
- 22 ;;M;313111131
- 23 ;;N;111131133
- 24 ;;O;311131131
- 25 ;;P;113131131
- 26 ;;Q;111111333
- 27 ;;R;311111331
- 28 ;;S;113111331
- 29 ;;T;111131331
- 30 ;;U;331111113
- 31 ;;V;133111113
- 32 ;;W;333111111
- 33 ;;X;131131113
- 34 ;;Y;331131111
- 35 ;;Z;133131111
- 36 ;;-;131111313
- 37 ;;.;331111311
- 38 ;; ;133111311
- 39 ;;$;131313111
- 40 ;;/;131311131
- 41 ;;+;131113131
- 42 ;;%;111313131
- 99 ;;*;131131311
- CIAUBC39 ;MSC/IND/PLS - Converts barcode 39 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 ; Purpose:
- +16 ; Accepts a barcode 39 string and writes an HPCL-compatible
- +17 ; string that will display the barcode on an HP laser printer.
- +18 ; A barcode font cartridge is not required. The print position
- +19 ; on entry is restored upon exit.
- +20 ;=================================================================
- BC(TXT,ORN,HGT,HOR,VER,WID) ;
- +1 NEW DD,CHK,CH,ZDD,C,P,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 TXT=$TRANSLATE(TXT,"*","")
- SET CH="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+Z"
- +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 CHECKSUM CHARACTER
- SET TXT=DD
- IF +$GET(CHK)
- SET TXT=$$CHK(TXT)
- +7 ;ADD START AND STOP CODES
- SET TXT="*"_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($EXTRACT(TXT,Z)="*":$PIECE($TEXT(99),";",4),1:$PIECE($TEXT(@($FIND(CH,$EXTRACT(TXT,Z))-2)),";",4))
- SET Z4=15
- 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 CHK,Y
- +3 SET CHK=0
- SET Y=X
- +4 FOR
- IF X=""
- QUIT
- SET CHK=$FIND(CH,$EXTRACT(X))-2+CHK
- SET X=$EXTRACT(X,2,255)
- +5 SET CHK=$EXTRACT(CH,CHK#43+1)
- +6 QUIT Y_CHK
- 0 ;;0;111331311
- 1 ;;1;311311113
- 2 ;;2;113311113
- 3 ;;3;313311111
- 4 ;;4;111331113
- 5 ;;5;311331111
- 6 ;;6;113331111
- 7 ;;7;111311313
- 8 ;;8;311311311
- 9 ;;9;113311311
- 10 ;;A;311113113
- 11 ;;B;113113113
- 12 ;;C;313113111
- 13 ;;D;111133113
- 14 ;;E;311133111
- 15 ;;F;113133111
- 16 ;;G;111113313
- 17 ;;H;311113311
- 18 ;;I;113113311
- 19 ;;J;111133311
- 20 ;;K;311111133
- 21 ;;L;113111133
- 22 ;;M;313111131
- 23 ;;N;111131133
- 24 ;;O;311131131
- 25 ;;P;113131131
- 26 ;;Q;111111333
- 27 ;;R;311111331
- 28 ;;S;113111331
- 29 ;;T;111131331
- 30 ;;U;331111113
- 31 ;;V;133111113
- 32 ;;W;333111111
- 33 ;;X;131131113
- 34 ;;Y;331131111
- 35 ;;Z;133131111
- 36 ;;-;131111313
- 37 ;;.;331111311
- 38 ;; ;133111311
- 39 ;;$;131313111
- 40 ;;/;131311131
- 41 ;;+;131113131
- 42 ;;%;111313131
- 99 ;;*;131131311
