IBDF2F ;ALB/CJM - ENCOUNTER FORM - PRINT FORM(sends to printer) ;NOV 16,1992
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
LNPRINT(IBPFID) ;prints the form
;IBPFID is the id for form tracking
;
N CURY,CURX,NXTTXT,NXTX,LINE,NXTUL,PERPAGE,STRING,STARTY,PAGE
S PAGE=1
;
;determine if simplex or duplex
;
D
.I IBFORM("PRINT_MODE")="DUPLEX_LONG",IBDEVICE("DUPLEX_LONG")]"" W IBDEVICE("DUPLEX_LONG") Q
.I IBFORM("PRINT_MODE")="DUPLEX_SHORT",IBDEVICE("DUPLEX_SHORT")]"" W IBDEVICE("DUPLEX_SHORT") Q
.I IBDEVICE("SIMPLEX")]"" W IBDEVICE("SIMPLEX") Q
.I $Y W @IOF
;
S PERPAGE=IBFORM("PAGE_HT")
I 'PERPAGE!(PERPAGE>IOSL) S PERPAGE=IOSL
S NXTUL=$O(@IBARRAY("UNDERLINES")@("")),NXTTXT=$O(@IBARRAY("TEXT")@(""))
S STARTY=""
S:NXTTXT'="" LINE=$G(@IBARRAY("TEXT")@(NXTTXT))
;
;want this rectangular fill area to apply to underlining
W:IBDEVICE("PCL") $C(27)_"*c35G"
;
D REGISTER^IBDF2F1(PAGE)
F CURY=0:1 D I NXTUL'>0,NXTTXT'>0 Q
.I (CURY>0)&('(CURY#PERPAGE)) D
..I ((NXTTXT'="")!(NXTUL'="")) D
...D:IBDEVICE("GRAPHICS")&('IBDEVICE("PCL")) PGRPHCS(.STARTY,CURY)
...D:IBDEVICE("PCL") DRAW(.STARTY,CURY),WHITEOUT
...W:'$G(IBDEVICE("TCP")) @IOF
...S PAGE=PAGE+1
...D REGISTER^IBDF2F1(PAGE)
.E I (CURY#PERPAGE) W !
.I CURY=NXTTXT D
..S CURX=0,NXTX="" F S NXTX=$O(@IBARRAY("CONTROLS")@(NXTTXT,NXTX)) Q:NXTX="" D
...W $E(LINE,+CURX,NXTX),$$CTRLS^IBDFU($G(@IBARRAY("CONTROLS")@(NXTTXT,NXTX)),NXTX,NXTTXT#PERPAGE)
...S CURX=NXTX+1
..S STRING=$E(LINE,CURX,240) W:STRING'="" STRING
..S NXTTXT=$O(@IBARRAY("TEXT")@(NXTTXT)) S:NXTTXT LINE=$G(@IBARRAY("TEXT")@(NXTTXT))
.I CURY=NXTUL D UNDRLINE
;
;draw stuff requiring graphics mode - obsoleted by PCL, if available
D:IBDEVICE("GRAPHICS")&('IBDEVICE("PCL")) PGRPHCS(STARTY,0)
;
;draw boxes,bubbles, etc. that require PCL
D:IBDEVICE("PCL") DRAW(STARTY,0),WHITEOUT
;
W:'$G(IBDEVICE("TCP")) @IOF
;go back to simplex
D
.I IBFORM("PRINT_MODE")="DUPLEX_LONG",IBDEVICE("DUPLEX_LONG")]"",IBDEVICE("SIMPLEX")]"" W IBDEVICE("SIMPLEX") Q
.I IBFORM("PRINT_MODE")="DUPLEX_SHORT",IBDEVICE("DUPLEX_SHORT")]"",IBDEVICE("SIMPLEX")]"" W IBDEVICE("SIMPLEX")
;
;set the printer for other stuff to print
S X=IOM X $G(^%ZOSF("RM")) K X ;sets device to wrap
;set the printer to 132 col for everything else to print
I IBDEVICE("PCL") D
.W $C(27),"E"
.I $G(IBDEVICE("RESET"))'="" W @IBDEVICE("RESET")
.W $C(27),"(s0p16.67h8.5v0s0b0T",!,$C(27),"&l6C" S IOSL=80
Q
;
UNDRLINE ;
Q:IBDEVICE("CRT")
N UL
S UL=$G(@IBARRAY("UNDERLINES")@(NXTUL))
I 'IBDEVICE("PCL") D
.W:UL'="" $C(13),UL
;do it a bit differently if IBDEVICE("PCL")
I IBDEVICE("PCL") D
.W:UL'="" $C(13),$C(27)_"*v2t1n0O",UL,$C(27)_"*v0T"
.;!!!!!!!!! with the area fill command - needed? see above
.;W:UL'="" $C(13),$C(27)_"*c35G",$C(27)_"*v2t1n0O",UL,$C(27)_"*v0T"
S NXTUL=$O(@IBARRAY("UNDERLINES")@(NXTUL))
Q
PGRPHCS(STARTY,LASTY) ;print graphics - only for raster devices
N DX,DY,GRPHCS,LINE
W IOG1
S (DX,DY)=0 X IOXY
S LINE=STARTY F S LINE=$O(@IBARRAY("GRAPHICS")@(LINE)) Q:(LINE="")!($G(LASTY)&(LINE'<LASTY)) D
.S DX="" F S DX=$O(@IBARRAY("GRAPHICS")@(LINE,DX)) Q:DX="" S GRPHCS=$G(@IBARRAY("GRAPHICS")@(LINE,DX)),GRPHCS=$$GRPHCS^IBDFU(GRPHCS) I GRPHCS'="" S DY=LINE#PERPAGE W ! X IOXY W GRPHCS
S STARTY=LASTY-1
W IOG0
Q
;
DRAW(STARTY,LASTY) ; draws the objects needing HP-GL/2
N ROW,COL,BLK,NODE,WIDTH,HT,IEN,PRNTTYPE
W $C(27),"*p0x0Y"
W $C(27),"*c5760x7200Y"
W $C(27),"*c0T"
W $C(27),"%1B"
W "IN;SP1;"
W "SC0,5760,7200,0;" ;sets up the coordinate system same as PCL
W "AD3,16.6;" ;sets the alternate font for the labels
;
;draw bubbles
W "SV1,30;" ;set fill to 30%
W "PW.15;" ;set pen width to .15 mm
S ROW=STARTY
F S ROW=$O(@IBARRAY("BUBBLES")@(ROW)) Q:(ROW="")!($G(LASTY)&(ROW'<LASTY)) S COL="" F S COL=$O(@IBARRAY("BUBBLES")@(ROW,COL)) Q:COL="" D DRWBBL(ROW#PERPAGE,COL)
;
;draw boxes
W "PW.4;" ;set pen width to .4 mm
;set the fill to 100%
W "SV1,100;"
S ROW=STARTY
F S ROW=$O(@IBARRAY("BOXES")@(ROW)) Q:(ROW="")!($G(LASTY)&(ROW'<(LASTY))) S COL="" F S COL=$O(@IBARRAY("BOXES")@(ROW,COL)) Q:COL="" S BLK=0 F S BLK=$O(@IBARRAY("BOXES")@(ROW,COL,BLK)) Q:'BLK D
.S NODE=$G(@IBARRAY("BOXES")@(ROW,COL,BLK)) S WIDTH=$P(NODE,"^"),HT=$P(NODE,"^",2) D DRWBOX(ROW#PERPAGE,COL,WIDTH,HT)
;
;draw hand print fields
W "PW.15;" ;set pen width to .1 mm
;set the fill to 40%
W "SV1,30;"
S ROW=STARTY
F S ROW=$O(@IBARRAY("HAND_PRINT")@(ROW)) Q:(ROW="")!($G(LASTY)&(ROW'<LASTY)) S COL="" F S COL=$O(@IBARRAY("HAND_PRINT")@(ROW,COL)) Q:COL="" S IEN=0 F S IEN=$O(@IBARRAY("HAND_PRINT")@(ROW,COL,IEN)) Q:'IEN D
.S NODE=$G(@IBARRAY("HAND_PRINT")@(ROW,COL,IEN)),WIDTH=+$P(NODE,"^",3),PRNTTYPE=$P(NODE,"^",14) Q:('WIDTH)!('PRNTTYPE)
.D HANDPRNT(ROW#PERPAGE,COL,WIDTH,$P(NODE,"^",6),PRNTTYPE,$P(NODE,"^",17))
;
S STARTY=LASTY-1
W $C(27),"%0A"
Q
;
DRWBBL(Y,X) ;
;position is in terms of col,row - change to decipoints
S Y=(Y*IBDEVICE("ROW_HT"))+$S(IBFORM("WIDTH")>96:20,IBFORM("WIDTH")>80:30,1:40),X=(X+$S(IBFORM("WIDTH")>96:.5,IBFORM("WIDTH")>80:.75,1:1))*IBDEVICE("COL_WIDTH")
;
;position the pen
W "PA"_(X)_","_(Y)_";"
;draw the bubble (a little box)
W "EA"_(X+87)_","_(Y+45)_";"
Q
DRWBOX(Y,X,WIDTH,HT) ;
;position is in terms of col,row - change to decipoints
S Y=((Y+.75)*IBDEVICE("ROW_HT"))+15,X=(X+.5)*IBDEVICE("COL_WIDTH")
;position the pen
W "PA"_(X)_","_(Y)_";"
;draw the box
W "EA"_(X+((WIDTH-1)*IBDEVICE("COL_WIDTH")))_","_(Y+((HT-1.7)*IBDEVICE("ROW_HT")))_";"
Q
HANDPRNT(Y,X,WIDTH,LINES,PRNTTYPE,TYPEDATA) ; draw hand print area
;FORMAT - contains overlay for the field
;UNIT - label to print on the right of print area
;PRNTTYPE = could be for ICR (print comb) or not ICR (no comb, different size)
N CHAR,FORMAT,UNIT,NODE
S NODE=""
I $G(TYPEDATA) S NODE=$G(^IBE(359.1,TYPEDATA,0))
S FORMAT=$P(NODE,"^",5),UNIT=$P(NODE,"^",11)
S:LINES'>0 LINES=1
I PRNTTYPE=2 D
.;change scale from col,row to decipoints
.S Y=(Y*IBDEVICE("ROW_HT"))+$S(IBFORM("WIDTH")>96:0,IBFORM("WIDTH")>80:15,1:30),X=X*IBDEVICE("COL_WIDTH")
.F Q:LINES'>0 D S LINES=LINES-1,Y=Y+(2*IBDEVICE("ROW_HT"))
..;position the pen
..W !,"PA"_(X)_","_(Y)_";"
..;draw the box
..W "EA"_(X+(172.7654*WIDTH))_","_(Y+(180))_";"
..;print the unit of measurement
..I $L(UNIT) W "SA;","PA"_(X+50+(172.7654*WIDTH))_",",(Y+(120))_";","LB",UNIT,$CHAR(3),"SS;"
..;draw the comb
..N I F I=1:1:WIDTH-1 W "PA"_(X+(172.7654*I))_",",(Y+(180))_";PD;PR0,-180;PU" S CHAR=$E(FORMAT,I+1) I CHAR'="",CHAR'="_" D
...;character pre-slug
...W !,"PA"_(X+50+(172.7654*I))_",",(Y+(120))_";"
...W "LB",CHAR,$CHAR(3)
;
I PRNTTYPE=1 D
.;change scale from col,row to decipoints
.S Y=(Y*IBDEVICE("ROW_HT")),X=X*IBDEVICE("COL_WIDTH")
.D CNVRTHT^IBDF2D1(LINES,.LINES)
.;position the pen
.W "PA"_(X)_","_(Y)_";"
.;draw the box
.W "EA"_(X+(103.6593*WIDTH))_","_(Y+(IBDEVICE("ROW_HT")*LINES))_";"
Q
;
WHITEOUT ;puts white space around the anchors - helps insure that the anchors can be located
;
;if the form isn't scannable there are no anchor marks
Q:'IBFORM("SCAN")
;
W $C(27),"&a0v0H",!
;set top margin to top of page
W $C(27),"&l0E"
;top left corner (ANCHOR 1)
W $C(27),"&a354v4H",$C(27),"*c200h60v1P"
;top middle (ANCHOR 2)
W $C(27),"&a354v2676H",$C(27),"*c400h60v1P"
;bottom left (ANCHOR 4)
W $C(27),"&a7505v4H",$C(27),"*c200h60v1P"
;top right (ANCHOR 3)
W $C(27),"&a354v5450H",$C(27),"*c400h60v1P"
;bottom middle (ANCHOR 5)
W $C(27),"&a7505v2676H",$C(27),"*c400h60v1P"
;bottom right (ANCHOR 6)
W $C(27),"&a7505v5450H",$C(27),"*c400h60v1P"
Q
IBDF2F ;ALB/CJM - ENCOUNTER FORM - PRINT FORM(sends to printer) ;NOV 16,1992
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
LNPRINT(IBPFID) ;prints the form
+1 ;IBPFID is the id for form tracking
+2 ;
+3 NEW CURY,CURX,NXTTXT,NXTX,LINE,NXTUL,PERPAGE,STRING,STARTY,PAGE
+4 SET PAGE=1
+5 ;
+6 ;determine if simplex or duplex
+7 ;
+8 Begin DoDot:1
+9 IF IBFORM("PRINT_MODE")="DUPLEX_LONG"
IF IBDEVICE("DUPLEX_LONG")]""
WRITE IBDEVICE("DUPLEX_LONG")
QUIT
+10 IF IBFORM("PRINT_MODE")="DUPLEX_SHORT"
IF IBDEVICE("DUPLEX_SHORT")]""
WRITE IBDEVICE("DUPLEX_SHORT")
QUIT
+11 IF IBDEVICE("SIMPLEX")]""
WRITE IBDEVICE("SIMPLEX")
QUIT
+12 IF $Y
WRITE @IOF
End DoDot:1
+13 ;
+14 SET PERPAGE=IBFORM("PAGE_HT")
+15 IF 'PERPAGE!(PERPAGE>IOSL)
SET PERPAGE=IOSL
+16 SET NXTUL=$ORDER(@IBARRAY("UNDERLINES")@(""))
SET NXTTXT=$ORDER(@IBARRAY("TEXT")@(""))
+17 SET STARTY=""
+18 IF NXTTXT'=""
SET LINE=$GET(@IBARRAY("TEXT")@(NXTTXT))
+19 ;
+20 ;want this rectangular fill area to apply to underlining
+21 IF IBDEVICE("PCL")
WRITE $CHAR(27)_"*c35G"
+22 ;
+23 DO REGISTER^IBDF2F1(PAGE)
+24 FOR CURY=0:1
Begin DoDot:1
+25 IF (CURY>0)&('(CURY#PERPAGE))
Begin DoDot:2
+26 IF ((NXTTXT'="")!(NXTUL'=""))
Begin DoDot:3
+27 IF IBDEVICE("GRAPHICS")&('IBDEVICE("PCL"))
DO PGRPHCS(.STARTY,CURY)
+28 IF IBDEVICE("PCL")
DO DRAW(.STARTY,CURY)
DO WHITEOUT
+29 IF '$GET(IBDEVICE("TCP"))
WRITE @IOF
+30 SET PAGE=PAGE+1
+31 DO REGISTER^IBDF2F1(PAGE)
End DoDot:3
End DoDot:2
+32 IF '$TEST
IF (CURY#PERPAGE)
WRITE !
+33 IF CURY=NXTTXT
Begin DoDot:2
+34 SET CURX=0
SET NXTX=""
FOR
SET NXTX=$ORDER(@IBARRAY("CONTROLS")@(NXTTXT,NXTX))
IF NXTX=""
QUIT
Begin DoDot:3
+35 WRITE $EXTRACT(LINE,+CURX,NXTX),$$CTRLS^IBDFU($GET(@IBARRAY("CONTROLS")@(NXTTXT,NXTX)),NXTX,NXTTXT#PERPAGE)
+36 SET CURX=NXTX+1
End DoDot:3
+37 SET STRING=$EXTRACT(LINE,CURX,240)
IF STRING'=""
WRITE STRING
+38 SET NXTTXT=$ORDER(@IBARRAY("TEXT")@(NXTTXT))
IF NXTTXT
SET LINE=$GET(@IBARRAY("TEXT")@(NXTTXT))
End DoDot:2
+39 IF CURY=NXTUL
DO UNDRLINE
End DoDot:1
IF NXTUL'>0
IF NXTTXT'>0
QUIT
+40 ;
+41 ;draw stuff requiring graphics mode - obsoleted by PCL, if available
+42 IF IBDEVICE("GRAPHICS")&('IBDEVICE("PCL"))
DO PGRPHCS(STARTY,0)
+43 ;
+44 ;draw boxes,bubbles, etc. that require PCL
+45 IF IBDEVICE("PCL")
DO DRAW(STARTY,0)
DO WHITEOUT
+46 ;
+47 IF '$GET(IBDEVICE("TCP"))
WRITE @IOF
+48 ;go back to simplex
+49 Begin DoDot:1
+50 IF IBFORM("PRINT_MODE")="DUPLEX_LONG"
IF IBDEVICE("DUPLEX_LONG")]""
IF IBDEVICE("SIMPLEX")]""
WRITE IBDEVICE("SIMPLEX")
QUIT
+51 IF IBFORM("PRINT_MODE")="DUPLEX_SHORT"
IF IBDEVICE("DUPLEX_SHORT")]""
IF IBDEVICE("SIMPLEX")]""
WRITE IBDEVICE("SIMPLEX")
End DoDot:1
+52 ;
+53 ;set the printer for other stuff to print
+54 ;sets device to wrap
SET X=IOM
XECUTE $GET(^%ZOSF("RM"))
KILL X
+55 ;set the printer to 132 col for everything else to print
+56 IF IBDEVICE("PCL")
Begin DoDot:1
+57 WRITE $CHAR(27),"E"
+58 IF $GET(IBDEVICE("RESET"))'=""
WRITE @IBDEVICE("RESET")
+59 WRITE $CHAR(27),"(s0p16.67h8.5v0s0b0T",!,$CHAR(27),"&l6C"
SET IOSL=80
End DoDot:1
+60 QUIT
+61 ;
UNDRLINE ;
+1 IF IBDEVICE("CRT")
QUIT
+2 NEW UL
+3 SET UL=$GET(@IBARRAY("UNDERLINES")@(NXTUL))
+4 IF 'IBDEVICE("PCL")
Begin DoDot:1
+5 IF UL'=""
WRITE $CHAR(13),UL
End DoDot:1
+6 ;do it a bit differently if IBDEVICE("PCL")
+7 IF IBDEVICE("PCL")
Begin DoDot:1
+8 IF UL'=""
WRITE $CHAR(13),$CHAR(27)_"*v2t1n0O",UL,$CHAR(27)_"*v0T"
+9 ;!!!!!!!!! with the area fill command - needed? see above
+10 ;W:UL'="" $C(13),$C(27)_"*c35G",$C(27)_"*v2t1n0O",UL,$C(27)_"*v0T"
End DoDot:1
+11 SET NXTUL=$ORDER(@IBARRAY("UNDERLINES")@(NXTUL))
+12 QUIT
PGRPHCS(STARTY,LASTY) ;print graphics - only for raster devices
+1 NEW DX,DY,GRPHCS,LINE
+2 WRITE IOG1
+3 SET (DX,DY)=0
XECUTE IOXY
+4 SET LINE=STARTY
FOR
SET LINE=$ORDER(@IBARRAY("GRAPHICS")@(LINE))
IF (LINE="")!($GET(LASTY)&(LINE'<LASTY))
QUIT
Begin DoDot:1
+5 SET DX=""
FOR
SET DX=$ORDER(@IBARRAY("GRAPHICS")@(LINE,DX))
IF DX=""
QUIT
SET GRPHCS=$GET(@IBARRAY("GRAPHICS")@(LINE,DX))
SET GRPHCS=$$GRPHCS^IBDFU(GRPHCS)
IF GRPHCS'=""
SET DY=LINE#PERPAGE
WRITE !
XECUTE IOXY
WRITE GRPHCS
End DoDot:1
+6 SET STARTY=LASTY-1
+7 WRITE IOG0
+8 QUIT
+9 ;
DRAW(STARTY,LASTY) ; draws the objects needing HP-GL/2
+1 NEW ROW,COL,BLK,NODE,WIDTH,HT,IEN,PRNTTYPE
+2 WRITE $CHAR(27),"*p0x0Y"
+3 WRITE $CHAR(27),"*c5760x7200Y"
+4 WRITE $CHAR(27),"*c0T"
+5 WRITE $CHAR(27),"%1B"
+6 WRITE "IN;SP1;"
+7 ;sets up the coordinate system same as PCL
WRITE "SC0,5760,7200,0;"
+8 ;sets the alternate font for the labels
WRITE "AD3,16.6;"
+9 ;
+10 ;draw bubbles
+11 ;set fill to 30%
WRITE "SV1,30;"
+12 ;set pen width to .15 mm
WRITE "PW.15;"
+13 SET ROW=STARTY
+14 FOR
SET ROW=$ORDER(@IBARRAY("BUBBLES")@(ROW))
IF (ROW="")!($GET(LASTY)&(ROW'<LASTY))
QUIT
SET COL=""
FOR
SET COL=$ORDER(@IBARRAY("BUBBLES")@(ROW,COL))
IF COL=""
QUIT
DO DRWBBL(ROW#PERPAGE,COL)
+15 ;
+16 ;draw boxes
+17 ;set pen width to .4 mm
WRITE "PW.4;"
+18 ;set the fill to 100%
+19 WRITE "SV1,100;"
+20 SET ROW=STARTY
+21 FOR
SET ROW=$ORDER(@IBARRAY("BOXES")@(ROW))
IF (ROW="")!($GET(LASTY)&(ROW'<(LASTY)))
QUIT
SET COL=""
FOR
SET COL=$ORDER(@IBARRAY("BOXES")@(ROW,COL))
IF COL=""
QUIT
SET BLK=0
FOR
SET BLK=$ORDER(@IBARRAY("BOXES")@(ROW,COL,BLK))
IF 'BLK
QUIT
Begin DoDot:1
+22 SET NODE=$GET(@IBARRAY("BOXES")@(ROW,COL,BLK))
SET WIDTH=$PIECE(NODE,"^")
SET HT=$PIECE(NODE,"^",2)
DO DRWBOX(ROW#PERPAGE,COL,WIDTH,HT)
End DoDot:1
+23 ;
+24 ;draw hand print fields
+25 ;set pen width to .1 mm
WRITE "PW.15;"
+26 ;set the fill to 40%
+27 WRITE "SV1,30;"
+28 SET ROW=STARTY
+29 FOR
SET ROW=$ORDER(@IBARRAY("HAND_PRINT")@(ROW))
IF (ROW="")!($GET(LASTY)&(ROW'<LASTY))
QUIT
SET COL=""
FOR
SET COL=$ORDER(@IBARRAY("HAND_PRINT")@(ROW,COL))
IF COL=""
QUIT
SET IEN=0
FOR
SET IEN=$ORDER(@IBARRAY("HAND_PRINT")@(ROW,COL,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+30 SET NODE=$GET(@IBARRAY("HAND_PRINT")@(ROW,COL,IEN))
SET WIDTH=+$PIECE(NODE,"^",3)
SET PRNTTYPE=$PIECE(NODE,"^",14)
IF ('WIDTH)!('PRNTTYPE)
QUIT
+31 DO HANDPRNT(ROW#PERPAGE,COL,WIDTH,$PIECE(NODE,"^",6),PRNTTYPE,$PIECE(NODE,"^",17))
End DoDot:1
+32 ;
+33 SET STARTY=LASTY-1
+34 WRITE $CHAR(27),"%0A"
+35 QUIT
+36 ;
DRWBBL(Y,X) ;
+1 ;position is in terms of col,row - change to decipoints
+2 SET Y=(Y*IBDEVICE("ROW_HT"))+$SELECT(IBFORM("WIDTH")>96:20,IBFORM("WIDTH")>80:30,1:40)
SET X=(X+$SELECT(IBFORM("WIDTH")>96:.5,IBFORM("WIDTH")>80:.75,1:1))*IBDEVICE("COL_WIDTH")
+3 ;
+4 ;position the pen
+5 WRITE "PA"_(X)_","_(Y)_";"
+6 ;draw the bubble (a little box)
+7 WRITE "EA"_(X+87)_","_(Y+45)_";"
+8 QUIT
DRWBOX(Y,X,WIDTH,HT) ;
+1 ;position is in terms of col,row - change to decipoints
+2 SET Y=((Y+.75)*IBDEVICE("ROW_HT"))+15
SET X=(X+.5)*IBDEVICE("COL_WIDTH")
+3 ;position the pen
+4 WRITE "PA"_(X)_","_(Y)_";"
+5 ;draw the box
+6 WRITE "EA"_(X+((WIDTH-1)*IBDEVICE("COL_WIDTH")))_","_(Y+((HT-1.7)*IBDEVICE("ROW_HT")))_";"
+7 QUIT
HANDPRNT(Y,X,WIDTH,LINES,PRNTTYPE,TYPEDATA) ; draw hand print area
+1 ;FORMAT - contains overlay for the field
+2 ;UNIT - label to print on the right of print area
+3 ;PRNTTYPE = could be for ICR (print comb) or not ICR (no comb, different size)
+4 NEW CHAR,FORMAT,UNIT,NODE
+5 SET NODE=""
+6 IF $GET(TYPEDATA)
SET NODE=$GET(^IBE(359.1,TYPEDATA,0))
+7 SET FORMAT=$PIECE(NODE,"^",5)
SET UNIT=$PIECE(NODE,"^",11)
+8 IF LINES'>0
SET LINES=1
+9 IF PRNTTYPE=2
Begin DoDot:1
+10 ;change scale from col,row to decipoints
+11 SET Y=(Y*IBDEVICE("ROW_HT"))+$SELECT(IBFORM("WIDTH")>96:0,IBFORM("WIDTH")>80:15,1:30)
SET X=X*IBDEVICE("COL_WIDTH")
+12 FOR
IF LINES'>0
QUIT
Begin DoDot:2
+13 ;position the pen
+14 WRITE !,"PA"_(X)_","_(Y)_";"
+15 ;draw the box
+16 WRITE "EA"_(X+(172.7654*WIDTH))_","_(Y+(180))_";"
+17 ;print the unit of measurement
+18 IF $LENGTH(UNIT)
WRITE "SA;","PA"_(X+50+(172.7654*WIDTH))_",",(Y+(120))_";","LB",UNIT,$CHAR(3),"SS;"
+19 ;draw the comb
+20 NEW I
FOR I=1:1:WIDTH-1
WRITE "PA"_(X+(172.7654*I))_",",(Y+(180))_";PD;PR0,-180;PU"
SET CHAR=$EXTRACT(FORMAT,I+1)
IF CHAR'=""
IF CHAR'="_"
Begin DoDot:3
+21 ;character pre-slug
+22 WRITE !,"PA"_(X+50+(172.7654*I))_",",(Y+(120))_";"
+23 WRITE "LB",CHAR,$CHAR(3)
End DoDot:3
End DoDot:2
SET LINES=LINES-1
SET Y=Y+(2*IBDEVICE("ROW_HT"))
End DoDot:1
+24 ;
+25 IF PRNTTYPE=1
Begin DoDot:1
+26 ;change scale from col,row to decipoints
+27 SET Y=(Y*IBDEVICE("ROW_HT"))
SET X=X*IBDEVICE("COL_WIDTH")
+28 DO CNVRTHT^IBDF2D1(LINES,.LINES)
+29 ;position the pen
+30 WRITE "PA"_(X)_","_(Y)_";"
+31 ;draw the box
+32 WRITE "EA"_(X+(103.6593*WIDTH))_","_(Y+(IBDEVICE("ROW_HT")*LINES))_";"
End DoDot:1
+33 QUIT
+34 ;
WHITEOUT ;puts white space around the anchors - helps insure that the anchors can be located
+1 ;
+2 ;if the form isn't scannable there are no anchor marks
+3 IF 'IBFORM("SCAN")
QUIT
+4 ;
+5 WRITE $CHAR(27),"&a0v0H",!
+6 ;set top margin to top of page
+7 WRITE $CHAR(27),"&l0E"
+8 ;top left corner (ANCHOR 1)
+9 WRITE $CHAR(27),"&a354v4H",$CHAR(27),"*c200h60v1P"
+10 ;top middle (ANCHOR 2)
+11 WRITE $CHAR(27),"&a354v2676H",$CHAR(27),"*c400h60v1P"
+12 ;bottom left (ANCHOR 4)
+13 WRITE $CHAR(27),"&a7505v4H",$CHAR(27),"*c200h60v1P"
+14 ;top right (ANCHOR 3)
+15 WRITE $CHAR(27),"&a354v5450H",$CHAR(27),"*c400h60v1P"
+16 ;bottom middle (ANCHOR 5)
+17 WRITE $CHAR(27),"&a7505v2676H",$CHAR(27),"*c400h60v1P"
+18 ;bottom right (ANCHOR 6)
+19 WRITE $CHAR(27),"&a7505v5450H",$CHAR(27),"*c400h60v1P"
+20 QUIT
