LEXDCCC ;ISL/KER - Default Display - Create ;05/23/2017
;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^TMP("LEXX") SACC 2.3.2.5.1
;
; External References
; YN^DICN ICR 10009
;
; Entry: S X=$$EN^LEXDCCC
;
; 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 "^^"
;
; LEXA Answer to prompt (Yes 1 No 0)
; LEXC Counter
; LEXI Incremental Counter
; LEXS Source, i.e., ICD94, NAN90, CPT89
; LEXSO Source abbreviation, i.e., ICD, CPT, DSM
; LEXR Internal Entry (Record) Number in #757.31
;
; LEXFIL Flag, indicates that the
; classification codes selected are
; for building a filter - DIC("S")
;
T S X=$$EN W !!,X Q
EN(LEXX) ; Entry point S X=$$EN^LEXDCCC
BUILD ; Build the list to select from
K ^TMP("LEXX",$J) W @IOF
W:$D(LEXFIL) !,"Include terms linked to the following classification systems:",!!
W:'$D(LEXFIL) !,"Display codes belonging to the following classification systems:",!!
N LEXA,LEXC,LEXI,LEXSO,LEXR,LEXS
S LEXS=""
F S LEXS=$O(^LEX(757.03,"B",LEXS)) Q:LEXS="" D
. Q:'$D(^LEX(757.02,"ASRC",$E(LEXS,1,3)))
. S LEXSO=$E(LEXS,1,3) I LEXSO="UND" Q
. S LEXR=$O(^LEX(757.03,"B",LEXS,0))
. S LEXC=$S($D(^TMP("LEXX",$J,LEXSO)):LEXC+1,1:1)
. S ^TMP("LEXX",$J,LEXSO,0)=LEXC
. S ^TMP("LEXX",$J,LEXSO,LEXC)=$P(^LEX(757.03,LEXR,0),U,2,4000)
LIST ; Display the list to select from
S (LEXX,LEXA,LEXSO)=""
F S LEXSO=$O(^TMP("LEXX",$J,LEXSO)) Q:LEXSO=""!(LEXA[U) D
. W !,LEXSO F LEXI=1:1:^TMP("LEXX",$J,LEXSO,0) D
. . W ?5,$P(^TMP("LEXX",$J,LEXSO,LEXI),U,2),!
ANS . ; Ask for user selection
. W:'$D(LEXFIL) "Display these codes during look-up"
. W:$D(LEXFIL) "Include terms linked to these codes during look-up"
. S %=2 D YN^DICN S LEXA=%Y I %=2 W ! Q
. I '%,'$D(LEXFIL) W !,"The codes from the selected coding systems may be displayed with the term.",! G ANS
. I '%,$D(LEXFIL) W !,"Searches will display terms linked to the selected coding systems",! G ANS
. I +($G(%))<0 S:%Y["^" LEXA="^" S:%Y["^^" LEXA="^^" W ! Q
. S LEXX=LEXX_"/"_LEXSO W ! Q
I $E(LEXX,1)="/" S LEXX=$E(LEXX,2,$L(LEXX))
S:$D(LEXFIL) LEXX=LEXX_"^" I '$D(LEXFIL) D
. N LEXNAM S LEXNAM=""
. S:$P(LEXX,U,1)'="" LEXNAM=$$NAME^LEXDM3
. S LEXX=LEXX_"^"_$S($L(LEXX):LEXNAM,1:"No display selected")
S:LEXA["^^" LEXX="^^"
K ^TMP("LEXX",$J),%,LEXA,LEXC,LEXI,LEXSO,LEXS,LEXR
Q LEXX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXDCCC 2804 printed Apr 09, 2024@21:10:37 Page 2
LEXDCCC ;ISL/KER - Default Display - Create ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXX") SACC 2.3.2.5.1
+5 ;
+6 ; External References
+7 ; YN^DICN ICR 10009
+8 ;
+9 ; Entry: S X=$$EN^LEXDCCC
+10 ;
+11 ; Function returns a two piece string
+12 ;
+13 ; $P 1 String of classifications coding
+14 ; system mnemonics, i.e., "ICD/CPT",
+15 ; and a legitimate value for LEXSHOW.
+16 ; This will be null if input is "^"
+17 ;
+18 ; $P 2 Name of display string selected i.e.,
+19 ; "ICD/CPT only" This will be null only
+20 ; when user input is "^^"
+21 ;
+22 ; LEXA Answer to prompt (Yes 1 No 0)
+23 ; LEXC Counter
+24 ; LEXI Incremental Counter
+25 ; LEXS Source, i.e., ICD94, NAN90, CPT89
+26 ; LEXSO Source abbreviation, i.e., ICD, CPT, DSM
+27 ; LEXR Internal Entry (Record) Number in #757.31
+28 ;
+29 ; LEXFIL Flag, indicates that the
+30 ; classification codes selected are
+31 ; for building a filter - DIC("S")
+32 ;
T SET X=$$EN
WRITE !!,X
QUIT
EN(LEXX) ; Entry point S X=$$EN^LEXDCCC
BUILD ; Build the list to select from
+1 KILL ^TMP("LEXX",$JOB)
WRITE @IOF
+2 if $DATA(LEXFIL)
WRITE !,"Include terms linked to the following classification systems:",!!
+3 if '$DATA(LEXFIL)
WRITE !,"Display codes belonging to the following classification systems:",!!
+4 NEW LEXA,LEXC,LEXI,LEXSO,LEXR,LEXS
+5 SET LEXS=""
+6 FOR
SET LEXS=$ORDER(^LEX(757.03,"B",LEXS))
if LEXS=""
QUIT
Begin DoDot:1
+7 if '$DATA(^LEX(757.02,"ASRC",$EXTRACT(LEXS,1,3)))
QUIT
+8 SET LEXSO=$EXTRACT(LEXS,1,3)
IF LEXSO="UND"
QUIT
+9 SET LEXR=$ORDER(^LEX(757.03,"B",LEXS,0))
+10 SET LEXC=$SELECT($DATA(^TMP("LEXX",$JOB,LEXSO)):LEXC+1,1:1)
+11 SET ^TMP("LEXX",$JOB,LEXSO,0)=LEXC
+12 SET ^TMP("LEXX",$JOB,LEXSO,LEXC)=$PIECE(^LEX(757.03,LEXR,0),U,2,4000)
End DoDot:1
LIST ; Display the list to select from
+1 SET (LEXX,LEXA,LEXSO)=""
+2 FOR
SET LEXSO=$ORDER(^TMP("LEXX",$JOB,LEXSO))
if LEXSO=""!(LEXA[U)
QUIT
Begin DoDot:1
+3 WRITE !,LEXSO
FOR LEXI=1:1:^TMP("LEXX",$JOB,LEXSO,0)
Begin DoDot:2
+4 WRITE ?5,$PIECE(^TMP("LEXX",$JOB,LEXSO,LEXI),U,2),!
End DoDot:2
ANS ; Ask for user selection
+1 if '$DATA(LEXFIL)
WRITE "Display these codes during look-up"
+2 if $DATA(LEXFIL)
WRITE "Include terms linked to these codes during look-up"
+3 SET %=2
DO YN^DICN
SET LEXA=%Y
IF %=2
WRITE !
QUIT
+4 IF '%
IF '$DATA(LEXFIL)
WRITE !,"The codes from the selected coding systems may be displayed with the term.",!
GOTO ANS
+5 IF '%
IF $DATA(LEXFIL)
WRITE !,"Searches will display terms linked to the selected coding systems",!
GOTO ANS
+6 IF +($GET(%))<0
if %Y["^"
SET LEXA="^"
if %Y["^^"
SET LEXA="^^"
WRITE !
QUIT
+7 SET LEXX=LEXX_"/"_LEXSO
WRITE !
QUIT
End DoDot:1
+8 IF $EXTRACT(LEXX,1)="/"
SET LEXX=$EXTRACT(LEXX,2,$LENGTH(LEXX))
+9 if $DATA(LEXFIL)
SET LEXX=LEXX_"^"
IF '$DATA(LEXFIL)
Begin DoDot:1
+10 NEW LEXNAM
SET LEXNAM=""
+11 if $PIECE(LEXX,U,1)'=""
SET LEXNAM=$$NAME^LEXDM3
+12 SET LEXX=LEXX_"^"_$SELECT($LENGTH(LEXX):LEXNAM,1:"No display selected")
End DoDot:1
+13 if LEXA["^^"
SET LEXX="^^"
+14 KILL ^TMP("LEXX",$JOB),%,LEXA,LEXC,LEXI,LEXSO,LEXS,LEXR
+15 QUIT LEXX
