IBDF2F ;ALB/CJM - ENCOUNTER FORM - PRINT FORM(sends to printer) ;NOV 16,1992
;;3.0;AUTOMATED INFO COLLECTION SYS;**3,25**;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")) ! ;if TCP device must use ! to get to TOF
...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,PWPARAM,FIPARAM
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 "PW.12;" ;set pen width to .12 mm, patch 3 value
;W "SV1,25;" ;set fill to 25%, patch 3 value
S PWPARAM=$P($G(^IBD(357.09,1,0)),"^",13)
I PWPARAM="" S PWPARAM=12
S FIPARAM=$P($G(^IBD(357.09,1,0)),"^",14)
I FIPARAM="" S FIPARAM=25
W "PW."_PWPARAM_";" ;set pen width param to file value
W "SV1,"_FIPARAM_";" ;set the fill to file value
;
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
W "SV1,100;" ;set the fill to 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.12;" ;set pen width to .12 mm, patch 3 value
;W "SV1,25;" ;set the fill to 25%, patch 3 value
S PWPARAM=$P($G(^IBD(357.09,1,0)),"^",13)
I PWPARAM="" S PWPARAM=12
S FIPARAM=$P($G(^IBD(357.09,1,0)),"^",14)
I FIPARAM="" S FIPARAM=25
W "PW."_PWPARAM_";" ;set pen width param to file value
W "SV1,"_FIPARAM_";" ;set the fill to file value
;
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=$$FRMT(NODE,$G(IBAPPT)),UNIT=$P(NODE,"^",11) ;don't use frmt here, cause pre-slugging of data and read when scanning
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
;
FRMT(ND,ADT) ; -- function returns piece 5 on entries from 359.1
; -- reformats the Checkout/date format for y2k
; -- input nd := zero node from 359.1 for entry
; adt := alternate date (appointment date, when known)
N FRMT
S FRMT=$P(ND,"^",5)
I $P(ND,"^")="CHECKOUT DATE@TIME" S $E(FRMT,5)=$S($G(ADT):$E(ADT,2),1:$E(DT,2))
Q FRMT
;
WHITEOUT ; -- puts white space around the anchors
; helps insure that the anchors can be located
;
Q:'IBFORM("SCAN") ;if the form isn't scannable there are no anchors
;
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"
;
; -- bottom left (ANCHOR 2)
W $C(27),"&a7505v4H",$C(27),"*c200h60v1P"
;
; -- top right (ANCHOR 3)
W $C(27),"&a354v5450H",$C(27),"*c400h60v1P"
;
; -- bottom right (ANCHOR 4)
W $C(27),"&a7505v5450H",$C(27),"*c400h60v1P"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF2F 8841 printed Apr 09, 2024@21:53:23 Page 2
IBDF2F ;ALB/CJM - ENCOUNTER FORM - PRINT FORM(sends to printer) ;NOV 16,1992
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**3,25**;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 TCP device must use ! to get to TOF
if $GET(IBDEVICE("TCP"))
WRITE !
+30 if '$GET(IBDEVICE("TCP"))
WRITE @IOF
+31 SET PAGE=PAGE+1
+32 DO REGISTER^IBDF2F1(PAGE)
End DoDot:3
End DoDot:2
+33 IF '$TEST
IF (CURY#PERPAGE)
WRITE !
+34 IF CURY=NXTTXT
Begin DoDot:2
+35 SET CURX=0
SET NXTX=""
FOR
SET NXTX=$ORDER(@IBARRAY("CONTROLS")@(NXTTXT,NXTX))
if NXTX=""
QUIT
Begin DoDot:3
+36 WRITE $EXTRACT(LINE,+CURX,NXTX),$$CTRLS^IBDFU($GET(@IBARRAY("CONTROLS")@(NXTTXT,NXTX)),NXTX,NXTTXT#PERPAGE)
+37 SET CURX=NXTX+1
End DoDot:3
+38 SET STRING=$EXTRACT(LINE,CURX,240)
if STRING'=""
WRITE STRING
+39 SET NXTTXT=$ORDER(@IBARRAY("TEXT")@(NXTTXT))
if NXTTXT
SET LINE=$GET(@IBARRAY("TEXT")@(NXTTXT))
End DoDot:2
+40 IF CURY=NXTUL
DO UNDRLINE
End DoDot:1
IF NXTUL'>0
IF NXTTXT'>0
QUIT
+41 ;
+42 ;draw stuff requiring graphics mode - obsoleted by PCL, if available
+43 if IBDEVICE("GRAPHICS")&('IBDEVICE("PCL"))
DO PGRPHCS(STARTY,0)
+44 ;
+45 ;draw boxes,bubbles, etc. that require PCL
+46 if IBDEVICE("PCL")
DO DRAW(STARTY,0)
DO WHITEOUT
+47 ;
+48 if '$GET(IBDEVICE("TCP"))
WRITE @IOF
+49 ;go back to simplex
+50 Begin DoDot:1
+51 IF IBFORM("PRINT_MODE")="DUPLEX_LONG"
IF IBDEVICE("DUPLEX_LONG")]""
IF IBDEVICE("SIMPLEX")]""
WRITE IBDEVICE("SIMPLEX")
QUIT
+52 IF IBFORM("PRINT_MODE")="DUPLEX_SHORT"
IF IBDEVICE("DUPLEX_SHORT")]""
IF IBDEVICE("SIMPLEX")]""
WRITE IBDEVICE("SIMPLEX")
End DoDot:1
+53 ;
+54 ;set the printer for other stuff to print
+55 ;sets device to wrap
SET X=IOM
XECUTE $GET(^%ZOSF("RM"))
KILL X
+56 ;set the printer to 132 col for everything else to print
+57 IF IBDEVICE("PCL")
Begin DoDot:1
+58 WRITE $CHAR(27),"E"
+59 IF $GET(IBDEVICE("RESET"))'=""
WRITE @IBDEVICE("RESET")
+60 WRITE $CHAR(27),"(s0p16.67h8.5v0s0b0T",!,$CHAR(27),"&l6C"
SET IOSL=80
End DoDot:1
+61 QUIT
+62 ;
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,PWPARAM,FIPARAM
+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 ;W "PW.12;" ;set pen width to .12 mm, patch 3 value
+12 ;W "SV1,25;" ;set fill to 25%, patch 3 value
+13 SET PWPARAM=$PIECE($GET(^IBD(357.09,1,0)),"^",13)
+14 IF PWPARAM=""
SET PWPARAM=12
+15 SET FIPARAM=$PIECE($GET(^IBD(357.09,1,0)),"^",14)
+16 IF FIPARAM=""
SET FIPARAM=25
+17 ;set pen width param to file value
WRITE "PW."_PWPARAM_";"
+18 ;set the fill to file value
WRITE "SV1,"_FIPARAM_";"
+19 ;
+20 SET ROW=STARTY
+21 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)
+22 ;
+23 ;draw boxes
+24 ;set pen width to .4 mm
WRITE "PW.4;"
+25 ;set the fill to 100%
WRITE "SV1,100;"
+26 SET ROW=STARTY
+27 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
+28 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
+29 ;
+30 ;draw hand print fields
+31 ;W "PW.12;" ;set pen width to .12 mm, patch 3 value
+32 ;W "SV1,25;" ;set the fill to 25%, patch 3 value
+33 SET PWPARAM=$PIECE($GET(^IBD(357.09,1,0)),"^",13)
+34 IF PWPARAM=""
SET PWPARAM=12
+35 SET FIPARAM=$PIECE($GET(^IBD(357.09,1,0)),"^",14)
+36 IF FIPARAM=""
SET FIPARAM=25
+37 ;set pen width param to file value
WRITE "PW."_PWPARAM_";"
+38 ;set the fill to file value
WRITE "SV1,"_FIPARAM_";"
+39 ;
+40 SET ROW=STARTY
+41 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
+42 SET NODE=$GET(@IBARRAY("HAND_PRINT")@(ROW,COL,IEN))
SET WIDTH=+$PIECE(NODE,"^",3)
SET PRNTTYPE=$PIECE(NODE,"^",14)
if ('WIDTH)!('PRNTTYPE)
QUIT
+43 DO HANDPRNT(ROW#PERPAGE,COL,WIDTH,$PIECE(NODE,"^",6),PRNTTYPE,$PIECE(NODE,"^",17))
End DoDot:1
+44 ;
+45 SET STARTY=LASTY-1
+46 WRITE $CHAR(27),"%0A"
+47 QUIT
+48 ;
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 ;
+7 ; -- draw the bubble (a little box)
+8 WRITE "EA"_(X+87)_","_(Y+45)_";"
+9 QUIT
+10 ;
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 ;
+4 ;position the pen
+5 WRITE "PA"_(X)_","_(Y)_";"
+6 ;
+7 ;draw the box
+8 WRITE "EA"_(X+((WIDTH-1)*IBDEVICE("COL_WIDTH")))_","_(Y+((HT-1.7)*IBDEVICE("ROW_HT")))_";"
+9 QUIT
+10 ;
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 ;S FORMAT=$$FRMT(NODE,$G(IBAPPT)),UNIT=$P(NODE,"^",11) ;don't use frmt here, cause pre-slugging of data and read when scanning
+8 SET FORMAT=$PIECE(NODE,"^",5)
SET UNIT=$PIECE(NODE,"^",11)
+9 if LINES'>0
SET LINES=1
+10 IF PRNTTYPE=2
Begin DoDot:1
+11 ;change scale from col,row to decipoints
+12 SET Y=(Y*IBDEVICE("ROW_HT"))+$SELECT(IBFORM("WIDTH")>96:0,IBFORM("WIDTH")>80:15,1:30)
SET X=X*IBDEVICE("COL_WIDTH")
+13 FOR
if LINES'>0
QUIT
Begin DoDot:2
+14 ;position the pen
+15 WRITE !,"PA"_(X)_","_(Y)_";"
+16 ;draw the box
+17 WRITE "EA"_(X+(172.7654*WIDTH))_","_(Y+(180))_";"
+18 ;print the unit of measurement
+19 IF $LENGTH(UNIT)
WRITE "SA;","PA"_(X+50+(172.7654*WIDTH))_",",(Y+(120))_";","LB",UNIT,$CHAR(3),"SS;"
+20 ;draw the comb
+21 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
+22 ;character pre-slug
+23 WRITE !,"PA"_(X+50+(172.7654*I))_",",(Y+(120))_";"
+24 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
+25 ;
+26 IF PRNTTYPE=1
Begin DoDot:1
+27 ;change scale from col,row to decipoints
+28 SET Y=(Y*IBDEVICE("ROW_HT"))
SET X=X*IBDEVICE("COL_WIDTH")
+29 DO CNVRTHT^IBDF2D1(LINES,.LINES)
+30 ;position the pen
+31 WRITE "PA"_(X)_","_(Y)_";"
+32 ;draw the box
+33 WRITE "EA"_(X+(103.6593*WIDTH))_","_(Y+(IBDEVICE("ROW_HT")*LINES))_";"
End DoDot:1
+34 QUIT
+35 ;
FRMT(ND,ADT) ; -- function returns piece 5 on entries from 359.1
+1 ; -- reformats the Checkout/date format for y2k
+2 ; -- input nd := zero node from 359.1 for entry
+3 ; adt := alternate date (appointment date, when known)
+4 NEW FRMT
+5 SET FRMT=$PIECE(ND,"^",5)
+6 IF $PIECE(ND,"^")="CHECKOUT DATE@TIME"
SET $EXTRACT(FRMT,5)=$SELECT($GET(ADT):$EXTRACT(ADT,2),1:$EXTRACT(DT,2))
+7 QUIT FRMT
+8 ;
WHITEOUT ; -- puts white space around the anchors
+1 ; helps insure that the anchors can be located
+2 ;
+3 ;if the form isn't scannable there are no anchors
if 'IBFORM("SCAN")
QUIT
+4 ;
+5 ;set top margin to top of page
WRITE $CHAR(27),"&a0v0H",!
+6 WRITE $CHAR(27),"&l0E"
+7 ;
+8 ; -- top left corner (ANCHOR 1)
+9 WRITE $CHAR(27),"&a354v4H",$CHAR(27),"*c200h60v1P"
+10 ;
+11 ; -- bottom left (ANCHOR 2)
+12 WRITE $CHAR(27),"&a7505v4H",$CHAR(27),"*c200h60v1P"
+13 ;
+14 ; -- top right (ANCHOR 3)
+15 WRITE $CHAR(27),"&a354v5450H",$CHAR(27),"*c400h60v1P"
+16 ;
+17 ; -- bottom right (ANCHOR 4)
+18 WRITE $CHAR(27),"&a7505v5450H",$CHAR(27),"*c400h60v1P"
+19 QUIT
