- LEXDCCS ;ISL/KER - Default Display - Select ;04/21/2014
- ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
- ;
- ; Global Variables
- ; ^LEX(757.31) N/A
- ;
- ; External References
- ; ^DIR ICR 10026
- ;
- ; Special Look-up in file 757.31 Display formats
- ; Entry: S X=$$EN^LEXDCCS
- ;
- ; Function returns a two piece string
- ;
- ; $P 1 String of classifications coding
- ; system mnemonics, i.e., "ICD/CPT",
- ; and a legitimate value for LEXSHOW.
- ; This will be null if input is "^"
- ;
- ; $P 2 Name of display string selected i.e.,
- ; "ICD/CPT only" This will be null only
- ; when user input is "^^"
- ;
- ; LEX Array containing pointers to 757.31
- ; LEXA Users answer to selection
- ; LEXC Counter
- ; LEXD Display
- ; LEXF Re-display starting from #LEXF
- ; LEXI Incremental Counter
- ; LEXL Last entry displayed
- ; LEXLN Line counter
- ; LEXR Internal Entry Number (Record) in #757.31
- ; LEXS Selection
- ; LEXT Re-display up through #LEXT
- ;
- EN(LEXX) ; Select a predefined display string
- N X,Y,LEX,LEXC,LEXL,LEXR,LEXA,LEXD D TOT
- S LEXD="",(LEXA,LEXX,LEXC,LEXR)=0
- F S LEXD=$O(^LEX(757.31,"B",LEXD)) Q:LEXD=""!(LEXA["^")!(+LEXX>0) D
- . S LEXR=0
- . F S LEXR=$O(^LEX(757.31,"B",LEXD,LEXR)) Q:+LEXR=0!(LEXA["^")!(+LEXX>0) D
- . . S LEXC=LEXC+1,LEXL=LEXC
- . . S LEX(LEXC)=LEXR,LEX(0)=LEXC
- . . D W(LEXC,LEXR)
- . . I LEXC#5=0,+LEXX=0 S LEXA=$$SEL S:+LEXA>0&(+LEXA<(LEXC+1)) LEXX=+LEXA
- I +LEXX=0,LEXA'["^",LEXC#5'=0 S LEXA=$$SEL S:+LEXA>0&(+LEXA<(LEXC+1)) LEXX=+LEXA
- S LEXX=+LEXX S:LEXX'=0&($D(LEX(LEXX))) LEXX=LEX(LEXX) K LEX
- I +LEXX>0 S LEXX=$G(^LEX(757.31,+LEXX,1))_"^"_$P($G(^LEX(757.31,+LEXX,0)),"^",1) Q LEXX
- S:LEXA'["^^" LEXX="^No display selected" S:LEXA["^^" LEXX="^^"
- Q LEXX
- SEL(LEXS) ; Select from the array
- S LEXS="" W ! N X,Y,DIRUT,DTOUT,DUOUT,DIROUT,DIR
- S DIR(0)="NAO^1:"_LEXC
- S DIR("A")="Select 1-"_LEXC_": ",(DIR("?"),DIR("??"))="^D SH^LEXDCCS"
- D ^DIR W:$G(X)="" ! S LEXS=$S(X["^"&(X'["^^"):"^",X["^^":"^^",X'["^"&(+Y=0):"",1:+Y) Q LEXS
- SH ; Show help
- I X'["?" D STD Q
- 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.31,LEXR,2,1)) NODES,STD Q:'$D(^LEX(757.31,LEXR,2,1)) D DES
- D:$E(X,1)="?"&(LEXR<1!(LEXR>LEX(0))) STD D:$E(X,1)'="?" STD D RD
- Q
- STD ; Standard Help
- W !!,"Enter 1-",LEXC," to select a Shortcut Context, or ""?"" for help, or ""?#"" for descriptive"
- W !,"help on an entry flagged with an ""*"", or ""^"" to exit or <Return> for more."
- Q
- DES ; Description Help
- N LEXLN,LEXI S (LEXLN,LEXI)=0 W !!,?2,$P(^LEX(757.31,LEXR,0),"^",1),!
- F S LEXI=$O(^LEX(757.31,LEXR,2,LEXI)) Q:+LEXI=0 D
- . W !,?4,^LEX(757.31,LEXR,2,LEXI,0) S LEXLN=LEXLN+1
- D:LEXLN>4 EOP W ! Q
- NODES ; No Description Help Available
- W !!,?2,$P(^LEX(757.31,LEXR,0),"^",1)," does not have a description",! Q
- RD ; Re-Display List
- N LEXF,LEXT S LEXT=+($G(LEXL)),LEXF=(+(LEXT#5)-1)
- S:LEXF<0 LEXF=4 S LEXF=LEXT-LEXF S 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
- W(LEXC,LEXR) ; Write entry
- W !,$J(LEXC,4),". ",$P(^LEX(757.31,LEXR,0),"^",1)
- W $S($D(^LEX(757.31,LEXR,2,1)):" *",1:"") Q
- TOT ; Total displays
- N LEXD,LEXR,LEXC S LEXD="",LEXC=0
- F S LEXD=$O(^LEX(757.31,"B",LEXD)) Q:LEXD="" S LEXR=0 D
- . F S LEXR=$O(^LEX(757.31,"B",LEXD,LEXR)) Q:+LEXR=0 S LEXC=LEXC+1
- W !!,LEXC," Displays found",!
- Q
- EOP ; End of Page
- W ! N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT S DIR(0)="E" D ^DIR S:X[U LEXA="^" W ! Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXDCCS 3656 printed Jan 18, 2025@03:08:15 Page 2
- LEXDCCS ;ISL/KER - Default Display - Select ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
- +2 ;
- +3 ; Global Variables
- +4 ; ^LEX(757.31) N/A
- +5 ;
- +6 ; External References
- +7 ; ^DIR ICR 10026
- +8 ;
- +9 ; Special Look-up in file 757.31 Display formats
- +10 ; Entry: S X=$$EN^LEXDCCS
- +11 ;
- +12 ; Function returns a two piece string
- +13 ;
- +14 ; $P 1 String of classifications coding
- +15 ; system mnemonics, i.e., "ICD/CPT",
- +16 ; and a legitimate value for LEXSHOW.
- +17 ; This will be null if input is "^"
- +18 ;
- +19 ; $P 2 Name of display string selected i.e.,
- +20 ; "ICD/CPT only" This will be null only
- +21 ; when user input is "^^"
- +22 ;
- +23 ; LEX Array containing pointers to 757.31
- +24 ; LEXA Users answer to selection
- +25 ; LEXC Counter
- +26 ; LEXD Display
- +27 ; LEXF Re-display starting from #LEXF
- +28 ; LEXI Incremental Counter
- +29 ; LEXL Last entry displayed
- +30 ; LEXLN Line counter
- +31 ; LEXR Internal Entry Number (Record) in #757.31
- +32 ; LEXS Selection
- +33 ; LEXT Re-display up through #LEXT
- +34 ;
- EN(LEXX) ; Select a predefined display string
- +1 NEW X,Y,LEX,LEXC,LEXL,LEXR,LEXA,LEXD
- DO TOT
- +2 SET LEXD=""
- SET (LEXA,LEXX,LEXC,LEXR)=0
- +3 FOR
- SET LEXD=$ORDER(^LEX(757.31,"B",LEXD))
- if LEXD=""!(LEXA["^")!(+LEXX>0)
- QUIT
- Begin DoDot:1
- +4 SET LEXR=0
- +5 FOR
- SET LEXR=$ORDER(^LEX(757.31,"B",LEXD,LEXR))
- if +LEXR=0!(LEXA["^")!(+LEXX>0)
- QUIT
- Begin DoDot:2
- +6 SET LEXC=LEXC+1
- SET LEXL=LEXC
- +7 SET LEX(LEXC)=LEXR
- SET LEX(0)=LEXC
- +8 DO W(LEXC,LEXR)
- +9 IF LEXC#5=0
- IF +LEXX=0
- SET LEXA=$$SEL
- if +LEXA>0&(+LEXA<(LEXC+1))
- SET LEXX=+LEXA
- End DoDot:2
- End DoDot:1
- +10 IF +LEXX=0
- IF LEXA'["^"
- IF LEXC#5'=0
- SET LEXA=$$SEL
- if +LEXA>0&(+LEXA<(LEXC+1))
- SET LEXX=+LEXA
- +11 SET LEXX=+LEXX
- if LEXX'=0&($DATA(LEX(LEXX)))
- SET LEXX=LEX(LEXX)
- KILL LEX
- +12 IF +LEXX>0
- SET LEXX=$GET(^LEX(757.31,+LEXX,1))_"^"_$PIECE($GET(^LEX(757.31,+LEXX,0)),"^",1)
- QUIT LEXX
- +13 if LEXA'["^^"
- SET LEXX="^No display selected"
- if LEXA["^^"
- SET LEXX="^^"
- +14 QUIT LEXX
- SEL(LEXS) ; Select from the array
- +1 SET LEXS=""
- WRITE !
- NEW X,Y,DIRUT,DTOUT,DUOUT,DIROUT,DIR
- +2 SET DIR(0)="NAO^1:"_LEXC
- +3 SET DIR("A")="Select 1-"_LEXC_": "
- SET (DIR("?"),DIR("??"))="^D SH^LEXDCCS"
- +4 DO ^DIR
- if $GET(X)=""
- WRITE !
- SET LEXS=$SELECT(X["^"&(X'["^^"):"^",X["^^":"^^",X'["^"&(+Y=0):"",1:+Y)
- QUIT LEXS
- SH ; Show help
- +1 IF X'["?"
- DO STD
- QUIT
- +2 NEW LEXR
- SET LEXR=+($EXTRACT(X,2,$LENGTH(X)))
- IF $EXTRACT(X,1)="?"
- IF LEXR>0
- IF LEXR<(LEX(0)+1)
- Begin DoDot:1
- +3 SET LEXR=LEX(LEXR)
- if '$DATA(^LEX(757.31,LEXR,2,1))
- DO NODES
- DO STD
- if '$DATA(^LEX(757.31,LEXR,2,1))
- QUIT
- DO DES
- End DoDot:1
- +4 if $EXTRACT(X,1)="?"&(LEXR<1!(LEXR>LEX(0)))
- DO STD
- if $EXTRACT(X,1)'="?"
- DO STD
- DO RD
- +5 QUIT
- STD ; Standard Help
- +1 WRITE !!,"Enter 1-",LEXC," to select a Shortcut Context, or ""?"" for help, or ""?#"" for descriptive"
- +2 WRITE !,"help on an entry flagged with an ""*"", or ""^"" to exit or <Return> for more."
- +3 QUIT
- DES ; Description Help
- +1 NEW LEXLN,LEXI
- SET (LEXLN,LEXI)=0
- WRITE !!,?2,$PIECE(^LEX(757.31,LEXR,0),"^",1),!
- +2 FOR
- SET LEXI=$ORDER(^LEX(757.31,LEXR,2,LEXI))
- if +LEXI=0
- QUIT
- Begin DoDot:1
- +3 WRITE !,?4,^LEX(757.31,LEXR,2,LEXI,0)
- SET LEXLN=LEXLN+1
- End DoDot:1
- +4 if LEXLN>4
- DO EOP
- WRITE !
- QUIT
- NODES ; No Description Help Available
- +1 WRITE !!,?2,$PIECE(^LEX(757.31,LEXR,0),"^",1)," does not have a description",!
- QUIT
- RD ; Re-Display List
- +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
- W(LEXC,LEXR) ; Write entry
- +1 WRITE !,$JUSTIFY(LEXC,4),". ",$PIECE(^LEX(757.31,LEXR,0),"^",1)
- +2 WRITE $SELECT($DATA(^LEX(757.31,LEXR,2,1)):" *",1:"")
- QUIT
- TOT ; Total displays
- +1 NEW LEXD,LEXR,LEXC
- SET LEXD=""
- SET LEXC=0
- +2 FOR
- SET LEXD=$ORDER(^LEX(757.31,"B",LEXD))
- if LEXD=""
- QUIT
- SET LEXR=0
- Begin DoDot:1
- +3 FOR
- SET LEXR=$ORDER(^LEX(757.31,"B",LEXD,LEXR))
- if +LEXR=0
- QUIT
- SET LEXC=LEXC+1
- End DoDot:1
- +4 WRITE !!,LEXC," Displays found",!
- +5 QUIT
- EOP ; End of Page
- +1 WRITE !
- NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
- SET DIR(0)="E"
- DO ^DIR
- if X[U
- SET LEXA="^"
- WRITE !
- QUIT