LEXSET ;ISL/KER - Setup Appl/User Defaults for Look-up ;04/21/2014
;;2.0;LEXICON UTILITY;**25,80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^TMP("LEXSCH") SACC 2.3.2.5.1
;
; External References
; $$DT^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
;
; Local Variables NEWed or KILLed Elsewhere
; DIC,x Killed by calling application
; LEXLL,LEXQ,LEXVDT Killed by Speicial Lookup LEXA1
; XTLKGBL,XTLKHLP Killed by MTLU
; XTLKKSCH,XTLKSAY Killed by MTLU
;
EN ; Namespace/subset are not known
N DTOUT,DUOUT,LEXNS,LEXSS,LEXDS,LEXDW,LEXDR,LEXDP,LEXDA,LEXDB,LEXD0,LEXD,LEXDX
S LEXNS=$$NS^LEXSET4 Q:LEXNS[U!($D(DTOUT))!($D(DUOUT))
S LEXSS=$$SS^LEXSET4(LEXNS) Q:LEXSS[U!($D(DTOUT))!($D(DUOUT))
D CONFIG(LEXNS,LEXSS)
Q
CONFIG(LEXNS,LEXSS,LEXCDT) ; Namespace/subset are known
;
; Input
;
; LEXNS Namespace from file 757.2 'AN' index
; LEXSS Subset from file 757.2, 'AA' or 'AB' index
; LEXCDT Date to used to configure lookp
;
; Output
;
; ^TMP(LEXSCH,$J)
;
; Global array containing the following parameters
; APP Application (from LEXNS)
; DIS Display format
; FIL Filter
; FLN File Number
; GBL Global (Fileman DIC)
; IDX Index used during the search
; LEN Length of list to display
; LOC Hospital Location
; OVR Overwrite User Defaults flag
; SCT Shortcuts
; SVC Service
; UNR Unresolved Narrative flag
; USR User (DUZ)
; VDT Versioning Date
; VOC Vocabulary
;
N LEXD,LEXSUB,LEXAP,LEXSHOW,LEXSCT,LEXUN,LEXQOK S LEXCDT=$P($G(LEXCDT),".",1)
S:LEXCDT?7N LEXVDT=LEXCDT D VDT^LEXU S LEXCDT=$G(LEXVDT),LEXQOK=$D(LEXQ)
N LEXA,LEXL,LEXS,LEXM,LEXD S LEXNS=$G(LEXNS),LEXSS=$G(LEXSS)
S LEXQ=$S($D(LEXQ):+LEXQ,1:1) S:LEXNS="" LEXNS="LEX" S:LEXSS="" LEXSS="WRD"
S:'$D(^LEXT(757.2,"AN",LEXNS)) LEXNS=$$NS^LEXDFN2(LEXNS)
S:'$D(^LEXT(757.2,"AA",LEXSS))&('$D(^LEXT(757.2,"AB",LEXSS))) LEXSS=$$MD^LEXDFN2(LEXSS)
N LEXUS,LEXO,LEXT
S LEXA=$$NSIEN(LEXNS),LEXS=$$SSIEN(LEXSS)
S LEXM=$$MDIEN(LEXSS),LEXL=$$ASIEN(LEXA)
I +LEXA=0!(+LEXS=0) D DEF G SET
D APP^LEXSET2(LEXA)
I LEXM=0!(LEXM>0&(LEXM=LEXA)) D SUB^LEXSET2(LEXS)
I LEXM>0,LEXM'=LEXA D MOD^LEXSET2(LEXM)
D USR^LEXSET2(LEXA)
D GEN^LEXSET2
I +($G(LEXD("DF","OVR")))>0 D OVER^LEXSET3
I +($G(LEXD("DF","OVR")))=0 D USER^LEXSET3
S:$G(LEXCDT)?7N ^TMP("LEXSCH",$J,"VDT",0)=+($G(LEXCDT))
S:$G(LEXCDT)?7N ^TMP("LEXSCH",$J,"VDT",1)="Version Date Check: "_$$FMTE^XLFDT($G(LEXCDT))
D EN^LEXSET5 S:+($G(LEXQ))=1 ^TMP("LEXSCH",$J,"ADF",0)=1
SET ; Quit Setting Defaults
I LEXQOK'>0 K LEXLL,LEXQ,LEXVDT
Q
DEF ; Defaults if LEXNS or LEXSS are invalid
S LEXD("DF","DIS")="ICD/CPT",LEXD("DF","DSP")="XTLK^LEXPRNT"
S LEXD("DF","FLN")=757.01,LEXD("DF","GBL")="^LEX(757.01,"
S LEXD("DF","LEXAP")=1,LEXD("DF","UNR")=0
S LEXD("DF","HLP")="D XTLK^LEXHLP",LEXD("DF","IDX")="AWRD"
S LEXD("DF","NAM")="Lexicon",LEXD("DF","OVR")=0
S LEXD("DF","SUB")="WRD"
Q
ALTDEF ; Defaults if LEXNS or LEXSS are invalid
S (DIC,XTLKGBL,XTLKKSCH("GBL"))="^LEX(757.01,"
S XTLKKSCH("DSPLY")="XTLK^LEXPRNT",XTLKKSCH("INDEX")="AWRD",XTLKHLP="D XTLK^LEXHLP"
S XTLKSAY=1 S:'$L($G(DIC(0))) DIC(0)="EQM" S:'$L($G(X))&(DIC(0)'["A") DIC(0)="A"_DIC(0)
S:DIC(0)["L" DIC(0)=$P(DIC(0),"L",1)_$P(DIC(0),"L",2) S:DIC(0)["I" DIC(0)=$P(DIC(0),"I",1)_$P(DIC(0),"L",2)
S LEXAP=1,LEXLL=5,LEXUN=0,LEXSUB="WRD",LEXSHOW="ICD/CPT"
Q
NSIEN(LEX) ; Get IEN for application based on namespace
Q:'$L($G(LEX)) 0 Q:$D(^LEXT(757.2,"AN",LEX)) $O(^LEXT(757.2,"AN",LEX,0)) Q 0
SSIEN(LEX) ; Get IEN for subset based on subset
Q:'$L($G(LEX)) 0
Q:$D(^LEXT(757.2,"AA",LEX)) $O(^LEXT(757.2,"AA",LEX,0))
S:$D(^LEXT(757.2,"AB",LEX)) LEX=$O(^LEXT(757.2,"AB",LEX,0))
I +LEX>0,$D(^LEXT(757.2,LEX,5)) S LEX=$P(^LEXT(757.2,LEX,5),"^",2)
I LEX'="",$D(^LEXT(757.2,"AA",LEX)) Q $O(^LEXT(757.2,"AA",LEX,0))
Q 0
MDIEN(LEX) ; Get IEN for mode based on subset
Q:'$L($G(LEX)) 0
I $D(^LEXT(757.2,"AB",LEX)) S LEX=$O(^LEXT(757.2,"AB",LEX,0)) S LEX=+LEX Q LEX
Q 0
ASIEN(LEX) ; Get IEN for application
Q:+($G(LEX))=0 0
S LEX=+LEX Q:'$L($P($G(^LEXT(757.2,LEX,5)),"^",2))&('$L($P($G(^LEXT(757.2,LEX,0)),"^",2))) 0
S:$L($P($G(^LEXT(757.2,LEX,5)),"^",2)) LEX=$P($G(^LEXT(757.2,LEX,5)),"^",2)
S:$L($P($G(^LEXT(757.2,LEX,0)),"^",2)) LEX=$P($G(^LEXT(757.2,LEX,0)),"^",2)
Q:$D(^LEXT(757.2,"AA",LEX)) $O(^LEXT(757.2,"AA",LEX,0))
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXSET 4765 printed Oct 16, 2024@18:10:19 Page 2
LEXSET ;ISL/KER - Setup Appl/User Defaults for Look-up ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**25,80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+5 ;
+6 ; External References
+7 ; $$DT^XLFDT ICR 10103
+8 ; $$FMTE^XLFDT ICR 10103
+9 ;
+10 ; Local Variables NEWed or KILLed Elsewhere
+11 ; DIC,x Killed by calling application
+12 ; LEXLL,LEXQ,LEXVDT Killed by Speicial Lookup LEXA1
+13 ; XTLKGBL,XTLKHLP Killed by MTLU
+14 ; XTLKKSCH,XTLKSAY Killed by MTLU
+15 ;
EN ; Namespace/subset are not known
+1 NEW DTOUT,DUOUT,LEXNS,LEXSS,LEXDS,LEXDW,LEXDR,LEXDP,LEXDA,LEXDB,LEXD0,LEXD,LEXDX
+2 SET LEXNS=$$NS^LEXSET4
if LEXNS[U!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+3 SET LEXSS=$$SS^LEXSET4(LEXNS)
if LEXSS[U!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+4 DO CONFIG(LEXNS,LEXSS)
+5 QUIT
CONFIG(LEXNS,LEXSS,LEXCDT) ; Namespace/subset are known
+1 ;
+2 ; Input
+3 ;
+4 ; LEXNS Namespace from file 757.2 'AN' index
+5 ; LEXSS Subset from file 757.2, 'AA' or 'AB' index
+6 ; LEXCDT Date to used to configure lookp
+7 ;
+8 ; Output
+9 ;
+10 ; ^TMP(LEXSCH,$J)
+11 ;
+12 ; Global array containing the following parameters
+13 ; APP Application (from LEXNS)
+14 ; DIS Display format
+15 ; FIL Filter
+16 ; FLN File Number
+17 ; GBL Global (Fileman DIC)
+18 ; IDX Index used during the search
+19 ; LEN Length of list to display
+20 ; LOC Hospital Location
+21 ; OVR Overwrite User Defaults flag
+22 ; SCT Shortcuts
+23 ; SVC Service
+24 ; UNR Unresolved Narrative flag
+25 ; USR User (DUZ)
+26 ; VDT Versioning Date
+27 ; VOC Vocabulary
+28 ;
+29 NEW LEXD,LEXSUB,LEXAP,LEXSHOW,LEXSCT,LEXUN,LEXQOK
SET LEXCDT=$PIECE($GET(LEXCDT),".",1)
+30 if LEXCDT?7N
SET LEXVDT=LEXCDT
DO VDT^LEXU
SET LEXCDT=$GET(LEXVDT)
SET LEXQOK=$DATA(LEXQ)
+31 NEW LEXA,LEXL,LEXS,LEXM,LEXD
SET LEXNS=$GET(LEXNS)
SET LEXSS=$GET(LEXSS)
+32 SET LEXQ=$SELECT($DATA(LEXQ):+LEXQ,1:1)
if LEXNS=""
SET LEXNS="LEX"
if LEXSS=""
SET LEXSS="WRD"
+33 if '$DATA(^LEXT(757.2,"AN",LEXNS))
SET LEXNS=$$NS^LEXDFN2(LEXNS)
+34 if '$DATA(^LEXT(757.2,"AA",LEXSS))&('$DATA(^LEXT(757.2,"AB",LEXSS)))
SET LEXSS=$$MD^LEXDFN2(LEXSS)
+35 NEW LEXUS,LEXO,LEXT
+36 SET LEXA=$$NSIEN(LEXNS)
SET LEXS=$$SSIEN(LEXSS)
+37 SET LEXM=$$MDIEN(LEXSS)
SET LEXL=$$ASIEN(LEXA)
+38 IF +LEXA=0!(+LEXS=0)
DO DEF
GOTO SET
+39 DO APP^LEXSET2(LEXA)
+40 IF LEXM=0!(LEXM>0&(LEXM=LEXA))
DO SUB^LEXSET2(LEXS)
+41 IF LEXM>0
IF LEXM'=LEXA
DO MOD^LEXSET2(LEXM)
+42 DO USR^LEXSET2(LEXA)
+43 DO GEN^LEXSET2
+44 IF +($GET(LEXD("DF","OVR")))>0
DO OVER^LEXSET3
+45 IF +($GET(LEXD("DF","OVR")))=0
DO USER^LEXSET3
+46 if $GET(LEXCDT)?7N
SET ^TMP("LEXSCH",$JOB,"VDT",0)=+($GET(LEXCDT))
+47 if $GET(LEXCDT)?7N
SET ^TMP("LEXSCH",$JOB,"VDT",1)="Version Date Check: "_$$FMTE^XLFDT($GET(LEXCDT))
+48 DO EN^LEXSET5
if +($GET(LEXQ))=1
SET ^TMP("LEXSCH",$JOB,"ADF",0)=1
SET ; Quit Setting Defaults
+1 IF LEXQOK'>0
KILL LEXLL,LEXQ,LEXVDT
+2 QUIT
DEF ; Defaults if LEXNS or LEXSS are invalid
+1 SET LEXD("DF","DIS")="ICD/CPT"
SET LEXD("DF","DSP")="XTLK^LEXPRNT"
+2 SET LEXD("DF","FLN")=757.01
SET LEXD("DF","GBL")="^LEX(757.01,"
+3 SET LEXD("DF","LEXAP")=1
SET LEXD("DF","UNR")=0
+4 SET LEXD("DF","HLP")="D XTLK^LEXHLP"
SET LEXD("DF","IDX")="AWRD"
+5 SET LEXD("DF","NAM")="Lexicon"
SET LEXD("DF","OVR")=0
+6 SET LEXD("DF","SUB")="WRD"
+7 QUIT
ALTDEF ; Defaults if LEXNS or LEXSS are invalid
+1 SET (DIC,XTLKGBL,XTLKKSCH("GBL"))="^LEX(757.01,"
+2 SET XTLKKSCH("DSPLY")="XTLK^LEXPRNT"
SET XTLKKSCH("INDEX")="AWRD"
SET XTLKHLP="D XTLK^LEXHLP"
+3 SET XTLKSAY=1
if '$LENGTH($GET(DIC(0)))
SET DIC(0)="EQM"
if '$LENGTH($GET(X))&(DIC(0)'["A")
SET DIC(0)="A"_DIC(0)
+4 if DIC(0)["L"
SET DIC(0)=$PIECE(DIC(0),"L",1)_$PIECE(DIC(0),"L",2)
if DIC(0)["I"
SET DIC(0)=$PIECE(DIC(0),"I",1)_$PIECE(DIC(0),"L",2)
+5 SET LEXAP=1
SET LEXLL=5
SET LEXUN=0
SET LEXSUB="WRD"
SET LEXSHOW="ICD/CPT"
+6 QUIT
NSIEN(LEX) ; Get IEN for application based on namespace
+1 if '$LENGTH($GET(LEX))
QUIT 0
if $DATA(^LEXT(757.2,"AN",LEX))
QUIT $ORDER(^LEXT(757.2,"AN",LEX,0))
QUIT 0
SSIEN(LEX) ; Get IEN for subset based on subset
+1 if '$LENGTH($GET(LEX))
QUIT 0
+2 if $DATA(^LEXT(757.2,"AA",LEX))
QUIT $ORDER(^LEXT(757.2,"AA",LEX,0))
+3 if $DATA(^LEXT(757.2,"AB",LEX))
SET LEX=$ORDER(^LEXT(757.2,"AB",LEX,0))
+4 IF +LEX>0
IF $DATA(^LEXT(757.2,LEX,5))
SET LEX=$PIECE(^LEXT(757.2,LEX,5),"^",2)
+5 IF LEX'=""
IF $DATA(^LEXT(757.2,"AA",LEX))
QUIT $ORDER(^LEXT(757.2,"AA",LEX,0))
+6 QUIT 0
MDIEN(LEX) ; Get IEN for mode based on subset
+1 if '$LENGTH($GET(LEX))
QUIT 0
+2 IF $DATA(^LEXT(757.2,"AB",LEX))
SET LEX=$ORDER(^LEXT(757.2,"AB",LEX,0))
SET LEX=+LEX
QUIT LEX
+3 QUIT 0
ASIEN(LEX) ; Get IEN for application
+1 if +($GET(LEX))=0
QUIT 0
+2 SET LEX=+LEX
if '$LENGTH($PIECE($GET(^LEXT(757.2,LEX,5)),"^",2))&('$LENGTH($PIECE($GET(^LEXT(757.2,LEX,0)),"^",2)))
QUIT 0
+3 if $LENGTH($PIECE($GET(^LEXT(757.2,LEX,5)),"^",2))
SET LEX=$PIECE($GET(^LEXT(757.2,LEX,5)),"^",2)
+4 if $LENGTH($PIECE($GET(^LEXT(757.2,LEX,0)),"^",2))
SET LEX=$PIECE($GET(^LEXT(757.2,LEX,0)),"^",2)
+5 if $DATA(^LEXT(757.2,"AA",LEX))
QUIT $ORDER(^LEXT(757.2,"AA",LEX,0))
+6 QUIT 0
