source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF2F.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.4 KB
Line 
1IBDF2F ;ALB/CJM - ENCOUNTER FORM - PRINT FORM(sends to printer) ;NOV 16,1992
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**3,25**;APR 24, 1997
3 ;
4LNPRINT(IBPFID) ;prints the form
5 ;IBPFID is the id for form tracking
6 ;
7 N CURY,CURX,NXTTXT,NXTX,LINE,NXTUL,PERPAGE,STRING,STARTY,PAGE
8 S PAGE=1
9 ;
10 ;determine if simplex or duplex
11 ;
12 D
13 .I IBFORM("PRINT_MODE")="DUPLEX_LONG",IBDEVICE("DUPLEX_LONG")]"" W IBDEVICE("DUPLEX_LONG") Q
14 .I IBFORM("PRINT_MODE")="DUPLEX_SHORT",IBDEVICE("DUPLEX_SHORT")]"" W IBDEVICE("DUPLEX_SHORT") Q
15 .I IBDEVICE("SIMPLEX")]"" W IBDEVICE("SIMPLEX") Q
16 .I $Y W @IOF
17 ;
18 S PERPAGE=IBFORM("PAGE_HT")
19 I 'PERPAGE!(PERPAGE>IOSL) S PERPAGE=IOSL
20 S NXTUL=$O(@IBARRAY("UNDERLINES")@("")),NXTTXT=$O(@IBARRAY("TEXT")@(""))
21 S STARTY=""
22 S:NXTTXT'="" LINE=$G(@IBARRAY("TEXT")@(NXTTXT))
23 ;
24 ;want this rectangular fill area to apply to underlining
25 W:IBDEVICE("PCL") $C(27)_"*c35G"
26 ;
27 D REGISTER^IBDF2F1(PAGE)
28 F CURY=0:1 D I NXTUL'>0,NXTTXT'>0 Q
29 .I (CURY>0)&('(CURY#PERPAGE)) D
30 ..I ((NXTTXT'="")!(NXTUL'="")) D
31 ...D:IBDEVICE("GRAPHICS")&('IBDEVICE("PCL")) PGRPHCS(.STARTY,CURY)
32 ...D:IBDEVICE("PCL") DRAW(.STARTY,CURY),WHITEOUT
33 ...W:$G(IBDEVICE("TCP")) ! ;if TCP device must use ! to get to TOF
34 ...W:'$G(IBDEVICE("TCP")) @IOF
35 ...S PAGE=PAGE+1
36 ...D REGISTER^IBDF2F1(PAGE)
37 .E I (CURY#PERPAGE) W !
38 .I CURY=NXTTXT D
39 ..S CURX=0,NXTX="" F S NXTX=$O(@IBARRAY("CONTROLS")@(NXTTXT,NXTX)) Q:NXTX="" D
40 ...W $E(LINE,+CURX,NXTX),$$CTRLS^IBDFU($G(@IBARRAY("CONTROLS")@(NXTTXT,NXTX)),NXTX,NXTTXT#PERPAGE)
41 ...S CURX=NXTX+1
42 ..S STRING=$E(LINE,CURX,240) W:STRING'="" STRING
43 ..S NXTTXT=$O(@IBARRAY("TEXT")@(NXTTXT)) S:NXTTXT LINE=$G(@IBARRAY("TEXT")@(NXTTXT))
44 .I CURY=NXTUL D UNDRLINE
45 ;
46 ;draw stuff requiring graphics mode - obsoleted by PCL, if available
47 D:IBDEVICE("GRAPHICS")&('IBDEVICE("PCL")) PGRPHCS(STARTY,0)
48 ;
49 ;draw boxes,bubbles, etc. that require PCL
50 D:IBDEVICE("PCL") DRAW(STARTY,0),WHITEOUT
51 ;
52 W:'$G(IBDEVICE("TCP")) @IOF
53 ;go back to simplex
54 D
55 .I IBFORM("PRINT_MODE")="DUPLEX_LONG",IBDEVICE("DUPLEX_LONG")]"",IBDEVICE("SIMPLEX")]"" W IBDEVICE("SIMPLEX") Q
56 .I IBFORM("PRINT_MODE")="DUPLEX_SHORT",IBDEVICE("DUPLEX_SHORT")]"",IBDEVICE("SIMPLEX")]"" W IBDEVICE("SIMPLEX")
57 ;
58 ;set the printer for other stuff to print
59 S X=IOM X $G(^%ZOSF("RM")) K X ;sets device to wrap
60 ;set the printer to 132 col for everything else to print
61 I IBDEVICE("PCL") D
62 .W $C(27),"E"
63 .I $G(IBDEVICE("RESET"))'="" W @IBDEVICE("RESET")
64 .W $C(27),"(s0p16.67h8.5v0s0b0T",!,$C(27),"&l6C" S IOSL=80
65 Q
66 ;
67UNDRLINE ;
68 Q:IBDEVICE("CRT")
69 N UL
70 S UL=$G(@IBARRAY("UNDERLINES")@(NXTUL))
71 I 'IBDEVICE("PCL") D
72 .W:UL'="" $C(13),UL
73 ;do it a bit differently if IBDEVICE("PCL")
74 I IBDEVICE("PCL") D
75 .W:UL'="" $C(13),$C(27)_"*v2t1n0O",UL,$C(27)_"*v0T"
76 .;!!!!!!!!! with the area fill command - needed? see above
77 .;W:UL'="" $C(13),$C(27)_"*c35G",$C(27)_"*v2t1n0O",UL,$C(27)_"*v0T"
78 S NXTUL=$O(@IBARRAY("UNDERLINES")@(NXTUL))
79 Q
80PGRPHCS(STARTY,LASTY) ;print graphics - only for raster devices
81 N DX,DY,GRPHCS,LINE
82 W IOG1
83 S (DX,DY)=0 X IOXY
84 S LINE=STARTY F S LINE=$O(@IBARRAY("GRAPHICS")@(LINE)) Q:(LINE="")!($G(LASTY)&(LINE'<LASTY)) D
85 .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
86 S STARTY=LASTY-1
87 W IOG0
88 Q
89 ;
90DRAW(STARTY,LASTY) ; draws the objects needing HP-GL/2
91 N ROW,COL,BLK,NODE,WIDTH,HT,IEN,PRNTTYPE,PWPARAM,FIPARAM
92 W $C(27),"*p0x0Y"
93 W $C(27),"*c5760x7200Y"
94 W $C(27),"*c0T"
95 W $C(27),"%1B"
96 W "IN;SP1;"
97 W "SC0,5760,7200,0;" ;sets up the coordinate system same as PCL
98 W "AD3,16.6;" ;sets the alternate font for the labels
99 ;
100 ;draw bubbles
101 ;W "PW.12;" ;set pen width to .12 mm, patch 3 value
102 ;W "SV1,25;" ;set fill to 25%, patch 3 value
103 S PWPARAM=$P($G(^IBD(357.09,1,0)),"^",13)
104 I PWPARAM="" S PWPARAM=12
105 S FIPARAM=$P($G(^IBD(357.09,1,0)),"^",14)
106 I FIPARAM="" S FIPARAM=25
107 W "PW."_PWPARAM_";" ;set pen width param to file value
108 W "SV1,"_FIPARAM_";" ;set the fill to file value
109 ;
110 S ROW=STARTY
111 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)
112 ;
113 ;draw boxes
114 W "PW.4;" ;set pen width to .4 mm
115 W "SV1,100;" ;set the fill to 100%
116 S ROW=STARTY
117 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
118 .S NODE=$G(@IBARRAY("BOXES")@(ROW,COL,BLK)) S WIDTH=$P(NODE,"^"),HT=$P(NODE,"^",2) D DRWBOX(ROW#PERPAGE,COL,WIDTH,HT)
119 ;
120 ;draw hand print fields
121 ;W "PW.12;" ;set pen width to .12 mm, patch 3 value
122 ;W "SV1,25;" ;set the fill to 25%, patch 3 value
123 S PWPARAM=$P($G(^IBD(357.09,1,0)),"^",13)
124 I PWPARAM="" S PWPARAM=12
125 S FIPARAM=$P($G(^IBD(357.09,1,0)),"^",14)
126 I FIPARAM="" S FIPARAM=25
127 W "PW."_PWPARAM_";" ;set pen width param to file value
128 W "SV1,"_FIPARAM_";" ;set the fill to file value
129 ;
130 S ROW=STARTY
131 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
132 .S NODE=$G(@IBARRAY("HAND_PRINT")@(ROW,COL,IEN)),WIDTH=+$P(NODE,"^",3),PRNTTYPE=$P(NODE,"^",14) Q:('WIDTH)!('PRNTTYPE)
133 .D HANDPRNT(ROW#PERPAGE,COL,WIDTH,$P(NODE,"^",6),PRNTTYPE,$P(NODE,"^",17))
134 ;
135 S STARTY=LASTY-1
136 W $C(27),"%0A"
137 Q
138 ;
139DRWBBL(Y,X) ;
140 ; -- position is in terms of col,row - change to decipoints
141 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")
142 ;
143 ; -- position the pen
144 W "PA"_(X)_","_(Y)_";"
145 ;
146 ; -- draw the bubble (a little box)
147 W "EA"_(X+87)_","_(Y+45)_";"
148 Q
149 ;
150DRWBOX(Y,X,WIDTH,HT) ;
151 ; -- position is in terms of col,row - change to decipoints
152 S Y=((Y+.75)*IBDEVICE("ROW_HT"))+15,X=(X+.5)*IBDEVICE("COL_WIDTH")
153 ;
154 ;position the pen
155 W "PA"_(X)_","_(Y)_";"
156 ;
157 ;draw the box
158 W "EA"_(X+((WIDTH-1)*IBDEVICE("COL_WIDTH")))_","_(Y+((HT-1.7)*IBDEVICE("ROW_HT")))_";"
159 Q
160 ;
161HANDPRNT(Y,X,WIDTH,LINES,PRNTTYPE,TYPEDATA) ; draw hand print area
162 ; -- FORMAT - contains overlay for the field
163 ; -- UNIT - label to print on the right of print area
164 ; -- PRNTTYPE = could be for ICR (print comb) or not ICR (no comb, different size)
165 N CHAR,FORMAT,UNIT,NODE
166 S NODE=""
167 I $G(TYPEDATA) S NODE=$G(^IBE(359.1,TYPEDATA,0))
168 ;S FORMAT=$$FRMT(NODE,$G(IBAPPT)),UNIT=$P(NODE,"^",11) ;don't use frmt here, cause pre-slugging of data and read when scanning
169 S FORMAT=$P(NODE,"^",5),UNIT=$P(NODE,"^",11)
170 S:LINES'>0 LINES=1
171 I PRNTTYPE=2 D
172 .;change scale from col,row to decipoints
173 .S Y=(Y*IBDEVICE("ROW_HT"))+$S(IBFORM("WIDTH")>96:0,IBFORM("WIDTH")>80:15,1:30),X=X*IBDEVICE("COL_WIDTH")
174 .F Q:LINES'>0 D S LINES=LINES-1,Y=Y+(2*IBDEVICE("ROW_HT"))
175 ..;position the pen
176 ..W !,"PA"_(X)_","_(Y)_";"
177 ..;draw the box
178 ..W "EA"_(X+(172.7654*WIDTH))_","_(Y+(180))_";"
179 ..;print the unit of measurement
180 ..I $L(UNIT) W "SA;","PA"_(X+50+(172.7654*WIDTH))_",",(Y+(120))_";","LB",UNIT,$CHAR(3),"SS;"
181 ..;draw the comb
182 ..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
183 ...;character pre-slug
184 ...W !,"PA"_(X+50+(172.7654*I))_",",(Y+(120))_";"
185 ...W "LB",CHAR,$CHAR(3)
186 ;
187 I PRNTTYPE=1 D
188 .;change scale from col,row to decipoints
189 .S Y=(Y*IBDEVICE("ROW_HT")),X=X*IBDEVICE("COL_WIDTH")
190 .D CNVRTHT^IBDF2D1(LINES,.LINES)
191 .;position the pen
192 .W "PA"_(X)_","_(Y)_";"
193 .;draw the box
194 .W "EA"_(X+(103.6593*WIDTH))_","_(Y+(IBDEVICE("ROW_HT")*LINES))_";"
195 Q
196 ;
197FRMT(ND,ADT) ; -- function returns piece 5 on entries from 359.1
198 ; -- reformats the Checkout/date format for y2k
199 ; -- input nd := zero node from 359.1 for entry
200 ; adt := alternate date (appointment date, when known)
201 N FRMT
202 S FRMT=$P(ND,"^",5)
203 I $P(ND,"^")="CHECKOUT DATE@TIME" S $E(FRMT,5)=$S($G(ADT):$E(ADT,2),1:$E(DT,2))
204 Q FRMT
205 ;
206WHITEOUT ; -- puts white space around the anchors
207 ; helps insure that the anchors can be located
208 ;
209 Q:'IBFORM("SCAN") ;if the form isn't scannable there are no anchors
210 ;
211 W $C(27),"&a0v0H",! ;set top margin to top of page
212 W $C(27),"&l0E"
213 ;
214 ; -- top left corner (ANCHOR 1)
215 W $C(27),"&a354v4H",$C(27),"*c200h60v1P"
216 ;
217 ; -- bottom left (ANCHOR 2)
218 W $C(27),"&a7505v4H",$C(27),"*c200h60v1P"
219 ;
220 ; -- top right (ANCHOR 3)
221 W $C(27),"&a354v5450H",$C(27),"*c400h60v1P"
222 ;
223 ; -- bottom right (ANCHOR 4)
224 W $C(27),"&a7505v5450H",$C(27),"*c400h60v1P"
225 Q
Note: See TracBrowser for help on using the repository browser.