IBDF2A ;ALB/CJM - ENCOUNTER FORM (builds form and prints it) ;NOV 16,1992
;;3.0;AUTOMATED INFO COLLECTION SYS;**1,46**;APR 24, 1997
FORM(IBFORM,WITHDATA) ;prints FORM - defines IBDEVICE array
;input variables - IBFORM=ien of the form, WITHDATA=1 if the form should be completed with data
;
N IBDEVICE
;
D DEVICE^IBDFUA(0,.IBDEVICE)
D DRWFORM(IBFORM,WITHDATA,.IBDEVICE)
EXIT ;
;
D KPRNTVAR^IBDFUA ;kills the screen and graphics parameters
K X,Y,I
Q
DRWFORM(IBFORM,WITHDATA,IBDEVICE) ;prints IBFORM - IBDEVICE array already defined, must be passed by reference
N RTNLIST,NODE,IBPFID,IBARRAY,LINES,HAND,IBPRINT,TYPE,UNIT,PRINT,REPRINT
;
Q:'$$FORMDSCR^IBDFU1C(.IBFORM)
D PRNTPRMS^IBDFU1C(.IBPRINT,WITHDATA,1,0,1)
;
D DEVSETUP^IBDF2A1(.IBFORM,.IBDEVICE)
K ^TMP("IB",$J,"INTERFACES"),^TMP("IBDF",$J,"FORM"),^("OVERFLOW")
S IBPFID=""
;
;for forms other than toolkit, always use compiled version
I 'IBFORM("TOOLKIT"),'IBFORM("COMPILED") D COMPILE^IBDF19 Q:'IBFORM("COMPILED")
;
S REPRINT=0
;if printing a form with patient data to paper get id for form tracking
I '$G(IBDSAMP),IBFORM("COMPILED"),IBPRINT("WITH_DATA"),'IBDEVICE("CRT") S IBPFID=+$$FID^IBDF18C(DFN,IBAPPT,1,IBFORM("TYPE"),IBCLINIC) I $P($G(^IBD(357.96,+IBPFID,1,0)),"^",4) S REPRINT=1
;
D ARRAYS^IBDFU1C(.IBFORM,.IBARRAY)
I 'IBFORM("TOOLKIT"),WITHDATA D JUSTDATA(WITHDATA)
I IBFORM("TOOLKIT") D DRWBLKS
;
;if no graphics and not PCL replace graphics with something printable
I 'IBDEVICE("PCL") D REPLACE
;
;can not do underlining on a CRT
I IBDEVICE("CRT") S IBARRAY("UNDERLINES")="IBARRAY(""UNDERLINES"")"
;
;print the form
D LNPRINT^IBDF2F($G(IBPFID))
;
;print the overflow report
D OVERFLOW^IBDF1B3
;
K ^TMP("IB",$J,"INTERFACES"),^TMP("IBDF",$J,"FORM")
;
;reset printer defaults if PCL5
I $G(IBDEVICE("PCL")) D
. X $G(^%ZIS(2,$G(IOST(0)),2))
Q
;
DRWBLKS ;draws all the form's blocks
N IBBLK,RTNLIST
S IBBLK="" F S IBBLK=$O(^IBE(357.1,"C",IBFORM,IBBLK)) Q:'IBBLK D DRWBLOCK^IBDF2A1(IBBLK,0)
Q
;
JUSTDATA(WITHDATA) ;draws the form's data fields and dynamic selection lists, just the portion that may change with data
;WITHDATA means to fill in with data
;
N IBBLK,RTNLIST,IBFLD,IBLIST,SUB,NODE,IBPRINT
;
D PRNTPRMS^IBDFU1C(.IBPRINT,WITHDATA,0,0,1)
;
I IBDEVICE("LISTMAN") N IBWARN S IBWARN=0
S IBBLK="" F S IBBLK=$O(^IBE(357.1,"C",IBFORM,IBBLK)) Q:'IBBLK D
.Q:$$BLKDESCR^IBDFU1B(.IBBLK)
.S IBFLD="" F S IBFLD=$O(^IBE(357.5,"C",IBBLK,IBFLD)) Q:'IBFLD D DATAFLD^IBDF2B(IBFLD)
.S:'IBPRINT("WITH_DATA") IBPRINT("ENTIRE")=1 S IBLIST="" F S IBLIST=$O(^IBE(357.2,"AD",IBBLK,IBLIST)) Q:'IBLIST D PRINTLST^IBDF2D(IBLIST)
.I IBDEVICE("LISTMAN") S SUB=0 F S SUB=$O(^IBE(357.1,IBBLK,"B",SUB)) Q:'SUB S NODE=$G(^IBE(357.1,IBBLK,"B",SUB,0)) D DRWSTR^IBDFU(+$P(NODE,"^")\1,+$P(NODE,"^",2),"[ ]")
Q
;
REPLACE ;replace objects requiring PCL with plain text
N IBROW,IBCOL,IBBLK
D PRNTPRMS^IBDFU1C(.IBPRINT,0,1,0,1)
S IBBLK("X")=0,IBBLK("Y")=0
I 'IBDEVICE("GRAPHICS") D
.S IBROW="" F S IBROW=$O(@IBARRAY("GRAPHICS")@(IBROW)) Q:IBROW="" S IBCOL="" F S IBCOL=$O(@IBARRAY("GRAPHICS")@(IBROW,IBCOL)) Q:IBCOL="" D DRWSTR^IBDFU(IBROW,IBCOL,$G(@IBARRAY("GRAPHICS")@(IBROW,IBCOL)),"G")
.S IBARRAY("GRAPHICS")="IBARRAY(""GRAPHICS"")"
;
;replace bubbles with "[ ]"
S IBROW="" F S IBROW=$O(@IBARRAY("BUBBLES")@(IBROW)) Q:IBROW="" S IBCOL="" F S IBCOL=$O(@IBARRAY("BUBBLES")@(IBROW,IBCOL)) Q:IBCOL="" D DRWSTR^IBDFU(IBROW\1,IBCOL,"[ ]")
S IBARRAY("BUBBLES")="IBARRAY(""BUBBLES"")"
;
;now replace hand print fields
S IBROW="" F S IBROW=$O(@IBARRAY("HAND_PRINT")@(IBROW)) Q:IBROW="" S IBCOL="" F S IBCOL=$O(@IBARRAY("HAND_PRINT")@(IBROW,IBCOL)) Q:IBCOL="" S HAND=0 F S HAND=$O(@IBARRAY("HAND_PRINT")@(IBROW,IBCOL,HAND)) Q:'HAND D
.N ROW
.S NODE=$G(@IBARRAY("HAND_PRINT")@(IBROW,IBCOL,HAND)),WIDTH=$P(NODE,"^",3),LINES=$P(NODE,"^",6),TYPE=$P(NODE,"^",14),(UNIT,PRINT)="" I $P(NODE,"^",17) S NODE=$G(^IBE(359.1,$P(NODE,"^",17),0)),UNIT=$P(NODE,"^",11),PRINT=$P(NODE,"^",5)
.Q:('WIDTH)!('TYPE)
.S STRING=""
.S:LINES'>0 LINES=1
.S ROW=IBROW
.I TYPE=1 D CNVRTLEN^IBDF2D1(WIDTH,.WIDTH),CNVRTHT^IBDF2D1(LINES,.LINES)
.I TYPE=2 F Q:LINES'>0 D S LINES=LINES-1,ROW=IBROW+2
..N REPLACE,A,I
..I IBFORM("WIDTH")>96 S $P(STRING,"___|",WIDTH+1)="",REPLACE("_")=" " F I=1:1:$L(PRINT) S A=$E(PRINT,I) S:A'="_" REPLACE(A)=" "_A_" "
..I IBFORM("WIDTH")'>96 S $P(STRING,"__|",WIDTH+1)="",REPLACE("_")=" " F I=1:1:$L(PRINT) S A=$E(PRINT,I) S:A'="_" REPLACE(A)=" "_A_" "
..S:$L(UNIT) STRING=STRING_" "_UNIT
..I $L(PRINT) S PRINT=$$REPLACE^XLFSTR(PRINT,.REPLACE)
..D:$L(PRINT) DRWSTR^IBDFU(ROW,IBCOL,PRINT,"",$L(STRING))
..D DRWSTR^IBDFU(ROW+1,IBCOL,STRING,"",$L(STRING))
.I TYPE=1 S $P(STRING,"_",WIDTH+1)="_" D DRWSTR^IBDFU(ROW+LINES-1,IBCOL,STRING,"")
S IBARRAY("HAND_PRINT")="IBARRAY(""HAND_PRINT"")"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF2A 4947 printed Jan 18, 2025@03:52:23 Page 2
IBDF2A ;ALB/CJM - ENCOUNTER FORM (builds form and prints it) ;NOV 16,1992
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**1,46**;APR 24, 1997
FORM(IBFORM,WITHDATA) ;prints FORM - defines IBDEVICE array
+1 ;input variables - IBFORM=ien of the form, WITHDATA=1 if the form should be completed with data
+2 ;
+3 NEW IBDEVICE
+4 ;
+5 DO DEVICE^IBDFUA(0,.IBDEVICE)
+6 DO DRWFORM(IBFORM,WITHDATA,.IBDEVICE)
EXIT ;
+1 ;
+2 ;kills the screen and graphics parameters
DO KPRNTVAR^IBDFUA
+3 KILL X,Y,I
+4 QUIT
DRWFORM(IBFORM,WITHDATA,IBDEVICE) ;prints IBFORM - IBDEVICE array already defined, must be passed by reference
+1 NEW RTNLIST,NODE,IBPFID,IBARRAY,LINES,HAND,IBPRINT,TYPE,UNIT,PRINT,REPRINT
+2 ;
+3 if '$$FORMDSCR^IBDFU1C(.IBFORM)
QUIT
+4 DO PRNTPRMS^IBDFU1C(.IBPRINT,WITHDATA,1,0,1)
+5 ;
+6 DO DEVSETUP^IBDF2A1(.IBFORM,.IBDEVICE)
+7 KILL ^TMP("IB",$JOB,"INTERFACES"),^TMP("IBDF",$JOB,"FORM"),^("OVERFLOW")
+8 SET IBPFID=""
+9 ;
+10 ;for forms other than toolkit, always use compiled version
+11 IF 'IBFORM("TOOLKIT")
IF 'IBFORM("COMPILED")
DO COMPILE^IBDF19
if 'IBFORM("COMPILED")
QUIT
+12 ;
+13 SET REPRINT=0
+14 ;if printing a form with patient data to paper get id for form tracking
+15 IF '$GET(IBDSAMP)
IF IBFORM("COMPILED")
IF IBPRINT("WITH_DATA")
IF 'IBDEVICE("CRT")
SET IBPFID=+$$FID^IBDF18C(DFN,IBAPPT,1,IBFORM("TYPE"),IBCLINIC)
IF $PIECE($GET(^IBD(357.96,+IBPFID,1,0)),"^",4)
SET REPRINT=1
+16 ;
+17 DO ARRAYS^IBDFU1C(.IBFORM,.IBARRAY)
+18 IF 'IBFORM("TOOLKIT")
IF WITHDATA
DO JUSTDATA(WITHDATA)
+19 IF IBFORM("TOOLKIT")
DO DRWBLKS
+20 ;
+21 ;if no graphics and not PCL replace graphics with something printable
+22 IF 'IBDEVICE("PCL")
DO REPLACE
+23 ;
+24 ;can not do underlining on a CRT
+25 IF IBDEVICE("CRT")
SET IBARRAY("UNDERLINES")="IBARRAY(""UNDERLINES"")"
+26 ;
+27 ;print the form
+28 DO LNPRINT^IBDF2F($GET(IBPFID))
+29 ;
+30 ;print the overflow report
+31 DO OVERFLOW^IBDF1B3
+32 ;
+33 KILL ^TMP("IB",$JOB,"INTERFACES"),^TMP("IBDF",$JOB,"FORM")
+34 ;
+35 ;reset printer defaults if PCL5
+36 IF $GET(IBDEVICE("PCL"))
Begin DoDot:1
+37 XECUTE $GET(^%ZIS(2,$GET(IOST(0)),2))
End DoDot:1
+38 QUIT
+39 ;
DRWBLKS ;draws all the form's blocks
+1 NEW IBBLK,RTNLIST
+2 SET IBBLK=""
FOR
SET IBBLK=$ORDER(^IBE(357.1,"C",IBFORM,IBBLK))
if 'IBBLK
QUIT
DO DRWBLOCK^IBDF2A1(IBBLK,0)
+3 QUIT
+4 ;
JUSTDATA(WITHDATA) ;draws the form's data fields and dynamic selection lists, just the portion that may change with data
+1 ;WITHDATA means to fill in with data
+2 ;
+3 NEW IBBLK,RTNLIST,IBFLD,IBLIST,SUB,NODE,IBPRINT
+4 ;
+5 DO PRNTPRMS^IBDFU1C(.IBPRINT,WITHDATA,0,0,1)
+6 ;
+7 IF IBDEVICE("LISTMAN")
NEW IBWARN
SET IBWARN=0
+8 SET IBBLK=""
FOR
SET IBBLK=$ORDER(^IBE(357.1,"C",IBFORM,IBBLK))
if 'IBBLK
QUIT
Begin DoDot:1
+9 if $$BLKDESCR^IBDFU1B(.IBBLK)
QUIT
+10 SET IBFLD=""
FOR
SET IBFLD=$ORDER(^IBE(357.5,"C",IBBLK,IBFLD))
if 'IBFLD
QUIT
DO DATAFLD^IBDF2B(IBFLD)
+11 if 'IBPRINT("WITH_DATA")
SET IBPRINT("ENTIRE")=1
SET IBLIST=""
FOR
SET IBLIST=$ORDER(^IBE(357.2,"AD",IBBLK,IBLIST))
if 'IBLIST
QUIT
DO PRINTLST^IBDF2D(IBLIST)
+12 IF IBDEVICE("LISTMAN")
SET SUB=0
FOR
SET SUB=$ORDER(^IBE(357.1,IBBLK,"B",SUB))
if 'SUB
QUIT
SET NODE=$GET(^IBE(357.1,IBBLK,"B",SUB,0))
DO DRWSTR^IBDFU(+$PIECE(NODE,"^")\1,+$PIECE(NODE,"^",2),"[ ]")
End DoDot:1
+13 QUIT
+14 ;
REPLACE ;replace objects requiring PCL with plain text
+1 NEW IBROW,IBCOL,IBBLK
+2 DO PRNTPRMS^IBDFU1C(.IBPRINT,0,1,0,1)
+3 SET IBBLK("X")=0
SET IBBLK("Y")=0
+4 IF 'IBDEVICE("GRAPHICS")
Begin DoDot:1
+5 SET IBROW=""
FOR
SET IBROW=$ORDER(@IBARRAY("GRAPHICS")@(IBROW))
if IBROW=""
QUIT
SET IBCOL=""
FOR
SET IBCOL=$ORDER(@IBARRAY("GRAPHICS")@(IBROW,IBCOL))
if IBCOL=""
QUIT
DO DRWSTR^IBDFU(IBROW,IBCOL,$GET(@IBARRAY("GRAPHICS")@(IBROW,IBCOL)),"G")
+6 SET IBARRAY("GRAPHICS")="IBARRAY(""GRAPHICS"")"
End DoDot:1
+7 ;
+8 ;replace bubbles with "[ ]"
+9 SET IBROW=""
FOR
SET IBROW=$ORDER(@IBARRAY("BUBBLES")@(IBROW))
if IBROW=""
QUIT
SET IBCOL=""
FOR
SET IBCOL=$ORDER(@IBARRAY("BUBBLES")@(IBROW,IBCOL))
if IBCOL=""
QUIT
DO DRWSTR^IBDFU(IBROW\1,IBCOL,"[ ]")
+10 SET IBARRAY("BUBBLES")="IBARRAY(""BUBBLES"")"
+11 ;
+12 ;now replace hand print fields
+13 SET IBROW=""
FOR
SET IBROW=$ORDER(@IBARRAY("HAND_PRINT")@(IBROW))
if IBROW=""
QUIT
SET IBCOL=""
FOR
SET IBCOL=$ORDER(@IBARRAY("HAND_PRINT")@(IBROW,IBCOL))
if IBCOL=""
QUIT
SET HAND=0
FOR
SET HAND=$ORDER(@IBARRAY("HAND_PRINT")@(IBROW,IBCOL,HAND))
if 'HAND
QUIT
Begin DoDot:1
+14 NEW ROW
+15 SET NODE=$GET(@IBARRAY("HAND_PRINT")@(IBROW,IBCOL,HAND))
SET WIDTH=$PIECE(NODE,"^",3)
SET LINES=$PIECE(NODE,"^",6)
SET TYPE=$PIECE(NODE,"^",14)
SET (UNIT,PRINT)=""
IF $PIECE(NODE,"^",17)
SET NODE=$GET(^IBE(359.1,$PIECE(NODE,"^",17),0))
SET UNIT=$PIECE(NODE,"^",11)
SET PRINT=$PIECE(NODE,"^",5)
+16 if ('WIDTH)!('TYPE)
QUIT
+17 SET STRING=""
+18 if LINES'>0
SET LINES=1
+19 SET ROW=IBROW
+20 IF TYPE=1
DO CNVRTLEN^IBDF2D1(WIDTH,.WIDTH)
DO CNVRTHT^IBDF2D1(LINES,.LINES)
+21 IF TYPE=2
FOR
if LINES'>0
QUIT
Begin DoDot:2
+22 NEW REPLACE,A,I
+23 IF IBFORM("WIDTH")>96
SET $PIECE(STRING,"___|",WIDTH+1)=""
SET REPLACE("_")=" "
FOR I=1:1:$LENGTH(PRINT)
SET A=$EXTRACT(PRINT,I)
if A'="_"
SET REPLACE(A)=" "_A_" "
+24 IF IBFORM("WIDTH")'>96
SET $PIECE(STRING,"__|",WIDTH+1)=""
SET REPLACE("_")=" "
FOR I=1:1:$LENGTH(PRINT)
SET A=$EXTRACT(PRINT,I)
if A'="_"
SET REPLACE(A)=" "_A_" "
+25 if $LENGTH(UNIT)
SET STRING=STRING_" "_UNIT
+26 IF $LENGTH(PRINT)
SET PRINT=$$REPLACE^XLFSTR(PRINT,.REPLACE)
+27 if $LENGTH(PRINT)
DO DRWSTR^IBDFU(ROW,IBCOL,PRINT,"",$LENGTH(STRING))
+28 DO DRWSTR^IBDFU(ROW+1,IBCOL,STRING,"",$LENGTH(STRING))
End DoDot:2
SET LINES=LINES-1
SET ROW=IBROW+2
+29 IF TYPE=1
SET $PIECE(STRING,"_",WIDTH+1)="_"
DO DRWSTR^IBDFU(ROW+LINES-1,IBCOL,STRING,"")
End DoDot:1
+30 SET IBARRAY("HAND_PRINT")="IBARRAY(""HAND_PRINT"")"
+31 QUIT
