source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDM4.m@ 1361

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

initial load of WorldVistAEHR
File size: 5.4 KB
RevLine 
[613]1LEXDM4 ; ISL Default Misc - Files/User/Svc/Loc ; 02-02-96
2 ;;2.0;LEXICON UTILITY;**4**;Sep 23, 1996;Build 1
3 ;
4DFI(LEXX) ; Select one application
5 N D,DIC,DTOUT,DUOUT I $D(LEXX),LEXX'="" S X=LEXX,DIC(0)="QM"
6 I '$D(LEXX) S DIC(0)="AQEM" W !
7 S DIC("W")="W ?45,$P($G(^(5)),U,5)"
8 S DIC="^LEXT(757.2,",DIC("S")="I +($P($G(^(5)),U,3))>0"
9 S D="B^C^AN" S DIC("A")="Select application: " D MIX^DIC1 K DIC
10 S LEXX=$S(+Y>0:+Y,1:0)
11 Q LEXX
12FI(LEXX) ; Select one or more applications
13FI2 W ! N LEXMAX,LEXI,LEXA,LEXAI,LEXAN,LEXC,LEXLEN
14 K ^TMP("LEXIL",$J)
15 S ^TMP("LEXIL",$J,0)=0
16FIB ; Build the list of files/applications
17 S (LEXAI,LEXC,LEXLEN)=0,(LEXAN,LEXA)=""
18 F S LEXA=$O(^LEXT(757.2,"ADEF",LEXA)) Q:LEXA="" D
19 . S LEXI=$O(^LEXT(757.2,"ADEF",LEXA,0))
20 . S LEXAN=$P(^LEXT(757.2,LEXI,0),U,1)
21 . Q:$D(^TMP("LEXIL",$J,"B",LEXAN))
22 . S:$L(LEXAN)>LEXLEN LEXLEN=$L(LEXAN)
23 . S LEXC=LEXC+1,^TMP("LEXIL",$J,LEXC)=LEXAN_U_LEXI,^TMP("LEXIL",$J,0)=^TMP("LEXIL",$J,0)+1,^TMP("LEXIL",$J,"B",LEXAN)=LEXC,^TMP("LEXIL",$J,"C",$$UP^XLFSTR(LEXAN))=LEXC
24 I $D(LEXMGR) D ; Pch 4
25 . S LEXC=+($G(^TMP("LEXIL",$J,0)))+1
26 . S ^TMP("LEXIL",$J,0)=LEXC,^TMP("LEXIL",$J,LEXC)="All of the Above"
27 . S ^TMP("LEXIL",$J,"B","All of the Above")=LEXC,^TMP("LEXIL",$J,"C","ALL OF THE ABOVE")=LEXC
28 . S:$L($G(^TMP("LEXIL",$J,LEXC)))>LEXLEN LEXLEN=$L($G(^TMP("LEXIL",$J,LEXC)))
29FIP ; Prompt user
30 G:'$D(^TMP("LEXIL",$J)) FIQ
31 W !,"Applications"
32FIL ; Display the list
33 S LEXMAX=^TMP("LEXIL",$J,0)
34 W ! F LEXI=1:1:^TMP("LEXIL",$J,0) W !,$J(LEXI,6)," ",$E($P(^TMP("LEXIL",$J,LEXI),U,1),1,50)
35 S LEXX=$$FIS G:LEXX="" FIQ S LEXX=+LEXX I '$D(LEXMGR),+LEXX>0,+LEXX<LEXMAX+1 S LEXX=$P(^TMP("LEXIL",$J,LEXX),U,2) G FIQ
36 I $D(LEXMGR),+LEXX>0,+LEXX<LEXMAX D G FIQ
37 . S ^TMP("LEXMGR",$J,"FI",0)=1
38 . S ^TMP("LEXMGR",$J,"FI",1)=$P(^TMP("LEXIL",$J,LEXX),U,2)_U_$S($P(^TMP("LEXIL",$J,LEXX),U,1)'[" (":$P(^TMP("LEXIL",$J,LEXX),U,1),1:$P($P(^TMP("LEXIL",$J,LEXX),U,1)," (",1))
39 . S LEXX=$P(^TMP("LEXIL",$J,LEXX),U,2)
40 I $D(LEXMGR),LEXX=LEXMAX S LEXX="" D G FIQ
41 . F LEXI=1:1:^TMP("LEXIL",$J,0) D
42 . . S ^TMP("LEXMGR",$J,"FI",LEXI)=$P(^TMP("LEXIL",$J,LEXI),U,2)_U_$S($P(^TMP("LEXIL",$J,LEXI),U,1)'[" (":$P(^TMP("LEXIL",$J,LEXI),U,1),1:$P($P(^TMP("LEXIL",$J,LEXI),U,1)," (",1))
43 . . S LEXX=LEXX_";"_$P(^TMP("LEXIL",$J,LEXI),U,2)
44 . . S ^TMP("LEXMGR",$J,"FI",0)=LEXI
45 . F Q:$E(LEXX,1)'=";" S LEXX=$E(LEXX,2,$L(LEXX))
46 . F Q:$E(LEXX,$L(LEXX))'=";" S LEXX=$E(LEXX,1,($L(LEXX)-1))
47 G FIP Q
48FIS(X) ; Select from the list
49 W ! N Y,DIR,DIC,DTOUT,DUOUT,DIRUT,DIROUT
50 S LEXLEN=+($G(LEXLEN)) S:LEXLEN=0 LEXLEN=15
51 S DIR("A")="Select (1-"_LEXMAX_"): "
52 S DIR("?")="^D FIHLP^LEXDM4"
53 S DIR(0)="FAO^1:"_LEXLEN_"^S X=+($$FIW^LEXDM4(X)) K:'X X" ; PCH 4
54 D ^DIR S:$D(DTOUT)!($D(DUOUT)) X="" S:$L(X) X=$$FIW(X) Q X ; PCH 4
55FIHLP ; Help for selection
56 I $D(LEXMGR) D
57 . W !!,"User defaults for both the Lexicon and applications using the Lexicon"
58 . W !,"(by agreement) will be stored along with their application definitions"
59 . W !,"contained in the Subset Definition File."
60 . W !!,"You may set user defaults for one or all of the listed applications"
61 I '$D(LEXMGR) D
62 . W !!,"User defaults for the Lexicon may be set for individual applications."
63 . W !!!,"Select an application:"
64 S LEXMAX=^TMP("LEXIL",$J,0) S:$D(LEXMGR) LEXMAX=LEXMAX+1
65 W ! F LEXI=1:1:^TMP("LEXIL",$J,0) D
66 . W !,$J(LEXI,6)," ",$E($P(^TMP("LEXIL",$J,LEXI),U,1),1,50)
67 Q
68FIQ ; Quit application selection
69 K ^TMP("LEXIL",$J),^TMP("LEXMGR",$J)
70 K LEXA,LEXAI,LEXAN,LEXC,LEXI,LEXMAX
71 Q LEXX
72FIW(LEXX) ; Input transform for DIR Pch 4
73 S LEXX=$G(LEXX) S:$G(LEXX)["^" LEXX="^" Q:LEXX["^" LEXX Q:$G(LEXX)="" ""
74 I +($G(LEXX))>0,$D(^TMP("LEXIL",$J,+($G(LEXX)))) S LEXX=+($G(LEXX)) Q LEXX
75 N LEXU,LEXO,LEXOC,LEXCT S LEXU=$TR($G(LEXX),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") Q:'$L(LEXU) LEXX
76 S LEXCT=0,(LEXO,LEXOC)=$E(LEXU,1,($L(LEXU)-1))_$C($A($E(LEXU,$L(LEXU)))-1)_"~"
77 F S LEXOC=$O(^TMP("LEXIL",$J,"C",LEXOC)) Q:LEXOC=""!($E(LEXOC,1,$L(LEXU))'=LEXU) S LEXCT=LEXCT+1
78 S LEXOC="" I LEXCT=1 S LEXOC=$O(^TMP("LEXIL",$J,"C",LEXO)),LEXOC=+($G(^TMP("LEXIL",$J,"C",LEXOC)))
79 I +LEXOC>0,$D(^TMP("LEXIL",$J,+LEXOC)) S LEXX=+LEXOC Q LEXX
80 Q ""
81SERV(LEXX) ; Select a service
82 S DIC="^DIC(49,",DIC("A")="Select users by service: ",DIC(0)="AMEQ"
83 N LEXI S LEXI="" F S LEXI=$O(^DIC(49,"B",LEXI)) Q:LEXI="" D Q:LEXI=""
84 . I LEXI["MEDI",((LEXI["GEN")!(LEXI["INTER")) S ^TMP("LEXSERV",$J,1)=$O(^DIC(49,"B",LEXI,0))
85 . I LEXI["AMBULAT" S ^TMP("LEXSERV",$J,2)=$O(^DIC(49,"B",LEXI,0))
86 . I LEXI["OUT",LEXI["PAT" S ^TMP("LEXSERV",$J,2)=$O(^DIC(49,"B",LEXI,0))
87 I $D(^TMP("LEXSERV",$J,1)) S DIC("B")=$P(^DIC(49,^TMP("LEXSERV",$J,1),0),U,1) K ^TMP("LEXSERV",$J)
88 I $D(^TMP("LEXSERV",$J,2)) S DIC("B")=$P(^DIC(49,^TMP("LEXSERV",$J,2),0),U,1)
89 K ^TMP("LEXSERV",$J) D ^DIC S LEXX=Y W:+Y'>0 " No Service Selected"
90 S:X["^" LEXX="^" S:X["^^" LEXX="^^" K LEXI,Y,X,DIC,DIC("A"),DIC(0),DIC("B")
91 S:LEXX'[U&(+LEXX'>0) LEXX=""
92 Q LEXX
93LOC(LEXX) ; Select a Hospital Location
94 S DIC="^SC(",DIC("A")="Select users by Hospital Location: ",DIC(0)="AMEQ"
95 D ^DIC S LEXX=Y W:+Y'>0 " No Location Selected"
96 S:X["^" LEXX="^" S:X["^^" LEXX="^^" K Y,X,DIC,DIC("A"),DIC(0),DIC("B")
97 S:LEXX'[U&(+LEXX'>0) LEXX=""
98 Q LEXX
99USER(LEXX) ; Select a single user
100 K DIC N X,Y S DIC="^VA(200,",DIC("A")="Select a single user: ",DIC(0)="AMEQ"
101 D ^DIC S LEXX=Y W:+Y'>0 " No User Selected"
102 S:X["^" LEXX="^" S:X["^^" LEXX="^^" K Y,X,DIC,DIC("A"),DIC(0),DIC("B")
103 S:LEXX'[U&(+LEXX'>0) LEXX=""
104 Q LEXX
Note: See TracBrowser for help on using the repository browser.