Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDF2F

IBDF2F.m

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