XGF ;SFISC/VYD - Graphics Functions ;11/06/2002 11:10
;;8.0;KERNEL;**269**;Jul 10, 1995
PREP ;prepair graphics environment
D PREP^XGSETUP Q
;
;
IOXY(R,C) ;cursor positioning R:row, C:col
D ADJRC
W $$IOXY^XGS(R,C)
S $Y=R,$X=C
Q
;
;
SAY(R,C,S,A) ;coordinate output instead of WRITE
D ADJRC
S:C+$L(S)>IOM S=$E(S,1,IOM-C) ;truncate if longer than screen
I $L($G(A)) S A=$$UP^XLFSTR(A) D SAY^XGS(R,C,S,$S($$ATRSYNTX(A):A,1:"")) I 1
E D SAY^XGS(R,C,S)
Q
;
;
SAYU(R,C,S,A) ;coordinate output w/ underline instead of WRITE
D ADJRC
I $L($G(A)) S A=$$UP^XLFSTR(A) D SAYU^XGS(R,C,S,$S($$ATRSYNTX(A):A,1:"")) I 1
E D SAYU^XGS(R,C,S)
Q
;
;
ADJRC ;adjust row and column R and C are assumed to exist
S R=$S($G(R)="":$Y,1:R),C=$S($G(C)="":$X,1:C) ;use current coords if none are passed
S:"+-"[$E(R) R=$Y+$S(R="+":1,R="-":-1,1:R) ;increment/decrement
S:"+-"[$E(C) C=$X+$S(C="+":1,C="-":-1,1:C)
S R=$S(R<0:0,1:R\1),C=$S(C<0:0,1:C\1) ;make sure only pos int
Q
;
;
SETA(XGATR) ;set screen attribute(s) regardless of previous state
;XGATR=1 char when converted to binary represents all new attr
N XGOLDX,XGOLDY
S XGOLDX=$X,XGOLDY=$Y ;save $X $Y
W $$SET^XGSA(XGATR)
S $X=XGOLDX,$Y=XGOLDY ;restore $X $Y
Q
;
;
CHGA(XGATR) ;change screen attribute(s) w/ respect to previous state
;XGNEWATR=string of attr to change eg. "B0U1" or "E1"
N XGOLDX,XGOLDY,XGSYNTX,XGACODE,%
S XGATR=$$UP^XLFSTR(XGATR) ;make sure all attr codes are in upper case
D:$$ATRSYNTX(XGATR)
. S XGOLDX=$X,XGOLDY=$Y ;save $X $Y
. W $$CHG^XGSA(XGATR)
. S $X=XGOLDX,$Y=XGOLDY ;restore $X $Y
Q
;
;
ATRSYNTX(XGATR) ;check attribute code syntax
;proper attr is 1 or more (char from {BIRGUE} concat w/ 1 or 0)
N XGSYNTX,%
S XGSYNTX=$S($L(XGATR)&($L(XGATR)#2=0):1,1:0) ;even # of chars
F %=1:2:$L(XGATR) S:"B1B0I1I0R1R0G1G0U1U0E1"'[$E(XGATR,%,%+1) XGSYNTX=0
Q XGSYNTX
;
;
RESTORE(S) ;restore screen region TOP,LEFT,BOTTOM,RIGHT,SAVE ROOT
D RESTORE^XGSW(S) Q
K @S
;
;
SAVE(T,L,B,R,S) ;save screen region TOP,LEFT,BOTTOM,RIGHT,SAVE ROOT
D SAVE^XGSW(T,L,B,R,S) Q
;
;
WIN(T,L,B,R,S) ;put up a window TOP,LEFT,BOTTOM,RIGHT[,SAVE ROOT]
;window style is not yet implemented
I $L($G(S)) D WIN^XGSW(T,L,B,R,S) I 1
E D WIN^XGSW(T,L,B,R)
Q
;
;
FRAME(T,L,B,R) ;put a frame without clearing the inside TOP,LEFT,BOTTOM,RIGHT
D FRAME^XGSBOX(T,L,B,R) Q
;
;
CLEAR(T,L,B,R) ;clear screen portion TOP,LEFT,BOTTOM,RIGHT
D CLEAR^XGSBOX(T,L,B,R) Q
;
;
CLEAN ;clean up and destroy graphics environment
D CLEAN^XGSETUP Q
;
;
INITKB(XGTRM) ;initialize keyboard
;turn escape processing on, turn on passed terminators (if any)
D INIT^XGKB($G(XGTRM)) Q
;
;
READ(XGCHARS,XGTO) ;read the keyboard
;XGCHARS:number of chars to read, XGTO:timeout
Q $$READ^XGKB($G(XGCHARS),$G(XGTO))
;
;
RESETKB ;reset keyboard(escape processing off, terminators off)
D EXIT^XGKB Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXGF 2962 printed Oct 16, 2024@18:03:07 Page 2
XGF ;SFISC/VYD - Graphics Functions ;11/06/2002 11:10
+1 ;;8.0;KERNEL;**269**;Jul 10, 1995
PREP ;prepair graphics environment
+1 DO PREP^XGSETUP
QUIT
+2 ;
+3 ;
IOXY(R,C) ;cursor positioning R:row, C:col
+1 DO ADJRC
+2 WRITE $$IOXY^XGS(R,C)
+3 SET $Y=R
SET $X=C
+4 QUIT
+5 ;
+6 ;
SAY(R,C,S,A) ;coordinate output instead of WRITE
+1 DO ADJRC
+2 ;truncate if longer than screen
if C+$LENGTH(S)>IOM
SET S=$EXTRACT(S,1,IOM-C)
+3 IF $LENGTH($GET(A))
SET A=$$UP^XLFSTR(A)
DO SAY^XGS(R,C,S,$SELECT($$ATRSYNTX(A):A,1:""))
IF 1
+4 IF '$TEST
DO SAY^XGS(R,C,S)
+5 QUIT
+6 ;
+7 ;
SAYU(R,C,S,A) ;coordinate output w/ underline instead of WRITE
+1 DO ADJRC
+2 IF $LENGTH($GET(A))
SET A=$$UP^XLFSTR(A)
DO SAYU^XGS(R,C,S,$SELECT($$ATRSYNTX(A):A,1:""))
IF 1
+3 IF '$TEST
DO SAYU^XGS(R,C,S)
+4 QUIT
+5 ;
+6 ;
ADJRC ;adjust row and column R and C are assumed to exist
+1 ;use current coords if none are passed
SET R=$SELECT($GET(R)="":$Y,1:R)
SET C=$SELECT($GET(C)="":$X,1:C)
+2 ;increment/decrement
if "+-"[$EXTRACT(R)
SET R=$Y+$SELECT(R="+":1,R="-":-1,1:R)
+3 if "+-"[$EXTRACT(C)
SET C=$X+$SELECT(C="+":1,C="-":-1,1:C)
+4 ;make sure only pos int
SET R=$SELECT(R<0:0,1:R\1)
SET C=$SELECT(C<0:0,1:C\1)
+5 QUIT
+6 ;
+7 ;
SETA(XGATR) ;set screen attribute(s) regardless of previous state
+1 ;XGATR=1 char when converted to binary represents all new attr
+2 NEW XGOLDX,XGOLDY
+3 ;save $X $Y
SET XGOLDX=$X
SET XGOLDY=$Y
+4 WRITE $$SET^XGSA(XGATR)
+5 ;restore $X $Y
SET $X=XGOLDX
SET $Y=XGOLDY
+6 QUIT
+7 ;
+8 ;
CHGA(XGATR) ;change screen attribute(s) w/ respect to previous state
+1 ;XGNEWATR=string of attr to change eg. "B0U1" or "E1"
+2 NEW XGOLDX,XGOLDY,XGSYNTX,XGACODE,%
+3 ;make sure all attr codes are in upper case
SET XGATR=$$UP^XLFSTR(XGATR)
+4 if $$ATRSYNTX(XGATR)
Begin DoDot:1
+5 ;save $X $Y
SET XGOLDX=$X
SET XGOLDY=$Y
+6 WRITE $$CHG^XGSA(XGATR)
+7 ;restore $X $Y
SET $X=XGOLDX
SET $Y=XGOLDY
End DoDot:1
+8 QUIT
+9 ;
+10 ;
ATRSYNTX(XGATR) ;check attribute code syntax
+1 ;proper attr is 1 or more (char from {BIRGUE} concat w/ 1 or 0)
+2 NEW XGSYNTX,%
+3 ;even # of chars
SET XGSYNTX=$SELECT($LENGTH(XGATR)&($LENGTH(XGATR)#2=0):1,1:0)
+4 FOR %=1:2:$LENGTH(XGATR)
if "B1B0I1I0R1R0G1G0U1U0E1"'[$EXTRACT(XGATR,%,%+1)
SET XGSYNTX=0
+5 QUIT XGSYNTX
+6 ;
+7 ;
RESTORE(S) ;restore screen region TOP,LEFT,BOTTOM,RIGHT,SAVE ROOT
+1 DO RESTORE^XGSW(S)
QUIT
+2 KILL @S
+3 ;
+4 ;
SAVE(T,L,B,R,S) ;save screen region TOP,LEFT,BOTTOM,RIGHT,SAVE ROOT
+1 DO SAVE^XGSW(T,L,B,R,S)
QUIT
+2 ;
+3 ;
WIN(T,L,B,R,S) ;put up a window TOP,LEFT,BOTTOM,RIGHT[,SAVE ROOT]
+1 ;window style is not yet implemented
+2 IF $LENGTH($GET(S))
DO WIN^XGSW(T,L,B,R,S)
IF 1
+3 IF '$TEST
DO WIN^XGSW(T,L,B,R)
+4 QUIT
+5 ;
+6 ;
FRAME(T,L,B,R) ;put a frame without clearing the inside TOP,LEFT,BOTTOM,RIGHT
+1 DO FRAME^XGSBOX(T,L,B,R)
QUIT
+2 ;
+3 ;
CLEAR(T,L,B,R) ;clear screen portion TOP,LEFT,BOTTOM,RIGHT
+1 DO CLEAR^XGSBOX(T,L,B,R)
QUIT
+2 ;
+3 ;
CLEAN ;clean up and destroy graphics environment
+1 DO CLEAN^XGSETUP
QUIT
+2 ;
+3 ;
INITKB(XGTRM) ;initialize keyboard
+1 ;turn escape processing on, turn on passed terminators (if any)
+2 DO INIT^XGKB($GET(XGTRM))
QUIT
+3 ;
+4 ;
READ(XGCHARS,XGTO) ;read the keyboard
+1 ;XGCHARS:number of chars to read, XGTO:timeout
+2 QUIT $$READ^XGKB($GET(XGCHARS),$GET(XGTO))
+3 ;
+4 ;
RESETKB ;reset keyboard(escape processing off, terminators off)
+1 DO EXIT^XGKB
QUIT
