XGSA ;SFISC/VYD - screen attribute primitives ;03/15/95 13:50
;;8.0;KERNEL;;Jul 10, 1995
SET(XGNEWATR) ;set screen attributes return only the ESC codes
;ABSOLUTE setting of screen attributes to new attributes regadless
;of prev state. For relative change use CHG
;XGNEWATR=char represents what all attributes should become ex: R1B0
;XGCURATR=state of all current attributes in form of a char
S XGCURATR=XGNEWATR ;set curr attr var
Q ^XUTL("XGATR",XGNEWATR)
;
CHG99(XGATR) ;XGATR=passed attribute string ie: R1B0G1
;RELATIVE change of screen attributes to the new ones. Only changes attributes that were passed, retains others. For ABSOLUTE set use SET
N X,%,XGATRLTR,XGATRNO,XGCURBIN,XGESC,XGONOFF
;S XGCURBIN=$$CNV(XGCURATR)
S XGCURBIN=^XUTL("XGATR1",XGCURATR)
;parse passed string, generate ESC codes
F %=1:2:$L(XGATR) S XGATRLTR=$E(XGATR,%),XGONOFF=$E(XGATR,%+1) D
. I XGATRLTR'="E" D ;continue if not EMPTY
. . S XGATRNO=$F("BIRDGU",XGATRLTR) ;get attr # to match in XGATRSET
. . S $E(XGCURBIN,XGATRNO)=XGONOFF ;chg bin str
. E S XGCURBIN="00000001" ;EMPTY attr clears everything
;in case all prev attr got turned off, turn on EMPTY attr
S $E(XGCURBIN,8)=$S($E(XGCURBIN,1,7)[1:0,1:1)
;S XGCURATR=$$CNV(XGCURBIN)
S XGCURATR=^XUTL("XGATR1",XGCURBIN)
Q ^XUTL("XGATR",XGCURATR) ;return escape sequence
;
;
CHG(XGATR) ;XGATR=passed attribute string ie: R1B0G1
;RELATIVE change of screen attributes to the new ones. Only changes attributes that were passed, retains others. For ABSOLUTE set use SET
N X,%,XGATRLTR,XGATRASC,XGBIT,XGONOFF
S XGATRASC=$A(XGCURATR)
F %=1:2:$L(XGATR) S XGATRLTR=$E(XGATR,%),XGONOFF=$E(XGATR,%+1) D
. I XGATRLTR'="E" D ;continue if not EMPTY
. . S XGBIT=2**($F("UGDRIB",XGATRLTR)-1) ;bit mask
. . ;if attribute bit needs to change add/subtract the mask
. . S:(XGATRASC\XGBIT#2)'=XGONOFF XGATRASC=XGATRASC+$S(XGONOFF=0:-XGBIT,1:XGBIT)
. E S XGATRASC=1 ;EMPTY attr clears everything
S:XGATRASC=0 XGATRASC=1 ;if all attr got turned off, turn on EMPTY attr
S XGCURATR=$C(XGATRASC)
Q ^XUTL("XGATR",XGCURATR) ;return escape sequence
;
;
STAT(XGATR) ;returns the state of a specific attribute
;XGATR is the attribute mnemonic character. Possible values are
;B-blinking, I-high intensity, R-reverse, D-double wide, G-graphics
;U-underline, E-empty
Q $A(XGCURATR)\(2**($F("EUGDRIB",XGATR)-2))#2
;
;
ESC(XGATR) ;return ESC codes of all attributes in XGATR
;XGATR=char represents what all attributes should be ex: R1B0
N %,XGESC,X,XGBIN
I XGATR'=XGEMPATR D ;if setting to other than EMPTY attribute
.;get binary representation of CURRENTATTRIBUTES and NEWATTRIBUTES
.S XGBIN=$$CNV(XGATR)
.S XGESC=IORESET D ;turn off all attr & process only 1s to turn on
..F %=2:1:7 S X=$E(XGBIN,%) S:X XGESC=XGESC_$P(XGATRSET(%),U,2)
E S XGESC=IORESET
Q XGESC
;
;
CNV(ATR) ;convert attribute from character to binary and vice-versa
;if $L(ATR)=8 then binary format is passed and character returned
;if $L(ATR)=1 then character format is passed and binary str returned
N X,Y
I $L(ATR)=1 S X=$A(ATR),Y="" F S Y=(X#2)_Y,X=X\2 I 'X S Y=$E(100000000+Y,2,9) Q
E S Y="" F X=1:1:8 S Y=Y*2+$E(ATR,X)
E S Y=$C(Y)
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXGSA 3255 printed Jun 11, 2024@21:52:34 Page 2
XGSA ;SFISC/VYD - screen attribute primitives ;03/15/95 13:50
+1 ;;8.0;KERNEL;;Jul 10, 1995
SET(XGNEWATR) ;set screen attributes return only the ESC codes
+1 ;ABSOLUTE setting of screen attributes to new attributes regadless
+2 ;of prev state. For relative change use CHG
+3 ;XGNEWATR=char represents what all attributes should become ex: R1B0
+4 ;XGCURATR=state of all current attributes in form of a char
+5 ;set curr attr var
SET XGCURATR=XGNEWATR
+6 QUIT ^XUTL("XGATR",XGNEWATR)
+7 ;
CHG99(XGATR) ;XGATR=passed attribute string ie: R1B0G1
+1 ;RELATIVE change of screen attributes to the new ones. Only changes attributes that were passed, retains others. For ABSOLUTE set use SET
+2 NEW X,%,XGATRLTR,XGATRNO,XGCURBIN,XGESC,XGONOFF
+3 ;S XGCURBIN=$$CNV(XGCURATR)
+4 SET XGCURBIN=^XUTL("XGATR1",XGCURATR)
+5 ;parse passed string, generate ESC codes
+6 FOR %=1:2:$LENGTH(XGATR)
SET XGATRLTR=$EXTRACT(XGATR,%)
SET XGONOFF=$EXTRACT(XGATR,%+1)
Begin DoDot:1
+7 ;continue if not EMPTY
IF XGATRLTR'="E"
Begin DoDot:2
+8 ;get attr # to match in XGATRSET
SET XGATRNO=$FIND("BIRDGU",XGATRLTR)
+9 ;chg bin str
SET $EXTRACT(XGCURBIN,XGATRNO)=XGONOFF
End DoDot:2
+10 ;EMPTY attr clears everything
IF '$TEST
SET XGCURBIN="00000001"
End DoDot:1
+11 ;in case all prev attr got turned off, turn on EMPTY attr
+12 SET $EXTRACT(XGCURBIN,8)=$SELECT($EXTRACT(XGCURBIN,1,7)[1:0,1:1)
+13 ;S XGCURATR=$$CNV(XGCURBIN)
+14 SET XGCURATR=^XUTL("XGATR1",XGCURBIN)
+15 ;return escape sequence
QUIT ^XUTL("XGATR",XGCURATR)
+16 ;
+17 ;
CHG(XGATR) ;XGATR=passed attribute string ie: R1B0G1
+1 ;RELATIVE change of screen attributes to the new ones. Only changes attributes that were passed, retains others. For ABSOLUTE set use SET
+2 NEW X,%,XGATRLTR,XGATRASC,XGBIT,XGONOFF
+3 SET XGATRASC=$ASCII(XGCURATR)
+4 FOR %=1:2:$LENGTH(XGATR)
SET XGATRLTR=$EXTRACT(XGATR,%)
SET XGONOFF=$EXTRACT(XGATR,%+1)
Begin DoDot:1
+5 ;continue if not EMPTY
IF XGATRLTR'="E"
Begin DoDot:2
+6 ;bit mask
SET XGBIT=2**($FIND("UGDRIB",XGATRLTR)-1)
+7 ;if attribute bit needs to change add/subtract the mask
+8 if (XGATRASC\XGBIT#2)'=XGONOFF
SET XGATRASC=XGATRASC+$SELECT(XGONOFF=0:-XGBIT,1:XGBIT)
End DoDot:2
+9 ;EMPTY attr clears everything
IF '$TEST
SET XGATRASC=1
End DoDot:1
+10 ;if all attr got turned off, turn on EMPTY attr
if XGATRASC=0
SET XGATRASC=1
+11 SET XGCURATR=$CHAR(XGATRASC)
+12 ;return escape sequence
QUIT ^XUTL("XGATR",XGCURATR)
+13 ;
+14 ;
STAT(XGATR) ;returns the state of a specific attribute
+1 ;XGATR is the attribute mnemonic character. Possible values are
+2 ;B-blinking, I-high intensity, R-reverse, D-double wide, G-graphics
+3 ;U-underline, E-empty
+4 QUIT $ASCII(XGCURATR)\(2**($FIND("EUGDRIB",XGATR)-2))#2
+5 ;
+6 ;
ESC(XGATR) ;return ESC codes of all attributes in XGATR
+1 ;XGATR=char represents what all attributes should be ex: R1B0
+2 NEW %,XGESC,X,XGBIN
+3 ;if setting to other than EMPTY attribute
IF XGATR'=XGEMPATR
Begin DoDot:1
+4 ;get binary representation of CURRENTATTRIBUTES and NEWATTRIBUTES
+5 SET XGBIN=$$CNV(XGATR)
+6 ;turn off all attr & process only 1s to turn on
SET XGESC=IORESET
Begin DoDot:2
+7 FOR %=2:1:7
SET X=$EXTRACT(XGBIN,%)
if X
SET XGESC=XGESC_$PIECE(XGATRSET(%),U,2)
End DoDot:2
End DoDot:1
+8 IF '$TEST
SET XGESC=IORESET
+9 QUIT XGESC
+10 ;
+11 ;
CNV(ATR) ;convert attribute from character to binary and vice-versa
+1 ;if $L(ATR)=8 then binary format is passed and character returned
+2 ;if $L(ATR)=1 then character format is passed and binary str returned
+3 NEW X,Y
+4 IF $LENGTH(ATR)=1
SET X=$ASCII(ATR)
SET Y=""
FOR
SET Y=(X#2)_Y
SET X=X\2
IF 'X
SET Y=$EXTRACT(100000000+Y,2,9)
QUIT
+5 IF '$TEST
SET Y=""
FOR X=1:1:8
SET Y=Y*2+$EXTRACT(ATR,X)
+6 IF '$TEST
SET Y=$CHAR(Y)
+7 QUIT Y
