- 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 Feb 18, 2025@23:35:42 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