IBDF2F2 ;ALB/AAS - PRINT VA LOGO AS ANCHORS ON ENCOUNTER FORMS ; 25-JUNE-97
;;3.0;AUTOMATED INFO COLLECTION SYS;**3**;APR 24, 1997
;
ANCHORS ; -- print anchors,
; escape &a positions cursor at specified vert and horiz decipoints
; escape &f1y2X prints macro #1
;
; -- old anchors composed of two narrow rectangles
; escape *c prints rectangle of specified vert and horiz decipoints
; 0P is for complete fill.
;
D MACRO
;
; -- top left corner (ANCHOR 1)
W !,$C(27),"&a184v4H",$C(27),"&f1y2X"
;
; -- top right (ANCHOR 3)
W !,$C(27),"&a184v5534H",$C(27),"&f1y2X"
;
; -- bottom left (ANCHOR 4)
W !,$C(27),"&a7615v4H",$C(27),"&f1y2X"
;
; -- scannable page
I $G(IBFORM("SCAN",PAGE)),'$G(IBDSAMP) W $C(27),"&a7576v3400H",$C(27),"&f1y2X"
;
;bottom right (ANCHOR 6)
W $C(27),"&a7615v5534H",$C(27),"&f1y2X"
Q
;
MACRO ; -- build macro for printing va logo
; -- position cursor before printing macro
W $C(27),"&f1Y" ; define marco as #1
W !
W $C(27),"&f0X" ; start macro definition
D VALOGO
W $C(27),"&f1X" ; stop macro definition
W !
W $C(27),"&f1y10X" ; make macro permanent, still defined after reset
Q
;
VALOGO ; -- Raster Graphic print of VA LOGO
; -- position curser before calling directly
W $C(27),"*t150R" ; raster graphics at (75,150,or 300) dots per inch
W $C(27),"*r0F" ; presentation mode orientation of logical page
W $C(27),"*r1A" ; sets the left graphics margin to current x
; -- begin raster data
1 W $C(27),"*b5W",$C(3),$C(224),$C(15),$C(248),$C(0)
2 W $C(27),"*b5W",$C(7),$C(240),$C(15),$C(248),$C(0)
3 W $C(27),"*b5W",$C(15),$C(240),$C(31),$C(252),$C(0)
4 ;W $C(27),"*b5W",$C(15),$C(248),$C(31),$C(252),$C(0)
5 W $C(27),"*b5W",$C(15),$C(248),$C(31),$C(254),$C(0)
6 W $C(27),"*b5W",$C(31),$C(252),$C(63),$C(254),$C(0)
7 W $C(27),"*b5W",$C(31),$C(252),$C(63),$C(255),$C(0)
8 W $C(27),"*b5W",$C(32),$C(254),$C(112),$C(63),$C(0)
9 W $C(27),"*b5W",$C(32),$C(254),$C(112),$C(63),$C(128)
10 W $C(27),"*b5W",$C(96),$C(126),$C(112),$C(31),$C(128)
11 W $C(27),"*b5W",$C(112),$C(127),$C(224),$C(15),$C(192)
12 W $C(27),"*b5W",$C(240),$C(127),$C(224),$C(15),$C(192)
13 W $C(27),"*b5W",$C(248),$C(63),$C(193),$C(7),$C(224)
14 W $C(27),"*b5W",$C(252),$C(63),$C(193),$C(7),$C(224)
15 W $C(27),"*b5W",$C(252),$C(31),$C(195),$C(131),$C(240)
16 W $C(27),"*b5W",$C(126),$C(15),$C(195),$C(131),$C(240)
17 W $C(27),"*b5W",$C(126),$C(15),$C(131),$C(131),$C(240)
18 W $C(27),"*b5W",$C(63),$C(7),$C(135),$C(193),$C(248)
19 W $C(27),"*b5W",$C(63),$C(3),$C(135),$C(193),$C(248)
20 W $C(27),"*b5W",$C(31),$C(131),$C(7),$C(224),$C(252)
21 W $C(27),"*b5W",$C(31),$C(129),$C(15),$C(224),$C(252)
22 W $C(27),"*b5W",$C(15),$C(193),$C(15),$C(240),$C(124)
23 W $C(27),"*b5W",$C(15),$C(192),$C(12),$C(0),$C(120)
24 W $C(27),"*b5W",$C(7),$C(224),$C(30),$C(0),$C(120)
25 W $C(27),"*b5W",$C(7),$C(224),$C(30),$C(0),$C(56)
26 W $C(27),"*b5W",$C(3),$C(240),$C(63),$C(0),$C(48)
27 W $C(27),"*b5W",$C(3),$C(240),$C(63),$C(0),$C(16)
28 W $C(27),"*b5W",$C(1),$C(255),$C(255),$C(255),$C(240)
29 W $C(27),"*b5W",$C(1),$C(255),$C(255),$C(255),$C(224)
30 W $C(27),"*b5W",$C(0),$C(255),$C(255),$C(255),$C(224)
31 W $C(27),"*b5W",$C(0),$C(255),$C(239),$C(255),$C(192)
32 ;W $C(27),"*b5W",$C(0),$C(127),$C(239),$C(255),$C(192)
33 W $C(27),"*b5W",$C(0),$C(127),$C(199),$C(255),$C(128)
34 W $C(27),"*b5W",$C(0),$C(63),$C(131),$C(255),$C(128)
W $C(27),"*rB" ; signifies the end of the raster graphic
Q
;
TESTM ; -- Test macro printing
S PAGE=1,IBFORM("SCAN",PAGE)=1,IBDSAMP=0
D ^%ZIS G:POP END
U IO
;
; -- sets top of page
W $C(27),"&l0E"
W !
D ANCHORS
END D ^%ZISC
K PAGE,IBDFORM,IBDSAMP
Q
;
TESTD ; -- Test printing without macro
S PAGE=1,IBFORM("SCAN",PAGE)=1,IBDSAMP=0
D ^%ZIS G:POP END1
U IO
;
; -- sets top of page
W $C(27),"&l0E"
W !
D DIRECT
END1 D ^%ZISC
K PAGE,IBFORM,IBDSAMP
Q
DIRECT ; -- print logo direct without macros
; -- top left corner (ANCHOR 1)
W !,$C(27),"&a184v4H",$C(27) D VALOGO
;
; -- top right (ANCHOR 3)
W !,$C(27),"&a184v5534H" D VALOGO
;
W !!!,"PRINTING ANCHORS DIRECTLY, NO MACRO"
;
; -- bottom left (ANCHOR 4)
W !,$C(27),"&a7615v4H" D VALOGO
;
; -- scannable page
I $G(IBFORM("SCAN",PAGE)),'$G(IBDSAMP) W $C(27),"&a7576v3400H" D VALOGO
;
;bottom right (ANCHOR 6)
W $C(27),"&a7615v5534H" D VALOGO
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF2F2 4436 printed Nov 22, 2024@18:01:33 Page 2
IBDF2F2 ;ALB/AAS - PRINT VA LOGO AS ANCHORS ON ENCOUNTER FORMS ; 25-JUNE-97
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**3**;APR 24, 1997
+2 ;
ANCHORS ; -- print anchors,
+1 ; escape &a positions cursor at specified vert and horiz decipoints
+2 ; escape &f1y2X prints macro #1
+3 ;
+4 ; -- old anchors composed of two narrow rectangles
+5 ; escape *c prints rectangle of specified vert and horiz decipoints
+6 ; 0P is for complete fill.
+7 ;
+8 DO MACRO
+9 ;
+10 ; -- top left corner (ANCHOR 1)
+11 WRITE !,$CHAR(27),"&a184v4H",$CHAR(27),"&f1y2X"
+12 ;
+13 ; -- top right (ANCHOR 3)
+14 WRITE !,$CHAR(27),"&a184v5534H",$CHAR(27),"&f1y2X"
+15 ;
+16 ; -- bottom left (ANCHOR 4)
+17 WRITE !,$CHAR(27),"&a7615v4H",$CHAR(27),"&f1y2X"
+18 ;
+19 ; -- scannable page
+20 IF $GET(IBFORM("SCAN",PAGE))
IF '$GET(IBDSAMP)
WRITE $CHAR(27),"&a7576v3400H",$CHAR(27),"&f1y2X"
+21 ;
+22 ;bottom right (ANCHOR 6)
+23 WRITE $CHAR(27),"&a7615v5534H",$CHAR(27),"&f1y2X"
+24 QUIT
+25 ;
MACRO ; -- build macro for printing va logo
+1 ; -- position cursor before printing macro
+2 ; define marco as #1
WRITE $CHAR(27),"&f1Y"
+3 WRITE !
+4 ; start macro definition
WRITE $CHAR(27),"&f0X"
+5 DO VALOGO
+6 ; stop macro definition
WRITE $CHAR(27),"&f1X"
+7 WRITE !
+8 ; make macro permanent, still defined after reset
WRITE $CHAR(27),"&f1y10X"
+9 QUIT
+10 ;
VALOGO ; -- Raster Graphic print of VA LOGO
+1 ; -- position curser before calling directly
+2 ; raster graphics at (75,150,or 300) dots per inch
WRITE $CHAR(27),"*t150R"
+3 ; presentation mode orientation of logical page
WRITE $CHAR(27),"*r0F"
+4 ; sets the left graphics margin to current x
WRITE $CHAR(27),"*r1A"
+5 ; -- begin raster data
1 WRITE $CHAR(27),"*b5W",$CHAR(3),$CHAR(224),$CHAR(15),$CHAR(248),$CHAR(0)
2 WRITE $CHAR(27),"*b5W",$CHAR(7),$CHAR(240),$CHAR(15),$CHAR(248),$CHAR(0)
3 WRITE $CHAR(27),"*b5W",$CHAR(15),$CHAR(240),$CHAR(31),$CHAR(252),$CHAR(0)
4 ;W $C(27),"*b5W",$C(15),$C(248),$C(31),$C(252),$C(0)
5 WRITE $CHAR(27),"*b5W",$CHAR(15),$CHAR(248),$CHAR(31),$CHAR(254),$CHAR(0)
6 WRITE $CHAR(27),"*b5W",$CHAR(31),$CHAR(252),$CHAR(63),$CHAR(254),$CHAR(0)
7 WRITE $CHAR(27),"*b5W",$CHAR(31),$CHAR(252),$CHAR(63),$CHAR(255),$CHAR(0)
8 WRITE $CHAR(27),"*b5W",$CHAR(32),$CHAR(254),$CHAR(112),$CHAR(63),$CHAR(0)
9 WRITE $CHAR(27),"*b5W",$CHAR(32),$CHAR(254),$CHAR(112),$CHAR(63),$CHAR(128)
10 WRITE $CHAR(27),"*b5W",$CHAR(96),$CHAR(126),$CHAR(112),$CHAR(31),$CHAR(128)
11 WRITE $CHAR(27),"*b5W",$CHAR(112),$CHAR(127),$CHAR(224),$CHAR(15),$CHAR(192)
12 WRITE $CHAR(27),"*b5W",$CHAR(240),$CHAR(127),$CHAR(224),$CHAR(15),$CHAR(192)
13 WRITE $CHAR(27),"*b5W",$CHAR(248),$CHAR(63),$CHAR(193),$CHAR(7),$CHAR(224)
14 WRITE $CHAR(27),"*b5W",$CHAR(252),$CHAR(63),$CHAR(193),$CHAR(7),$CHAR(224)
15 WRITE $CHAR(27),"*b5W",$CHAR(252),$CHAR(31),$CHAR(195),$CHAR(131),$CHAR(240)
16 WRITE $CHAR(27),"*b5W",$CHAR(126),$CHAR(15),$CHAR(195),$CHAR(131),$CHAR(240)
17 WRITE $CHAR(27),"*b5W",$CHAR(126),$CHAR(15),$CHAR(131),$CHAR(131),$CHAR(240)
18 WRITE $CHAR(27),"*b5W",$CHAR(63),$CHAR(7),$CHAR(135),$CHAR(193),$CHAR(248)
19 WRITE $CHAR(27),"*b5W",$CHAR(63),$CHAR(3),$CHAR(135),$CHAR(193),$CHAR(248)
20 WRITE $CHAR(27),"*b5W",$CHAR(31),$CHAR(131),$CHAR(7),$CHAR(224),$CHAR(252)
21 WRITE $CHAR(27),"*b5W",$CHAR(31),$CHAR(129),$CHAR(15),$CHAR(224),$CHAR(252)
22 WRITE $CHAR(27),"*b5W",$CHAR(15),$CHAR(193),$CHAR(15),$CHAR(240),$CHAR(124)
23 WRITE $CHAR(27),"*b5W",$CHAR(15),$CHAR(192),$CHAR(12),$CHAR(0),$CHAR(120)
24 WRITE $CHAR(27),"*b5W",$CHAR(7),$CHAR(224),$CHAR(30),$CHAR(0),$CHAR(120)
25 WRITE $CHAR(27),"*b5W",$CHAR(7),$CHAR(224),$CHAR(30),$CHAR(0),$CHAR(56)
26 WRITE $CHAR(27),"*b5W",$CHAR(3),$CHAR(240),$CHAR(63),$CHAR(0),$CHAR(48)
27 WRITE $CHAR(27),"*b5W",$CHAR(3),$CHAR(240),$CHAR(63),$CHAR(0),$CHAR(16)
28 WRITE $CHAR(27),"*b5W",$CHAR(1),$CHAR(255),$CHAR(255),$CHAR(255),$CHAR(240)
29 WRITE $CHAR(27),"*b5W",$CHAR(1),$CHAR(255),$CHAR(255),$CHAR(255),$CHAR(224)
30 WRITE $CHAR(27),"*b5W",$CHAR(0),$CHAR(255),$CHAR(255),$CHAR(255),$CHAR(224)
31 WRITE $CHAR(27),"*b5W",$CHAR(0),$CHAR(255),$CHAR(239),$CHAR(255),$CHAR(192)
32 ;W $C(27),"*b5W",$C(0),$C(127),$C(239),$C(255),$C(192)
33 WRITE $CHAR(27),"*b5W",$CHAR(0),$CHAR(127),$CHAR(199),$CHAR(255),$CHAR(128)
34 WRITE $CHAR(27),"*b5W",$CHAR(0),$CHAR(63),$CHAR(131),$CHAR(255),$CHAR(128)
+1 ; signifies the end of the raster graphic
WRITE $CHAR(27),"*rB"
+2 QUIT
+3 ;
TESTM ; -- Test macro printing
+1 SET PAGE=1
SET IBFORM("SCAN",PAGE)=1
SET IBDSAMP=0
+2 DO ^%ZIS
if POP
GOTO END
+3 USE IO
+4 ;
+5 ; -- sets top of page
+6 WRITE $CHAR(27),"&l0E"
+7 WRITE !
+8 DO ANCHORS
END DO ^%ZISC
+1 KILL PAGE,IBDFORM,IBDSAMP
+2 QUIT
+3 ;
TESTD ; -- Test printing without macro
+1 SET PAGE=1
SET IBFORM("SCAN",PAGE)=1
SET IBDSAMP=0
+2 DO ^%ZIS
if POP
GOTO END1
+3 USE IO
+4 ;
+5 ; -- sets top of page
+6 WRITE $CHAR(27),"&l0E"
+7 WRITE !
+8 DO DIRECT
END1 DO ^%ZISC
+1 KILL PAGE,IBFORM,IBDSAMP
+2 QUIT
DIRECT ; -- print logo direct without macros
+1 ; -- top left corner (ANCHOR 1)
+2 WRITE !,$CHAR(27),"&a184v4H",$CHAR(27)
DO VALOGO
+3 ;
+4 ; -- top right (ANCHOR 3)
+5 WRITE !,$CHAR(27),"&a184v5534H"
DO VALOGO
+6 ;
+7 WRITE !!!,"PRINTING ANCHORS DIRECTLY, NO MACRO"
+8 ;
+9 ; -- bottom left (ANCHOR 4)
+10 WRITE !,$CHAR(27),"&a7615v4H"
DO VALOGO
+11 ;
+12 ; -- scannable page
+13 IF $GET(IBFORM("SCAN",PAGE))
IF '$GET(IBDSAMP)
WRITE $CHAR(27),"&a7576v3400H"
DO VALOGO
+14 ;
+15 ;bottom right (ANCHOR 6)
+16 WRITE $CHAR(27),"&a7615v5534H"
DO VALOGO
+17 QUIT
