source: FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXSC3.m@ 811

Last change on this file since 811 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.5 KB
Line 
1LEXSC3 ; ISL Shortcuts Add/Delete ; 09-23-96
2 ;;2.0;LEXICON UTILITY;;Sep 23, 1996
3 ;
4ADD ; Add a shortcut
5 N LEXADD,LEXERM
6ADD2 F D Q:$G(LEXRP)[U!(+($G(Y))>0)
7 . W ! S LEXERM=$$TERM^LEXSC2 Q:LEXRP[U
8 . D LK(LEXERM)
9 I LEXRP[U,LEXRP'["^^" W ! S LEXRP="" Q
10 Q:LEXRP["^^" I +Y>0 D ASKADD I $G(LEXADD)>0 D ADDSC(+Y,LEXSC,LEXCX)
11 I LEXRP[U,LEXRP'["^^" S LEXRP="" G ADD2
12 Q
13ASKADD ;
14 N LEXERM,LEXSTR S LEXERM=+Y
15 S LEXERM=$S(+LEXERM'>0:"",1:$G(^LEX(757.01,LEXERM,0)))
16 S LEXSTR="Add """_LEXSC_""" as a short cut "
17 S LEXSTR=LEXSTR_"(in the context of "_LEXCXN_")"
18 S:LEXERM'="" LEXSTR=LEXSTR_" pointing to the term """_LEXERM_""""
19 D WRT^LEXSC2(LEXSTR) S LEXADD=$$ADDOK^LEXSC2
20 Q
21ADDSC(LEXEXP,LEXSC,LEXCX) ; Add shortcut
22 I '$D(^LEX(757.4,"B",LEXEXP)) D ADDR
23 I $D(^LEX(757.4,"B",LEXEXP)) D ADDS
24 Q
25ADDS ; Add Shortcut to sub-file
26 N DIC,DLAYGO,X,Y,DTOUT,DUOUT
27 N LEXR S LEXR=$O(^LEX(757.4,"B",LEXEXP,0)) Q:'$D(^LEX(757.4,LEXR,0)) K DD,DO S DA(1)=LEXR,X=LEXSC
28 S DLAYGO=757.401,DIC="^LEX(757.4,"_DA(1)_",1,",DIC(0)="AEMQL",DIC("P")="757.401",DIC("DR")="1////^S X=LEXCX" D FILE^DICN
29 Q
30ADDR ; Add record
31 N DIC,DLAYGO,X,Y,DTOUT,DUOUT
32 N LEXERM S LEXERM=$G(^LEX(757.01,LEXEXP,0))
33 K DD,DO S X=LEXEXP,DIC="^LEX(757.4,",DLAYGO=757.4,DIC(0)="AEMQL" D FILE^DICN
34 Q
35LK(X) ; Set up Lookup
36 S X=$G(X) K DLAYGO N DIC,DIPGM,DO G:X=""!(X["^") LKQ S:$L($G(LEXDICS)) DIC("S")=LEXDICS
37 S XTLKKSCH("INDEX")="AWRD",(DIC,XTLKGBL,XTLKKSCH("GBL"))="^LEX(757.01,"
38 S LEXSHOW="ICD/CPT/DSM/NAN/OMA/NIC"
39 S:$L($G(^LEXT(757.2,1,2))) XTLKHLP="D "_^LEXT(757.2,1,2)
40 S:$L($G(^LEXT(757.2,1,3))) XTLKKSCH("DSPLY")=^LEXT(757.2,1,3)
41 S:'$L($G(XTLKHLP)) XTLKHLP="D XTLK^LEXHLP" S:'$L($G(XTLKKSCH("DSPLY"))) XTLKKSCH="XTLK^LEXPRNT"
42 S (X,XTLKX)=$$UP^XLFSTR(LEXERM),DO=@(DIC_"0)"),DIC(0)="EMQ",XTLKSAY=0
43 W !,"Searching ... "
44 D ^XTLKKWL K XTLKSAY,XTLKHLP S LEXRP=X
45LKQ ;
46 K LEXSUB,LEXU,LEXAP,LEXUN,LEXLST,LEXLL,LEXSHOW
47 K XTLKX,XTLKKSCH,XTLKHLP,XTLKSAY,XTLKGBL,XTLKWD2
48 Q
49DELS ;
50 N DIK,LEXC S LEXCX=+($G(LEXCX)) Q:'$L($G(LEXSC)) Q:LEXCX=0 N LEXR,LEXS
51 S LEXR=$O(^LEX(757.4,"ARA",$E($$UP^XLFSTR(LEXSC),1,63),LEXCX,0)) Q:+LEXR=0
52 S LEXS=$O(^LEX(757.4,"ARA",$E($$UP^XLFSTR(LEXSC),1,63),LEXCX,+LEXR,0)) Q:+LEXS=0
53 S DA(1)=+LEXR,DA=+LEXS,DIK="^LEX(757.4,"_DA(1)_",1," D ^DIK
54 S LEXC=$$CNT(LEXR) I LEXC'[U,+LEXC=0 D DELR(LEXR)
55 Q
56DELR(DA) ;
57 S DA=+($G(DA)) Q:DA=0 Q:'$D(^LEX(757.4,DA)) N DIK S DIK="^LEX(757.4," D ^DIK
58 Q
59CNT(X) ;
60 N LEXR,LEXC,LEXI S (LEXC,LEXI)=0,LEXR=+$G(X)
61 Q:'$L($G(^LEX(757.4,LEXR,0))) "^"
62 F S LEXI=$O(^LEX(757.4,LEXR,1,LEXI)) Q:+LEXI=0 D
63 . S LEXC=LEXC+1
64 S X=LEXC Q X
Note: See TracBrowser for help on using the repository browser.