source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXHLP.m@ 1321

Last change on this file since 1321 was 613, checked in by George Lilly, 16 years ago

initial load of WorldVistAEHR
File size: 6.7 KB
RevLine 
[613]1LEXHLP ; ISL Help/input transformations ; 05/25/1998
2 ;;2.0;LEXICON UTILITY;**11**;Sep 23, 1996;Build 1
3 ;
4EXC ; Excluded Word Help
5 I '$D(X) Q
6 S X=$$UP^XLFSTR(X) I $D(^LEX(757.05,"AB",$E(X,1,40))) D Q
7 . W !!,$C(7),"""",X,""""," already exist in the Replacement Words file."
8 . W !,"You can not exclude a word which is to be replaced",!!
9 . K X
10 S X=$$UP^XLFSTR(X) I $D(^LEX(757.04,"C",$E(X,1,40))) D Q
11 . W !!,$C(7),"""",X,""""," already exist in the Replacement Words file."
12 . W !,"You can not exclude a replacement word",!!
13 . K X
14 Q
15REP ; Replacement Words Help (replace)
16 I '$D(X) Q
17 S X=$$UP^XLFSTR(X) I $D(^LEX(757.04,"AB",$E(X,1,40))) D Q
18 . W !!,$C(7),"""",X,""""," already exist in the Excluded Words file."
19 . W !,"You can not replace an excluded word.",!!
20 . K X
21 I $D(^LEX(757.01,"AWRD",X)) D Q
22 . W !!,$C(7),"""",X,""""," is indexed as a key word for: ",!
23 . S LEXREC=0 F S LEXREC=$O(^LEX(757.01,"AWRD",X,LEXREC)) Q:+LEXREC=0 D
24 . . W !,?2,^LEX(757.01,LEXREC,0)
25 . W !!,"You can not alter this keyword/term linkage.",!!
26 . K LEXREC,X
27 Q
28REPBY ; Replacement Words Help (insert)
29 I '$D(X) Q
30 S X=$$UP^XLFSTR(X) I $D(^LEX(757.04,"AB",$E(X,1,40))) D Q
31 . W !!,$C(7),"""",X,""""," already exist in the Excluded Words file."
32 . W !,"You can not replace an excluded word.",!!
33 . K X
34 Q
35APPS(X) ; Input Help for ^LEX(757.2 field 8
36 N LEXOK S LEXOK=1
37 I '$D(X)!('$D(DA)) Q 0
38 I $L(X)>3!($L(X)<3) W !,"3 characters, please ",! Q 0
39 N LEXI,LEXC F LEXI=1:1:3 S LEXC=$A($E(X,LEXI)) D
40 . I ((LEXC>64)&(LEXC<91))!((LEXC>47)&(LEXC<58)) Q
41 . S LEXOK=0
42 K LEXI,LEXC
43 I 'LEXOK K LEXOK W !,"Invalid characters detected, use any combination of uppercase or numeric ",! Q 0
44 I X=$P(^LEXT(757.2,DA,0),"^",2) W !,"Cannot be the same as the Short TitLe",LEXOK,! Q 0
45 Q 1
46XTLK ; MTLY Help
47 ; Uses ^TMP("XTLKHITS",$J), XTLKH, XTLKI, XTLKKSCH("DSPLY"),
48 ; XTLKKSCH("GBL"), XTLKMULT, XTLKREF0 and XTLKREF1
49 N LEXHLPF S LEXHLPF=1
50 Q:'$D(XTLKHLP) D XTLKONE:^TMP("XTLKHITS",$J)=1,XTLKSEL:^TMP("XTLKHITS",$J)>1 Q
51XTLKONE ; Help for a single entry on the selection list
52 N LEXMC,LEXLN
53 S LEXMC=$S(LEXSUB="WRD":$P(^LEX(757.01,XTLKI,1),U,1),1:$P(^LEX(757.01,+(@(DIC_XTLKI_",0)")),1),U,1))
54 S LEXEXP=0 S:+LEXMC>0 LEXEXP=+(^LEX(757,LEXMC,0))
55 I +LEXEXP'=0,$D(^LEX(757.01,LEXEXP,3,0)) D
56 . F LEXLN=1:1:$P(^LEX(757.01,LEXEXP,3,0),U,4) D
57 . . I $D(^LEX(757.01,LEXEXP,3,LEXLN,0)) W !,?2,^LEX(757.01,LEXEXP,3,LEXLN,0)
58 . . I '(+(LEXLN#5)) D XTLKCON
59 I $D(LEXLN),(+(LEXLN#5)) D XTLKCON W !
60 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),!
61 K LEXEXP,LEXMC,LEXLN Q
62XTLKSEL ; Help for a multiple entries on the selection list
63 I X?1"?"1N.N!(X?2"?"1N.N) D XTLKDEF,XTLKEND W:XTLKH<6 !! Q
64 D XTLKEND,XTLKRED Q
65XTLKDEF ; Display an Expression Defintion as part of the Help
66 S X=$E(X,2,$L(X)) G:X["?" XTLKDEF I +X<1!(+X>XTLKH) Q
67 N LEXMC,LEXLN,LEXEXP
68 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))
69 S LEXEXP=0 S:+LEXMC>0 LEXEXP=+(^LEX(757,LEXMC,0)) I +LEXEXP'=0,$D(^LEX(757.01,LEXEXP,3,0)) D
70 . F LEXLN=1:1:$P(^LEX(757.01,LEXEXP,3,0),U,4) D
71 . . I $D(^LEX(757.01,LEXEXP,3,LEXLN,0)) D
72 . . . W:LEXLN=1 ! W !,?2,^LEX(757.01,LEXEXP,3,LEXLN,0)
73 . . I '(+(LEXLN#5)) D XTLKCON
74 I $D(LEXLN),(+(LEXLN#5)) D XTLKCON
75 ; W !
76 K LEXMC,LEXLN,LEXEXP Q
77XTLKCON ; End of Page
78 Q:'$D(VALM) W ! N X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DIR
79 S DIR("A")="Press <Return> to continue "
80 S DIR("?")="Press the <Return> key to continue ",DIR(0)="EA" D ^DIR Q
81XTLKEND ; End of Help
82 W !!,"Answer with # (1-",XTLKH,"), ^ (quit), ^# (jump - ",^TMP("XTLKHITS",$J)," choices), or ?# (help on a term)" Q
83XTLKRED ; Post-Help, redisplay the last segment of the list
84 N LEXSTRT,LEXEND S LEXSTRT=(((XTLKH-1)\5)*5)+1,LEXEND=XTLKH
85 F XTLKH=LEXSTRT:1:LEXEND D
86 . S (Y,XTLKI)=^TMP("XTLKHITS",$J,XTLKH)
87 . S XTLKREF0=XTLKREF1_XTLKI_",0)" W:XTLKH=1 !!
88 . I $D(XTLKKSCH("DSPLY")) D @XTLKKSCH("DSPLY") Q
89 . W:XTLKMULT $J(XTLKH,4),": " W $P(@(XTLKREF1_"XTLKI,0)"),"^",1),!
90 W ! K LEXSTRT,LEXEND Q
91SUB(LEXS) ; Subset help
92 W ! N X,Y,LEXDICA,LEXDIC0,LEXDICW,LEXDIC S LEXS=""
93 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")
94 S DIC("A")="Enter the name of a vocabulary to use: ",DIC("W")="",DIC(0)="AEQM",DIC="^LEXT(757.2," D ^DIC
95 I +Y>0,$D(^LEXT(757.2,+Y,0)) D
96 . I $P(^LEXT(757.2,+Y,0),"^",2)'="" S LEXS=$P(^LEXT(757.2,+Y,0),"^",2) Q
97 . I $D(^LEXT(757.2,+Y,5)),$P(^LEXT(757.2,+Y,5),"^",1)'="" S LEXS=$P(^LEXT(757.2,+Y,5),"^",1) Q
98 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")
99 Q LEXS
100SQ(X) ; Single question mark help for DIR("?") based on DIC("S") PCH 11
101 N LEXD,LEXI,LEXA,LEXT,LEXC,LEXN,LEXJ
102 I $D(^TMP("LEXSCH",$J)) D
103 . S LEXD=$G(^TMP("LEXSCH",$J,"FIL",0)),LEXI=$G(^TMP("LEXSCH",$J,"IDX",0)),LEXA=$G(^TMP("LEXSCH",$J,"APP",1))
104 I '$D(^TMP("LEXSCH",$J)) D
105 . N LEXTNS,LEXTSS,LEXONS,LEXOSS
106 . S (LEXONS,LEXTNS)=$G(LEXAP),LEXTNS=+LEXTNS S:LEXTNS=0 LEXTNS=1
107 . S (LEXOSS,LEXTSS)=$G(LEXSUB) S:LEXTSS="" LEXTSS="WRD"
108 . D CONFIG^LEXSET(LEXTNS,LEXTSS)
109 . S LEXD=$G(^TMP("LEXSCH",$J,"FIL",0)),LEXI=$G(^TMP("LEXSCH",$J,"IDX",0)),LEXA=$G(^TMP("LEXSCH",$J,"APP",1))
110 . K ^TMP("LEXSCH",$J) S:$L(LEXONS) LEXAP=LEXONS S:$L(LEXOSS) LEXSUB=LEXOSS
111 S (LEXT,LEXC)="",X=""
112 S:'$L($G(LEXD))&($L($G(DIC("S")))) LEXD=$G(DIC("S"))
113 I $L($G(LEXI)),$G(LEXI)'["WRD" D Q X
114 . F LEXJ="DEN;Dental","IMM;Immunologic","NUR;Nursing","SOC;Social Work" S:LEXI[$P(LEXJ,";",1) LEXT=" "_$P(LEXJ,";",2)
115 . S X="Enter a ""free text"""_LEXT_" term"
116 I $L($G(LEXD)) D Q X
117 . I LEXD'["SRC^LEXU" D Q
118 . . F LEXJ="ICD;ICD","CPT;CPT","CPC;HCPCS","DS4;DSM","NAN;NANDA" D
119 . . . S:LEXD[$P(LEXJ,";",1)&(LEXC'[$P(LEXJ,";",2)) LEXC=LEXC_", "_$P(LEXJ,";",2)
120 . . . S:LEXD[$P(LEXJ,";",1)&("NAN^ICD^DSM^DS4^DS3"[$P(LEXJ,";",1))&(LEXT'["diagnosis") LEXT=LEXT_"/diagnosis"
121 . . . S:LEXD[$P(LEXJ,";",1)&("CPT^CPC"[$P(LEXJ,";",1))&(LEXT'["procedure") LEXT=LEXT_"/procedure"
122 . . S:$E(LEXT,1)="/" LEXT=$E(LEXT,2,$L(LEXT)) S:$E(LEXC,1,2)=", " LEXC=$E(LEXC,3,$L(LEXC))
123 . . 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"
124 . . 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
125 . I LEXD["SRC^LEXU",$L(LEXA) D Q
126 . . N LEXN1,LEXN2 S LEXN1=LEXA,LEXN2="" I LEXA[" (",$L($P($P(LEXA," (",2),")",1)) D
127 . . . S LEXN1=$P(LEXA," (",1),LEXN2="("_$P(LEXA," (",2),LEXN2=$P(LEXN2,")",1)_")"
128 . . S X="Enter a ""free text""" S:$L(LEXN1) X=X_" "_LEXN1 S:$L(LEXN2) X=X_" "_LEXN2 S X=X_" term"
129 S X="Enter a ""free text"" term"
130 Q X
Note: See TracBrowser for help on using the repository browser.