LEXINF ;ISL/KER - Information - Main ;05/23/2017
;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.01 SACC 1.3
; ^LEX(757.02 SACC 1.3
; ^LEX(757.03 SACC 1.3
; ^XTMP( SACC 2.3.2.5.2
;
; External References
; HOME^%ZIS ICR 10086
; $$GET1^DIQ ICR 2056
; ^DIR ICR 10026
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
;
EN ; Main Entry Point (interactive)
N LEXENV,LEXMET,LEXCDT,LEXDSP,LEXTMP K ARY,LEXARY,LEXIIEN S LEXENV=$$ENV I LEXENV'>0 W !!,?3,"Environmental variables missing ",! Q
S LEXTMP=0,LEXMET=$$CT I "^C^T^"'[("^"_LEXMET_"^") W !!,?3,"Type of information not selected ",! Q
S LEXCDT=$$DATE I LEXCDT'?7N W !!,?3,"Date not selected",! Q
S LEXDSP=$$DISP I "^1^0^"'[("^"_LEXDSP_"^") W !!,?3,"Display not selected",! Q
I LEXDSP>0 S LEXTMP=$$INCI I "^1^0^"'[("^"_LEXTMP_"^") W !!,?3,"IEN inclusion not selected",! Q
S:LEXTMP>0 LEXIIEN=1 D:LEXMET="C" SO D:LEXMET="T" EX
Q
SO ; Code
N LEXSO,LEXCODE,LEXSRC S LEXDSP=+($G(LEXDSP)) S LEXSO=$$CODE^LEXINF4
S LEXCODE=$P(LEXSO,"^",1) I '$L(LEXCODE) W !!,?3,"Code not selected",! Q
S LEXSRC=$P(LEXSO,"^",5) I '$D(^LEX(757.03,+LEXSRC,0)) W !!,?3,"Invalid Coding System selected",! Q
D CODE^LEXINF2(LEXCODE,LEXSRC,$G(LEXCDT),.LEXARY,LEXDSP) K:+($G(LEXDSP))>0 LEXARY
Q
EX ; Expression
N LEXEX,LEXEIEN S LEXDSP=+($G(LEXDSP)) S LEXEX=$$TERM^LEXINF4
S LEXEIEN=$P(LEXEX,"^",1) I '$D(^LEX(757.01,+LEXEIEN,0)) W !!,?3,"Term not selected",! Q
D TERM^LEXINF3(LEXEIEN,LEXCDT,.LEXARY,LEXDSP) K:+($G(LEXDSP))>0 LEXARY
Q
;
; Silent Entry Points
CODE(LEXCODE,LEXSRC,LEXCDT,LEXARY,LEXOUT) ; Information about a Code
D CODE^LEXINF2($G(LEXCODE),$G(LEXSRC),$G(LEXCDT),.LEXARY,$G(LEXOUT)) Q
TERM(LEXEIEN,LEXCDT,LEXARY,LEXOUT) ; Information about a Term
D TERM^LEXINF3(+($G(LEXEIEN)),$G(LEXCDT),.LEXARY,$G(LEXOUT)) Q
;
; Questions
CT(X) ; Code or Term
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXDEF,LEXVAL,Y S LEXDEF=$$RET("CT") S:'$L(LEXDEF) LEXDEF="Code"
S DIR("B")=LEXDEF,DIR(0)="SAO^C:Code;T:Term",DIR("A")=" Get information for a Code or a Term (C/T): "
D ^DIR Q:X["^" "^" Q:$D(DTOUT)!($D(DUOUT)) "^" Q:"^C^T^"'[("^"_$E($G(Y),1)_"^") "^"
S LEXVAL=$S(Y="C":"Code",Y="T":"Term",1:"") D:$L(LEXVAL) SAV("CT",LEXVAL) S:$L(LEXVAL) X=Y
Q X
DISP(X) ; Display
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXDEF,LEXVAL,Y S LEXDEF=$$RET("DISP") S:'$L(LEXDEF) LEXDEF="Yes"
S (DIR("?"),DIR("??"))="^D DISPH^LEXINF",DIR(0)="YAO",DIR("B")=LEXDEF,DIR("A")=" Display the results? (Y/N) "
D ^DIR Q:X["^" "^" Q:$D(DTOUT)!($D(DUOUT)) "^" Q:"^1^0^"'[("^"_$G(Y)_"^") "^"
S LEXVAL=$S(Y="1":"Yes",Y="0":"No",1:"") D:$L(LEXVAL) SAV("DISP",LEXVAL) S X=+Y
Q X
DISPH ; Display Help
W !,?4," Enter YES to extract and display the information"
W !,?4," Enter No to extract to a Local Array (no display)"
Q
INCI(X) ; Include IENs
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXDEF,LEXVAL,Y S LEXDEF=$$RET("INCI") S:'$L(LEXDEF) LEXDEF="Yes"
S (DIR("?"),DIR("??"))="^D INCIH^LEXINF",DIR(0)="YAO",DIR("B")=LEXDEF,DIR("A")=" Include IENs in the Display? (Y/N) "
D ^DIR Q:X["^" "^" Q:$D(DTOUT)!($D(DUOUT)) "^" Q:"^1^0^"'[("^"_$G(Y)_"^") "^"
S LEXVAL=$S(Y="1":"Yes",Y="0":"No",1:"") D:$L(LEXVAL) SAV("INCI",LEXVAL) S X=+Y
Q X
INCIH ; Include IENs Help
W !,?4," Enter YES to extract and display the information"
W !,?4," Enter No to extract to a Local Array (no display)"
Q
DATE(X) ; Date
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXIND,LEXCUR,LEXDEF,LEXFUT,LEXPAS,Y S LEXPAS=2960923,LEXCUR=$$DT^XLFDT
S LEXFUT=$$FMADD^XLFDT(LEXCUR,730),LEXDEF=$$RET("DATE") S:'$L(LEXDEF) LEXDEF=LEXCUR
S:$L(LEXDEF) LEXDEF=$$FMTE^XLFDT(LEXDEF,"5Z") S (DIR("?"),DIR("??"))="^D DATEH^LEXINF"
S DIR("A")=" Select a Date: ",DIR("B")=LEXDEF,DIR(0)="DAO^"_LEXPAS_":"_LEXFUT_":EX"
D ^DIR Q:X["^" "^" Q:$D(DTOUT)!($D(DUOUT)) "^" D:$P($G(Y),"^",1)?7N SAV("DATE",$P($G(Y),"^",1))
S X="" S:$P($G(Y),".",1)?7N X=$P($G(Y),".",1)
Q X
DATEH ; Date Help
N LEXIND S LEXIND=4 I $G(LEXPAS)?7N,$G(LEXFUT)?7N,$G(LEXFUT)>$G(LEXPAS) D
. W !,?4,"Enter a date from ",$$FMTE^XLFDT($G(LEXPAS),"5Z")," to ",$$FMTE^XLFDT($G(LEXFUT),"5Z"),! S LEXIND=8
W !,?LEXIND,"Examples of Valid Dates:",!,?LEXIND," JAN 20 1957 or 20 JAN 57 or 1/20/57 or 012057"
W !,?LEXIND," T (for TODAY), T+1 (for TOMORROW), T+2",!,?LEXIND," T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO)",!
W !,?LEXIND,"If the year is omitted, the computer uses ",!,?LEXIND,"CURRENT YEAR. A 2-digit year means no more than"
W !,?LEXIND,"20 years in the future, or 80 years in the past."
Q
;
; Miscellaneous
SRC(X) ; VA Sources
N LEXCO,LEXSIEN,LEXSRS,LEXSRSE,LEXSS,LEXCO,LEXS
S LEXCO=$G(X) Q:'$L(LEXCO) ""
S LEXSRS="^1^30^2^31^3^4^57^6^17^56^",LEXSRSE=""
S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXCO_" "),LEXSIEN)) Q:+LEXSIEN'>0 D
. N LEXSRC S LEXSRC=$P($G(^LEX(757.02,+LEXSIEN,0)),"^",3) Q:+LEXSRC'>0 Q:'$D(^LEX(757.03,+LEXSRC,0))
. S:LEXSRS'[("^"_LEXSRC_"^") LEXSRSE="Not used by the VA" Q:LEXSRS'[("^"_LEXSRC_"^")
. S:'$D(LEXSS(+LEXSRC)) LEXSS(0)=+($G(LEXSS(0)))+1
. S LEXSS(+LEXSRC)=+($G(LEXSS(+LEXSRC)))+1
I +($G(LEXSS(1)))>0,+($G(LEXSS(5)))>0,+($G(LEXSS(1)))>+($G(LEXSS(5))) K LEXSS(5) S LEXSS(0)=+($G(LEXSS(0)))-1
I +($G(LEXSS(1)))>0,+($G(LEXSS(6)))>0,+($G(LEXSS(1)))>+($G(LEXSS(6))) K LEXSS(6) S LEXSS(0)=+($G(LEXSS(0)))-1
S:+($G(LEXSS(0)))'>0 X="-1^Source not found"
S:+($G(LEXSS(0)))>1 X="-1^Multiple sources found"
S:+($G(LEXSS(0)))=1&($O(LEXSS(0))>0) X=$O(LEXSS(0))
S:+($G(LEXSS(0)))'>0&($L($G(LEXSRSE))) X="-1^"_$G(LEXSRSE)
Q X
SH(ARY) ; Display Array
N LEXS S LEXS="" W ! W:$D(LEXDOC) " ;" F S LEXS=$O(ARY(LEXS)) Q:'$L(LEXS) D
. N LEXN,LEXC,LEXD S LEXN="ARY("""_LEXS_""")",LEXC="ARY("""_LEXS_""","
. I $D(@LEXN) D
. . W ! W:$D(LEXDOC) " ;" W ! W:$D(LEXDOC) " ;" W ?4,LEXN,"=",$G(@LEXN)
. F S LEXN=$Q(@LEXN) Q:'$L(LEXN)!(LEXN'[LEXC) D
. . S LEXD=$G(@LEXN) W ! W:$D(LEXDOC) " ;" W ?4,LEXN,"=""",LEXD,""""
W ! W:$D(LEXDOC) " ;" N LEXDOC
Q
SAV(X,Y) ; Save Defaults
N LEXRTN,LEXTAG,LEXNUM,LEXCOM,LEXVAL,LEXNAM,LEXID,LEXNOW,LEXFUT,LEXKEY
S LEXRTN=$P($T(+1)," ",1) Q:'$L(LEXRTN) S LEXTAG=$G(X) Q:'$L(LEXTAG)
S LEXCOM=$E($$TM($TR($P($T(@LEXTAG+0)," ",2,4000),";"," ")),1,13) Q:'$L(LEXCOM) S LEXNUM=+($G(DUZ)) Q:+LEXNUM'>0 S LEXVAL=$G(Y) Q:'$L(LEXVAL)
S LEXNAM=$$GET1^DIQ(200,(LEXNUM_","),.01) Q:'$L(LEXNAM) S LEXKEY=$E(LEXCOM,1,13) S:$L(LEXKEY)'>11 LEXKEY=LEXKEY_$J(" ",12-$L(LEXKEY))
S LEXNOW=$$DT^XLFDT,LEXFUT=$$FMADD^XLFDT(LEXNOW,60),LEXID=LEXRTN_" "_LEXNUM_" "_LEXKEY S ^XTMP(LEXID,0)=LEXFUT_"^"_LEXNOW_"^"_LEXCOM,^XTMP(LEXID,LEXTAG)=LEXVAL
Q
RET(X) ; Retrieve Defaults
N LEXRTN,LEXTAG,LEXNUM,LEXCOM,LEXNAM,LEXID,LEXKEY S LEXRTN=$P($T(+1)," ",1) Q:'$L(LEXRTN) "" S LEXTAG=$G(X) Q:'$L(LEXTAG) ""
S LEXCOM=$E($$TM($TR($P($T(@LEXTAG+0)," ",2,4000),";"," ")),1,13) Q:'$L(LEXCOM) "" S LEXNUM=+($G(DUZ)) Q:+LEXNUM'>0 ""
S LEXNAM=$$GET1^DIQ(200,(LEXNUM_","),.01) Q:'$L(LEXNAM) "" S LEXKEY=$E(LEXCOM,1,13) S:$L(LEXKEY)'>11 LEXKEY=LEXKEY_$J(" ",12-$L(LEXKEY))
S LEXID=LEXRTN_" "_LEXNUM_" "_LEXKEY S X=$G(^XTMP(LEXID,LEXTAG))
Q X
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
ENV(X) ; Environment
D HOME^%ZIS S U="^",DT=$$DT^XLFDT,DTIME=300 K POP
N LEXNM S LEXNM=$$GET1^DIQ(200,(+($G(DUZ))_","),.01)
I '$L(LEXNM) W !!,?5,"Invalid/Missing DUZ" Q 0
S:$G(DUZ(0))'["@" DUZ(0)=$G(DUZ(0))_"@"
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXINF 7736 printed Jan 18, 2025@03:09 Page 2
LEXINF ;ISL/KER - Information - Main ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.01 SACC 1.3
+5 ; ^LEX(757.02 SACC 1.3
+6 ; ^LEX(757.03 SACC 1.3
+7 ; ^XTMP( SACC 2.3.2.5.2
+8 ;
+9 ; External References
+10 ; HOME^%ZIS ICR 10086
+11 ; $$GET1^DIQ ICR 2056
+12 ; ^DIR ICR 10026
+13 ; $$DT^XLFDT ICR 10103
+14 ; $$FMADD^XLFDT ICR 10103
+15 ; $$FMTE^XLFDT ICR 10103
+16 ;
EN ; Main Entry Point (interactive)
+1 NEW LEXENV,LEXMET,LEXCDT,LEXDSP,LEXTMP
KILL ARY,LEXARY,LEXIIEN
SET LEXENV=$$ENV
IF LEXENV'>0
WRITE !!,?3,"Environmental variables missing ",!
QUIT
+2 SET LEXTMP=0
SET LEXMET=$$CT
IF "^C^T^"'[("^"_LEXMET_"^")
WRITE !!,?3,"Type of information not selected ",!
QUIT
+3 SET LEXCDT=$$DATE
IF LEXCDT'?7N
WRITE !!,?3,"Date not selected",!
QUIT
+4 SET LEXDSP=$$DISP
IF "^1^0^"'[("^"_LEXDSP_"^")
WRITE !!,?3,"Display not selected",!
QUIT
+5 IF LEXDSP>0
SET LEXTMP=$$INCI
IF "^1^0^"'[("^"_LEXTMP_"^")
WRITE !!,?3,"IEN inclusion not selected",!
QUIT
+6 if LEXTMP>0
SET LEXIIEN=1
if LEXMET="C"
DO SO
if LEXMET="T"
DO EX
+7 QUIT
SO ; Code
+1 NEW LEXSO,LEXCODE,LEXSRC
SET LEXDSP=+($GET(LEXDSP))
SET LEXSO=$$CODE^LEXINF4
+2 SET LEXCODE=$PIECE(LEXSO,"^",1)
IF '$LENGTH(LEXCODE)
WRITE !!,?3,"Code not selected",!
QUIT
+3 SET LEXSRC=$PIECE(LEXSO,"^",5)
IF '$DATA(^LEX(757.03,+LEXSRC,0))
WRITE !!,?3,"Invalid Coding System selected",!
QUIT
+4 DO CODE^LEXINF2(LEXCODE,LEXSRC,$GET(LEXCDT),.LEXARY,LEXDSP)
if +($GET(LEXDSP))>0
KILL LEXARY
+5 QUIT
EX ; Expression
+1 NEW LEXEX,LEXEIEN
SET LEXDSP=+($GET(LEXDSP))
SET LEXEX=$$TERM^LEXINF4
+2 SET LEXEIEN=$PIECE(LEXEX,"^",1)
IF '$DATA(^LEX(757.01,+LEXEIEN,0))
WRITE !!,?3,"Term not selected",!
QUIT
+3 DO TERM^LEXINF3(LEXEIEN,LEXCDT,.LEXARY,LEXDSP)
if +($GET(LEXDSP))>0
KILL LEXARY
+4 QUIT
+5 ;
+6 ; Silent Entry Points
CODE(LEXCODE,LEXSRC,LEXCDT,LEXARY,LEXOUT) ; Information about a Code
+1 DO CODE^LEXINF2($GET(LEXCODE),$GET(LEXSRC),$GET(LEXCDT),.LEXARY,$GET(LEXOUT))
QUIT
TERM(LEXEIEN,LEXCDT,LEXARY,LEXOUT) ; Information about a Term
+1 DO TERM^LEXINF3(+($GET(LEXEIEN)),$GET(LEXCDT),.LEXARY,$GET(LEXOUT))
QUIT
+2 ;
+3 ; Questions
CT(X) ; Code or Term
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXDEF,LEXVAL,Y
SET LEXDEF=$$RET("CT")
if '$LENGTH(LEXDEF)
SET LEXDEF="Code"
+2 SET DIR("B")=LEXDEF
SET DIR(0)="SAO^C:Code;T:Term"
SET DIR("A")=" Get information for a Code or a Term (C/T): "
+3 DO ^DIR
if X["^"
QUIT "^"
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT "^"
if "^C^T^"'[("^"_$EXTRACT($GET(Y),1)_"^")
QUIT "^"
+4 SET LEXVAL=$SELECT(Y="C":"Code",Y="T":"Term",1:"")
if $LENGTH(LEXVAL)
DO SAV("CT",LEXVAL)
if $LENGTH(LEXVAL)
SET X=Y
+5 QUIT X
DISP(X) ; Display
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXDEF,LEXVAL,Y
SET LEXDEF=$$RET("DISP")
if '$LENGTH(LEXDEF)
SET LEXDEF="Yes"
+2 SET (DIR("?"),DIR("??"))="^D DISPH^LEXINF"
SET DIR(0)="YAO"
SET DIR("B")=LEXDEF
SET DIR("A")=" Display the results? (Y/N) "
+3 DO ^DIR
if X["^"
QUIT "^"
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT "^"
if "^1^0^"'[("^"_$GET(Y)_"^")
QUIT "^"
+4 SET LEXVAL=$SELECT(Y="1":"Yes",Y="0":"No",1:"")
if $LENGTH(LEXVAL)
DO SAV("DISP",LEXVAL)
SET X=+Y
+5 QUIT X
DISPH ; Display Help
+1 WRITE !,?4," Enter YES to extract and display the information"
+2 WRITE !,?4," Enter No to extract to a Local Array (no display)"
+3 QUIT
INCI(X) ; Include IENs
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXDEF,LEXVAL,Y
SET LEXDEF=$$RET("INCI")
if '$LENGTH(LEXDEF)
SET LEXDEF="Yes"
+2 SET (DIR("?"),DIR("??"))="^D INCIH^LEXINF"
SET DIR(0)="YAO"
SET DIR("B")=LEXDEF
SET DIR("A")=" Include IENs in the Display? (Y/N) "
+3 DO ^DIR
if X["^"
QUIT "^"
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT "^"
if "^1^0^"'[("^"_$GET(Y)_"^")
QUIT "^"
+4 SET LEXVAL=$SELECT(Y="1":"Yes",Y="0":"No",1:"")
if $LENGTH(LEXVAL)
DO SAV("INCI",LEXVAL)
SET X=+Y
+5 QUIT X
INCIH ; Include IENs Help
+1 WRITE !,?4," Enter YES to extract and display the information"
+2 WRITE !,?4," Enter No to extract to a Local Array (no display)"
+3 QUIT
DATE(X) ; Date
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LEXIND,LEXCUR,LEXDEF,LEXFUT,LEXPAS,Y
SET LEXPAS=2960923
SET LEXCUR=$$DT^XLFDT
+2 SET LEXFUT=$$FMADD^XLFDT(LEXCUR,730)
SET LEXDEF=$$RET("DATE")
if '$LENGTH(LEXDEF)
SET LEXDEF=LEXCUR
+3 if $LENGTH(LEXDEF)
SET LEXDEF=$$FMTE^XLFDT(LEXDEF,"5Z")
SET (DIR("?"),DIR("??"))="^D DATEH^LEXINF"
+4 SET DIR("A")=" Select a Date: "
SET DIR("B")=LEXDEF
SET DIR(0)="DAO^"_LEXPAS_":"_LEXFUT_":EX"
+5 DO ^DIR
if X["^"
QUIT "^"
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT "^"
if $PIECE($GET(Y),"^",1)?7N
DO SAV("DATE",$PIECE($GET(Y),"^",1))
+6 SET X=""
if $PIECE($GET(Y),".",1)?7N
SET X=$PIECE($GET(Y),".",1)
+7 QUIT X
DATEH ; Date Help
+1 NEW LEXIND
SET LEXIND=4
IF $GET(LEXPAS)?7N
IF $GET(LEXFUT)?7N
IF $GET(LEXFUT)>$GET(LEXPAS)
Begin DoDot:1
+2 WRITE !,?4,"Enter a date from ",$$FMTE^XLFDT($GET(LEXPAS),"5Z")," to ",$$FMTE^XLFDT($GET(LEXFUT),"5Z"),!
SET LEXIND=8
End DoDot:1
+3 WRITE !,?LEXIND,"Examples of Valid Dates:",!,?LEXIND," JAN 20 1957 or 20 JAN 57 or 1/20/57 or 012057"
+4 WRITE !,?LEXIND," T (for TODAY), T+1 (for TOMORROW), T+2",!,?LEXIND," T-1 (for YESTERDAY), T-3W (for 3 WEEKS AGO)",!
+5 WRITE !,?LEXIND,"If the year is omitted, the computer uses ",!,?LEXIND,"CURRENT YEAR. A 2-digit year means no more than"
+6 WRITE !,?LEXIND,"20 years in the future, or 80 years in the past."
+7 QUIT
+8 ;
+9 ; Miscellaneous
SRC(X) ; VA Sources
+1 NEW LEXCO,LEXSIEN,LEXSRS,LEXSRSE,LEXSS,LEXCO,LEXS
+2 SET LEXCO=$GET(X)
if '$LENGTH(LEXCO)
QUIT ""
+3 SET LEXSRS="^1^30^2^31^3^4^57^6^17^56^"
SET LEXSRSE=""
+4 SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"CODE",(LEXCO_" "),LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+5 NEW LEXSRC
SET LEXSRC=$PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",3)
if +LEXSRC'>0
QUIT
if '$DATA(^LEX(757.03,+LEXSRC,0))
QUIT
+6 if LEXSRS'[("^"_LEXSRC_"^")
SET LEXSRSE="Not used by the VA"
if LEXSRS'[("^"_LEXSRC_"^")
QUIT
+7 if '$DATA(LEXSS(+LEXSRC))
SET LEXSS(0)=+($GET(LEXSS(0)))+1
+8 SET LEXSS(+LEXSRC)=+($GET(LEXSS(+LEXSRC)))+1
End DoDot:1
+9 IF +($GET(LEXSS(1)))>0
IF +($GET(LEXSS(5)))>0
IF +($GET(LEXSS(1)))>+($GET(LEXSS(5)))
KILL LEXSS(5)
SET LEXSS(0)=+($GET(LEXSS(0)))-1
+10 IF +($GET(LEXSS(1)))>0
IF +($GET(LEXSS(6)))>0
IF +($GET(LEXSS(1)))>+($GET(LEXSS(6)))
KILL LEXSS(6)
SET LEXSS(0)=+($GET(LEXSS(0)))-1
+11 if +($GET(LEXSS(0)))'>0
SET X="-1^Source not found"
+12 if +($GET(LEXSS(0)))>1
SET X="-1^Multiple sources found"
+13 if +($GET(LEXSS(0)))=1&($ORDER(LEXSS(0))>0)
SET X=$ORDER(LEXSS(0))
+14 if +($GET(LEXSS(0)))'>0&($LENGTH($GET(LEXSRSE)))
SET X="-1^"_$GET(LEXSRSE)
+15 QUIT X
SH(ARY) ; Display Array
+1 NEW LEXS
SET LEXS=""
WRITE !
if $DATA(LEXDOC)
WRITE " ;"
FOR
SET LEXS=$ORDER(ARY(LEXS))
if '$LENGTH(LEXS)
QUIT
Begin DoDot:1
+2 NEW LEXN,LEXC,LEXD
SET LEXN="ARY("""_LEXS_""")"
SET LEXC="ARY("""_LEXS_""","
+3 IF $DATA(@LEXN)
Begin DoDot:2
+4 WRITE !
if $DATA(LEXDOC)
WRITE " ;"
WRITE !
if $DATA(LEXDOC)
WRITE " ;"
WRITE ?4,LEXN,"=",$GET(@LEXN)
End DoDot:2
+5 FOR
SET LEXN=$QUERY(@LEXN)
if '$LENGTH(LEXN)!(LEXN'[LEXC)
QUIT
Begin DoDot:2
+6 SET LEXD=$GET(@LEXN)
WRITE !
if $DATA(LEXDOC)
WRITE " ;"
WRITE ?4,LEXN,"=""",LEXD,""""
End DoDot:2
End DoDot:1
+7 WRITE !
if $DATA(LEXDOC)
WRITE " ;"
NEW LEXDOC
+8 QUIT
SAV(X,Y) ; Save Defaults
+1 NEW LEXRTN,LEXTAG,LEXNUM,LEXCOM,LEXVAL,LEXNAM,LEXID,LEXNOW,LEXFUT,LEXKEY
+2 SET LEXRTN=$PIECE($TEXT(+1)," ",1)
if '$LENGTH(LEXRTN)
QUIT
SET LEXTAG=$GET(X)
if '$LENGTH(LEXTAG)
QUIT
+3 SET LEXCOM=$EXTRACT($$TM($TRANSLATE($PIECE($TEXT(@LEXTAG+0)," ",2,4000),";"," ")),1,13)
if '$LENGTH(LEXCOM)
QUIT
SET LEXNUM=+($GET(DUZ))
if +LEXNUM'>0
QUIT
SET LEXVAL=$GET(Y)
if '$LENGTH(LEXVAL)
QUIT
+4 SET LEXNAM=$$GET1^DIQ(200,(LEXNUM_","),.01)
if '$LENGTH(LEXNAM)
QUIT
SET LEXKEY=$EXTRACT(LEXCOM,1,13)
if $LENGTH(LEXKEY)'>11
SET LEXKEY=LEXKEY_$JUSTIFY(" ",12-$LENGTH(LEXKEY))
+5 SET LEXNOW=$$DT^XLFDT
SET LEXFUT=$$FMADD^XLFDT(LEXNOW,60)
SET LEXID=LEXRTN_" "_LEXNUM_" "_LEXKEY
SET ^XTMP(LEXID,0)=LEXFUT_"^"_LEXNOW_"^"_LEXCOM
SET ^XTMP(LEXID,LEXTAG)=LEXVAL
+6 QUIT
RET(X) ; Retrieve Defaults
+1 NEW LEXRTN,LEXTAG,LEXNUM,LEXCOM,LEXNAM,LEXID,LEXKEY
SET LEXRTN=$PIECE($TEXT(+1)," ",1)
if '$LENGTH(LEXRTN)
QUIT ""
SET LEXTAG=$GET(X)
if '$LENGTH(LEXTAG)
QUIT ""
+2 SET LEXCOM=$EXTRACT($$TM($TRANSLATE($PIECE($TEXT(@LEXTAG+0)," ",2,4000),";"," ")),1,13)
if '$LENGTH(LEXCOM)
QUIT ""
SET LEXNUM=+($GET(DUZ))
if +LEXNUM'>0
QUIT ""
+3 SET LEXNAM=$$GET1^DIQ(200,(LEXNUM_","),.01)
if '$LENGTH(LEXNAM)
QUIT ""
SET LEXKEY=$EXTRACT(LEXCOM,1,13)
if $LENGTH(LEXKEY)'>11
SET LEXKEY=LEXKEY_$JUSTIFY(" ",12-$LENGTH(LEXKEY))
+4 SET LEXID=LEXRTN_" "_LEXNUM_" "_LEXKEY
SET X=$GET(^XTMP(LEXID,LEXTAG))
+5 QUIT X
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
if X=""
QUIT X
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
+2 FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
ENV(X) ; Environment
+1 DO HOME^%ZIS
SET U="^"
SET DT=$$DT^XLFDT
SET DTIME=300
KILL POP
+2 NEW LEXNM
SET LEXNM=$$GET1^DIQ(200,(+($GET(DUZ))_","),.01)
+3 IF '$LENGTH(LEXNM)
WRITE !!,?5,"Invalid/Missing DUZ"
QUIT 0
+4 if $GET(DUZ(0))'["@"
SET DUZ(0)=$GET(DUZ(0))_"@"
+5 QUIT 1
