LEXAR3 ;ISL/KER - Look-up Response (Help, Def, MAX) ;05/23/2017
;;2.0;LEXICON UTILITY;**73,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^TMP("LEXHIT") SACC 2.3.2.5.1
; ^TMP("LEXSCH") SACC 2.3.2.5.1
;
; External References
; $$IMP^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
;
; Local Variables NEWed or KILLed Elsewhere
; LEXLL List Length NEWed in LEXAR
; LEXUR User's Response NEWed in LEXAR
; LEXVDT Versioning Date NEWed in LEXAR
;
HLP ; Help
N LEXRP,LEXMAX K LEX("HLP")
S LEXMAX=+($G(^TMP("LEXSCH",$J,"LST",0)))
I LEXUR["??" D EXT Q
S LEXRP=+($P(LEXUR,"?",2,229))
I LEXRP>0,LEXRP'>LEXMAX D Q
. S LEXRP=+($G(^TMP("LEXHIT",$J,LEXRP))) D DEF(LEXRP)
I LEXUR["?",LEXRP'["?",+LEXRP'>0 D STD
Q
STD ; Standard Help LEX("HLP",
I +($G(LEX))=1 D STD2 Q
N LEXC S LEXC=+($G(LEX("HLP",0))),LEXC=LEXC+1,LEX("HLP",0)=LEXC
S:LEX'>LEXMAX LEX("HLP",LEXC)="Select 1-"_LEXMAX_", ^ (quit), or ?# (help on a term)"
S:LEX>LEXMAX LEX("HLP",LEXC)="Select 1-"_LEXMAX_", ^ (quit), ^# (jump - "_LEX_"), ?# (term help), or <Return> for more"
D:$D(LEX("LIST")) LST^LEXAR
Q
STD2 ; Standard Help LEX("HLP",
K LEX("HLP") S LEXRP=+($G(^TMP("LEXHIT",$J,1))) D DEF(LEXRP)
N LEXC S LEXC=+($G(LEX("HLP",0))) I LEXC>0 S LEXC=LEXC+1,LEX("HLP",LEXC)="",LEX("HLP",0)=LEXC
S LEXC=LEXC+1,LEX("HLP",0)=LEXC,LEX("HLP",LEXC)="Enter ""Yes"" to select, ""No"" to ignore, ""^"" to quit or ""?"" for term help"
D:$D(LEX("LIST")) LST^LEXAR
Q
EXT ; Extended Help LEX("HLP",
Q:+($G(LEX))'>0 Q:+($G(LEXLL))'>0 I +($G(LEX))=1 D EXT2 Q
N LEXCP,LEXTP,LEXM S LEXTP=LEX\LEXLL S:LEX#LEXLL>0 LEXTP=LEXTP+1
S LEXCP=LEXMAX\LEXLL S:LEXMAX#LEXLL>0 LEXCP=LEXCP+1
S LEXM=$S(LEXTP>LEXCP:1,1:0) N LEXS,LEXE,LEXJ,LEXH,LEXR,LEXSTR,LEXC
S LEXC=+($G(LEX("HLP",0))) S LEXC=LEXC+1
S (LEXS,LEXE,LEXJ,LEXH,LEXR,LEXSTR)=""
S LEXS="You may select 1-"_LEXMAX
S LEXE="enter an ^ to quit" S:LEXM LEXJ="enter ^# to jump to another entry on the list (up to "_LEX_")"
S LEXH="enter ?# to display the definition of an entry marked with an asterisk (*)"
S:LEXM LEXR="or press <Return> to continue."
S:'LEXM LEXR="or press <Return> to quit without making a selection."
S LEXSTR=LEXS S:LEXE'="" LEXSTR=LEXSTR_", "_LEXE S:LEXJ'="" LEXSTR=LEXSTR_", "_LEXJ
S:LEXH'="" LEXSTR=LEXSTR_", "_LEXH S:LEXR'="" LEXSTR=LEXSTR_", "_LEXR
I $L(LEXSTR)>74 D
. F Q:$L(LEXSTR)'>74 D
. . N LEXI F LEXI=74:-1:1 Q:$E(LEXSTR,LEXI)=" "
. . S LEX("HLP",LEXC)=$E(LEXSTR,1,(LEXI-1)),LEX("HLP",0)=LEXC
. . S LEXC=LEXC+1,LEXSTR=$E(LEXSTR,(LEXI+1),$L(LEXSTR))
. I $L(LEXSTR)>0,$L(LEXSTR)'>74 S LEXC=LEXC+1,LEX("HLP",LEXC)=LEXSTR,LEX("HLP",0)=LEXC
D:$D(LEX("LIST")) LST^LEXAR
Q
EXT2 ; Extended help for one
N LEXS,LEXE,LEXH,LEXSTR,LEXC,LEXDEF,LEXRP
S (LEXS,LEXE,LEXJ,LEXC,LEXH,LEXR,LEXSTR)=""
S LEXRP=+($G(^TMP("LEXHIT",$J,1))) D DEF(LEXRP)
S LEXC=+($G(LEX("HLP",0))) I LEXC>0 S LEXC=LEXC+1,LEX("HLP",LEXC)="",LEX("HLP",0)=LEXC
S LEXC=LEXC+1
S LEXDEF=+($G(^TMP("LEXHIT",$J,1)))
S LEXDEF=$S($D(^LEX(757.01,+LEXDEF,3)):1,1:0)
S LEXS="There was only one term found. Enter ""Yes"" to select, ""No"" to ignore"
S LEXE="or an ""^"" to quit"
S LEXH="" S:+LEXDEF>0 LEXH="""?"" to display the term definition"
S LEXSTR=LEXS
S:LEXH'="" LEXSTR=LEXSTR_", "_LEXH
S:LEXE'="" LEXSTR=LEXSTR_", "_LEXE
I $L(LEXSTR)>74 D
. F Q:$L(LEXSTR)'>74 D
. . N LEXI F LEXI=74:-1:1 Q:$E(LEXSTR,LEXI)=" "
. . S LEX("HLP",LEXC)=$E(LEXSTR,1,(LEXI-1)),LEX("HLP",0)=LEXC
. . S LEXC=LEXC+1,LEXSTR=$E(LEXSTR,(LEXI+1),$L(LEXSTR))
. I $L(LEXSTR)>0,$L(LEXSTR)'>74 S LEXC=LEXC+1,LEX("HLP",LEXC)=LEXSTR,LEX("HLP",0)=LEXC
D:$D(LEX("LIST")) LST^LEXAR
Q
DH ; Display Help
N LEXI S LEXI=0
F S LEXI=$O(LEX("HLP",LEXI)) Q:+LEXI=0 W !," ",LEX("HLP",LEXI)
Q
DA ; Display List
Q
N LEXI S LEXI=0
F S LEXI=$O(LEX("LIST",LEXI)) Q:+LEXI=0 W !," ",LEX("LIST",LEXI)
Q
DEF(LEXIEN) ; Definition Help LEX("HLP",
N LEXR,LEXLN,LEXMC,LEXTY,LEXC
S (LEXR,LEXIEN)=+($G(LEXIEN))
S LEXTY=$P($G(^LEX(757.01,LEXIEN,1)),"^",2)
D:$D(LEX("LIST")) LST^LEXAR Q:LEXIEN'>0
N LEXLN,LEXMC,LEXC S (LEXLN,LEXC)=0 K LEX("HLP")
I '$D(^LEX(757.01,LEXIEN,3,1)),LEXTY'=1 D
. S LEXIEN=+($G(^LEX(757.01,LEXIEN,1)))
. S LEXIEN=+($G(^LEX(757,LEXIEN,0)))
I $D(^LEX(757.01,LEXIEN,0)),$L($G(^LEX(757.01,LEXIEN,3,1,0))) D
. S LEXC=1,LEX("HLP",LEXC)=$G(^LEX(757.01,LEXIEN,0)) S LEXC=LEXC+1
. S LEX("HLP",LEXC)="",LEXC("HLP",0)=LEXC
. F S LEXLN=$O(^LEX(757.01,LEXIEN,3,LEXLN)) Q:+LEXLN=0 D
. . S LEXC=LEXC+1 S LEX("HLP",LEXC)=^LEX(757.01,LEXIEN,3,LEXLN,0)
. . S LEX("HLP",0)=LEXC
I '$D(LEX("HLP")) D
. K LEX("HLP")
. S LEX("HLP",1)="No definition found"
. I $L($G(^LEX(757.01,LEXR,0))) D
. . N LEXEXP S LEXEXP=$G(^LEX(757.01,LEXR,0)) Q:'$L(LEXEXP)
. . S LEX("HLP",1)=LEX("HLP",1)_" found for "_$C(34)_LEXEXP_$C(34)
. S:'$L($G(^LEX(757.01,LEXR,0))) LEX("HLP",1)="No definition found"
D:$D(LEX("LIST")) LST^LEXAR
Q
;
QMH(X) ; Question Mark Help (system sensitive)
K LEX N LEX2,LEX3,LEX4,LEXA,LEXC,LEXCT,LEXD,LEXEX,LEXF,LEXFIL,LEXHDT
N LEXI,LEXIDT,LEXLEN,LEXO,LEXOK,LEXP,LEXS,LEXSP,LEXT,LEXU,LEXX,LEXY,Y
S LEXHDT=$G(LEXVDT) S:LEXHDT'?7N LEXHDT=$G(^TMP("LEXSCH",$J,"VDT",0))
S:LEXHDT'?7N LEXHDT=$G(DT) S:LEXHDT'?7N LEXHDT=$$DT^XLFDT
S LEXFIL=$G(^TMP("LEXSCH",$J,"FIL",0))
S LEXY=$$HSYS^LEXHLP2(LEXFIL,LEXHDT),LEXIDT=$$IMP^ICDEX("10D")
S:$L(LEXY,"/")>2 LEXY=LEXY_" etc" S LEXX=$G(X),(LEX2,LEX3,LEX4)=""
S (LEXC,LEXS,LEXEX)="",LEXF=0 D:LEXX["??" HTXT
I LEXX["??"&($L(LEX2))&($L(LEX3))&($L(LEX4)) D
. S:$L(LEXC)&($L(LEXS))&($L(LEXEX)) LEXF=1
S LEXOK=0 I LEXHDT?7N,LEXIDT?7N,LEXHDT<LEXIDT D
. I LEXFIL["$$"&(LEXFIL["ONE^") D
. . D:LEXFIL["$$10P"&(LEXFIL'["$$10D") N10P^LEXHLP2
. . D:LEXFIL'["$$10P"&(LEXFIL["$$10D") N10D^LEXHLP2
. . D:LEXFIL["$$10P"&(LEXFIL["$$10D") N10^LEXHLP2
. I LEXFIL["$$SO^LEXU" D
. . D:LEXFIL["10P"&(LEXFIL'["10D") N10P^LEXHLP2
. . D:LEXFIL'["10P"&(LEXFIL["10D") N10D^LEXHLP2
. . D:LEXFIL["10P"&(LEXFIL["10D") N10^LEXHLP2
I 'LEXOK,LEXX["?"&(LEXX'["^") D
. N LEXP,LEXSP,LEXI,LEXCT S LEXSP=" "
. K LEXP S LEXP(1)="Enter a ""free text"" term. "
. S LEXP(1)=LEXP(1)_"Best results occur using two to four full "
. S LEXP(1)=LEXP(1)_"or partial words without a suffix"
. S:LEXF>0 LEXP(2)="(i.e., """_LEX2_""", """_LEX3_""", """_LEX4_""")"
. D PR^LEXU(.LEXP,70) S LEXCT=$O(LEX("HLP"," "),-1),LEXI=0
. F S LEXI=$O(LEXP(LEXI)) Q:+LEXI'>0 D
. . N LEXT S LEXT=$G(LEXP(LEXI)),LEXCT=LEXCT+1
. . S LEX("HLP",LEXCT)=LEXSP_LEXT
. S LEXCT=$O(LEX("HLP"," "),-1)+1
. S LEX("HLP",LEXCT)=" or "
. K LEXP S LEXP(1)="Enter a classification code "
. S:$L(LEXY) LEXP(1)=LEXP(1)_"("_LEXY_") "
. S LEXP(1)=LEXP(1)_"to find the term associated with the code."
. I LEXF>0 D
. . S LEXP(2)="Example; a lookup of "_LEXS_" code "_LEXC_" "
. . S LEXP(2)=LEXP(2)_"returns one and only one term. "
. . S LEXP(2)=LEXP(2)_"That term is the preferred term for the code "
. . S LEXP(2)=LEXP(2)_LEXC_", """_LEXEX_""""
. D PR^LEXU(.LEXP,70) S LEXCT=$O(LEX("HLP"," "),-1),LEXI=0
. F S LEXI=$O(LEXP(LEXI)) Q:+LEXI'>0 D
. . N LEXT S LEXT=$G(LEXP(LEXI)),LEXCT=LEXCT+1
. . S LEX("HLP",LEXCT)=LEXSP_LEXT
. S LEXCT=$O(LEX("HLP"," "),-1)+1
. S LEX("HLP",LEXCT)=" or "
. K LEXP S LEXP(1)="Enter a classification code "
. S:$L(LEXY) LEXP(1)=LEXP(1)_"("_LEXY_") "
. S LEXP(1)=LEXP(1)_"followed by a plus sign (+) to retrieve "
. S LEXP(1)=LEXP(1)_"all terms associated with the code."
. I LEXF>0 D
. . S LEXP(2)="Example; a lookup of "_LEXS_" code "_LEXC
. . S LEXP(2)=LEXP(2)_"+ returns all terms that are linked to "
. . S LEXP(2)=LEXP(2)_"the code "_LEXC_"."
. D PR^LEXU(.LEXP,70) S LEXCT=$O(LEX("HLP"," "),-1),LEXI=0
. F S LEXI=$O(LEXP(LEXI)) Q:+LEXI'>0 D
. . N LEXT S LEXT=$G(LEXP(LEXI)),LEXCT=LEXCT+1
. . S LEX("HLP",LEXCT)=LEXSP_LEXT
S LEXC=$O(LEX("HLP"," "),-1) I LEXC>0 D
. S LEX=0,LEX("HLP",0)=LEXC S:$L($G(LEXX)) LEX("NAR")=$G(LEXX)
Q
HTXT ; Help Text (expanded)
N LEXF,LEXOK,LEXU
S LEXOK=0,LEXU=$G(LEXX) S LEXF=$G(^TMP("LEXSCH",$J,"FIL",0))
S (LEX2,LEX3,LEX4,LEXC,LEXS,LEXEX)="",LEXOK=0 D:'$L(LEXF) HICD^LEXHLP2
Q:LEXOK D:LEXF["$$DX^LEXU" HICD^LEXHLP2 Q:LEXOK
I LEXF["$$"&(LEXF["ONE^") D Q:LEXOK
. D:LEXF["$$10P"&(LEXF'["$$10D") H10P^LEXHLP2 D:LEXF["$$10D" H10D^LEXHLP2 Q:LEXOK
. D:LEXF["$$CPC"&(LEXF'["$$CPT") HCPC^LEXHLP2 D:LEXF["$$CPT" HCPT^LEXHLP2 Q:LEXOK
I LEXF["$$SO^LEXU" D Q:LEXOK
. D:LEXF["10P"&(LEXF'["10D") H10P^LEXHLP2 D:LEXF["10D" H10D^LEXHLP2 Q:LEXOK
. D:LEXF["CPC"&(LEXF'["CPT") HCPC^LEXHLP2 D:LEXF["CPT" HCPT^LEXHLP2 Q:LEXOK
. D:LEXF["SCC" HSCC^LEXHLP2 Q:LEXOK D:LEXF["DS3"!(LEXF["DS4") HDS4^LEXHLP2 Q:LEXOK
. D:LEXF["OMA"&(LEXF'["NAN") HOMA^LEXHLP2 D:LEXF["NAN" HNAN^LEXHLP2 Q:LEXOK
D HICD^LEXHLP2
Q
;
; Miscellaneous
SA ; Show Array
N LEXI S LEXI=0 F S LEXI=$O(LEX("HLP",LEXI)) Q:+LEXI'>0 D
. W !,LEX("HLP",LEXI)
Q
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXAR3 9231 printed Oct 16, 2024@18:07:44 Page 2
LEXAR3 ;ISL/KER - Look-up Response (Help, Def, MAX) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**73,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXHIT") SACC 2.3.2.5.1
+5 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+6 ;
+7 ; External References
+8 ; $$IMP^ICDEX ICR 5747
+9 ; $$DT^XLFDT ICR 10103
+10 ;
+11 ; Local Variables NEWed or KILLed Elsewhere
+12 ; LEXLL List Length NEWed in LEXAR
+13 ; LEXUR User's Response NEWed in LEXAR
+14 ; LEXVDT Versioning Date NEWed in LEXAR
+15 ;
HLP ; Help
+1 NEW LEXRP,LEXMAX
KILL LEX("HLP")
+2 SET LEXMAX=+($GET(^TMP("LEXSCH",$JOB,"LST",0)))
+3 IF LEXUR["??"
DO EXT
QUIT
+4 SET LEXRP=+($PIECE(LEXUR,"?",2,229))
+5 IF LEXRP>0
IF LEXRP'>LEXMAX
Begin DoDot:1
+6 SET LEXRP=+($GET(^TMP("LEXHIT",$JOB,LEXRP)))
DO DEF(LEXRP)
End DoDot:1
QUIT
+7 IF LEXUR["?"
IF LEXRP'["?"
IF +LEXRP'>0
DO STD
+8 QUIT
STD ; Standard Help LEX("HLP",
+1 IF +($GET(LEX))=1
DO STD2
QUIT
+2 NEW LEXC
SET LEXC=+($GET(LEX("HLP",0)))
SET LEXC=LEXC+1
SET LEX("HLP",0)=LEXC
+3 if LEX'>LEXMAX
SET LEX("HLP",LEXC)="Select 1-"_LEXMAX_", ^ (quit), or ?# (help on a term)"
+4 if LEX>LEXMAX
SET LEX("HLP",LEXC)="Select 1-"_LEXMAX_", ^ (quit), ^# (jump - "_LEX_"), ?# (term help), or <Return> for more"
+5 if $DATA(LEX("LIST"))
DO LST^LEXAR
+6 QUIT
STD2 ; Standard Help LEX("HLP",
+1 KILL LEX("HLP")
SET LEXRP=+($GET(^TMP("LEXHIT",$JOB,1)))
DO DEF(LEXRP)
+2 NEW LEXC
SET LEXC=+($GET(LEX("HLP",0)))
IF LEXC>0
SET LEXC=LEXC+1
SET LEX("HLP",LEXC)=""
SET LEX("HLP",0)=LEXC
+3 SET LEXC=LEXC+1
SET LEX("HLP",0)=LEXC
SET LEX("HLP",LEXC)="Enter ""Yes"" to select, ""No"" to ignore, ""^"" to quit or ""?"" for term help"
+4 if $DATA(LEX("LIST"))
DO LST^LEXAR
+5 QUIT
EXT ; Extended Help LEX("HLP",
+1 if +($GET(LEX))'>0
QUIT
if +($GET(LEXLL))'>0
QUIT
IF +($GET(LEX))=1
DO EXT2
QUIT
+2 NEW LEXCP,LEXTP,LEXM
SET LEXTP=LEX\LEXLL
if LEX#LEXLL>0
SET LEXTP=LEXTP+1
+3 SET LEXCP=LEXMAX\LEXLL
if LEXMAX#LEXLL>0
SET LEXCP=LEXCP+1
+4 SET LEXM=$SELECT(LEXTP>LEXCP:1,1:0)
NEW LEXS,LEXE,LEXJ,LEXH,LEXR,LEXSTR,LEXC
+5 SET LEXC=+($GET(LEX("HLP",0)))
SET LEXC=LEXC+1
+6 SET (LEXS,LEXE,LEXJ,LEXH,LEXR,LEXSTR)=""
+7 SET LEXS="You may select 1-"_LEXMAX
+8 SET LEXE="enter an ^ to quit"
if LEXM
SET LEXJ="enter ^# to jump to another entry on the list (up to "_LEX_")"
+9 SET LEXH="enter ?# to display the definition of an entry marked with an asterisk (*)"
+10 if LEXM
SET LEXR="or press <Return> to continue."
+11 if 'LEXM
SET LEXR="or press <Return> to quit without making a selection."
+12 SET LEXSTR=LEXS
if LEXE'=""
SET LEXSTR=LEXSTR_", "_LEXE
if LEXJ'=""
SET LEXSTR=LEXSTR_", "_LEXJ
+13 if LEXH'=""
SET LEXSTR=LEXSTR_", "_LEXH
if LEXR'=""
SET LEXSTR=LEXSTR_", "_LEXR
+14 IF $LENGTH(LEXSTR)>74
Begin DoDot:1
+15 FOR
if $LENGTH(LEXSTR)'>74
QUIT
Begin DoDot:2
+16 NEW LEXI
FOR LEXI=74:-1:1
if $EXTRACT(LEXSTR,LEXI)=" "
QUIT
+17 SET LEX("HLP",LEXC)=$EXTRACT(LEXSTR,1,(LEXI-1))
SET LEX("HLP",0)=LEXC
+18 SET LEXC=LEXC+1
SET LEXSTR=$EXTRACT(LEXSTR,(LEXI+1),$LENGTH(LEXSTR))
End DoDot:2
+19 IF $LENGTH(LEXSTR)>0
IF $LENGTH(LEXSTR)'>74
SET LEXC=LEXC+1
SET LEX("HLP",LEXC)=LEXSTR
SET LEX("HLP",0)=LEXC
End DoDot:1
+20 if $DATA(LEX("LIST"))
DO LST^LEXAR
+21 QUIT
EXT2 ; Extended help for one
+1 NEW LEXS,LEXE,LEXH,LEXSTR,LEXC,LEXDEF,LEXRP
+2 SET (LEXS,LEXE,LEXJ,LEXC,LEXH,LEXR,LEXSTR)=""
+3 SET LEXRP=+($GET(^TMP("LEXHIT",$JOB,1)))
DO DEF(LEXRP)
+4 SET LEXC=+($GET(LEX("HLP",0)))
IF LEXC>0
SET LEXC=LEXC+1
SET LEX("HLP",LEXC)=""
SET LEX("HLP",0)=LEXC
+5 SET LEXC=LEXC+1
+6 SET LEXDEF=+($GET(^TMP("LEXHIT",$JOB,1)))
+7 SET LEXDEF=$SELECT($DATA(^LEX(757.01,+LEXDEF,3)):1,1:0)
+8 SET LEXS="There was only one term found. Enter ""Yes"" to select, ""No"" to ignore"
+9 SET LEXE="or an ""^"" to quit"
+10 SET LEXH=""
if +LEXDEF>0
SET LEXH="""?"" to display the term definition"
+11 SET LEXSTR=LEXS
+12 if LEXH'=""
SET LEXSTR=LEXSTR_", "_LEXH
+13 if LEXE'=""
SET LEXSTR=LEXSTR_", "_LEXE
+14 IF $LENGTH(LEXSTR)>74
Begin DoDot:1
+15 FOR
if $LENGTH(LEXSTR)'>74
QUIT
Begin DoDot:2
+16 NEW LEXI
FOR LEXI=74:-1:1
if $EXTRACT(LEXSTR,LEXI)=" "
QUIT
+17 SET LEX("HLP",LEXC)=$EXTRACT(LEXSTR,1,(LEXI-1))
SET LEX("HLP",0)=LEXC
+18 SET LEXC=LEXC+1
SET LEXSTR=$EXTRACT(LEXSTR,(LEXI+1),$LENGTH(LEXSTR))
End DoDot:2
+19 IF $LENGTH(LEXSTR)>0
IF $LENGTH(LEXSTR)'>74
SET LEXC=LEXC+1
SET LEX("HLP",LEXC)=LEXSTR
SET LEX("HLP",0)=LEXC
End DoDot:1
+20 if $DATA(LEX("LIST"))
DO LST^LEXAR
+21 QUIT
DH ; Display Help
+1 NEW LEXI
SET LEXI=0
+2 FOR
SET LEXI=$ORDER(LEX("HLP",LEXI))
if +LEXI=0
QUIT
WRITE !," ",LEX("HLP",LEXI)
+3 QUIT
DA ; Display List
+1 QUIT
+2 NEW LEXI
SET LEXI=0
+3 FOR
SET LEXI=$ORDER(LEX("LIST",LEXI))
if +LEXI=0
QUIT
WRITE !," ",LEX("LIST",LEXI)
+4 QUIT
DEF(LEXIEN) ; Definition Help LEX("HLP",
+1 NEW LEXR,LEXLN,LEXMC,LEXTY,LEXC
+2 SET (LEXR,LEXIEN)=+($GET(LEXIEN))
+3 SET LEXTY=$PIECE($GET(^LEX(757.01,LEXIEN,1)),"^",2)
+4 if $DATA(LEX("LIST"))
DO LST^LEXAR
if LEXIEN'>0
QUIT
+5 NEW LEXLN,LEXMC,LEXC
SET (LEXLN,LEXC)=0
KILL LEX("HLP")
+6 IF '$DATA(^LEX(757.01,LEXIEN,3,1))
IF LEXTY'=1
Begin DoDot:1
+7 SET LEXIEN=+($GET(^LEX(757.01,LEXIEN,1)))
+8 SET LEXIEN=+($GET(^LEX(757,LEXIEN,0)))
End DoDot:1
+9 IF $DATA(^LEX(757.01,LEXIEN,0))
IF $LENGTH($GET(^LEX(757.01,LEXIEN,3,1,0)))
Begin DoDot:1
+10 SET LEXC=1
SET LEX("HLP",LEXC)=$GET(^LEX(757.01,LEXIEN,0))
SET LEXC=LEXC+1
+11 SET LEX("HLP",LEXC)=""
SET LEXC("HLP",0)=LEXC
+12 FOR
SET LEXLN=$ORDER(^LEX(757.01,LEXIEN,3,LEXLN))
if +LEXLN=0
QUIT
Begin DoDot:2
+13 SET LEXC=LEXC+1
SET LEX("HLP",LEXC)=^LEX(757.01,LEXIEN,3,LEXLN,0)
+14 SET LEX("HLP",0)=LEXC
End DoDot:2
End DoDot:1
+15 IF '$DATA(LEX("HLP"))
Begin DoDot:1
+16 KILL LEX("HLP")
+17 SET LEX("HLP",1)="No definition found"
+18 IF $LENGTH($GET(^LEX(757.01,LEXR,0)))
Begin DoDot:2
+19 NEW LEXEXP
SET LEXEXP=$GET(^LEX(757.01,LEXR,0))
if '$LENGTH(LEXEXP)
QUIT
+20 SET LEX("HLP",1)=LEX("HLP",1)_" found for "_$CHAR(34)_LEXEXP_$CHAR(34)
End DoDot:2
+21 if '$LENGTH($GET(^LEX(757.01,LEXR,0)))
SET LEX("HLP",1)="No definition found"
End DoDot:1
+22 if $DATA(LEX("LIST"))
DO LST^LEXAR
+23 QUIT
+24 ;
QMH(X) ; Question Mark Help (system sensitive)
+1 KILL LEX
NEW LEX2,LEX3,LEX4,LEXA,LEXC,LEXCT,LEXD,LEXEX,LEXF,LEXFIL,LEXHDT
+2 NEW LEXI,LEXIDT,LEXLEN,LEXO,LEXOK,LEXP,LEXS,LEXSP,LEXT,LEXU,LEXX,LEXY,Y
+3 SET LEXHDT=$GET(LEXVDT)
if LEXHDT'?7N
SET LEXHDT=$GET(^TMP("LEXSCH",$JOB,"VDT",0))
+4 if LEXHDT'?7N
SET LEXHDT=$GET(DT)
if LEXHDT'?7N
SET LEXHDT=$$DT^XLFDT
+5 SET LEXFIL=$GET(^TMP("LEXSCH",$JOB,"FIL",0))
+6 SET LEXY=$$HSYS^LEXHLP2(LEXFIL,LEXHDT)
SET LEXIDT=$$IMP^ICDEX("10D")
+7 if $LENGTH(LEXY,"/")>2
SET LEXY=LEXY_" etc"
SET LEXX=$GET(X)
SET (LEX2,LEX3,LEX4)=""
+8 SET (LEXC,LEXS,LEXEX)=""
SET LEXF=0
if LEXX["??"
DO HTXT
+9 IF LEXX["??"&($LENGTH(LEX2))&($LENGTH(LEX3))&($LENGTH(LEX4))
Begin DoDot:1
+10 if $LENGTH(LEXC)&($LENGTH(LEXS))&($LENGTH(LEXEX))
SET LEXF=1
End DoDot:1
+11 SET LEXOK=0
IF LEXHDT?7N
IF LEXIDT?7N
IF LEXHDT<LEXIDT
Begin DoDot:1
+12 IF LEXFIL["$$"&(LEXFIL["ONE^")
Begin DoDot:2
+13 if LEXFIL["$$10P"&(LEXFIL'["$$10D")
DO N10P^LEXHLP2
+14 if LEXFIL'["$$10P"&(LEXFIL["$$10D")
DO N10D^LEXHLP2
+15 if LEXFIL["$$10P"&(LEXFIL["$$10D")
DO N10^LEXHLP2
End DoDot:2
+16 IF LEXFIL["$$SO^LEXU"
Begin DoDot:2
+17 if LEXFIL["10P"&(LEXFIL'["10D")
DO N10P^LEXHLP2
+18 if LEXFIL'["10P"&(LEXFIL["10D")
DO N10D^LEXHLP2
+19 if LEXFIL["10P"&(LEXFIL["10D")
DO N10^LEXHLP2
End DoDot:2
End DoDot:1
+20 IF 'LEXOK
IF LEXX["?"&(LEXX'["^")
Begin DoDot:1
+21 NEW LEXP,LEXSP,LEXI,LEXCT
SET LEXSP=" "
+22 KILL LEXP
SET LEXP(1)="Enter a ""free text"" term. "
+23 SET LEXP(1)=LEXP(1)_"Best results occur using two to four full "
+24 SET LEXP(1)=LEXP(1)_"or partial words without a suffix"
+25 if LEXF>0
SET LEXP(2)="(i.e., """_LEX2_""", """_LEX3_""", """_LEX4_""")"
+26 DO PR^LEXU(.LEXP,70)
SET LEXCT=$ORDER(LEX("HLP"," "),-1)
SET LEXI=0
+27 FOR
SET LEXI=$ORDER(LEXP(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+28 NEW LEXT
SET LEXT=$GET(LEXP(LEXI))
SET LEXCT=LEXCT+1
+29 SET LEX("HLP",LEXCT)=LEXSP_LEXT
End DoDot:2
+30 SET LEXCT=$ORDER(LEX("HLP"," "),-1)+1
+31 SET LEX("HLP",LEXCT)=" or "
+32 KILL LEXP
SET LEXP(1)="Enter a classification code "
+33 if $LENGTH(LEXY)
SET LEXP(1)=LEXP(1)_"("_LEXY_") "
+34 SET LEXP(1)=LEXP(1)_"to find the term associated with the code."
+35 IF LEXF>0
Begin DoDot:2
+36 SET LEXP(2)="Example; a lookup of "_LEXS_" code "_LEXC_" "
+37 SET LEXP(2)=LEXP(2)_"returns one and only one term. "
+38 SET LEXP(2)=LEXP(2)_"That term is the preferred term for the code "
+39 SET LEXP(2)=LEXP(2)_LEXC_", """_LEXEX_""""
End DoDot:2
+40 DO PR^LEXU(.LEXP,70)
SET LEXCT=$ORDER(LEX("HLP"," "),-1)
SET LEXI=0
+41 FOR
SET LEXI=$ORDER(LEXP(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+42 NEW LEXT
SET LEXT=$GET(LEXP(LEXI))
SET LEXCT=LEXCT+1
+43 SET LEX("HLP",LEXCT)=LEXSP_LEXT
End DoDot:2
+44 SET LEXCT=$ORDER(LEX("HLP"," "),-1)+1
+45 SET LEX("HLP",LEXCT)=" or "
+46 KILL LEXP
SET LEXP(1)="Enter a classification code "
+47 if $LENGTH(LEXY)
SET LEXP(1)=LEXP(1)_"("_LEXY_") "
+48 SET LEXP(1)=LEXP(1)_"followed by a plus sign (+) to retrieve "
+49 SET LEXP(1)=LEXP(1)_"all terms associated with the code."
+50 IF LEXF>0
Begin DoDot:2
+51 SET LEXP(2)="Example; a lookup of "_LEXS_" code "_LEXC
+52 SET LEXP(2)=LEXP(2)_"+ returns all terms that are linked to "
+53 SET LEXP(2)=LEXP(2)_"the code "_LEXC_"."
End DoDot:2
+54 DO PR^LEXU(.LEXP,70)
SET LEXCT=$ORDER(LEX("HLP"," "),-1)
SET LEXI=0
+55 FOR
SET LEXI=$ORDER(LEXP(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+56 NEW LEXT
SET LEXT=$GET(LEXP(LEXI))
SET LEXCT=LEXCT+1
+57 SET LEX("HLP",LEXCT)=LEXSP_LEXT
End DoDot:2
End DoDot:1
+58 SET LEXC=$ORDER(LEX("HLP"," "),-1)
IF LEXC>0
Begin DoDot:1
+59 SET LEX=0
SET LEX("HLP",0)=LEXC
if $LENGTH($GET(LEXX))
SET LEX("NAR")=$GET(LEXX)
End DoDot:1
+60 QUIT
HTXT ; Help Text (expanded)
+1 NEW LEXF,LEXOK,LEXU
+2 SET LEXOK=0
SET LEXU=$GET(LEXX)
SET LEXF=$GET(^TMP("LEXSCH",$JOB,"FIL",0))
+3 SET (LEX2,LEX3,LEX4,LEXC,LEXS,LEXEX)=""
SET LEXOK=0
if '$LENGTH(LEXF)
DO HICD^LEXHLP2
+4 if LEXOK
QUIT
if LEXF["$$DX^LEXU"
DO HICD^LEXHLP2
if LEXOK
QUIT
+5 IF LEXF["$$"&(LEXF["ONE^")
Begin DoDot:1
+6 if LEXF["$$10P"&(LEXF'["$$10D")
DO H10P^LEXHLP2
if LEXF["$$10D"
DO H10D^LEXHLP2
if LEXOK
QUIT
+7 if LEXF["$$CPC"&(LEXF'["$$CPT")
DO HCPC^LEXHLP2
if LEXF["$$CPT"
DO HCPT^LEXHLP2
if LEXOK
QUIT
End DoDot:1
if LEXOK
QUIT
+8 IF LEXF["$$SO^LEXU"
Begin DoDot:1
+9 if LEXF["10P"&(LEXF'["10D")
DO H10P^LEXHLP2
if LEXF["10D"
DO H10D^LEXHLP2
if LEXOK
QUIT
+10 if LEXF["CPC"&(LEXF'["CPT")
DO HCPC^LEXHLP2
if LEXF["CPT"
DO HCPT^LEXHLP2
if LEXOK
QUIT
+11 if LEXF["SCC"
DO HSCC^LEXHLP2
if LEXOK
QUIT
if LEXF["DS3"!(LEXF["DS4")
DO HDS4^LEXHLP2
if LEXOK
QUIT
+12 if LEXF["OMA"&(LEXF'["NAN")
DO HOMA^LEXHLP2
if LEXF["NAN"
DO HNAN^LEXHLP2
if LEXOK
QUIT
End DoDot:1
if LEXOK
QUIT
+13 DO HICD^LEXHLP2
+14 QUIT
+15 ;
+16 ; Miscellaneous
SA ; Show Array
+1 NEW LEXI
SET LEXI=0
FOR
SET LEXI=$ORDER(LEX("HLP",LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+2 WRITE !,LEX("HLP",LEXI)
End DoDot:1
+3 QUIT
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
