source: FOIAVistA/trunk/r/HEALTH_SUMMARY-GMTS/GMTSULT4.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 6.1 KB
Line 
1GMTSULT4 ; SLC/KER - HS Type Lookup (Array) ; 08/27/2002
2 ;;2.7;Health Summary;**30,32,56**;Oct 20, 1995
3 ;
4 ; External References
5 ; DBIA 10060 ^VA(200,
6 ; DBIA 2056 $$GET1^DIQ (file #200)
7 ; DBIA 10040 ^SC( file #44
8 ;
9 Q
10NT ; In Name/Title Array
11 Q:$D(GMTSINPT) Q:+GMTSWDS'>0 K GMTSLT D CMN
12 S GMTSFND=0,GMTSLT("W")=+($G(GMTSWDS))
13 N GMTSNT F GMTSI=1:1:GMTSWDS D
14 . Q:'$L(GMTSWRDS(GMTSI))
15 . S GMTSNT=+($$CHKW(GMTSWRDS(GMTSI)))
16 . S:GMTSNT GMTSFND=GMTSFND+1,GMTSLT(GMTSI1)=(+($G(GMTSLT(GMTSI1)))+1)
17 I GMTSFND>0,GMTSFND=GMTSWDS,'$D(GMTSLT(GMTSI1)) S GMTSLT(0)=+($G(GMTSLT(0)))+1
18 ; Reorder
19 S GMTSFND=0 F S GMTSFND=$O(GMTSLT(GMTSFND)) Q:+GMTSFND=0 D
20 . S:+($G(GMTSLT(GMTSFND)))>0&(+($G(GMTSLT(GMTSFND)))=+($G(GMTSLT("W")))) GMTSLT("B",+GMTSFND)=""
21 . K:+($G(GMTSLT(GMTSFND)))>0&(+($G(GMTSLT(GMTSFND)))'=+($G(GMTSLT("W")))) GMTSLT(+GMTSFND)
22 K GMTSLT("W") K:'$D(GMTSLT("B")) GMTSLT
23 S:$D(GMTSLT("B")) GMTSLT("C")=$$MX($P($G(^GMT(142,+($G(GMTSIEN)),0)),"^",1))
24 Q
25LC ; Location Array (Needs either GMTSIEN or GMTSI1)
26 Q:$D(GMTSINPT) Q:+GMTSWDS'>0
27 I '$D(GMTSI1),$D(GMTSIEN),$D(^GMT(142,+($G(GMTSIEN)),0)) N GMTSI1 S GMTSI1=+($G(GMTSIEN))
28 Q:'$D(GMTSI1)
29 N GMTSF,GMTSI,GMTSI2,GMTSI3,GMTSL,GMTSLC K GMTSLI
30 S GMTSI2=0 F S GMTSI2=$O(^GMT(142,GMTSI1,20,GMTSI2)) Q:+GMTSI2=0 D
31 . S GMTSI3=+($G(^GMT(142,GMTSI1,20,GMTSI2,0)))
32 . S GMTSL=$P($G(^SC(+GMTSI3,0)),"^",1)
33 . S GMTSF=0 I GMTSWDS>0 S GMTSLI("W")=+($G(GMTSWDS))
34 . F GMTSI=1:1:GMTSWDS D
35 . . Q:'$L(GMTSWRDS(GMTSI))
36 . . S:$$UP(GMTSL)[$$UP(GMTSWRDS(GMTSI)) GMTSF=GMTSF+1
37 . I GMTSF=GMTSWDS D
38 . . S:'$D(GMTSLI(GMTSI1,GMTSI2)) GMTSLI(0)=+($G(GMTSLI(0)))+1
39 . . S GMTSLI(GMTSI2)=GMTSF_"^"_GMTSL
40 . . S GMTSLI("I")=GMTSI1
41 S GMTSF=0 F S GMTSF=$O(GMTSLI(GMTSF)) Q:+GMTSF=0 D
42 . S:+($G(GMTSLI(GMTSF)))>0&(+($G(GMTSLI(GMTSF)))=+($G(GMTSLI("W")))) GMTSLI("B",+GMTSF)=""
43 . K:+($G(GMTSLI(GMTSF)))>0&(+($G(GMTSLI(GMTSF)))'=+($G(GMTSLI("W")))) GMTSLI(+GMTSF)
44 K:'$D(GMTSLI("B")) GMTSLI
45 I $D(GMTSLI("B")) D
46 . N GMTSI,GMTSC,GMTST,GMTSE S (GMTSE,GMTSC)=0,GMTST=+($G(GMTSLI(0))) Q:GMTST=0
47 . S GMTSI="",GMTSF=0 F S GMTSF=$O(GMTSLI(GMTSF)) Q:GMTSE Q:+GMTSF=0 D Q:GMTSE
48 . . I ($L($G(GMTSI))+$L($P($G(GMTSLI(GMTSF)),"^",2)))>60 S GMTSI="",GMTSE=1 Q
49 . . S GMTSC=GMTSC+1
50 . . S:GMTSI'=""&(GMTSC>1)&(GMTSC'=GMTST) GMTSI=GMTSI_", "_$$MX($P(GMTSLI(GMTSF),"^",2))
51 . . S:GMTSI'=""&(GMTSC>1)&(GMTSC=GMTST) GMTSI=GMTSI_" and "_$$MX($P(GMTSLI(GMTSF),"^",2))
52 . . S:GMTSI="" GMTSI=$$MX($P(GMTSLI(GMTSF),"^",2))
53 . S:$L(GMTSI) GMTSLI("C")=GMTSI
54 K:'$D(GMTSLI("C")) GMTSLI K GMTSLI("W")
55 Q
56CHKW(X) ; Check Words
57 S X=$$UP($G(X)) Q:'$L(X) 0
58 N I,OK S OK=0,I=0 F S I=$O(GMTSCOMP(I)) Q:+I=0 S:$$UP($G(GMTSCOMP(I)))[X OK=1 Q:OK
59 S X=+($G(OK)) Q X
60 ;
61CM ; Composite Array
62 K GMTSCOMP S GMTSIEN=+($G(GMTSIEN)) G:GMTSIEN=0 CMQ
63 N GMTSWL,GMTSL,GMTS2
64 D:$D(GMTSNAM) CMP($$UP($$UP(GMTSNAM))) D:'$D(GMTSNAM) CMP($$UP($P($G(^GMT(142,+GMTSIEN,0)),"^",1)))
65 D:$D(GMTSTTL) CMP($$UP($G(GMTSTTL))) D:'$D(GMTSTTL) CMP($$UP($P($G(^GMT(142,+GMTSIEN,"T")),"^",1)))
66 D:$D(GMTSOW) CMP($$UP($G(GMTSOW)))
67 I '$D(GMTSOW),+($P($G(^GMT(142,+GMTSIEN,0)),"^",3))>1 D CMP($$UP($$GET1^DIQ(200,(+($P($G(^GMT(142,+GMTSIEN,0)),"^",3))_","),.01)))
68 G:$D(GMTSNO) CMQ
69 S GMTS2=0 F S GMTS2=$O(^GMT(142,GMTSIEN,20,GMTS2)) Q:+GMTS2=0 D
70 . S GMTSL=+($G(^GMT(142,GMTSIEN,20,GMTS2,0)))
71 . S GMTSL=$P($G(^SC(+GMTSL,0)),"^",1) D CMP($$UP(GMTSL))
72CMQ ; Composite Array Quit
73 D CMC Q
74CMA ; Composite Array (name only)
75 N GMTSNO D CM Q
76CMN ; Composite Array (name only)
77 N GMTSNO S GMTSNO="" D CM Q
78CMP(X) ; Composite Array Word Parse
79 N GMTSX,GMTSP,GMTSC,GMTSW S GMTSX=$G(X) Q:'$L(GMTSX)
80 S GMTSC=1 F GMTSP=1:1:$L(GMTSX)+1 D
81 . S GMTSW=$E(GMTSX,GMTSP) I "(,.?! '-/&:;)"[GMTSW D
82 . . S GMTSW=$E($E(GMTSX,GMTSC,GMTSP-1),1,30),GMTSC=GMTSP+1 I $L(GMTSW)>0 D
83 . . . S:$L(GMTSW) GMTSWL(GMTSW)=""
84 Q
85CMC ; Composite Array Compile
86 S GMTSCOMP("B")="" N GMTSW,GMTSLI S GMTSW=""
87 F S GMTSW=$O(GMTSWL(GMTSW)) Q:GMTSW="" D
88 . I $L(GMTSCOMP("B")_" "_GMTSW)>200 D CMCA S GMTSCOMP("B")=GMTSCOMP("B")_" "_$$UP(GMTSW) K GMTSWL(GMTSW) Q
89 . S GMTSCOMP("B")=GMTSCOMP("B")_" "_$$UP(GMTSW) K GMTSWL(GMTSW) Q
90 F Q:$E(GMTSCOMP("B"),1)'=" " S GMTSCOMP("B")=$E(GMTSCOMP("B"),2,$L(GMTSCOMP("B")))
91 S GMTSLI=+($O(GMTSCOMP(" "),-1)) I $D(GMTSCOMP("B")) S GMTSCOMP((GMTSLI+1))=GMTSCOMP("B") K GMTSCOMP("B")
92 Q
93CMCA ; Composite Array Compile (Add String)
94 N I S I=+($O(GMTSCOMP(" "),-1))+1 S GMTSCOMP(I)=GMTSCOMP("B"),GMTSCOMP("B")=""
95 F Q:$E(GMTSCOMP(I),1)'=" " S GMTSCOMP(I)=$E(GMTSCOMP(I),2,$L(GMTSCOMP(I)))
96 Q
97 ;
98RDT ; Recommended Display Text
99 ; Name (used by Location)
100 I GMTSKEY["LOC" D
101 . Q:'$L(GMTS5)
102 . S:$$UP(GMTS2)'=$$UP(GMTS5) GMTSG=GMTSMN_" (used by "_GMTSLOC
103 . S:$$UP(GMTSMN)=$$UP(GMTSLOC) GMTSG=GMTSMN
104 ; Name (Title)
105 I GMTSKEY["TITL",GMTSKEY'["OWN" D
106 . Q:'$L(GMTS3)
107 . I $$UP(GMTS3)=$$UP(GMTS2) S GMTSG=GMTS2 Q
108 . S:GMTSKEY["TITL"&($$UP(GMTSMN)'=$$UP(GMTSL)) GMTSG=GMTSMN_" ("_$$MX(GMTS3)_")"
109 . S:GMTSKEY["TITL"&($$UP(GMTSMN)=$$UP(GMTSL)) GMTSG=GMTSMN
110 I GMTSKEY["TITL",GMTSKEY["OWN" D
111 . Q:'$L(GMTS3)
112 . ; Name (Title, Owner) if Title'=Name and Owner
113 . S:$$UP(GMTSMN)'=$$UP(GMTS3)&($L(GMTS4)) GMTSG=GMTSMN_" ("_$$MX(GMTS3)_", HS Owner "_$$OW(GMTSOW)
114 . ; Name (Title) if Title'=Name and no Owner
115 . S:$$UP(GMTSMN)'=$$UP(GMTS3)&('$L(GMTS4)) GMTSG=GMTSMN_" ("_$$MX(GMTSTTL)
116 . ; Name (Owner) if Title=Name and Owner
117 . S:$$UP(GMTSMN)=$$UP(GMTS3)&($L(GMTS4)) GMTSG=GMTSMN_" (HS Owner "_$$OW(GMTSOW)
118 . S:$$UP(GMTSMN)=$$UP(GMTS3)&('$L(GMTS4)) GMTSG=GMTSMN
119 ;
120 ; Assemble string and store in TMP Global
121 ; IEN^Name^Title^Owner^Location^Components^Display Text
122 S:$L(GMTSG)&(GMTSG'[")")&(GMTSG'["(")&(+GMTS6=0)&($L(GMTS6)) GMTSG=GMTSG_" ("_GMTS6_")" S GMTS7=GMTSG
123 S ^TMP("GMTSULT",$J,GMTSI)=GMTS1_U_GMTS2_U_GMTS3_U_GMTS4_U_GMTS5_U_GMTS6_U_GMTS7
124 S ^TMP("GMTSULT",$J,0)=GMTSI
125 Q
126 ;
127 ; Miscellaneous
128UP(X) ; Uppercase
129 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
130OW(X) ; Mix Case (owner name)
131 Q:$G(X)'["," $$EN^GMTSUMX($G(X))
132 Q $$EN^GMTSUMX(($P($G(X),",",1)_", "_$P($G(X),",",2)))
133MX(X) ; Mix Case
134 Q $$EN^GMTSUMX(X)
Note: See TracBrowser for help on using the repository browser.