LEXHLP ;ISL/KER - Help/input transformations ;04/21/2014
;;2.0;LEXICON UTILITY;**11,80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^TMP("LEXSCH") SACC 2.3.2.5.1
; ^TMP("XTLKHITS") SACC 2.3.2.5.1
;
; External References
; $$UP^XLFSTR ICR 10103
; ^DIC ICR 10006
; ^DIR ICR 10026
;
EXC ; Excluded Word Help
I '$D(X) Q
S X=$$UP^XLFSTR(X) I $D(^LEX(757.05,"AB",$E(X,1,40))) D Q
. W !!,$C(7),"""",X,""""," already exist in the Replacement Words file."
. W !,"You can not exclude a word which is to be replaced",!!
. K X
S X=$$UP^XLFSTR(X) I $D(^LEX(757.04,"C",$E(X,1,40))) D Q
. W !!,$C(7),"""",X,""""," already exist in the Replacement Words file."
. W !,"You can not exclude a replacement word",!!
. K X
Q
REP ; Replacement Words Help (replace)
I '$D(X) Q
S X=$$UP^XLFSTR(X) I $D(^LEX(757.04,"AB",$E(X,1,40))) D Q
. W !!,$C(7),"""",X,""""," already exist in the Excluded Words file."
. W !,"You can not replace an excluded word.",!!
. K X
I $D(^LEX(757.01,"AWRD",X)) D Q
. W !!,$C(7),"""",X,""""," is indexed as a key word for: ",!
. S LEXREC=0 F S LEXREC=$O(^LEX(757.01,"AWRD",X,LEXREC)) Q:+LEXREC=0 D
. . W !,?2,^LEX(757.01,LEXREC,0)
. W !!,"You can not alter this keyword/term linkage.",!!
. K LEXREC,X
Q
REPBY ; Replacement Words Help (insert)
I '$D(X) Q
S X=$$UP^XLFSTR(X) I $D(^LEX(757.04,"AB",$E(X,1,40))) D Q
. W !!,$C(7),"""",X,""""," already exist in the Excluded Words file."
. W !,"You can not replace an excluded word.",!!
. K X
Q
APPS(X) ; Input Help for ^LEX(757.2 field 8
N LEXOK S LEXOK=1
I '$D(X)!('$D(DA)) Q 0
I $L(X)>3!($L(X)<3) W !,"3 characters, please ",! Q 0
N LEXI,LEXC F LEXI=1:1:3 S LEXC=$A($E(X,LEXI)) D
. I ((LEXC>64)&(LEXC<91))!((LEXC>47)&(LEXC<58)) Q
. S LEXOK=0
K LEXI,LEXC
I 'LEXOK K LEXOK W !,"Invalid characters detected, use any combination of uppercase or numeric ",! Q 0
I X=$P(^LEXT(757.2,DA,0),"^",2) W !,"Cannot be the same as the Short TitLe",LEXOK,! Q 0
Q 1
XTLK ; MTLY Help
; Uses ^TMP("XTLKHITS",$J), XTLKH, XTLKI, XTLKKSCH("DSPLY"),
; XTLKKSCH("GBL"), XTLKMULT, XTLKREF0 and XTLKREF1
N LEXHLPF S LEXHLPF=1
Q:'$D(XTLKHLP) D XTLKONE:^TMP("XTLKHITS",$J)=1,XTLKSEL:^TMP("XTLKHITS",$J)>1 Q
XTLKONE ; Help for a single entry on the selection list
N LEXMC,LEXLN
S LEXMC=$S(LEXSUB="WRD":$P(^LEX(757.01,XTLKI,1),U,1),1:$P(^LEX(757.01,+(@(DIC_XTLKI_",0)")),1),U,1))
S LEXEXP=0 S:+LEXMC>0 LEXEXP=+(^LEX(757,LEXMC,0))
I +LEXEXP'=0,$D(^LEX(757.01,LEXEXP,3,0)) D
. F LEXLN=1:1:$P(^LEX(757.01,LEXEXP,3,0),U,4) D
. . I $D(^LEX(757.01,LEXEXP,3,LEXLN,0)) W !,?2,^LEX(757.01,LEXEXP,3,LEXLN,0)
. . I '(+(LEXLN#5)) D XTLKCON
I $D(LEXLN),(+(LEXLN#5)) D XTLKCON W !
I +LEXEXP'=0,'$D(^LEX(757.01,LEXEXP,3,0)) W !,"Only one match found, select: ",^LEX(757.01,$S(LEXSUB="WRD":XTLKI,1:+(@(DIC_XTLKI_",0)"))),0),!
K LEXEXP,LEXMC,LEXLN Q
XTLKSEL ; Help for a multiple entries on the selection list
I X?1"?"1N.N!(X?2"?"1N.N) D XTLKDEF,XTLKEND W:XTLKH<6 !! Q
D XTLKEND,XTLKRED Q
XTLKDEF ; Display an Expression Defintion as part of the Help
S X=$E(X,2,$L(X)) G:X["?" XTLKDEF I +X<1!(+X>XTLKH) Q
N LEXMC,LEXLN,LEXEXP
S LEXMC=$S(LEXSUB="WRD":$P(^LEX(757.01,^TMP("XTLKHITS",$J,+X),1),U,1),1:$P(^LEX(757.01,+(@(DIC_^TMP("XTLKHITS",$J,+X)_",0)")),1),U,1))
S LEXEXP=0 S:+LEXMC>0 LEXEXP=+(^LEX(757,LEXMC,0)) I +LEXEXP'=0,$D(^LEX(757.01,LEXEXP,3,0)) D
. F LEXLN=1:1:$P(^LEX(757.01,LEXEXP,3,0),U,4) D
. . I $D(^LEX(757.01,LEXEXP,3,LEXLN,0)) D
. . . W:LEXLN=1 ! W !,?2,^LEX(757.01,LEXEXP,3,LEXLN,0)
. . I '(+(LEXLN#5)) D XTLKCON
I $D(LEXLN),(+(LEXLN#5)) D XTLKCON
; W !
K LEXMC,LEXLN,LEXEXP Q
XTLKCON ; End of Page
Q:'$D(VALM) W ! N X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIR
S DIR("A")="Press <Return> to continue "
S DIR("?")="Press the <Return> key to continue ",DIR(0)="EA" D ^DIR Q
XTLKEND ; End of Help
W !!,"Answer with # (1-",XTLKH,"), ^ (quit), ^# (jump - ",^TMP("XTLKHITS",$J)," choices), or ?# (help on a term)" Q
XTLKRED ; Post-Help, redisplay the last segment of the list
N LEXSTRT,LEXEND S LEXSTRT=(((XTLKH-1)\5)*5)+1,LEXEND=XTLKH
F XTLKH=LEXSTRT:1:LEXEND D
. S (Y,XTLKI)=^TMP("XTLKHITS",$J,XTLKH)
. S XTLKREF0=XTLKREF1_XTLKI_",0)" W:XTLKH=1 !!
. I $D(XTLKKSCH("DSPLY")) D @XTLKKSCH("DSPLY") Q
. W:XTLKMULT $J(XTLKH,4),": " W $P(@(XTLKREF1_"XTLKI,0)"),"^",1),!
W ! K LEXSTRT,LEXEND Q
XTLKC ;
N DA,DIC,LEXAP,LEXSUB,VALM,XTLKH,XTLKHLP,XTLKI,XTLKKSCH,XTLKMULT,XTLKREF0,XTLKREF1
Q
SUB(LEXS) ; Subset help
W ! N X,Y,LEXDICA,LEXDIC0,LEXDICW,LEXDIC S LEXS=""
S:$D(DIC)#2>0 LEXDIC=DIC S:$D(DIC(0)) LEXDIC0=DIC(0) S:$D(DIC("A")) LEXDICA=DIC("A") S:$D(DIC("W")) LEXDICW=DIC("W")
S DIC("A")="Enter the name of a vocabulary to use: ",DIC("W")="",DIC(0)="AEQM",DIC="^LEXT(757.2," D ^DIC
I +Y>0,$D(^LEXT(757.2,+Y,0)) D
. I $P(^LEXT(757.2,+Y,0),"^",2)'="" S LEXS=$P(^LEXT(757.2,+Y,0),"^",2) Q
. I $D(^LEXT(757.2,+Y,5)),$P(^LEXT(757.2,+Y,5),"^",1)'="" S LEXS=$P(^LEXT(757.2,+Y,5),"^",1) Q
S:$D(LEXDIC) DIC=LEXDIC S:$D(LEXDICW) DIC("W")=LEXDICW S:$D(LEXDIC0) DIC(0)=LEXDIC0 S:$D(LEXDICA) DIC("A")=LEXDICA K:'$D(LEXDICA) DIC("A")
Q LEXS
SQ(X) ; Single question mark help for DIR("?") based on DIC("S") PCH 11
N LEXD,LEXI,LEXA,LEXT,LEXC,LEXN,LEXJ
I $D(^TMP("LEXSCH",$J)) D
. S LEXD=$G(^TMP("LEXSCH",$J,"FIL",0)),LEXI=$G(^TMP("LEXSCH",$J,"IDX",0)),LEXA=$G(^TMP("LEXSCH",$J,"APP",1))
I '$D(^TMP("LEXSCH",$J)) D
. N LEXTNS,LEXTSS,LEXONS,LEXOSS
. S (LEXONS,LEXTNS)=$G(LEXAP),LEXTNS=+LEXTNS S:LEXTNS=0 LEXTNS=1
. S (LEXOSS,LEXTSS)=$G(LEXSUB) S:LEXTSS="" LEXTSS="WRD"
. D CONFIG^LEXSET(LEXTNS,LEXTSS)
. S LEXD=$G(^TMP("LEXSCH",$J,"FIL",0)),LEXI=$G(^TMP("LEXSCH",$J,"IDX",0)),LEXA=$G(^TMP("LEXSCH",$J,"APP",1))
. K ^TMP("LEXSCH",$J) S:$L(LEXONS) LEXAP=LEXONS S:$L(LEXOSS) LEXSUB=LEXOSS
S (LEXT,LEXC)="",X=""
S:'$L($G(LEXD))&($L($G(DIC("S")))) LEXD=$G(DIC("S"))
I $L($G(LEXI)),$G(LEXI)'["WRD" D Q X
. F LEXJ="DEN;Dental","IMM;Immunologic","NUR;Nursing","SOC;Social Work" S:LEXI[$P(LEXJ,";",1) LEXT=" "_$P(LEXJ,";",2)
. S X="Enter a ""free text"""_LEXT_" term"
I $L($G(LEXD)) D Q X
. I LEXD'["SRC^LEXU" D Q
. . F LEXJ="ICD;ICD","CPT;CPT","CPC;HCPCS","DS4;DSM","NAN;NANDA" D
. . . S:LEXD[$P(LEXJ,";",1)&(LEXC'[$P(LEXJ,";",2)) LEXC=LEXC_", "_$P(LEXJ,";",2)
. . . S:LEXD[$P(LEXJ,";",1)&("NAN^ICD^DSM^DS4^DS3"[$P(LEXJ,";",1))&(LEXT'["diagnosis") LEXT=LEXT_"/diagnosis"
. . . S:LEXD[$P(LEXJ,";",1)&("CPT^CPC"[$P(LEXJ,";",1))&(LEXT'["procedure") LEXT=LEXT_"/procedure"
. . S:$E(LEXT,1)="/" LEXT=$E(LEXT,2,$L(LEXT)) S:$E(LEXC,1,2)=", " LEXC=$E(LEXC,3,$L(LEXC))
. . S:$L(LEXC,", ")>1 LEXC=$P(LEXC,", ",1,($L(LEXC,", ")-1))_" or "_$P(LEXC,", ",$L(LEXC,", ")) S:$L(LEXC) LEXC=$S($E(LEXC,1)="I":("an "_LEXC),1:("a "_LEXC)) S:$L(LEXC) LEXC=LEXC_" code"
. . S X="Enter a ""free text""" S:$L(LEXT) X=X_" "_LEXT S:'$L(LEXT) X=X_" term" S:$L(LEXC) X=X_" or "_LEXC
. I LEXD["SRC^LEXU",$L(LEXA) D Q
. . N LEXN1,LEXN2 S LEXN1=LEXA,LEXN2="" I LEXA[" (",$L($P($P(LEXA," (",2),")",1)) D
. . . S LEXN1=$P(LEXA," (",1),LEXN2="("_$P(LEXA," (",2),LEXN2=$P(LEXN2,")",1)_")"
. . S X="Enter a ""free text""" S:$L(LEXN1) X=X_" "_LEXN1 S:$L(LEXN2) X=X_" "_LEXN2 S X=X_" term"
S X="Enter a ""free text"" term"
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXHLP 7367 printed Nov 22, 2024@17:18:09 Page 2
LEXHLP ;ISL/KER - Help/input transformations ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**11,80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+5 ; ^TMP("XTLKHITS") SACC 2.3.2.5.1
+6 ;
+7 ; External References
+8 ; $$UP^XLFSTR ICR 10103
+9 ; ^DIC ICR 10006
+10 ; ^DIR ICR 10026
+11 ;
EXC ; Excluded Word Help
+1 IF '$DATA(X)
QUIT
+2 SET X=$$UP^XLFSTR(X)
IF $DATA(^LEX(757.05,"AB",$EXTRACT(X,1,40)))
Begin DoDot:1
+3 WRITE !!,$CHAR(7),"""",X,""""," already exist in the Replacement Words file."
+4 WRITE !,"You can not exclude a word which is to be replaced",!!
+5 KILL X
End DoDot:1
QUIT
+6 SET X=$$UP^XLFSTR(X)
IF $DATA(^LEX(757.04,"C",$EXTRACT(X,1,40)))
Begin DoDot:1
+7 WRITE !!,$CHAR(7),"""",X,""""," already exist in the Replacement Words file."
+8 WRITE !,"You can not exclude a replacement word",!!
+9 KILL X
End DoDot:1
QUIT
+10 QUIT
REP ; Replacement Words Help (replace)
+1 IF '$DATA(X)
QUIT
+2 SET X=$$UP^XLFSTR(X)
IF $DATA(^LEX(757.04,"AB",$EXTRACT(X,1,40)))
Begin DoDot:1
+3 WRITE !!,$CHAR(7),"""",X,""""," already exist in the Excluded Words file."
+4 WRITE !,"You can not replace an excluded word.",!!
+5 KILL X
End DoDot:1
QUIT
+6 IF $DATA(^LEX(757.01,"AWRD",X))
Begin DoDot:1
+7 WRITE !!,$CHAR(7),"""",X,""""," is indexed as a key word for: ",!
+8 SET LEXREC=0
FOR
SET LEXREC=$ORDER(^LEX(757.01,"AWRD",X,LEXREC))
if +LEXREC=0
QUIT
Begin DoDot:2
+9 WRITE !,?2,^LEX(757.01,LEXREC,0)
End DoDot:2
+10 WRITE !!,"You can not alter this keyword/term linkage.",!!
+11 KILL LEXREC,X
End DoDot:1
QUIT
+12 QUIT
REPBY ; Replacement Words Help (insert)
+1 IF '$DATA(X)
QUIT
+2 SET X=$$UP^XLFSTR(X)
IF $DATA(^LEX(757.04,"AB",$EXTRACT(X,1,40)))
Begin DoDot:1
+3 WRITE !!,$CHAR(7),"""",X,""""," already exist in the Excluded Words file."
+4 WRITE !,"You can not replace an excluded word.",!!
+5 KILL X
End DoDot:1
QUIT
+6 QUIT
APPS(X) ; Input Help for ^LEX(757.2 field 8
+1 NEW LEXOK
SET LEXOK=1
+2 IF '$DATA(X)!('$DATA(DA))
QUIT 0
+3 IF $LENGTH(X)>3!($LENGTH(X)<3)
WRITE !,"3 characters, please ",!
QUIT 0
+4 NEW LEXI,LEXC
FOR LEXI=1:1:3
SET LEXC=$ASCII($EXTRACT(X,LEXI))
Begin DoDot:1
+5 IF ((LEXC>64)&(LEXC<91))!((LEXC>47)&(LEXC<58))
QUIT
+6 SET LEXOK=0
End DoDot:1
+7 KILL LEXI,LEXC
+8 IF 'LEXOK
KILL LEXOK
WRITE !,"Invalid characters detected, use any combination of uppercase or numeric ",!
QUIT 0
+9 IF X=$PIECE(^LEXT(757.2,DA,0),"^",2)
WRITE !,"Cannot be the same as the Short TitLe",LEXOK,!
QUIT 0
+10 QUIT 1
XTLK ; MTLY Help
+1 ; Uses ^TMP("XTLKHITS",$J), XTLKH, XTLKI, XTLKKSCH("DSPLY"),
+2 ; XTLKKSCH("GBL"), XTLKMULT, XTLKREF0 and XTLKREF1
+3 NEW LEXHLPF
SET LEXHLPF=1
+4 if '$DATA(XTLKHLP)
QUIT
if ^TMP("XTLKHITS",$JOB)=1
DO XTLKONE
if ^TMP("XTLKHITS",$JOB)>1
DO XTLKSEL
QUIT
XTLKONE ; Help for a single entry on the selection list
+1 NEW LEXMC,LEXLN
+2 SET LEXMC=$SELECT(LEXSUB="WRD":$PIECE(^LEX(757.01,XTLKI,1),U,1),1:$PIECE(^LEX(757.01,+(@(DIC_XTLKI_",0)")),1),U,1))
+3 SET LEXEXP=0
if +LEXMC>0
SET LEXEXP=+(^LEX(757,LEXMC,0))
+4 IF +LEXEXP'=0
IF $DATA(^LEX(757.01,LEXEXP,3,0))
Begin DoDot:1
+5 FOR LEXLN=1:1:$PIECE(^LEX(757.01,LEXEXP,3,0),U,4)
Begin DoDot:2
+6 IF $DATA(^LEX(757.01,LEXEXP,3,LEXLN,0))
WRITE !,?2,^LEX(757.01,LEXEXP,3,LEXLN,0)
+7 IF '(+(LEXLN#5))
DO XTLKCON
End DoDot:2
End DoDot:1
+8 IF $DATA(LEXLN)
IF (+(LEXLN#5))
DO XTLKCON
WRITE !
+9 IF +LEXEXP'=0
IF '$DATA(^LEX(757.01,LEXEXP,3,0))
WRITE !,"Only one match found, select: ",^LEX(757.01,$SELECT(LEXSUB="WRD":XTLKI,1:+(@(DIC_XTLKI_",0)"))),0),!
+10 KILL LEXEXP,LEXMC,LEXLN
QUIT
XTLKSEL ; Help for a multiple entries on the selection list
+1 IF X?1"?"1N.N!(X?2"?"1N.N)
DO XTLKDEF
DO XTLKEND
if XTLKH<6
WRITE !!
QUIT
+2 DO XTLKEND
DO XTLKRED
QUIT
XTLKDEF ; Display an Expression Defintion as part of the Help
+1 SET X=$EXTRACT(X,2,$LENGTH(X))
if X["?"
GOTO XTLKDEF
IF +X<1!(+X>XTLKH)
QUIT
+2 NEW LEXMC,LEXLN,LEXEXP
+3 SET LEXMC=$SELECT(LEXSUB="WRD":$PIECE(^LEX(757.01,^TMP("XTLKHITS",$JOB,+X),1),U,1),1:$PIECE(^LEX(757.01,+(@(DIC_^TMP("XTLKHITS",$JOB,+X)_",0)")),1),U,1))
+4 SET LEXEXP=0
if +LEXMC>0
SET LEXEXP=+(^LEX(757,LEXMC,0))
IF +LEXEXP'=0
IF $DATA(^LEX(757.01,LEXEXP,3,0))
Begin DoDot:1
+5 FOR LEXLN=1:1:$PIECE(^LEX(757.01,LEXEXP,3,0),U,4)
Begin DoDot:2
+6 IF $DATA(^LEX(757.01,LEXEXP,3,LEXLN,0))
Begin DoDot:3
+7 if LEXLN=1
WRITE !
WRITE !,?2,^LEX(757.01,LEXEXP,3,LEXLN,0)
End DoDot:3
+8 IF '(+(LEXLN#5))
DO XTLKCON
End DoDot:2
End DoDot:1
+9 IF $DATA(LEXLN)
IF (+(LEXLN#5))
DO XTLKCON
+10 ; W !
+11 KILL LEXMC,LEXLN,LEXEXP
QUIT
XTLKCON ; End of Page
+1 if '$DATA(VALM)
QUIT
WRITE !
NEW X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIR
+2 SET DIR("A")="Press <Return> to continue "
+3 SET DIR("?")="Press the <Return> key to continue "
SET DIR(0)="EA"
DO ^DIR
QUIT
XTLKEND ; End of Help
+1 WRITE !!,"Answer with # (1-",XTLKH,"), ^ (quit), ^# (jump - ",^TMP("XTLKHITS",$JOB)," choices), or ?# (help on a term)"
QUIT
XTLKRED ; Post-Help, redisplay the last segment of the list
+1 NEW LEXSTRT,LEXEND
SET LEXSTRT=(((XTLKH-1)\5)*5)+1
SET LEXEND=XTLKH
+2 FOR XTLKH=LEXSTRT:1:LEXEND
Begin DoDot:1
+3 SET (Y,XTLKI)=^TMP("XTLKHITS",$JOB,XTLKH)
+4 SET XTLKREF0=XTLKREF1_XTLKI_",0)"
if XTLKH=1
WRITE !!
+5 IF $DATA(XTLKKSCH("DSPLY"))
DO @XTLKKSCH("DSPLY")
QUIT
+6 if XTLKMULT
WRITE $JUSTIFY(XTLKH,4),": "
WRITE $PIECE(@(XTLKREF1_"XTLKI,0)"),"^",1),!
End DoDot:1
+7 WRITE !
KILL LEXSTRT,LEXEND
QUIT
XTLKC ;
+1 NEW DA,DIC,LEXAP,LEXSUB,VALM,XTLKH,XTLKHLP,XTLKI,XTLKKSCH,XTLKMULT,XTLKREF0,XTLKREF1
+2 QUIT
SUB(LEXS) ; Subset help
+1 WRITE !
NEW X,Y,LEXDICA,LEXDIC0,LEXDICW,LEXDIC
SET LEXS=""
+2 if $DATA(DIC)#2>0
SET LEXDIC=DIC
if $DATA(DIC(0))
SET LEXDIC0=DIC(0)
if $DATA(DIC("A"))
SET LEXDICA=DIC("A")
if $DATA(DIC("W"))
SET LEXDICW=DIC("W")
+3 SET DIC("A")="Enter the name of a vocabulary to use: "
SET DIC("W")=""
SET DIC(0)="AEQM"
SET DIC="^LEXT(757.2,"
DO ^DIC
+4 IF +Y>0
IF $DATA(^LEXT(757.2,+Y,0))
Begin DoDot:1
+5 IF $PIECE(^LEXT(757.2,+Y,0),"^",2)'=""
SET LEXS=$PIECE(^LEXT(757.2,+Y,0),"^",2)
QUIT
+6 IF $DATA(^LEXT(757.2,+Y,5))
IF $PIECE(^LEXT(757.2,+Y,5),"^",1)'=""
SET LEXS=$PIECE(^LEXT(757.2,+Y,5),"^",1)
QUIT
End DoDot:1
+7 if $DATA(LEXDIC)
SET DIC=LEXDIC
if $DATA(LEXDICW)
SET DIC("W")=LEXDICW
if $DATA(LEXDIC0)
SET DIC(0)=LEXDIC0
if $DATA(LEXDICA)
SET DIC("A")=LEXDICA
if '$DATA(LEXDICA)
KILL DIC("A")
+8 QUIT LEXS
SQ(X) ; Single question mark help for DIR("?") based on DIC("S") PCH 11
+1 NEW LEXD,LEXI,LEXA,LEXT,LEXC,LEXN,LEXJ
+2 IF $DATA(^TMP("LEXSCH",$JOB))
Begin DoDot:1
+3 SET LEXD=$GET(^TMP("LEXSCH",$JOB,"FIL",0))
SET LEXI=$GET(^TMP("LEXSCH",$JOB,"IDX",0))
SET LEXA=$GET(^TMP("LEXSCH",$JOB,"APP",1))
End DoDot:1
+4 IF '$DATA(^TMP("LEXSCH",$JOB))
Begin DoDot:1
+5 NEW LEXTNS,LEXTSS,LEXONS,LEXOSS
+6 SET (LEXONS,LEXTNS)=$GET(LEXAP)
SET LEXTNS=+LEXTNS
if LEXTNS=0
SET LEXTNS=1
+7 SET (LEXOSS,LEXTSS)=$GET(LEXSUB)
if LEXTSS=""
SET LEXTSS="WRD"
+8 DO CONFIG^LEXSET(LEXTNS,LEXTSS)
+9 SET LEXD=$GET(^TMP("LEXSCH",$JOB,"FIL",0))
SET LEXI=$GET(^TMP("LEXSCH",$JOB,"IDX",0))
SET LEXA=$GET(^TMP("LEXSCH",$JOB,"APP",1))
+10 KILL ^TMP("LEXSCH",$JOB)
if $LENGTH(LEXONS)
SET LEXAP=LEXONS
if $LENGTH(LEXOSS)
SET LEXSUB=LEXOSS
End DoDot:1
+11 SET (LEXT,LEXC)=""
SET X=""
+12 if '$LENGTH($GET(LEXD))&($LENGTH($GET(DIC("S"))))
SET LEXD=$GET(DIC("S"))
+13 IF $LENGTH($GET(LEXI))
IF $GET(LEXI)'["WRD"
Begin DoDot:1
+14 FOR LEXJ="DEN;Dental","IMM;Immunologic","NUR;Nursing","SOC;Social Work"
if LEXI[$PIECE(LEXJ,";",1)
SET LEXT=" "_$PIECE(LEXJ,";",2)
+15 SET X="Enter a ""free text"""_LEXT_" term"
End DoDot:1
QUIT X
+16 IF $LENGTH($GET(LEXD))
Begin DoDot:1
+17 IF LEXD'["SRC^LEXU"
Begin DoDot:2
+18 FOR LEXJ="ICD;ICD","CPT;CPT","CPC;HCPCS","DS4;DSM","NAN;NANDA"
Begin DoDot:3
+19 if LEXD[$PIECE(LEXJ,";",1)&(LEXC'[$PIECE(LEXJ,";",2))
SET LEXC=LEXC_", "_$PIECE(LEXJ,";",2)
+20 if LEXD[$PIECE(LEXJ,";",1)&("NAN^ICD^DSM^DS4^DS3"[$PIECE(LEXJ,";",1))&(LEXT'["diagnosis")
SET LEXT=LEXT_"/diagnosis"
+21 if LEXD[$PIECE(LEXJ,";",1)&("CPT^CPC"[$PIECE(LEXJ,";",1))&(LEXT'["procedure")
SET LEXT=LEXT_"/procedure"
End DoDot:3
+22 if $EXTRACT(LEXT,1)="/"
SET LEXT=$EXTRACT(LEXT,2,$LENGTH(LEXT))
if $EXTRACT(LEXC,1,2)=", "
SET LEXC=$EXTRACT(LEXC,3,$LENGTH(LEXC))
+23 if $LENGTH(LEXC,", ")>1
SET LEXC=$PIECE(LEXC,", ",1,($LENGTH(LEXC,", ")-1))_" or "_$PIECE(LEXC,", ",$LENGTH(LEXC,", "))
if $LENGTH(LEXC)
SET LEXC=$SELECT($EXTRACT(LEXC,1)="I":("an "_LEXC),1:("a "_LEXC))
if $LENGTH(LEXC)
SET LEXC=LEXC_" code"
+24 SET X="Enter a ""free text"""
if $LENGTH(LEXT)
SET X=X_" "_LEXT
if '$LENGTH(LEXT)
SET X=X_" term"
if $LENGTH(LEXC)
SET X=X_" or "_LEXC
End DoDot:2
QUIT
+25 IF LEXD["SRC^LEXU"
IF $LENGTH(LEXA)
Begin DoDot:2
+26 NEW LEXN1,LEXN2
SET LEXN1=LEXA
SET LEXN2=""
IF LEXA[" ("
IF $LENGTH($PIECE($PIECE(LEXA," (",2),")",1))
Begin DoDot:3
+27 SET LEXN1=$PIECE(LEXA," (",1)
SET LEXN2="("_$PIECE(LEXA," (",2)
SET LEXN2=$PIECE(LEXN2,")",1)_")"
End DoDot:3
+28 SET X="Enter a ""free text"""
if $LENGTH(LEXN1)
SET X=X_" "_LEXN1
if $LENGTH(LEXN2)
SET X=X_" "_LEXN2
SET X=X_" term"
End DoDot:2
QUIT
End DoDot:1
QUIT X
+29 SET X="Enter a ""free text"" term"
+30 QUIT X
