- 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 Feb 19, 2025@00:17:47 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