LEXDCXS ;ISL/KER - Default Context - Select ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^LEX(757.41) N/A
;
; External References
; ^DIR ICR 10026
;
; Special Look-up in file 757.41 Shortcut Context
;
; Entry: S X=$$EN^LEXDCXS
;
; Function returns a two piece string
;
; $P 1 Pointer to file 757.41, and a valid
; value for LEXCTX (context user default)
; This will be null if input is "^"
;
; $P 2 Name of context selected. This will
; be null only when user input is "^^"
;
; LEX Array containing pointers to 757.41
; LEXA Users answer to selection
; LEXC Counter
; LEXE Edit/non-edit Counter
; LEXF Re-display starting from #LEXF
; LEXI Incremental Counter
; LEXL Last entry displayed
; LEXR Internal Entry Number (Record) in #757.41
; LEXT Re-display up through #LEXT
; LEXX Returned value
;
EN(LEXX) ; Entry: S X=$$EN^LEXDCXS
N X,Y,LEX,LEXC,LEXL,LEXR,LEXA,LEXE S LEXE=$$CNT D TOT
S LEXA="",(LEXX,LEXC,LEXR)=0
F S LEXR=$O(^LEX(757.41,LEXR)) Q:+LEXR=0!(LEXA["^")!(+LEXX>0) D
. I $D(LEXEDIT),$P($G(^LEX(757.41,LEXR,0)),"^",2)'=1 Q
. S LEXC=LEXC+1,LEXL=LEXC
. S LEX(LEXC)=LEXR,LEX(0)=LEXC
. D:LEXE>1 W(LEXC,LEXR)
. D:LEXE=1 WO(LEXR)
; D ASK
D ASK I LEXA["^" D UOUT Q LEXX
D VAL Q LEXX
ASK ; Ask for user input
Q:+LEXX>0 Q:LEXA["^" Q:+LEXR>0&(LEXC#5'=0)
Q:+LEXR=0&(LEXC#5=0)
D SEL Q:+LEXA'>0 Q:LEXA>LEXE S LEXX=$G(LEX(+LEXA))
Q
SEL ; Select from list
I LEXE=1 D ONE Q
W ! N X,Y,DIR,DIRUT,DTOUT,DUOUT,DIROUT
S DIR(0)="NAO^1:"_LEXC
S DIR("A")="Select SHORTCUT CONTEXT 1-"_LEXC_": // "
S (DIR("?"),DIR("??"))="^D SH^LEXDCXS"
D ^DIR S LEXA=Y
Q
ONE ;
W ! N X,Y,DIR,DIRUT,DTOUT,DUOUT,DIROUT
S DIR(0)="YAO"
S DIR("A")=" Ok? // "
S (DIR("?"),DIR("??"))="^D SO^LEXDCXS"
D ^DIR S LEXA=$S(+Y>0:1,1:0)
Q
UOUT ; Up Arrow detected
S:LEXA="^^" LEXX="^"
S:LEXA="^" LEXX="^No context selected"
Q
VAL ; No Un Arrow (value)
I +LEXX>0 D Q
. I $D(^LEX(757.41,+LEXX)) D Q
. . S LEXX=LEXX_"^"_$P($G(^LEX(757.41,+LEXX,0)),"^",1)
. S LEXX="^No context selected"
S LEXX="^No context selected"
Q
SH ; Show help
N LEXR S LEXR=+($E(X,2,$L(X)))
I $E(X,1)="?",LEXR>0,LEXR<(LEX(0)+1) D
. S LEXR=LEX(LEXR) D:'$D(^LEX(757.41,LEXR,1,1)) NODES,STD
. Q:'$D(^LEX(757.41,LEXR,1,1)) D DES
D:$E(X,1)="?"&(LEXR<1!(LEXR>LEX(0))) STD
D:$E(X,1)'="?" STD D RD
Q
SO ; Show one help
N LEXR S LEXR=1
I $E(X,1)="?",LEXR>0,LEXR<(LEX(0)+1) D
. S LEXR=LEX(LEXR) D:'$D(^LEX(757.41,LEXR,1,1)) NODES,STDO
. Q:'$D(^LEX(757.41,LEXR,1,1)) D DES
D:$E(X,1)'="?" STDO D RDO
Q
STD ; Standard Help
W !!,"Enter 1-",LEXC," to select a Shortcut Context, "
W "or ""?"" for help, or ""?#"" for descriptive"
W !,"help on an entry flagged with an ""*"", or ""^"" "
W "to exit or <Return> for more."
Q
STDO ; Standard Help - One
W !!,"One Shortcut Context available to edit, "
W "enter ""Yes"" to select, or ""^"" to exit."
Q
DES ; Description Help
N LEXI S LEXI=0 W !!,?2,$P(^LEX(757.41,LEXR,0),"^",1),!
F S LEXI=$O(^LEX(757.41,LEXR,1,LEXI)) Q:+LEXI=0 D
. W !,?4,^LEX(757.41,LEXR,1,LEXI,0)
W ! Q
NODES ; No Description Available
W !!,?2,$P(^LEX(757.41,LEXR,0),"^",1)
W " does not have a description",! Q
RD ; Re-Display List (MULTIPLE)
N LEXF,LEXT S LEXT=+($G(LEXL)),LEXF=(+(LEXT#5)-1)
S:LEXF<0 LEXF=4 S LEXF=LEXT-LEXF,LEXF=LEXF-1
F S LEXF=$O(LEX(LEXF)) Q:+LEXF=0!(LEXF'<(LEXT+1)) D
. W:LEXF=1 ! D W(LEXF,LEX(LEXF))
Q
RDO ; Re-Display List (ONE)
N LEXR S LEXR=LEX(1) W ! D WO(LEXR)
Q
W(LEXC,LEXR) ; Write entry
W !,$J(LEXC,4),". ",$P(^LEX(757.41,LEXR,0),"^",1)
W $S($D(^LEX(757.41,LEXR,1)):" *",1:"") Q
WO(LEXR) ; Write one entry
W !,$P(^LEX(757.41,LEXR,0),"^",1) W $S($D(^LEX(757.41,LEXR,1)):" *",1:"") Q
TOT ; Total Context
N LEXR,LEXC S (LEXR,LEXC)=0 F S LEXR=$O(^LEX(757.41,LEXR)) Q:+LEXR=0 D
. Q:$D(LEXEDIT)&($P($G(^LEX(757.41,LEXR,0)),"^",2)'=1) S LEXC=LEXC+1
I $D(LEXEDIT) D Q
. W:LEXC>1 !!,LEXC," SHORTCUT CONTEXT(s) found which can be edited",!
. W:LEXC=1 !!,"Only ",LEXC," SHORTCUT CONTEXT found which can be edited",!
W:LEXC>1 !!,LEXC," SHORTCUT CONTEXT(s) found",! W:LEXC=1 !!,"Only ",LEXC," SHORTCUT CONTEXT found",!
Q
CNT(X) ; Count
N LEXR,LEXC S (LEXR,LEXC)=0 F S LEXR=$O(^LEX(757.41,LEXR)) Q:+LEXR=0 D
. Q:$D(LEXEDIT)&($P($G(^LEX(757.41,LEXR,0)),"^",2)'=1) S LEXC=LEXC+1
S X=LEXC Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXDCXS 4586 printed Apr 09, 2024@21:13:15 Page 2
LEXDCXS ;ISL/KER - Default Context - Select ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.41) N/A
+5 ;
+6 ; External References
+7 ; ^DIR ICR 10026
+8 ;
+9 ; Special Look-up in file 757.41 Shortcut Context
+10 ;
+11 ; Entry: S X=$$EN^LEXDCXS
+12 ;
+13 ; Function returns a two piece string
+14 ;
+15 ; $P 1 Pointer to file 757.41, and a valid
+16 ; value for LEXCTX (context user default)
+17 ; This will be null if input is "^"
+18 ;
+19 ; $P 2 Name of context selected. This will
+20 ; be null only when user input is "^^"
+21 ;
+22 ; LEX Array containing pointers to 757.41
+23 ; LEXA Users answer to selection
+24 ; LEXC Counter
+25 ; LEXE Edit/non-edit Counter
+26 ; LEXF Re-display starting from #LEXF
+27 ; LEXI Incremental Counter
+28 ; LEXL Last entry displayed
+29 ; LEXR Internal Entry Number (Record) in #757.41
+30 ; LEXT Re-display up through #LEXT
+31 ; LEXX Returned value
+32 ;
EN(LEXX) ; Entry: S X=$$EN^LEXDCXS
+1 NEW X,Y,LEX,LEXC,LEXL,LEXR,LEXA,LEXE
SET LEXE=$$CNT
DO TOT
+2 SET LEXA=""
SET (LEXX,LEXC,LEXR)=0
+3 FOR
SET LEXR=$ORDER(^LEX(757.41,LEXR))
if +LEXR=0!(LEXA["^")!(+LEXX>0)
QUIT
Begin DoDot:1
+4 IF $DATA(LEXEDIT)
IF $PIECE($GET(^LEX(757.41,LEXR,0)),"^",2)'=1
QUIT
+5 SET LEXC=LEXC+1
SET LEXL=LEXC
+6 SET LEX(LEXC)=LEXR
SET LEX(0)=LEXC
+7 if LEXE>1
DO W(LEXC,LEXR)
+8 if LEXE=1
DO WO(LEXR)
End DoDot:1
+9 ; D ASK
+10 DO ASK
IF LEXA["^"
DO UOUT
QUIT LEXX
+11 DO VAL
QUIT LEXX
ASK ; Ask for user input
+1 if +LEXX>0
QUIT
if LEXA["^"
QUIT
if +LEXR>0&(LEXC#5'=0)
QUIT
+2 if +LEXR=0&(LEXC#5=0)
QUIT
+3 DO SEL
if +LEXA'>0
QUIT
if LEXA>LEXE
QUIT
SET LEXX=$GET(LEX(+LEXA))
+4 QUIT
SEL ; Select from list
+1 IF LEXE=1
DO ONE
QUIT
+2 WRITE !
NEW X,Y,DIR,DIRUT,DTOUT,DUOUT,DIROUT
+3 SET DIR(0)="NAO^1:"_LEXC
+4 SET DIR("A")="Select SHORTCUT CONTEXT 1-"_LEXC_": // "
+5 SET (DIR("?"),DIR("??"))="^D SH^LEXDCXS"
+6 DO ^DIR
SET LEXA=Y
+7 QUIT
ONE ;
+1 WRITE !
NEW X,Y,DIR,DIRUT,DTOUT,DUOUT,DIROUT
+2 SET DIR(0)="YAO"
+3 SET DIR("A")=" Ok? // "
+4 SET (DIR("?"),DIR("??"))="^D SO^LEXDCXS"
+5 DO ^DIR
SET LEXA=$SELECT(+Y>0:1,1:0)
+6 QUIT
UOUT ; Up Arrow detected
+1 if LEXA="^^"
SET LEXX="^"
+2 if LEXA="^"
SET LEXX="^No context selected"
+3 QUIT
VAL ; No Un Arrow (value)
+1 IF +LEXX>0
Begin DoDot:1
+2 IF $DATA(^LEX(757.41,+LEXX))
Begin DoDot:2
+3 SET LEXX=LEXX_"^"_$PIECE($GET(^LEX(757.41,+LEXX,0)),"^",1)
End DoDot:2
QUIT
+4 SET LEXX="^No context selected"
End DoDot:1
QUIT
+5 SET LEXX="^No context selected"
+6 QUIT
SH ; Show help
+1 NEW LEXR
SET LEXR=+($EXTRACT(X,2,$LENGTH(X)))
+2 IF $EXTRACT(X,1)="?"
IF LEXR>0
IF LEXR<(LEX(0)+1)
Begin DoDot:1
+3 SET LEXR=LEX(LEXR)
if '$DATA(^LEX(757.41,LEXR,1,1))
DO NODES
DO STD
+4 if '$DATA(^LEX(757.41,LEXR,1,1))
QUIT
DO DES
End DoDot:1
+5 if $EXTRACT(X,1)="?"&(LEXR<1!(LEXR>LEX(0)))
DO STD
+6 if $EXTRACT(X,1)'="?"
DO STD
DO RD
+7 QUIT
SO ; Show one help
+1 NEW LEXR
SET LEXR=1
+2 IF $EXTRACT(X,1)="?"
IF LEXR>0
IF LEXR<(LEX(0)+1)
Begin DoDot:1
+3 SET LEXR=LEX(LEXR)
if '$DATA(^LEX(757.41,LEXR,1,1))
DO NODES
DO STDO
+4 if '$DATA(^LEX(757.41,LEXR,1,1))
QUIT
DO DES
End DoDot:1
+5 if $EXTRACT(X,1)'="?"
DO STDO
DO RDO
+6 QUIT
STD ; Standard Help
+1 WRITE !!,"Enter 1-",LEXC," to select a Shortcut Context, "
+2 WRITE "or ""?"" for help, or ""?#"" for descriptive"
+3 WRITE !,"help on an entry flagged with an ""*"", or ""^"" "
+4 WRITE "to exit or <Return> for more."
+5 QUIT
STDO ; Standard Help - One
+1 WRITE !!,"One Shortcut Context available to edit, "
+2 WRITE "enter ""Yes"" to select, or ""^"" to exit."
+3 QUIT
DES ; Description Help
+1 NEW LEXI
SET LEXI=0
WRITE !!,?2,$PIECE(^LEX(757.41,LEXR,0),"^",1),!
+2 FOR
SET LEXI=$ORDER(^LEX(757.41,LEXR,1,LEXI))
if +LEXI=0
QUIT
Begin DoDot:1
+3 WRITE !,?4,^LEX(757.41,LEXR,1,LEXI,0)
End DoDot:1
+4 WRITE !
QUIT
NODES ; No Description Available
+1 WRITE !!,?2,$PIECE(^LEX(757.41,LEXR,0),"^",1)
+2 WRITE " does not have a description",!
QUIT
RD ; Re-Display List (MULTIPLE)
+1 NEW LEXF,LEXT
SET LEXT=+($GET(LEXL))
SET LEXF=(+(LEXT#5)-1)
+2 if LEXF<0
SET LEXF=4
SET LEXF=LEXT-LEXF
SET LEXF=LEXF-1
+3 FOR
SET LEXF=$ORDER(LEX(LEXF))
if +LEXF=0!(LEXF'<(LEXT+1))
QUIT
Begin DoDot:1
+4 if LEXF=1
WRITE !
DO W(LEXF,LEX(LEXF))
End DoDot:1
+5 QUIT
RDO ; Re-Display List (ONE)
+1 NEW LEXR
SET LEXR=LEX(1)
WRITE !
DO WO(LEXR)
+2 QUIT
W(LEXC,LEXR) ; Write entry
+1 WRITE !,$JUSTIFY(LEXC,4),". ",$PIECE(^LEX(757.41,LEXR,0),"^",1)
+2 WRITE $SELECT($DATA(^LEX(757.41,LEXR,1)):" *",1:"")
QUIT
WO(LEXR) ; Write one entry
+1 WRITE !,$PIECE(^LEX(757.41,LEXR,0),"^",1)
WRITE $SELECT($DATA(^LEX(757.41,LEXR,1)):" *",1:"")
QUIT
TOT ; Total Context
+1 NEW LEXR,LEXC
SET (LEXR,LEXC)=0
FOR
SET LEXR=$ORDER(^LEX(757.41,LEXR))
if +LEXR=0
QUIT
Begin DoDot:1
+2 if $DATA(LEXEDIT)&($PIECE($GET(^LEX(757.41,LEXR,0)),"^",2)'=1)
QUIT
SET LEXC=LEXC+1
End DoDot:1
+3 IF $DATA(LEXEDIT)
Begin DoDot:1
+4 if LEXC>1
WRITE !!,LEXC," SHORTCUT CONTEXT(s) found which can be edited",!
+5 if LEXC=1
WRITE !!,"Only ",LEXC," SHORTCUT CONTEXT found which can be edited",!
End DoDot:1
QUIT
+6 if LEXC>1
WRITE !!,LEXC," SHORTCUT CONTEXT(s) found",!
if LEXC=1
WRITE !!,"Only ",LEXC," SHORTCUT CONTEXT found",!
+7 QUIT
CNT(X) ; Count
+1 NEW LEXR,LEXC
SET (LEXR,LEXC)=0
FOR
SET LEXR=$ORDER(^LEX(757.41,LEXR))
if +LEXR=0
QUIT
Begin DoDot:1
+2 if $DATA(LEXEDIT)&($PIECE($GET(^LEX(757.41,LEXR,0)),"^",2)'=1)
QUIT
SET LEXC=LEXC+1
End DoDot:1
+3 SET X=LEXC
QUIT X
