source: WorldVistAEHR/trunk/r/HEALTH_SUMMARY-GMTS/GMTSULT6.m@ 703

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

initial load of WorldVistAEHR
File size: 5.3 KB
Line 
1GMTSULT6 ; SLC/KER - HS Type Lookup (Select) ; 08/27/2002
2 ;;2.7;Health Summary;**30,32,56**;Oct 20, 1995
3 ;
4 ; External References
5 ; DBIA 10026 ^DIR
6 ; DBIA 10006 ^DIC (file #142)
7 ; DBIA 10060 ^VA(200,
8 ; DBIA 2056 $$GET1^DIQ (file #200)
9 ; DBIA 10016 ^DIM
10 ; DBIA 2055 RECALL^DILFD
11 Q
12 ;
13MULTI ; Selection when Multiple Entries are found
14 I $L($G(GMTSDICB)),GMTSDEF=1 D DEF Q
15 S GMTSDICW=$$DICW($G(GMTSDICW)) K:'$L(GMTSDICW) GMTSDICW
16 N GMTSIEN,GMTSE,GMTSO,GMTST,GMTSTOT,GMTSM S GMTSTOT=^TMP("GMTSULT",$J,0) Q:+GMTSTOT=0 I +GMTSTOT=1 D ONE Q
17 W ! W:+GMTSTOT>1 !,GMTSTOT," Health Summary Types found"
18 N GMTSI,GMTSS,GMTSEX,X,GMTSTR,GMTSTR2,GMTSTR3,GMTSLEN S GMTSLEN=75,GMTSS=0,GMTSEX=0
19 ; List 5 at a time
20 F GMTSI=1:1:^TMP("GMTSULT",$J,0) Q:((GMTSS>0)&(GMTSS<GMTSI+1)) Q:GMTSEX D Q:GMTSEX
21 . S GMTSE=$G(^TMP("GMTSULT",$J,GMTSI))
22 . S GMTSM=GMTSI W:GMTSI#5=1 ! W !,$J(GMTSI,4),". "
23 . S GMTSIEN=+GMTSE,(GMTST,GMTSTR)=$P(GMTSE,U,7),GMTSO=$P(GMTSE,U,2)
24 . S:'$L(GMTSTR)&($L(GMTSO)) GMTSTR=GMTSO
25 . D WRM1
26 . W:GMTSI#5=0 ! S:GMTSI#5=0 GMTSS=$$SEL(GMTSM) S:GMTSS["^" GMTSEX=1
27 I GMTSI#5'=0,+GMTSS=0 W ! S GMTSS=$$SEL(GMTSM) S:GMTSS["^" GMTSEX=1
28 I 'GMTSEX,+GMTSS>0 D Q
29 . N GMTSNAM K Y S Y=+($G(^TMP("GMTSULT",$J,+GMTSS)))
30 . S GMTSNAM=$P($G(^GMT(142,+Y,0)),"^",1) I '$L(GMTSNAM) K Y S Y=-1 Q
31 . D Y(+Y)
32 K Y S Y=-1
33 Q
34WRM1 ; Write one entry of muli selection
35 N Y,GMTS S Y=+GMTSIEN,GMTS=$G(^GMT(142,+Y,0))
36 I '$D(GMTSDICW) W:$L(GMTSTR)'>GMTSLEN GMTSTR D:$L(GMTSTR)>GMTSLEN LONG Q
37 I $D(GMTSDICW),$G(GMTSDIC0)'["S" W $P(GMTS,"^",1)," " X GMTSDICW Q
38 I $D(GMTSDICW),$G(GMTSDIC0)["S" X GMTSDICW Q
39 Q
40SEL(X) ; Select multiple
41 N Y,GMTSM,DTOUT,DUOUT,DIRUT,DIROUT S GMTSM=+($G(X)) Q:GMTSM=0 -1
42 S:+($O(^TMP("GMTSULT",$J,+($G(GMTSI)))))>0 DIR("A")="Press <RETURN> for more, '^' to exit, or Select 1-"_GMTSM_": "
43 S:+($O(^TMP("GMTSULT",$J,+($G(GMTSI)))))'>0 DIR("A")="Select 1-"_GMTSM_": "
44 S (DIR("?"),DIR("??"))="Answer must be from 1 to "_GMTSM_", or <Return> to continue "
45 S DIR(0)="NAO^1:"_GMTSM_":0" D ^DIR S:$D(DTOUT)!(X[U) X=U K DIR Q X
46 Q
47 ;
48ONE ; One entry on the selection list
49 I $L($G(GMTSDICB)),GMTSDEF=1 D DEF Q
50 N GMTSEX,GMTSIEN,GMTSTR,GMTSTR2,GMTSY,GMTSX,GMTSLEN,DIR,X
51 S GMTSLEN=75,Y=0 S:GMTSQ!($G(GMTSDIC0)["E") GMTSQ=1,Y=1
52 S GMTSEX=0
53 ; No Echo or if Ask
54 S GMTSIEN=+($G(^TMP("GMTSULT",$J,1)))
55 I 'GMTSQ!($G(GMTSDIC0)["A") D
56 . N X S GMTSTR=$P($G(^TMP("GMTSULT",$J,1)),U,7)
57 . S:'$L(GMTSTR) GMTSTR=$P($G(^TMP("GMTSULT",$J,1)),U,2)
58 . D WRO1 S Y=$$OK S:Y["^" GMTSEX=1
59 I 'GMTSEX,+Y>0 D Q
60 . N GMTSNAM K Y S Y=+($G(^TMP("GMTSULT",$J,1)))
61 . S GMTSNAM=$P($G(^GMT(142,+Y,0)),"^",1) I '$L(GMTSNAM) K Y S Y=-1 Q
62 . D Y(+Y)
63 K Y S Y=-1
64 Q
65WRO1 ; Write one entry of single selection
66 W !!," " N Y,GMTS S Y=+GMTSIEN,GMTS=$G(^GMT(142,+Y,0))
67 I '$D(GMTSDICW) W:$L(GMTSTR)'>GMTSLEN GMTSTR D:$L(GMTSTR)>GMTSLEN LONG W ! Q
68 I $D(GMTSDICW),$G(GMTSDIC0)'["S" W $P(GMTS,"^",1)," " X GMTSDICW W ! Q
69 I $D(GMTSDICW),$G(GMTSDIC0)["S" X GMTSDICW W ! Q
70 Q
71OK(X) ; Select one if DIC(0)["A" Ask OK
72 N DIR,DTOUT,DUOUT,DIROUT S DIR(0)="YAO",DIR("B")="YES"
73 S DIR("A")=" OK? " D ^DIR S:X'["^" X=+Y S:$D(DTOUT)!($D(DUOUT)) X="^" S:X["^" X="^" Q X
74 ;
75DEF ; Select Default Entry
76 N GMTSNAM K Y S Y=+($G(^TMP("GMTSULT",$J,1)))
77 S GMTSNAM=$P($G(^GMT(142,+Y,0)),"^",1) I '$L(GMTSNAM) K Y S Y=-1 Q
78 D Y(+Y)
79 Q
80 ;
81 ; Display
82LONG ; Handle a long string
83 N GMTSP,GMTSOK,GMTSCHR,GMTSPSN,GMTSTO,GMTSREM,GMTSLN,GMTSOLD S GMTSLN=0,GMTSOLD=GMTSTR,GMTSP=5
84 F Q:$L(GMTSTR)<(GMTSLEN+1) D PARSE Q:$L(GMTSTR)<(GMTSLEN+1)
85 S GMTSLN=GMTSLN+1 W:GMTSLN>1 ! W ?GMTSP,GMTSTR
86 Q
87PARSE ; Parse a long string to screen length
88 S GMTSOK=0,GMTSCHR="" F GMTSPSN=GMTSLEN:-1:0 Q:+GMTSOK=1 D Q:+GMTSOK=1
89 . I $E(GMTSTR,GMTSPSN)=" " S GMTSCHR=" ",GMTSOK=1 Q
90 . I $E(GMTSTR,GMTSPSN)="," S GMTSCHR=",",GMTSOK=1 Q
91 . I $E(GMTSTR,GMTSPSN)="/" S GMTSCHR="/",GMTSOK=1 Q
92 . I $E(GMTSTR,GMTSPSN)="-" S GMTSCHR="-",GMTSOK=1 Q
93 I GMTSCHR=" " S GMTSTO=$E(GMTSTR,1,GMTSPSN-1),GMTSREM=$E(GMTSTR,GMTSPSN+1,$L(GMTSTR))
94 I GMTSCHR="," S GMTSTO=$E(GMTSTR,1,GMTSPSN),GMTSREM=$E(GMTSTR,(GMTSPSN+1),$L(GMTSTR)) S:$E(GMTSREM,1)=" " GMTSREM=$E(GMTSREM,2,$L(GMTSREM))
95 I GMTSCHR="/" S GMTSTO=$E(GMTSTR,1,GMTSPSN),GMTSREM=$E(GMTSTR,(GMTSPSN+1),$L(GMTSTR)) S:$E(GMTSREM,1)=" " GMTSREM=$E(GMTSREM,2,$L(GMTSREM))
96 I GMTSCHR="-" S GMTSTO=$E(GMTSTR,1,GMTSPSN),GMTSREM=$E(GMTSTR,(GMTSPSN+1),$L(GMTSTR)) S:$E(GMTSREM,1)=" " GMTSREM=$E(GMTSREM,2,$L(GMTSREM))
97 S GMTSTR=GMTSREM,GMTSLN=GMTSLN+1 W:GMTSLN>1 ! W ?GMTSP,GMTSTO
98 Q
99DICW(X) ; Check for valid DIC("W")
100 S X=$G(X) Q:'$L(X) ""
101 D ^DIM I '$D(X) Q ""
102 Q X
103 ;
104 ; Post Selection
105Y(X) ; Set Y
106 K Y S X=+($G(X))
107 S:X'>0!('$D(^GMT(142,+X,0))) Y=-1 Q:X'>0!('$D(^GMT(142,+X,0)))
108 S Y=+X_"^"_$P($G(^GMT(142,+X,0)),"^",1)
109 S:$G(GMTSDIC0)["Z"!($G(DIC(0))["Z") Y(0)=$G(^GMT(142,+X,0)),Y(0,0)=$P($G(^GMT(142,+X,0)),"^",1),Y(0,1)=$$MX(Y(0,0))
110 I +($G(GMTSWY))=0 W:$G(GMTSDIC0)["E"!($G(DIC(0))["E") " ",$P($G(^GMT(142,+X,0)),"^",1) S GMTSWY=1
111 D:$G(GMTSDIC0)'["F"&($G(DIC(0))'["F") SDISV
112 Q
113SDISV ; Save Default Value (Spacebar-Return)
114 Q:$G(GMTSDIC0)["F" Q:+($G(DUZ))=0 Q:'$L($$GET1^DIQ(200,(+($G(DUZ))_","),.01)) Q:+($G(Y))=0 Q:'$D(^GMT(142,+($G(Y)),0))
115 D RECALL^DILFD(142,+($G(Y))_",",+($G(DUZ))) Q
116 Q
117MX(X) ; Mix Case
118 Q $$EN^GMTSUMX(X)
Note: See TracBrowser for help on using the repository browser.