IBDF2A1 ;ALB/CJM - ENCOUNTER FORM (IBDF2A continued);NOV 16,1992
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
DEVSETUP(IBFORM,IBDEVICE) ;set up the device for the form
;pass IBFORM, IBDEVICE by reference
;sets device to no wrap
;sets "ROW_HT" and "COL_WIDTH" in IBDEVICE
;
S X=0 X $G(^%ZOSF("RM")) K X ;sets device to no wrapping
;
I $G(IBDEVICE("PCL")) D
.S IOSL=IBFORM("PAGE_HT")
.W $C(27),"E"
.I $G(IBDEVICE("RESET"))'="" W @IBDEVICE("RESET")
.S IOINHI=$C(27)_"(s3B",IOINORM=$C(27)_"(s0B"
.S IBDEVICE("DUPLEX_SHORT")=$C(27)_"&l2S",IBDEVICE("SIMPLEX")=$C(27)_"&l0S",IBDEVICE("DUPLEX_LONG")=$C(27)_"&l1S"
.S IORVON=$C(27)_"*v0n1o1T",IORVOFF=$C(27)_"*v0T"
.S IOXY="W $C(27)_""&a""_DX_""c""_DY_""R"""
.;set to paper to letter size, portrait mode
.W $C(27),"&l2a0O"
.D
..I IBFORM("WIDTH")>96 W $C(27)_"(s0p16.67h8.5v0s0b0T" S IBDEVICE("COL_WIDTH")=720/16.67,(IOINHI,IOINORM)="" Q
..I IBFORM("WIDTH")>80 W $C(27)_"(s0p12h10v0s0b0T" S IBDEVICE("COL_WIDTH")=720/12 Q
..W $C(27)_"(s0p10h12v0s0b0T" S IBDEVICE("COL_WIDTH")=720/10
.D
..;!!!!!!!!!!Make the VMI a bit bigger? Seems to look good at VMI=6, and getting too cramped
..;!!!!!!I IBFORM("PAGE_HT")>72 W $C(27),"&l5.6667C" S IBDEVICE("ROW_HT")=85.0005 Q ;sets the VMI=5.6667, to get 8 lines per inch Q
..I IBFORM("PAGE_HT")>72 W $C(27),"&l6C" S IBDEVICE("ROW_HT")=90 Q ;sets the VMI=5.6667, to get 8 lines per inch Q
..I IBFORM("PAGE_HT")>60 W $C(27),"&l6.6667C" S IBDEVICE("ROW_HT")=100.0005 Q ;sets the VMI=6.6667, to get 7.2 lines per inch
..W $C(27),"&l8C" S IBDEVICE("ROW_HT")=120 ;sets the VMI=8, to get 6 lines per inch
;
I '$G(IBDEVICE("PCL")) D
.S (DX,DY)=0 X $G(^%ZOSF("XY")) K DX,DY ;make sure $X,$Y=0
Q
;
DRWBLOCK(IBBLK,NOOFFSET) ;IBBLK should be passed by reference, is an array containing the block description
;NOOFFSET=1 means don't offset the block on the form
;
N IBFIELD,IBLIST,IBLINE,IBTEXT,IBWRTCNT,HDROS,BOX,OPTIONS,WIDTH,SUB,NODE,STRING,IBLINES,TYPE
;
;IBPRINT parameters may be altered durring this routine - make sure the original is restored after execution
D SAVE^IBDF2A2(.IBPRINT,.IBPRINT)
;
Q:$$BLKDESCR^IBDFU1B(.IBBLK)
I $G(NOOFFSET) S (IBBLK("X"),IBBLK("Y"))=0
I (IBBLK("X")'=+IBBLK("X"))!(IBBLK("Y")'=+IBBLK("Y")) G EXIT ;location not known
;
I 'IBPRINT("COMPILING_BLOCKS"),('$D(^IBE(357.1,IBBLK,"S"))!'$D(^IBE(357.1,IBBLK,"V"))!'$D(^IBE(357.1,IBBLK,"B"))!'$D(^IBE(357.1,IBBLK,"H"))) S IBPRINT("COMPILING_BLOCKS")=1,IBPRINT("WRITE_IF_COMPILING")=1
I IBPRINT("COMPILING_BLOCKS") S (IBWRTCNT("S"),IBWRTCNT("V"),IBWRTCNT("B"),IBWRTCNT("H"))=0 D UNCMPBLK^IBDF19(IBBLK)
I 'IBPRINT("COMPILING_BLOCKS") D WCMP^IBDF2A2
I IBPRINT("COMPILING_BLOCKS") D G:'IBPRINT("WRITE_IF_COMPILING") EXIT
.N TEMP S TEMP=IBPRINT("WITH_DATA"),IBPRINT("WITH_DATA")=0
.S IBLIST="" F S IBLIST=$O(^IBE(357.2,"C",IBBLK,IBLIST)) Q:'IBLIST D PRINTLST^IBDF2D(IBLIST)
.S IBFIELD="" F S IBFIELD=$O(^IBE(357.93,"C",IBBLK,IBFIELD)) Q:'IBFIELD D MFLD^IBDF2G(IBFIELD)
.S IBFIELD="" F S IBFIELD=$O(^IBE(359.94,"C",IBBLK,IBFIELD)) Q:'IBFIELD D HFLD^IBDF2H(IBFIELD)
.S ^IBE(357.1,IBBLK,"S",0)="^357.11A^"_IBWRTCNT("S")_"^"_IBWRTCNT("S")
.S ^IBE(357.1,IBBLK,"V",0)="^357.12A^"_IBWRTCNT("V")_"^"_IBWRTCNT("V")
.S ^IBE(357.1,IBBLK,"B",0)="^357.13A^"_IBWRTCNT("B")_"^"_IBWRTCNT("B")
.S ^IBE(357.1,IBBLK,"H",0)="^357.14A^"_IBWRTCNT("H")_"^"_IBWRTCNT("H")
.S IBPRINT("WITH_DATA")=TEMP
;
;now write the uncompiled part of the block
S IBPRINT("COMPILING_BLOCKS")=0
K IBWRTCNT
I IBDEVICE("LISTMAN") N IBWARN S IBWARN=0 ;flag set to 1 if a warning is already displayed - don't want to display multiple warnings, users find it aggravating
S BOX=$S(IBBLK("BOX")=1:1,1:0)
D:BOX DRWBOX^IBDFU(0,0,IBBLK("W"),IBBLK("H"))
I IBBLK("HDR")'="" D
.S HDROS=0
.S WIDTH=IBBLK("W")-(2*BOX)
.S OPTIONS=$TR(IBBLK("HDISP"),"C","")
.S OPTIONS=$TR(OPTIONS,"R","r")
.I IBBLK("HDISP")["C",$L(IBBLK("HDR"))<WIDTH S HDROS=(WIDTH-$L(IBBLK("HDR")))\2
.I BOX D DRWSTR^IBDFU(1,1,$J("",HDROS)_$E(IBBLK("HDR"),1,WIDTH),OPTIONS,WIDTH)
.I 'BOX D DRWSTR^IBDFU(0,0+HDROS,$E(IBBLK("HDR"),1,WIDTH),OPTIONS)
S IBLINE="" F S IBLINE=$O(^IBE(357.7,"C",IBBLK,IBLINE)) Q:'IBLINE D PRNTLINE^IBDF2E(IBLINE)
S IBTEXT="" F S IBTEXT=$O(^IBE(357.8,"C",IBBLK,IBTEXT)) Q:'IBTEXT D PRNTTEXT^IBDF2E(IBTEXT)
S IBFIELD="" F S IBFIELD=$O(^IBE(357.5,"C",IBBLK,IBFIELD)) Q:'IBFIELD D DATAFLD^IBDF2B(IBFIELD)
I IBPRINT("WITH_DATA") S IBPRINT("ENTIRE")=0,IBLIST="" F S IBLIST=$O(^IBE(357.2,"AD",IBBLK,IBLIST)) Q:'IBLIST D PRINTLST^IBDF2D(IBLIST)
;
;NOTE: bubbles & hand print fields have been written to file, but not to the array for list processor
;
G:'IBDEVICE("LISTMAN") EXIT
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),"[ ]")
S SUB=0 F S SUB=$O(^IBE(357.1,IBBLK,"H",SUB)) Q:'SUB S NODE=$G(^IBE(357.1,IBBLK,"H",SUB,0)) S TYPE=$P(NODE,"^",14),WIDTH=+$P(NODE,"^",3) I TYPE,WIDTH D
.N UNIT,PRINT,REPLACE,A,I,TYPENODE
.S IBLINES=$P(NODE,"^",6) S:IBLINES'>0 IBLINES=1
.S STRING="",ROW=+NODE
.;
.;replace the hand print fields - overlay with print format and label for units
.;TYPE=2 means use ICR, may have a print format and datatype
.I TYPE=2 D
..S TYPENODE=$P(NODE,"^",17) I TYPENODE S TYPENODE=$G(^IBE(359.1,TYPENODE,0))
..S UNIT=$P(TYPENODE,"^",11),PRINT=$P(TYPENODE,"^",5)
..F Q:IBLINES'>0 D S IBLINES=IBLINES-1,ROW=ROW+2
...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 DRWSTR^IBDFU(ROW,+$P(NODE,"^",2),PRINT,"R",$L(STRING))
...D DRWSTR^IBDFU(ROW+1,+$P(NODE,"^",2),STRING,"R",$L(STRING))
.;
.I TYPE=1 D CNVRTLEN^IBDF2D1(WIDTH,.WIDTH),CNVRTHT^IBDF2D1(IBLINES,.IBLINES) F Q:IBLINES'>0 D S IBLINES=IBLINES-1,ROW=ROW+1
..D DRWSTR^IBDFU(ROW,+$P(NODE,"^",2),"","R",WIDTH)
;
EXIT ;
D RESTORE^IBDF2A2(.IBPRINT,.IBPRINT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF2A1 6260 printed Oct 16, 2024@18:51:58 Page 2
IBDF2A1 ;ALB/CJM - ENCOUNTER FORM (IBDF2A continued);NOV 16,1992
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
DEVSETUP(IBFORM,IBDEVICE) ;set up the device for the form
+1 ;pass IBFORM, IBDEVICE by reference
+2 ;sets device to no wrap
+3 ;sets "ROW_HT" and "COL_WIDTH" in IBDEVICE
+4 ;
+5 ;sets device to no wrapping
SET X=0
XECUTE $GET(^%ZOSF("RM"))
KILL X
+6 ;
+7 IF $GET(IBDEVICE("PCL"))
Begin DoDot:1
+8 SET IOSL=IBFORM("PAGE_HT")
+9 WRITE $CHAR(27),"E"
+10 IF $GET(IBDEVICE("RESET"))'=""
WRITE @IBDEVICE("RESET")
+11 SET IOINHI=$CHAR(27)_"(s3B"
SET IOINORM=$CHAR(27)_"(s0B"
+12 SET IBDEVICE("DUPLEX_SHORT")=$CHAR(27)_"&l2S"
SET IBDEVICE("SIMPLEX")=$CHAR(27)_"&l0S"
SET IBDEVICE("DUPLEX_LONG")=$CHAR(27)_"&l1S"
+13 SET IORVON=$CHAR(27)_"*v0n1o1T"
SET IORVOFF=$CHAR(27)_"*v0T"
+14 SET IOXY="W $C(27)_""&a""_DX_""c""_DY_""R"""
+15 ;set to paper to letter size, portrait mode
+16 WRITE $CHAR(27),"&l2a0O"
+17 Begin DoDot:2
+18 IF IBFORM("WIDTH")>96
WRITE $CHAR(27)_"(s0p16.67h8.5v0s0b0T"
SET IBDEVICE("COL_WIDTH")=720/16.67
SET (IOINHI,IOINORM)=""
QUIT
+19 IF IBFORM("WIDTH")>80
WRITE $CHAR(27)_"(s0p12h10v0s0b0T"
SET IBDEVICE("COL_WIDTH")=720/12
QUIT
+20 WRITE $CHAR(27)_"(s0p10h12v0s0b0T"
SET IBDEVICE("COL_WIDTH")=720/10
End DoDot:2
+21 Begin DoDot:2
+22 ;!!!!!!!!!!Make the VMI a bit bigger? Seems to look good at VMI=6, and getting too cramped
+23 ;!!!!!!I IBFORM("PAGE_HT")>72 W $C(27),"&l5.6667C" S IBDEVICE("ROW_HT")=85.0005 Q ;sets the VMI=5.6667, to get 8 lines per inch Q
+24 ;sets the VMI=5.6667, to get 8 lines per inch Q
IF IBFORM("PAGE_HT")>72
WRITE $CHAR(27),"&l6C"
SET IBDEVICE("ROW_HT")=90
QUIT
+25 ;sets the VMI=6.6667, to get 7.2 lines per inch
IF IBFORM("PAGE_HT")>60
WRITE $CHAR(27),"&l6.6667C"
SET IBDEVICE("ROW_HT")=100.0005
QUIT
+26 ;sets the VMI=8, to get 6 lines per inch
WRITE $CHAR(27),"&l8C"
SET IBDEVICE("ROW_HT")=120
End DoDot:2
End DoDot:1
+27 ;
+28 IF '$GET(IBDEVICE("PCL"))
Begin DoDot:1
+29 ;make sure $X,$Y=0
SET (DX,DY)=0
XECUTE $GET(^%ZOSF("XY"))
KILL DX,DY
End DoDot:1
+30 QUIT
+31 ;
DRWBLOCK(IBBLK,NOOFFSET) ;IBBLK should be passed by reference, is an array containing the block description
+1 ;NOOFFSET=1 means don't offset the block on the form
+2 ;
+3 NEW IBFIELD,IBLIST,IBLINE,IBTEXT,IBWRTCNT,HDROS,BOX,OPTIONS,WIDTH,SUB,NODE,STRING,IBLINES,TYPE
+4 ;
+5 ;IBPRINT parameters may be altered durring this routine - make sure the original is restored after execution
+6 DO SAVE^IBDF2A2(.IBPRINT,.IBPRINT)
+7 ;
+8 if $$BLKDESCR^IBDFU1B(.IBBLK)
QUIT
+9 IF $GET(NOOFFSET)
SET (IBBLK("X"),IBBLK("Y"))=0
+10 ;location not known
IF (IBBLK("X")'=+IBBLK("X"))!(IBBLK("Y")'=+IBBLK("Y"))
GOTO EXIT
+11 ;
+12 IF 'IBPRINT("COMPILING_BLOCKS")
IF ('$DATA(^IBE(357.1,IBBLK,"S"))!'$DATA(^IBE(357.1,IBBLK,"V"))!'$DATA(^IBE(357.1,IBBLK,"B"))!'$DATA(^IBE(357.1,IBBLK,"H")))
SET IBPRINT("COMPILING_BLOCKS")=1
SET IBPRINT("WRITE_IF_COMPILING")=1
+13 IF IBPRINT("COMPILING_BLOCKS")
SET (IBWRTCNT("S"),IBWRTCNT("V"),IBWRTCNT("B"),IBWRTCNT("H"))=0
DO UNCMPBLK^IBDF19(IBBLK)
+14 IF 'IBPRINT("COMPILING_BLOCKS")
DO WCMP^IBDF2A2
+15 IF IBPRINT("COMPILING_BLOCKS")
Begin DoDot:1
+16 NEW TEMP
SET TEMP=IBPRINT("WITH_DATA")
SET IBPRINT("WITH_DATA")=0
+17 SET IBLIST=""
FOR
SET IBLIST=$ORDER(^IBE(357.2,"C",IBBLK,IBLIST))
if 'IBLIST
QUIT
DO PRINTLST^IBDF2D(IBLIST)
+18 SET IBFIELD=""
FOR
SET IBFIELD=$ORDER(^IBE(357.93,"C",IBBLK,IBFIELD))
if 'IBFIELD
QUIT
DO MFLD^IBDF2G(IBFIELD)
+19 SET IBFIELD=""
FOR
SET IBFIELD=$ORDER(^IBE(359.94,"C",IBBLK,IBFIELD))
if 'IBFIELD
QUIT
DO HFLD^IBDF2H(IBFIELD)
+20 SET ^IBE(357.1,IBBLK,"S",0)="^357.11A^"_IBWRTCNT("S")_"^"_IBWRTCNT("S")
+21 SET ^IBE(357.1,IBBLK,"V",0)="^357.12A^"_IBWRTCNT("V")_"^"_IBWRTCNT("V")
+22 SET ^IBE(357.1,IBBLK,"B",0)="^357.13A^"_IBWRTCNT("B")_"^"_IBWRTCNT("B")
+23 SET ^IBE(357.1,IBBLK,"H",0)="^357.14A^"_IBWRTCNT("H")_"^"_IBWRTCNT("H")
+24 SET IBPRINT("WITH_DATA")=TEMP
End DoDot:1
if 'IBPRINT("WRITE_IF_COMPILING")
GOTO EXIT
+25 ;
+26 ;now write the uncompiled part of the block
+27 SET IBPRINT("COMPILING_BLOCKS")=0
+28 KILL IBWRTCNT
+29 ;flag set to 1 if a warning is already displayed - don't want to display multiple warnings, users find it aggravating
IF IBDEVICE("LISTMAN")
NEW IBWARN
SET IBWARN=0
+30 SET BOX=$SELECT(IBBLK("BOX")=1:1,1:0)
+31 if BOX
DO DRWBOX^IBDFU(0,0,IBBLK("W"),IBBLK("H"))
+32 IF IBBLK("HDR")'=""
Begin DoDot:1
+33 SET HDROS=0
+34 SET WIDTH=IBBLK("W")-(2*BOX)
+35 SET OPTIONS=$TRANSLATE(IBBLK("HDISP"),"C","")
+36 SET OPTIONS=$TRANSLATE(OPTIONS,"R","r")
+37 IF IBBLK("HDISP")["C"
IF $LENGTH(IBBLK("HDR"))<WIDTH
SET HDROS=(WIDTH-$LENGTH(IBBLK("HDR")))\2
+38 IF BOX
DO DRWSTR^IBDFU(1,1,$JUSTIFY("",HDROS)_$EXTRACT(IBBLK("HDR"),1,WIDTH),OPTIONS,WIDTH)
+39 IF 'BOX
DO DRWSTR^IBDFU(0,0+HDROS,$EXTRACT(IBBLK("HDR"),1,WIDTH),OPTIONS)
End DoDot:1
+40 SET IBLINE=""
FOR
SET IBLINE=$ORDER(^IBE(357.7,"C",IBBLK,IBLINE))
if 'IBLINE
QUIT
DO PRNTLINE^IBDF2E(IBLINE)
+41 SET IBTEXT=""
FOR
SET IBTEXT=$ORDER(^IBE(357.8,"C",IBBLK,IBTEXT))
if 'IBTEXT
QUIT
DO PRNTTEXT^IBDF2E(IBTEXT)
+42 SET IBFIELD=""
FOR
SET IBFIELD=$ORDER(^IBE(357.5,"C",IBBLK,IBFIELD))
if 'IBFIELD
QUIT
DO DATAFLD^IBDF2B(IBFIELD)
+43 IF IBPRINT("WITH_DATA")
SET IBPRINT("ENTIRE")=0
SET IBLIST=""
FOR
SET IBLIST=$ORDER(^IBE(357.2,"AD",IBBLK,IBLIST))
if 'IBLIST
QUIT
DO PRINTLST^IBDF2D(IBLIST)
+44 ;
+45 ;NOTE: bubbles & hand print fields have been written to file, but not to the array for list processor
+46 ;
+47 if 'IBDEVICE("LISTMAN")
GOTO EXIT
+48 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),"[ ]")
+49 SET SUB=0
FOR
SET SUB=$ORDER(^IBE(357.1,IBBLK,"H",SUB))
if 'SUB
QUIT
SET NODE=$GET(^IBE(357.1,IBBLK,"H",SUB,0))
SET TYPE=$PIECE(NODE,"^",14)
SET WIDTH=+$PIECE(NODE,"^",3)
IF TYPE
IF WIDTH
Begin DoDot:1
+50 NEW UNIT,PRINT,REPLACE,A,I,TYPENODE
+51 SET IBLINES=$PIECE(NODE,"^",6)
if IBLINES'>0
SET IBLINES=1
+52 SET STRING=""
SET ROW=+NODE
+53 ;
+54 ;replace the hand print fields - overlay with print format and label for units
+55 ;TYPE=2 means use ICR, may have a print format and datatype
+56 IF TYPE=2
Begin DoDot:2
+57 SET TYPENODE=$PIECE(NODE,"^",17)
IF TYPENODE
SET TYPENODE=$GET(^IBE(359.1,TYPENODE,0))
+58 SET UNIT=$PIECE(TYPENODE,"^",11)
SET PRINT=$PIECE(TYPENODE,"^",5)
+59 FOR
if IBLINES'>0
QUIT
Begin DoDot:3
+60 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_" "
+61 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_" "
+62 if $LENGTH(UNIT)
SET STRING=STRING_" "_UNIT
+63 IF $LENGTH(PRINT)
SET PRINT=$$REPLACE^XLFSTR(PRINT,.REPLACE)
+64 DO DRWSTR^IBDFU(ROW,+$PIECE(NODE,"^",2),PRINT,"R",$LENGTH(STRING))
+65 DO DRWSTR^IBDFU(ROW+1,+$PIECE(NODE,"^",2),STRING,"R",$LENGTH(STRING))
End DoDot:3
SET IBLINES=IBLINES-1
SET ROW=ROW+2
End DoDot:2
+66 ;
+67 IF TYPE=1
DO CNVRTLEN^IBDF2D1(WIDTH,.WIDTH)
DO CNVRTHT^IBDF2D1(IBLINES,.IBLINES)
FOR
if IBLINES'>0
QUIT
Begin DoDot:2
+68 DO DRWSTR^IBDFU(ROW,+$PIECE(NODE,"^",2),"","R",WIDTH)
End DoDot:2
SET IBLINES=IBLINES-1
SET ROW=ROW+1
End DoDot:1
+69 ;
EXIT ;
+1 DO RESTORE^IBDF2A2(.IBPRINT,.IBPRINT)
+2 QUIT
