- 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 Mar 13, 2025@21:12:33 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
