IBDF2F1 ;ALB/CJM - ENCOUNTER FORM - PRINT FORM(sends to printer) ;NOV 16,1992
;;3.0;AUTOMATED INFO COLLECTION SYS;**3**;APR 24, 1997
;
REGISTER(PAGE) ;registration for scanning, form # and patient at bottom
N PAGECHK,TYPECHK,IDCHK,VA
I IBDEVICE("PCL") D
.I IBFORM("SCAN") D
..;calculate the checksums
..S PAGECHK=(3*PAGE)#29,TYPECHK=(3*IBFORM("TYPE"))#997,IDCHK=(3*(+$G(IBPFID)))#997
.;set top margin to top of page
.W $C(27),"&l0E"
.W $C(27),"&a0v0H",!
.;
.I IBFORM("SCAN") D ANCHORS^IBDF2F2
.;
.;I $G(IBFORM("SCAN",PAGE)) D
.; -- black box used to determine if page has data for scanning
.; but not for sample forms
.;I '$G(IBDSAMP) W $C(27),"&a7576v3400H",$C(27),"&f1y2X",$C(27)
.;I '$G(IBDSAMP) W $C(27),"&a7576v3400H",$C(27),"*c140h140v0P",$C(27)
.;
.;define font for OCR'd text
.W $C(27),")s1p10h14v0s0b3T"
.;define font for non-OCR' text
.W $C(27)_"(s0p16.67h8.5v0s0b0T"
.;print the form identifiers
.W $C(27),"&a330h300V",! ; new line needed to get rest of line to print okay
.W ! ; new line needed to get rest of line to print okay
.W $C(27),"&a330h300V",$C(15),"FORM:",$C(27),"&a650H",$C(14),IBFORM("TYPE")
.W $C(27),"&a1470H",$C(15),"ID:",$C(27),"&a1700H",$C(14),$G(IBPFID)
.W $C(27),"&a4830H",$C(15),"PAGE:",$C(27),"&a5150H",$C(14),PAGE
.;
.;is the page going to be scanned?
.I $G(IBFORM("SCAN",PAGE)),$G(IBPFID) D
..;Populating the scannable pages field in the forms tracking file
..;#357.96. This is used when scanning the EF to make sure all
..;scannable pages have been scanned before data is filed in PCE.
..I '$D(^IBD(357.96,IBPFID,9,PAGE,0)) D
...S DIC="^IBD(357.96,IBPFID,9,",DIC(0)="L",DIC("P")=$P(^DD(357.96,9,0),"^",2),DA(1)=IBPFID,X=PAGE,DLAYGO=357.96 K DD,DO D FILE^DICN K DIC,DA,DLAYGO,DD,DO
..;print the checksums
..W $C(14),$C(27),"&a3400H",TYPECHK,$C(27),"&a3900H",IDCHK,$C(27),"&a4400H",PAGECHK
.;
NAM .;print form id, etc. on bottom of form
.D
..W !,$C(15),$C(27),"&a300h7710V"
..I $G(IBDSAMP) W "Sample Form: ",$P($G(^IBE(357,+$G(IBFORM),0)),"^") Q
..S X=$G(^TMP("IB",$J,"INTERFACES",+$G(DFN),"DPT PATIENT'S NAME"))
..W:X'="" X W:X="" $P($G(^DPT(+$G(DFN),0)),"^")
.;
.D
..W $C(27),"&a1900H"
..I $G(IBDSAMP) W "Clinic: ",$P($G(^SC(+$G(IBCLINIC),0)),"^") Q
..S X=$G(^TMP("IB",$J,"INTERFACES",+$G(DFN),"DPT PATIENT'S PID"))
..W:X'="" X I X="",+$G(DFN) D PID^VADPT W VA("PID")
.;
.W $C(27),"&a4200H","VA FORM 10-0360 APR 1994"
.W $C(27),"&a4200h7620V","Station: ",$P($$SITE^VASITE,"^",3)
.I $G(REPRINT) W $C(27),"&a1900H","**REPRINT**"
.;
.;reset the primary font & top margin, position cursor at the top
.;reset the font for body of form
.D
..I IBFORM("WIDTH")>96 W $C(27)_"(s0p16.67h8.5v0s0b0T" Q
..I IBFORM("WIDTH")>80 W $C(27)_"(s0p12h10v0s0b0T" Q
..W $C(27)_"(s0p10h12v0s0b0T"
.;set top margin to leave 4 lines at top
.W $C(27),"&l4E"
.;set cursor to top left
.W $C(27),"&a0c0R"
;
;move cursor to top left
I '(IBFORM("SCAN")&IBDEVICE("PCL")),IBDEVICE("RASTER") S (DX,DY)=0 X IOXY K DX,DY
Q
;
;this call replaced by call to achors^ibdf2f2
ANCHORS ; -- print anchors, anchors composed of two narrow rectangles
; escape &a positions cursor at specified vert and horiz decipoints
; escape *c prints rectangle of specified vert and horiz decipoints
; 0P is for complete fill.
;
Q
W !
; -- top left corner (ANCHOR 1)
W $C(27),"&a184v4H",$C(27),"*c12h120v0P",$C(27),"*c124h12v0P"
;
; -- top right (ANCHOR 3)
W $C(27),"&a184v5534H",$C(27),"*c116h12v0P",$C(27),"&a184v5650H",$C(27),"*c12h120v0P"
;
; -- bottom left (ANCHOR 4)
W !,$C(27),"&a7732v4H",$C(27),"*c124h12v0P",$C(27),"&a7615v4H",$C(27),"*c12h121v0P"
;
; -- bottom right (ANCHOR 6)
W $C(27),"&a7732v5534H",$C(27),"*c116h12v0P",$C(27),"&a7616v5650H",$C(27),"*c12h120v0P"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF2F1 3861 printed Apr 09, 2024@21:31:21 Page 2
IBDF2F1 ;ALB/CJM - ENCOUNTER FORM - PRINT FORM(sends to printer) ;NOV 16,1992
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**3**;APR 24, 1997
+2 ;
REGISTER(PAGE) ;registration for scanning, form # and patient at bottom
+1 NEW PAGECHK,TYPECHK,IDCHK,VA
+2 IF IBDEVICE("PCL")
Begin DoDot:1
+3 IF IBFORM("SCAN")
Begin DoDot:2
+4 ;calculate the checksums
+5 SET PAGECHK=(3*PAGE)#29
SET TYPECHK=(3*IBFORM("TYPE"))#997
SET IDCHK=(3*(+$GET(IBPFID)))#997
End DoDot:2
+6 ;set top margin to top of page
+7 WRITE $CHAR(27),"&l0E"
+8 WRITE $CHAR(27),"&a0v0H",!
+9 ;
+10 IF IBFORM("SCAN")
DO ANCHORS^IBDF2F2
+11 ;
+12 ;I $G(IBFORM("SCAN",PAGE)) D
+13 ; -- black box used to determine if page has data for scanning
+14 ; but not for sample forms
+15 ;I '$G(IBDSAMP) W $C(27),"&a7576v3400H",$C(27),"&f1y2X",$C(27)
+16 ;I '$G(IBDSAMP) W $C(27),"&a7576v3400H",$C(27),"*c140h140v0P",$C(27)
+17 ;
+18 ;define font for OCR'd text
+19 WRITE $CHAR(27),")s1p10h14v0s0b3T"
+20 ;define font for non-OCR' text
+21 WRITE $CHAR(27)_"(s0p16.67h8.5v0s0b0T"
+22 ;print the form identifiers
+23 ; new line needed to get rest of line to print okay
WRITE $CHAR(27),"&a330h300V",!
+24 ; new line needed to get rest of line to print okay
WRITE !
+25 WRITE $CHAR(27),"&a330h300V",$CHAR(15),"FORM:",$CHAR(27),"&a650H",$CHAR(14),IBFORM("TYPE")
+26 WRITE $CHAR(27),"&a1470H",$CHAR(15),"ID:",$CHAR(27),"&a1700H",$CHAR(14),$GET(IBPFID)
+27 WRITE $CHAR(27),"&a4830H",$CHAR(15),"PAGE:",$CHAR(27),"&a5150H",$CHAR(14),PAGE
+28 ;
+29 ;is the page going to be scanned?
+30 IF $GET(IBFORM("SCAN",PAGE))
IF $GET(IBPFID)
Begin DoDot:2
+31 ;Populating the scannable pages field in the forms tracking file
+32 ;#357.96. This is used when scanning the EF to make sure all
+33 ;scannable pages have been scanned before data is filed in PCE.
+34 IF '$DATA(^IBD(357.96,IBPFID,9,PAGE,0))
Begin DoDot:3
+35 SET DIC="^IBD(357.96,IBPFID,9,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(357.96,9,0),"^",2)
SET DA(1)=IBPFID
SET X=PAGE
SET DLAYGO=357.96
KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DLAYGO,DD,DO
End DoDot:3
+36 ;print the checksums
+37 WRITE $CHAR(14),$CHAR(27),"&a3400H",TYPECHK,$CHAR(27),"&a3900H",IDCHK,$CHAR(27),"&a4400H",PAGECHK
End DoDot:2
+38 ;
NAM ;print form id, etc. on bottom of form
+1 Begin DoDot:2
+2 WRITE !,$CHAR(15),$CHAR(27),"&a300h7710V"
+3 IF $GET(IBDSAMP)
WRITE "Sample Form: ",$PIECE($GET(^IBE(357,+$GET(IBFORM),0)),"^")
QUIT
+4 SET X=$GET(^TMP("IB",$JOB,"INTERFACES",+$GET(DFN),"DPT PATIENT'S NAME"))
+5 if X'=""
WRITE X
if X=""
WRITE $PIECE($GET(^DPT(+$GET(DFN),0)),"^")
End DoDot:2
+6 ;
+7 Begin DoDot:2
+8 WRITE $CHAR(27),"&a1900H"
+9 IF $GET(IBDSAMP)
WRITE "Clinic: ",$PIECE($GET(^SC(+$GET(IBCLINIC),0)),"^")
QUIT
+10 SET X=$GET(^TMP("IB",$JOB,"INTERFACES",+$GET(DFN),"DPT PATIENT'S PID"))
+11 if X'=""
WRITE X
IF X=""
IF +$GET(DFN)
DO PID^VADPT
WRITE VA("PID")
End DoDot:2
+12 ;
+13 WRITE $CHAR(27),"&a4200H","VA FORM 10-0360 APR 1994"
+14 WRITE $CHAR(27),"&a4200h7620V","Station: ",$PIECE($$SITE^VASITE,"^",3)
+15 IF $GET(REPRINT)
WRITE $CHAR(27),"&a1900H","**REPRINT**"
+16 ;
+17 ;reset the primary font & top margin, position cursor at the top
+18 ;reset the font for body of form
+19 Begin DoDot:2
+20 IF IBFORM("WIDTH")>96
WRITE $CHAR(27)_"(s0p16.67h8.5v0s0b0T"
QUIT
+21 IF IBFORM("WIDTH")>80
WRITE $CHAR(27)_"(s0p12h10v0s0b0T"
QUIT
+22 WRITE $CHAR(27)_"(s0p10h12v0s0b0T"
End DoDot:2
+23 ;set top margin to leave 4 lines at top
+24 WRITE $CHAR(27),"&l4E"
+25 ;set cursor to top left
+26 WRITE $CHAR(27),"&a0c0R"
End DoDot:1
+27 ;
+28 ;move cursor to top left
+29 IF '(IBFORM("SCAN")&IBDEVICE("PCL"))
IF IBDEVICE("RASTER")
SET (DX,DY)=0
XECUTE IOXY
KILL DX,DY
+30 QUIT
+31 ;
+32 ;this call replaced by call to achors^ibdf2f2
ANCHORS ; -- print anchors, anchors composed of two narrow rectangles
+1 ; escape &a positions cursor at specified vert and horiz decipoints
+2 ; escape *c prints rectangle of specified vert and horiz decipoints
+3 ; 0P is for complete fill.
+4 ;
+5 QUIT
+6 WRITE !
+7 ; -- top left corner (ANCHOR 1)
+8 WRITE $CHAR(27),"&a184v4H",$CHAR(27),"*c12h120v0P",$CHAR(27),"*c124h12v0P"
+9 ;
+10 ; -- top right (ANCHOR 3)
+11 WRITE $CHAR(27),"&a184v5534H",$CHAR(27),"*c116h12v0P",$CHAR(27),"&a184v5650H",$CHAR(27),"*c12h120v0P"
+12 ;
+13 ; -- bottom left (ANCHOR 4)
+14 WRITE !,$CHAR(27),"&a7732v4H",$CHAR(27),"*c124h12v0P",$CHAR(27),"&a7615v4H",$CHAR(27),"*c12h121v0P"
+15 ;
+16 ; -- bottom right (ANCHOR 6)
+17 WRITE $CHAR(27),"&a7732v5534H",$CHAR(27),"*c116h12v0P",$CHAR(27),"&a7616v5650H",$CHAR(27),"*c12h120v0P"
+18 QUIT
