source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XGSA.m@ 1524

Last change on this file since 1524 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.1 KB
RevLine 
[613]1XGSA ;SFISC/VYD - screen attribute primitives ;03/15/95 13:50
2 ;;8.0;KERNEL;;Jul 10, 1995
3SET(XGNEWATR) ;set screen attributes return only the ESC codes
4 ;ABSOLUTE setting of screen attributes to new attributes regadless
5 ;of prev state. For relative change use CHG
6 ;XGNEWATR=char represents what all attributes should become ex: R1B0
7 ;XGCURATR=state of all current attributes in form of a char
8 S XGCURATR=XGNEWATR ;set curr attr var
9 Q ^XUTL("XGATR",XGNEWATR)
10 ;
11CHG99(XGATR) ;XGATR=passed attribute string ie: R1B0G1
12 ;RELATIVE change of screen attributes to the new ones. Only changes attributes that were passed, retains others. For ABSOLUTE set use SET
13 N X,%,XGATRLTR,XGATRNO,XGCURBIN,XGESC,XGONOFF
14 ;S XGCURBIN=$$CNV(XGCURATR)
15 S XGCURBIN=^XUTL("XGATR1",XGCURATR)
16 ;parse passed string, generate ESC codes
17 F %=1:2:$L(XGATR) S XGATRLTR=$E(XGATR,%),XGONOFF=$E(XGATR,%+1) D
18 . I XGATRLTR'="E" D ;continue if not EMPTY
19 . . S XGATRNO=$F("BIRDGU",XGATRLTR) ;get attr # to match in XGATRSET
20 . . S $E(XGCURBIN,XGATRNO)=XGONOFF ;chg bin str
21 . E S XGCURBIN="00000001" ;EMPTY attr clears everything
22 ;in case all prev attr got turned off, turn on EMPTY attr
23 S $E(XGCURBIN,8)=$S($E(XGCURBIN,1,7)[1:0,1:1)
24 ;S XGCURATR=$$CNV(XGCURBIN)
25 S XGCURATR=^XUTL("XGATR1",XGCURBIN)
26 Q ^XUTL("XGATR",XGCURATR) ;return escape sequence
27 ;
28 ;
29CHG(XGATR) ;XGATR=passed attribute string ie: R1B0G1
30 ;RELATIVE change of screen attributes to the new ones. Only changes attributes that were passed, retains others. For ABSOLUTE set use SET
31 N X,%,XGATRLTR,XGATRASC,XGBIT,XGONOFF
32 S XGATRASC=$A(XGCURATR)
33 F %=1:2:$L(XGATR) S XGATRLTR=$E(XGATR,%),XGONOFF=$E(XGATR,%+1) D
34 . I XGATRLTR'="E" D ;continue if not EMPTY
35 . . S XGBIT=2**($F("UGDRIB",XGATRLTR)-1) ;bit mask
36 . . ;if attribute bit needs to change add/subtract the mask
37 . . S:(XGATRASC\XGBIT#2)'=XGONOFF XGATRASC=XGATRASC+$S(XGONOFF=0:-XGBIT,1:XGBIT)
38 . E S XGATRASC=1 ;EMPTY attr clears everything
39 S:XGATRASC=0 XGATRASC=1 ;if all attr got turned off, turn on EMPTY attr
40 S XGCURATR=$C(XGATRASC)
41 Q ^XUTL("XGATR",XGCURATR) ;return escape sequence
42 ;
43 ;
44STAT(XGATR) ;returns the state of a specific attribute
45 ;XGATR is the attribute mnemonic character. Possible values are
46 ;B-blinking, I-high intensity, R-reverse, D-double wide, G-graphics
47 ;U-underline, E-empty
48 Q $A(XGCURATR)\(2**($F("EUGDRIB",XGATR)-2))#2
49 ;
50 ;
51ESC(XGATR) ;return ESC codes of all attributes in XGATR
52 ;XGATR=char represents what all attributes should be ex: R1B0
53 N %,XGESC,X,XGBIN
54 I XGATR'=XGEMPATR D ;if setting to other than EMPTY attribute
55 .;get binary representation of CURRENTATTRIBUTES and NEWATTRIBUTES
56 .S XGBIN=$$CNV(XGATR)
57 .S XGESC=IORESET D ;turn off all attr & process only 1s to turn on
58 ..F %=2:1:7 S X=$E(XGBIN,%) S:X XGESC=XGESC_$P(XGATRSET(%),U,2)
59 E S XGESC=IORESET
60 Q XGESC
61 ;
62 ;
63CNV(ATR) ;convert attribute from character to binary and vice-versa
64 ;if $L(ATR)=8 then binary format is passed and character returned
65 ;if $L(ATR)=1 then character format is passed and binary str returned
66 N X,Y
67 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
68 E S Y="" F X=1:1:8 S Y=Y*2+$E(ATR,X)
69 E S Y=$C(Y)
70 Q Y
Note: See TracBrowser for help on using the repository browser.