Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDFU

IBDFU.m

Go to the documentation of this file.
  1. IBDFU ;ALB/CJM - ENCOUNTER FORM (utilities) ;NOV 16,1992
  1. ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
  1. ;
  1. DRWBOX(IBY,IBX,W,H) ;draws a box
  1. I W=1,H N I D Q
  1. .D DRWVLINE(IBY+1,IBX,H-2)
  1. I H=1,W D DRWSTR(IBY,IBX,$$HLINE(W),"") Q
  1. I W<2,H<2 Q
  1. I 'IBDEVICE("LISTMAN") S @IBARRAY("BOXES")@((IBY+IBBLK("Y")),(IBX+IBBLK("X")),IBBLK)=W_"^"_H
  1. ;if IBDEVICE("PCL") means boxes will be drawn by PCL, via @IBARRAY("BOXES") array
  1. Q:IBDEVICE("PCL")
  1. D DRWSTR(IBY,IBX,"A"_$$HLINE(W-2,"B")_"C","G")
  1. D DRWSTR(IBY+H-1,IBX,"F"_$$HLINE(W-2,"B")_"E","G")
  1. D DRWVLINE(IBY+1,IBX,H-2,"|"),DRWVLINE(IBY+1,IBX+W-1,H-2,"|")
  1. Q
  1. HLINE(L,CHAR) ;returns a horizontal line
  1. I $G(CHAR)="" S CHAR="_"
  1. N LINE S LINE=""
  1. S $P(LINE,CHAR,L)=CHAR
  1. Q LINE
  1. DRWVLINE(IBY,IBX,IBH,CHAR) ;draw vertical line
  1. N SAVE
  1. S SAVE=IBPRINT("COMPILING_BLOCKS")
  1. I IBPRINT("COMPILING_BLOCKS") D CMPVLINE Q:'IBPRINT("WRITE_IF_COMPILING") S IBPRINT("COMPILING_BLOCKS")=0
  1. N I
  1. I $D(CHAR) D
  1. .F I=0:1:IBH-1 D DRWSTR(IBY+I,IBX,CHAR)
  1. I '$D(CHAR) F I=0:1:IBH-1 D DRWSTR(IBY+I,IBX,"D","G")
  1. S IBPRINT("COMPILING_BLOCKS")=SAVE
  1. Q
  1. ;
  1. DRWSTR(IBY,IBX,STRING,OPTIONS,IBW) ;
  1. ;IBW is the width over which to apply OPTIONS
  1. ;OPTIONS - B=bold,G=graphics,U=underline,R=reverse print,r=expanded reverse print,s=shaded(expanded)
  1. ;
  1. N UNDRLINE,END,ON,OFF,S,CURLINE
  1. S OPTIONS=$G(OPTIONS),STRING=$G(STRING)
  1. I '$D(IBW) S IBW=$L(STRING)
  1. I (IBW'>0)&(STRING="") Q
  1. I IBPRINT("COMPILING_BLOCKS") D CMPSTR Q:'IBPRINT("WRITE_IF_COMPILING")
  1. S IBY=IBY+IBBLK("Y"),IBX=IBX+IBBLK("X")
  1. I IBDEVICE("LISTMAN"),$G(IBTOPLN),$G(IBBOTLN),((IBY<IBTOPLN)!(IBY>IBBOTLN)) Q
  1. S (UNDRLINE,ON,OFF)=""
  1. ;
  1. I OPTIONS'="" D
  1. .I OPTIONS["B" S ON=ON_"B1;",OFF=OFF_"B0;"
  1. .I IBDEVICE("LISTMAN"),OPTIONS["U",OPTIONS'["R",OPTIONS'["r",OPTIONS'["s" S ON=ON_"U1;",OFF=OFF_"U0;"
  1. .I OPTIONS["R" S ON=ON_"R1,"_IBW_";",OFF=OFF_"R0;"
  1. .I OPTIONS["s" S ON=ON_"s1,"_IBW_";",OFF=OFF_"S0"
  1. .I OPTIONS["r" S ON=ON_"r1,"_IBW_";",OFF=OFF_"R0;"
  1. .I OPTIONS["C",IBDEVICE("LISTMAN") S OFF=OFF_$S((OPTIONS["R")!(OPTIONS["r")!(OPTIONS["s"):"R1;",OPTIONS["U":U1,1:"")
  1. .I 'IBDEVICE("LISTMAN"),OPTIONS["U",'IBDEVICE("CRT") S UNDRLINE=1
  1. I IBX+$L(STRING)>251 S STRING=$E(STRING,1,251-IBX)
  1. I IBX+IBW>251 S IBW=251-IBX
  1. ;
  1. ;for laser printing - NOT used presently
  1. ;I '$G(IBDEVICE("LISTMAN")),$G(IBDEVICE("RASTER")) D Q
  1. ;.I ON'="" W ON
  1. ;.S DX=IBX,DY=IBY X IOXY
  1. ;.W $J($G(STRING),+IBW) I OFF'="" W OFF
  1. ;.I UNDRLINE N ARY S ARY="ARY",ARY(IBY,IBX)=$$HLINE(IBW) D RASPRINT^IBDF2F(.ARY)
  1. ;
  1. I '$G(IBDEVICE("LISTMAN")) D Q
  1. .I OPTIONS["G",IBDEVICE("GRAPHICS") S @IBARRAY("GRAPHICS")@(IBY,IBX)=STRING Q
  1. .I OPTIONS["G" S STRING=$$GRPHCS(STRING)
  1. .S END=IBX+IBW-1
  1. .I UNDRLINE D UNDRLINE(IBY,IBX,IBW)
  1. .I STRING'="" D
  1. ..S CURLINE=$G(@IBARRAY("TEXT")@(IBY))
  1. ..S:CURLINE="" CURLINE=$J("",IBFORM("WIDTH"))
  1. ..S CURLINE=$$PADRIGHT($E(CURLINE,1,IBX),IBX)_STRING_$E(CURLINE,IBX+1+$L(STRING),IBFORM("WIDTH"))
  1. ..S @IBARRAY("TEXT")@(IBY)=CURLINE
  1. .I ON'="" S @IBARRAY("CONTROLS")@(IBY,IBX)=$G(@IBARRAY("CONTROLS")@(IBY,IBX))_ON,@IBARRAY("CONTROLS")@(IBY,END+1)=$G(@IBARRAY("CONTROLS")@(IBY,END+1))_OFF
  1. ;
  1. I $G(IBDEVICE("LISTMAN")) D
  1. .I OPTIONS["G" S STRING=$$GRPHCS(STRING)
  1. .S CURLINE=$G(@VALMAR@(IBY+1,0))
  1. .I CURLINE="" S CURLINE=$J((IBY#1000)+1,3,0)_$J("",IBFORM("WIDTH")) D CNTRL^VALM10(IBY+1,4,1,IORVON,IORVOFF) I (IBY+1)>VALMCNT S VALMCNT=(IBY+1)
  1. .S CURLINE=$$PADRIGHT($E(CURLINE,1,IBX+4),IBX+4)_STRING_$E(CURLINE,IBX+5+$L(STRING),IBFORM("WIDTH")+5)
  1. .S @VALMAR@(IBY+1,0)=CURLINE
  1. .I ON]"" D CNTRL^VALM10(IBY+1,IBX+5,IBW,$$CTRLS(ON),$$CTRLS(OFF))
  1. Q
  1. UNDRLINE(IBY,IBX,W) ; underlining with when not using printers underlining ability
  1. N LINE
  1. S LINE=$G(@IBARRAY("UNDERLINES")@(IBY))
  1. S LINE=$$PADRIGHT($E(LINE,1,IBX),IBX)_$$HLINE(W,"_")_$E(LINE,IBX+W+1,IBFORM("WIDTH"))
  1. S @IBARRAY("UNDERLINES")@(IBY)=LINE
  1. Q
  1. PADRIGHT(STR,LEN) ; pad right
  1. N B S STR=$E(STR,1,LEN)
  1. S:LEN>255 LEN=255
  1. S:LEN'=$L(STR) $P(B," ",LEN-$L(STR))=" "
  1. Q STR_$G(B)
  1. ;
  1. STRIP(STR) ;strips off leading and trailing spaces
  1. N I
  1. F I=1:1:$L(STR) I $A(STR,I)>32 Q
  1. S STR=$E(STR,I,$L(STR))
  1. F I=$L(STR):-1:1 I $A(STR,I)>32 Q
  1. S STR=$E(STR,1,I)
  1. Q STR
  1. ;
  1. CMPSTR ;saves compiled string write
  1. S IBWRTCNT("S")=IBWRTCNT("S")+1
  1. S ^IBE(357.1,IBBLK,"S",IBWRTCNT("S"),0)=IBY_"^"_IBX_"^"_OPTIONS_"^"_IBW_"^"_STRING
  1. Q
  1. CMPVLINE ;save compiled vertical line write
  1. S IBWRTCNT("V")=IBWRTCNT("V")+1
  1. S ^IBE(357.1,IBBLK,"V",IBWRTCNT("V"),0)=IBY_"^"_IBX_"^"_IBH_"^"_$G(CHAR)
  1. Q
  1. CTRLS(CTRLS,IBX,IBY) ;returns the needed escape sequences
  1. N I,X,RET,P1,P2 S RET=""
  1. F I=1:1 S X=$P(CTRLS,";",I) Q:X="" D
  1. .S P1=$P(X,","),P2=$P(X,",",2)
  1. .;
  1. .I 'IBDEVICE("PCL"),'IBDEVICE("LISTMAN") S P1=$TR(P1,"RrSs","UUUU")
  1. .;
  1. .;reverse printing is tricky - must draw a rectangle with black fill
  1. .;
  1. .I IBDEVICE("PCL"),P1="R1",$D(IBX),$D(IBY) W $C(27)_"&f0S",!,$C(27)_"&a"_IBY_"r"_(IBX+.05)_"C",$C(27)_"&a-1R",$C(27)_"*p+10Y",$C(27)_"*c"_(IBDEVICE("COL_WIDTH")*(+P2)-3)_"h"_((IBDEVICE("ROW_HT")-10))_"v0P",$C(27)_"&f1S"
  1. .I IBDEVICE("PCL"),P1="r1",$D(IBX),$D(IBY) W $C(27)_"&f0S",!,$C(27)_"&a"_IBY_"r"_(IBX-.5)_"C",$C(27)_"&a-1.005R",$C(27)_"*p+10Y",$C(27)_"*c"_(IBDEVICE("COL_WIDTH")*(+P2+1))_"h"_((IBDEVICE("ROW_HT")-10))_"v0P",$C(27)_"&f1S"
  1. .;
  1. .;test of dark gray
  1. .;I IBDEVICE("PCL"),P1="r1",$D(IBX),$D(IBY) D
  1. .;.W $C(27)_"*c70G",$C(27)_"&f0S",!,$C(27)_"&a"_IBY_"r"_(IBX-.5)_"C",$C(27)_"&a-1.005R",$C(27)_"*p+10Y",$C(27)_"*c"_(IBDEVICE("COL_WIDTH")*(+P2+1))_"h"_((IBDEVICE("ROW_HT")-10))_"v2P",$C(27)_"&f1S",$C(27)_"*c35G"
  1. .;
  1. .I IBDEVICE("PCL"),P1="s1",$D(IBX),$D(IBY) D
  1. ..W $C(27)_"*c11G",$C(27)_"&f0S",!,$C(27)_"&a"_IBY_"r"_(IBX-.5)_"C",$C(27)_"&a-1.005R",$C(27)_"*p+10Y",$C(27)_"*c"_(IBDEVICE("COL_WIDTH")*(+P2+1))_"h"_((IBDEVICE("ROW_HT")-10))_"v2P",$C(27)_"&f1S",$C(27)_"*c35G"
  1. .;
  1. .S RET=RET_$S(P1="B0":IOINORM,P1="B1":IOINHI,P1="U0":IOUOFF_IOINORM,P1="U1":IOUON,P1="G1":IOG1,P1="G0":IOG0,(P1="R1")!(P1="r1"):IORVON,P1="R0":IORVOFF,IBDEVICE("LISTMAN")&(P1="s1"):IORVON,IBDEVICE("LISTMAN")&(P1="S0"):IORVOFF,1:"")
  1. Q RET
  1. ;
  1. GRPHCS(GRPHCS) ;returns the needed graphics characters
  1. N I,X,RET S RET=""
  1. F I=1:1 S X=$E(GRPHCS,I) Q:X="" S RET=RET_$S(X="A":IOTLC,X="B":IOHL,X="C":IOTRC,X="D":IOVL,X="E":IOBRC,X="F":IOBLC,1:"")
  1. Q RET