Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXDCCS

LEXDCCS.m

Go to the documentation of this file.
  1. LEXDCCS ;ISL/KER - Default Display - Select ;04/21/2014
  1. ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
  1. ;
  1. ; Global Variables
  1. ; ^LEX(757.31) N/A
  1. ;
  1. ; External References
  1. ; ^DIR ICR 10026
  1. ;
  1. ; Special Look-up in file 757.31 Display formats
  1. ; Entry: S X=$$EN^LEXDCCS
  1. ;
  1. ; Function returns a two piece string
  1. ;
  1. ; $P 1 String of classifications coding
  1. ; system mnemonics, i.e., "ICD/CPT",
  1. ; and a legitimate value for LEXSHOW.
  1. ; This will be null if input is "^"
  1. ;
  1. ; $P 2 Name of display string selected i.e.,
  1. ; "ICD/CPT only" This will be null only
  1. ; when user input is "^^"
  1. ;
  1. ; LEX Array containing pointers to 757.31
  1. ; LEXA Users answer to selection
  1. ; LEXC Counter
  1. ; LEXD Display
  1. ; LEXF Re-display starting from #LEXF
  1. ; LEXI Incremental Counter
  1. ; LEXL Last entry displayed
  1. ; LEXLN Line counter
  1. ; LEXR Internal Entry Number (Record) in #757.31
  1. ; LEXS Selection
  1. ; LEXT Re-display up through #LEXT
  1. ;
  1. EN(LEXX) ; Select a predefined display string
  1. N X,Y,LEX,LEXC,LEXL,LEXR,LEXA,LEXD D TOT
  1. S LEXD="",(LEXA,LEXX,LEXC,LEXR)=0
  1. F S LEXD=$O(^LEX(757.31,"B",LEXD)) Q:LEXD=""!(LEXA["^")!(+LEXX>0) D
  1. . S LEXR=0
  1. . F S LEXR=$O(^LEX(757.31,"B",LEXD,LEXR)) Q:+LEXR=0!(LEXA["^")!(+LEXX>0) D
  1. . . S LEXC=LEXC+1,LEXL=LEXC
  1. . . S LEX(LEXC)=LEXR,LEX(0)=LEXC
  1. . . D W(LEXC,LEXR)
  1. . . I LEXC#5=0,+LEXX=0 S LEXA=$$SEL S:+LEXA>0&(+LEXA<(LEXC+1)) LEXX=+LEXA
  1. I +LEXX=0,LEXA'["^",LEXC#5'=0 S LEXA=$$SEL S:+LEXA>0&(+LEXA<(LEXC+1)) LEXX=+LEXA
  1. S LEXX=+LEXX S:LEXX'=0&($D(LEX(LEXX))) LEXX=LEX(LEXX) K LEX
  1. I +LEXX>0 S LEXX=$G(^LEX(757.31,+LEXX,1))_"^"_$P($G(^LEX(757.31,+LEXX,0)),"^",1) Q LEXX
  1. S:LEXA'["^^" LEXX="^No display selected" S:LEXA["^^" LEXX="^^"
  1. Q LEXX
  1. SEL(LEXS) ; Select from the array
  1. S LEXS="" W ! N X,Y,DIRUT,DTOUT,DUOUT,DIROUT,DIR
  1. S DIR(0)="NAO^1:"_LEXC
  1. S DIR("A")="Select 1-"_LEXC_": ",(DIR("?"),DIR("??"))="^D SH^LEXDCCS"
  1. D ^DIR W:$G(X)="" ! S LEXS=$S(X["^"&(X'["^^"):"^",X["^^":"^^",X'["^"&(+Y=0):"",1:+Y) Q LEXS
  1. SH ; Show help
  1. I X'["?" D STD Q
  1. N LEXR S LEXR=+($E(X,2,$L(X))) I $E(X,1)="?",LEXR>0,LEXR<(LEX(0)+1) D
  1. . S LEXR=LEX(LEXR) D:'$D(^LEX(757.31,LEXR,2,1)) NODES,STD Q:'$D(^LEX(757.31,LEXR,2,1)) D DES
  1. D:$E(X,1)="?"&(LEXR<1!(LEXR>LEX(0))) STD D:$E(X,1)'="?" STD D RD
  1. Q
  1. STD ; Standard Help
  1. W !!,"Enter 1-",LEXC," to select a Shortcut Context, or ""?"" for help, or ""?#"" for descriptive"
  1. W !,"help on an entry flagged with an ""*"", or ""^"" to exit or <Return> for more."
  1. Q
  1. DES ; Description Help
  1. N LEXLN,LEXI S (LEXLN,LEXI)=0 W !!,?2,$P(^LEX(757.31,LEXR,0),"^",1),!
  1. F S LEXI=$O(^LEX(757.31,LEXR,2,LEXI)) Q:+LEXI=0 D
  1. . W !,?4,^LEX(757.31,LEXR,2,LEXI,0) S LEXLN=LEXLN+1
  1. D:LEXLN>4 EOP W ! Q
  1. NODES ; No Description Help Available
  1. W !!,?2,$P(^LEX(757.31,LEXR,0),"^",1)," does not have a description",! Q
  1. RD ; Re-Display List
  1. N LEXF,LEXT S LEXT=+($G(LEXL)),LEXF=(+(LEXT#5)-1)
  1. S:LEXF<0 LEXF=4 S LEXF=LEXT-LEXF S LEXF=LEXF-1
  1. F S LEXF=$O(LEX(LEXF)) Q:+LEXF=0!(LEXF'<(LEXT+1)) D
  1. . W:LEXF=1 ! D W(LEXF,LEX(LEXF))
  1. Q
  1. W(LEXC,LEXR) ; Write entry
  1. W !,$J(LEXC,4),". ",$P(^LEX(757.31,LEXR,0),"^",1)
  1. W $S($D(^LEX(757.31,LEXR,2,1)):" *",1:"") Q
  1. TOT ; Total displays
  1. N LEXD,LEXR,LEXC S LEXD="",LEXC=0
  1. F S LEXD=$O(^LEX(757.31,"B",LEXD)) Q:LEXD="" S LEXR=0 D
  1. . F S LEXR=$O(^LEX(757.31,"B",LEXD,LEXR)) Q:+LEXR=0 S LEXC=LEXC+1
  1. W !!,LEXC," Displays found",!
  1. Q
  1. EOP ; End of Page
  1. W ! N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT S DIR(0)="E" D ^DIR S:X[U LEXA="^" W ! Q