- IBDFU ;ALB/CJM - ENCOUNTER FORM (utilities) ;NOV 16,1992
- ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- ;
- DRWBOX(IBY,IBX,W,H) ;draws a box
- I W=1,H N I D Q
- .D DRWVLINE(IBY+1,IBX,H-2)
- I H=1,W D DRWSTR(IBY,IBX,$$HLINE(W),"") Q
- I W<2,H<2 Q
- I 'IBDEVICE("LISTMAN") S @IBARRAY("BOXES")@((IBY+IBBLK("Y")),(IBX+IBBLK("X")),IBBLK)=W_"^"_H
- ;if IBDEVICE("PCL") means boxes will be drawn by PCL, via @IBARRAY("BOXES") array
- Q:IBDEVICE("PCL")
- D DRWSTR(IBY,IBX,"A"_$$HLINE(W-2,"B")_"C","G")
- D DRWSTR(IBY+H-1,IBX,"F"_$$HLINE(W-2,"B")_"E","G")
- D DRWVLINE(IBY+1,IBX,H-2,"|"),DRWVLINE(IBY+1,IBX+W-1,H-2,"|")
- Q
- HLINE(L,CHAR) ;returns a horizontal line
- I $G(CHAR)="" S CHAR="_"
- N LINE S LINE=""
- S $P(LINE,CHAR,L)=CHAR
- Q LINE
- DRWVLINE(IBY,IBX,IBH,CHAR) ;draw vertical line
- N SAVE
- S SAVE=IBPRINT("COMPILING_BLOCKS")
- I IBPRINT("COMPILING_BLOCKS") D CMPVLINE Q:'IBPRINT("WRITE_IF_COMPILING") S IBPRINT("COMPILING_BLOCKS")=0
- N I
- I $D(CHAR) D
- .F I=0:1:IBH-1 D DRWSTR(IBY+I,IBX,CHAR)
- I '$D(CHAR) F I=0:1:IBH-1 D DRWSTR(IBY+I,IBX,"D","G")
- S IBPRINT("COMPILING_BLOCKS")=SAVE
- Q
- ;
- DRWSTR(IBY,IBX,STRING,OPTIONS,IBW) ;
- ;IBW is the width over which to apply OPTIONS
- ;OPTIONS - B=bold,G=graphics,U=underline,R=reverse print,r=expanded reverse print,s=shaded(expanded)
- ;
- N UNDRLINE,END,ON,OFF,S,CURLINE
- S OPTIONS=$G(OPTIONS),STRING=$G(STRING)
- I '$D(IBW) S IBW=$L(STRING)
- I (IBW'>0)&(STRING="") Q
- I IBPRINT("COMPILING_BLOCKS") D CMPSTR Q:'IBPRINT("WRITE_IF_COMPILING")
- S IBY=IBY+IBBLK("Y"),IBX=IBX+IBBLK("X")
- I IBDEVICE("LISTMAN"),$G(IBTOPLN),$G(IBBOTLN),((IBY<IBTOPLN)!(IBY>IBBOTLN)) Q
- S (UNDRLINE,ON,OFF)=""
- ;
- I OPTIONS'="" D
- .I OPTIONS["B" S ON=ON_"B1;",OFF=OFF_"B0;"
- .I IBDEVICE("LISTMAN"),OPTIONS["U",OPTIONS'["R",OPTIONS'["r",OPTIONS'["s" S ON=ON_"U1;",OFF=OFF_"U0;"
- .I OPTIONS["R" S ON=ON_"R1,"_IBW_";",OFF=OFF_"R0;"
- .I OPTIONS["s" S ON=ON_"s1,"_IBW_";",OFF=OFF_"S0"
- .I OPTIONS["r" S ON=ON_"r1,"_IBW_";",OFF=OFF_"R0;"
- .I OPTIONS["C",IBDEVICE("LISTMAN") S OFF=OFF_$S((OPTIONS["R")!(OPTIONS["r")!(OPTIONS["s"):"R1;",OPTIONS["U":U1,1:"")
- .I 'IBDEVICE("LISTMAN"),OPTIONS["U",'IBDEVICE("CRT") S UNDRLINE=1
- I IBX+$L(STRING)>251 S STRING=$E(STRING,1,251-IBX)
- I IBX+IBW>251 S IBW=251-IBX
- ;
- ;for laser printing - NOT used presently
- ;I '$G(IBDEVICE("LISTMAN")),$G(IBDEVICE("RASTER")) D Q
- ;.I ON'="" W ON
- ;.S DX=IBX,DY=IBY X IOXY
- ;.W $J($G(STRING),+IBW) I OFF'="" W OFF
- ;.I UNDRLINE N ARY S ARY="ARY",ARY(IBY,IBX)=$$HLINE(IBW) D RASPRINT^IBDF2F(.ARY)
- ;
- I '$G(IBDEVICE("LISTMAN")) D Q
- .I OPTIONS["G",IBDEVICE("GRAPHICS") S @IBARRAY("GRAPHICS")@(IBY,IBX)=STRING Q
- .I OPTIONS["G" S STRING=$$GRPHCS(STRING)
- .S END=IBX+IBW-1
- .I UNDRLINE D UNDRLINE(IBY,IBX,IBW)
- .I STRING'="" D
- ..S CURLINE=$G(@IBARRAY("TEXT")@(IBY))
- ..S:CURLINE="" CURLINE=$J("",IBFORM("WIDTH"))
- ..S CURLINE=$$PADRIGHT($E(CURLINE,1,IBX),IBX)_STRING_$E(CURLINE,IBX+1+$L(STRING),IBFORM("WIDTH"))
- ..S @IBARRAY("TEXT")@(IBY)=CURLINE
- .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
- ;
- I $G(IBDEVICE("LISTMAN")) D
- .I OPTIONS["G" S STRING=$$GRPHCS(STRING)
- .S CURLINE=$G(@VALMAR@(IBY+1,0))
- .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)
- .S CURLINE=$$PADRIGHT($E(CURLINE,1,IBX+4),IBX+4)_STRING_$E(CURLINE,IBX+5+$L(STRING),IBFORM("WIDTH")+5)
- .S @VALMAR@(IBY+1,0)=CURLINE
- .I ON]"" D CNTRL^VALM10(IBY+1,IBX+5,IBW,$$CTRLS(ON),$$CTRLS(OFF))
- Q
- UNDRLINE(IBY,IBX,W) ; underlining with when not using printers underlining ability
- N LINE
- S LINE=$G(@IBARRAY("UNDERLINES")@(IBY))
- S LINE=$$PADRIGHT($E(LINE,1,IBX),IBX)_$$HLINE(W,"_")_$E(LINE,IBX+W+1,IBFORM("WIDTH"))
- S @IBARRAY("UNDERLINES")@(IBY)=LINE
- Q
- PADRIGHT(STR,LEN) ; pad right
- N B S STR=$E(STR,1,LEN)
- S:LEN>255 LEN=255
- S:LEN'=$L(STR) $P(B," ",LEN-$L(STR))=" "
- Q STR_$G(B)
- ;
- STRIP(STR) ;strips off leading and trailing spaces
- N I
- F I=1:1:$L(STR) I $A(STR,I)>32 Q
- S STR=$E(STR,I,$L(STR))
- F I=$L(STR):-1:1 I $A(STR,I)>32 Q
- S STR=$E(STR,1,I)
- Q STR
- ;
- CMPSTR ;saves compiled string write
- S IBWRTCNT("S")=IBWRTCNT("S")+1
- S ^IBE(357.1,IBBLK,"S",IBWRTCNT("S"),0)=IBY_"^"_IBX_"^"_OPTIONS_"^"_IBW_"^"_STRING
- Q
- CMPVLINE ;save compiled vertical line write
- S IBWRTCNT("V")=IBWRTCNT("V")+1
- S ^IBE(357.1,IBBLK,"V",IBWRTCNT("V"),0)=IBY_"^"_IBX_"^"_IBH_"^"_$G(CHAR)
- Q
- CTRLS(CTRLS,IBX,IBY) ;returns the needed escape sequences
- N I,X,RET,P1,P2 S RET=""
- F I=1:1 S X=$P(CTRLS,";",I) Q:X="" D
- .S P1=$P(X,","),P2=$P(X,",",2)
- .;
- .I 'IBDEVICE("PCL"),'IBDEVICE("LISTMAN") S P1=$TR(P1,"RrSs","UUUU")
- .;
- .;reverse printing is tricky - must draw a rectangle with black fill
- .;
- .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"
- .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"
- .;
- .;test of dark gray
- .;I IBDEVICE("PCL"),P1="r1",$D(IBX),$D(IBY) D
- .;.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"
- .;
- .I IBDEVICE("PCL"),P1="s1",$D(IBX),$D(IBY) D
- ..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"
- .;
- .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:"")
- Q RET
- ;
- GRPHCS(GRPHCS) ;returns the needed graphics characters
- N I,X,RET S RET=""
- 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:"")
- Q RET
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFU 6305 printed Jan 18, 2025@03:54:39 Page 2
- IBDFU ;ALB/CJM - ENCOUNTER FORM (utilities) ;NOV 16,1992
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- +2 ;
- DRWBOX(IBY,IBX,W,H) ;draws a box
- +1 IF W=1
- IF H
- NEW I
- Begin DoDot:1
- +2 DO DRWVLINE(IBY+1,IBX,H-2)
- End DoDot:1
- QUIT
- +3 IF H=1
- IF W
- DO DRWSTR(IBY,IBX,$$HLINE(W),"")
- QUIT
- +4 IF W<2
- IF H<2
- QUIT
- +5 IF 'IBDEVICE("LISTMAN")
- SET @IBARRAY("BOXES")@((IBY+IBBLK("Y")),(IBX+IBBLK("X")),IBBLK)=W_"^"_H
- +6 ;if IBDEVICE("PCL") means boxes will be drawn by PCL, via @IBARRAY("BOXES") array
- +7 if IBDEVICE("PCL")
- QUIT
- +8 DO DRWSTR(IBY,IBX,"A"_$$HLINE(W-2,"B")_"C","G")
- +9 DO DRWSTR(IBY+H-1,IBX,"F"_$$HLINE(W-2,"B")_"E","G")
- +10 DO DRWVLINE(IBY+1,IBX,H-2,"|")
- DO DRWVLINE(IBY+1,IBX+W-1,H-2,"|")
- +11 QUIT
- HLINE(L,CHAR) ;returns a horizontal line
- +1 IF $GET(CHAR)=""
- SET CHAR="_"
- +2 NEW LINE
- SET LINE=""
- +3 SET $PIECE(LINE,CHAR,L)=CHAR
- +4 QUIT LINE
- DRWVLINE(IBY,IBX,IBH,CHAR) ;draw vertical line
- +1 NEW SAVE
- +2 SET SAVE=IBPRINT("COMPILING_BLOCKS")
- +3 IF IBPRINT("COMPILING_BLOCKS")
- DO CMPVLINE
- if 'IBPRINT("WRITE_IF_COMPILING")
- QUIT
- SET IBPRINT("COMPILING_BLOCKS")=0
- +4 NEW I
- +5 IF $DATA(CHAR)
- Begin DoDot:1
- +6 FOR I=0:1:IBH-1
- DO DRWSTR(IBY+I,IBX,CHAR)
- End DoDot:1
- +7 IF '$DATA(CHAR)
- FOR I=0:1:IBH-1
- DO DRWSTR(IBY+I,IBX,"D","G")
- +8 SET IBPRINT("COMPILING_BLOCKS")=SAVE
- +9 QUIT
- +10 ;
- DRWSTR(IBY,IBX,STRING,OPTIONS,IBW) ;
- +1 ;IBW is the width over which to apply OPTIONS
- +2 ;OPTIONS - B=bold,G=graphics,U=underline,R=reverse print,r=expanded reverse print,s=shaded(expanded)
- +3 ;
- +4 NEW UNDRLINE,END,ON,OFF,S,CURLINE
- +5 SET OPTIONS=$GET(OPTIONS)
- SET STRING=$GET(STRING)
- +6 IF '$DATA(IBW)
- SET IBW=$LENGTH(STRING)
- +7 IF (IBW'>0)&(STRING="")
- QUIT
- +8 IF IBPRINT("COMPILING_BLOCKS")
- DO CMPSTR
- if 'IBPRINT("WRITE_IF_COMPILING")
- QUIT
- +9 SET IBY=IBY+IBBLK("Y")
- SET IBX=IBX+IBBLK("X")
- +10 IF IBDEVICE("LISTMAN")
- IF $GET(IBTOPLN)
- IF $GET(IBBOTLN)
- IF ((IBY<IBTOPLN)!(IBY>IBBOTLN))
- QUIT
- +11 SET (UNDRLINE,ON,OFF)=""
- +12 ;
- +13 IF OPTIONS'=""
- Begin DoDot:1
- +14 IF OPTIONS["B"
- SET ON=ON_"B1;"
- SET OFF=OFF_"B0;"
- +15 IF IBDEVICE("LISTMAN")
- IF OPTIONS["U"
- IF OPTIONS'["R"
- IF OPTIONS'["r"
- IF OPTIONS'["s"
- SET ON=ON_"U1;"
- SET OFF=OFF_"U0;"
- +16 IF OPTIONS["R"
- SET ON=ON_"R1,"_IBW_";"
- SET OFF=OFF_"R0;"
- +17 IF OPTIONS["s"
- SET ON=ON_"s1,"_IBW_";"
- SET OFF=OFF_"S0"
- +18 IF OPTIONS["r"
- SET ON=ON_"r1,"_IBW_";"
- SET OFF=OFF_"R0;"
- +19 IF OPTIONS["C"
- IF IBDEVICE("LISTMAN")
- SET OFF=OFF_$SELECT((OPTIONS["R")!(OPTIONS["r")!(OPTIONS["s"):"R1;",OPTIONS["U":U1,1:"")
- +20 IF 'IBDEVICE("LISTMAN")
- IF OPTIONS["U"
- IF 'IBDEVICE("CRT")
- SET UNDRLINE=1
- End DoDot:1
- +21 IF IBX+$LENGTH(STRING)>251
- SET STRING=$EXTRACT(STRING,1,251-IBX)
- +22 IF IBX+IBW>251
- SET IBW=251-IBX
- +23 ;
- +24 ;for laser printing - NOT used presently
- +25 ;I '$G(IBDEVICE("LISTMAN")),$G(IBDEVICE("RASTER")) D Q
- +26 ;.I ON'="" W ON
- +27 ;.S DX=IBX,DY=IBY X IOXY
- +28 ;.W $J($G(STRING),+IBW) I OFF'="" W OFF
- +29 ;.I UNDRLINE N ARY S ARY="ARY",ARY(IBY,IBX)=$$HLINE(IBW) D RASPRINT^IBDF2F(.ARY)
- +30 ;
- +31 IF '$GET(IBDEVICE("LISTMAN"))
- Begin DoDot:1
- +32 IF OPTIONS["G"
- IF IBDEVICE("GRAPHICS")
- SET @IBARRAY("GRAPHICS")@(IBY,IBX)=STRING
- QUIT
- +33 IF OPTIONS["G"
- SET STRING=$$GRPHCS(STRING)
- +34 SET END=IBX+IBW-1
- +35 IF UNDRLINE
- DO UNDRLINE(IBY,IBX,IBW)
- +36 IF STRING'=""
- Begin DoDot:2
- +37 SET CURLINE=$GET(@IBARRAY("TEXT")@(IBY))
- +38 if CURLINE=""
- SET CURLINE=$JUSTIFY("",IBFORM("WIDTH"))
- +39 SET CURLINE=$$PADRIGHT($EXTRACT(CURLINE,1,IBX),IBX)_STRING_$EXTRACT(CURLINE,IBX+1+$LENGTH(STRING),IBFORM("WIDTH"))
- +40 SET @IBARRAY("TEXT")@(IBY)=CURLINE
- End DoDot:2
- +41 IF ON'=""
- SET @IBARRAY("CONTROLS")@(IBY,IBX)=$GET(@IBARRAY("CONTROLS")@(IBY,IBX))_ON
- SET @IBARRAY("CONTROLS")@(IBY,END+1)=$GET(@IBARRAY("CONTROLS")@(IBY,END+1))_OFF
- End DoDot:1
- QUIT
- +42 ;
- +43 IF $GET(IBDEVICE("LISTMAN"))
- Begin DoDot:1
- +44 IF OPTIONS["G"
- SET STRING=$$GRPHCS(STRING)
- +45 SET CURLINE=$GET(@VALMAR@(IBY+1,0))
- +46 IF CURLINE=""
- SET CURLINE=$JUSTIFY((IBY#1000)+1,3,0)_$JUSTIFY("",IBFORM("WIDTH"))
- DO CNTRL^VALM10(IBY+1,4,1,IORVON,IORVOFF)
- IF (IBY+1)>VALMCNT
- SET VALMCNT=(IBY+1)
- +47 SET CURLINE=$$PADRIGHT($EXTRACT(CURLINE,1,IBX+4),IBX+4)_STRING_$EXTRACT(CURLINE,IBX+5+$LENGTH(STRING),IBFORM("WIDTH")+5)
- +48 SET @VALMAR@(IBY+1,0)=CURLINE
- +49 IF ON]""
- DO CNTRL^VALM10(IBY+1,IBX+5,IBW,$$CTRLS(ON),$$CTRLS(OFF))
- End DoDot:1
- +50 QUIT
- UNDRLINE(IBY,IBX,W) ; underlining with when not using printers underlining ability
- +1 NEW LINE
- +2 SET LINE=$GET(@IBARRAY("UNDERLINES")@(IBY))
- +3 SET LINE=$$PADRIGHT($EXTRACT(LINE,1,IBX),IBX)_$$HLINE(W,"_")_$EXTRACT(LINE,IBX+W+1,IBFORM("WIDTH"))
- +4 SET @IBARRAY("UNDERLINES")@(IBY)=LINE
- +5 QUIT
- PADRIGHT(STR,LEN) ; pad right
- +1 NEW B
- SET STR=$EXTRACT(STR,1,LEN)
- +2 if LEN>255
- SET LEN=255
- +3 if LEN'=$LENGTH(STR)
- SET $PIECE(B," ",LEN-$LENGTH(STR))=" "
- +4 QUIT STR_$GET(B)
- +5 ;
- STRIP(STR) ;strips off leading and trailing spaces
- +1 NEW I
- +2 FOR I=1:1:$LENGTH(STR)
- IF $ASCII(STR,I)>32
- QUIT
- +3 SET STR=$EXTRACT(STR,I,$LENGTH(STR))
- +4 FOR I=$LENGTH(STR):-1:1
- IF $ASCII(STR,I)>32
- QUIT
- +5 SET STR=$EXTRACT(STR,1,I)
- +6 QUIT STR
- +7 ;
- CMPSTR ;saves compiled string write
- +1 SET IBWRTCNT("S")=IBWRTCNT("S")+1
- +2 SET ^IBE(357.1,IBBLK,"S",IBWRTCNT("S"),0)=IBY_"^"_IBX_"^"_OPTIONS_"^"_IBW_"^"_STRING
- +3 QUIT
- CMPVLINE ;save compiled vertical line write
- +1 SET IBWRTCNT("V")=IBWRTCNT("V")+1
- +2 SET ^IBE(357.1,IBBLK,"V",IBWRTCNT("V"),0)=IBY_"^"_IBX_"^"_IBH_"^"_$GET(CHAR)
- +3 QUIT
- CTRLS(CTRLS,IBX,IBY) ;returns the needed escape sequences
- +1 NEW I,X,RET,P1,P2
- SET RET=""
- +2 FOR I=1:1
- SET X=$PIECE(CTRLS,";",I)
- if X=""
- QUIT
- Begin DoDot:1
- +3 SET P1=$PIECE(X,",")
- SET P2=$PIECE(X,",",2)
- +4 ;
- +5 IF 'IBDEVICE("PCL")
- IF 'IBDEVICE("LISTMAN")
- SET P1=$TRANSLATE(P1,"RrSs","UUUU")
- +6 ;
- +7 ;reverse printing is tricky - must draw a rectangle with black fill
- +8 ;
- +9 IF IBDEVICE("PCL")
- IF P1="R1"
- IF $DATA(IBX)
- IF $DATA(IBY)
- WRITE $CHAR(27)_"&f0S",!,$CHAR(27)_"&a"_IBY_"r"_(IBX+.05)_"C",$CHAR(27)_"&a-1R",$CHAR(27)_"*p+10Y",$CHAR(27)_"*c"_(IBDEVICE("COL_WIDTH")*(+P2)-3)_"h"_((IBDEVICE("ROW_HT")-10))_"v0P",$CHAR(27)_"&f1S"
- +10 IF IBDEVICE("PCL")
- IF P1="r1"
- IF $DATA(IBX)
- IF $DATA(IBY)
- WRITE $CHAR(27)_"&f0S",!,$CHAR(27)_"&a"_IBY_"r"_(IBX-.5)_"C",$CHAR(27)_"&a-1.005R",$CHAR(27)_"*p+10Y",$CHAR(27)_"*c"_(IBDEVICE("COL_WIDTH")*(+P2+1))_"h"_((IBDEVICE("ROW_HT")-10))_"v0P",$CHAR(27)_"&f1S"
- +11 ;
- +12 ;test of dark gray
- +13 ;I IBDEVICE("PCL"),P1="r1",$D(IBX),$D(IBY) D
- +14 ;.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"
- +15 ;
- +16 IF IBDEVICE("PCL")
- IF P1="s1"
- IF $DATA(IBX)
- IF $DATA(IBY)
- Begin DoDot:2
- +17 WRITE $CHAR(27)_"*c11G",$CHAR(27)_"&f0S",!,$CHAR(27)_"&a"_IBY_"r"_(IBX-.5)_"C",$CHAR(27)_"&a-1.005R",$CHAR(27)_"*p+10Y",$CHAR(27)_"*c"_(IBDEVICE("COL_WIDTH")*(+P2+1))_"h"_((IBDEVICE("ROW_HT")-10))_"v2P",$CHAR(27)_"&f
- 1S",$CHAR(27)_"*c35G"
- End DoDot:2
- +18 ;
- +19 SET RET=RET_$SELECT(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:""
- )
- End DoDot:1
- +20 QUIT RET
- +21 ;
- GRPHCS(GRPHCS) ;returns the needed graphics characters
- +1 NEW I,X,RET
- SET RET=""
- +2 FOR I=1:1
- SET X=$EXTRACT(GRPHCS,I)
- if X=""
- QUIT
- SET RET=RET_$SELECT(X="A":IOTLC,X="B":IOHL,X="C":IOTRC,X="D":IOVL,X="E":IOBRC,X="F":IOBLC,1:"")
- +3 QUIT RET