IBDF2F2.m

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 ---IBDF2F2   4436     printed  Feb 19, 2025@00:17:48                                                                                                                                                                                                     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