source: WorldVistAEHR/trunk/r/HEALTH_SUMMARY-GMTS/GMTSULT7.m@ 1769

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

initial load of WorldVistAEHR
File size: 5.3 KB
Line 
1GMTSULT7 ; SLC/KER - HS Type Lookup ("B" index) ; 09/21/2001
2 ;;2.7;Health Summary;**30,47**;Oct 20, 1995
3 ;
4 ; External References
5 ; DBIA 10060 ^VA(200
6 ;
7 Q
8B ; Search "B" Index
9 ;
10 ; Needs GMTSEQ and GMTSEO
11 ;
12 ; GMTSEQ=1 Exact match reqired
13 ; Stop search if found
14 ; Continue partial-exact search if not found
15 ;
16 ; GMTSEO=1 Exact match, only one entry
17 ; Stop search if found and return single entry
18 ; Do not continue if not found
19 ;
20 D CLR^GMTSULT S X=$G(X) Q:'$L(X) N GMTSKL1,GMTSKL2,GMTSIV,GMTSIEN,GMTSDS,GMTSD0,GMTSDW,GMTSC,GMTSE
21 S GMTSKL1=$$LO($E(X,1)),GMTSKL2=$$UP(GMTSKL1),U="^",(GMTSE,GMTSC)=0
22 S:$L($G(DIC("S")))&('$L($G(GMTSDICS))) GMTSDICS=$G(DIC("S")),GMTSDS=1
23 S:$L($G(DIC(0)))&('$L($G(GMTSDIC0))) GMTSDIC0=$G(DIC(0)),GMTSD0=1
24 S:$L($G(DIC("W")))&('$L($G(GMTSDICW))) GMTSDICW=$G(DIC("W")),GMTSDW=1
25 D:$G(GMTSDIC0)'["M" CLR^GMTSULT
26 S GMTSIV=$C($A(GMTSKL1)-1)_"~" F S GMTSIV=$O(^GMT(142,"B",GMTSIV)) Q:GMTSIV=""!($E(GMTSIV,1)'=GMTSKL1) Q:GMTSE D Q:GMTSE
27 . Q:$$UP($E(X,1,30))'=$$UP($E(GMTSIV,1,$L(X))) S GMTSIEN=0 F S GMTSIEN=$O(^GMT(142,"B",GMTSIV,GMTSIEN)) Q:+GMTSIEN=0 Q:GMTSE D CK Q:GMTSE
28 S GMTSIV=$C($A(GMTSKL2)-1)_"~" F S GMTSIV=$O(^GMT(142,"B",GMTSIV)) Q:GMTSIV=""!($E(GMTSIV,1)'=GMTSKL2) Q:GMTSE D Q:GMTSE
29 . Q:$$UP($E(X,1,30))'=$$UP($E(GMTSIV,1,$L(X))) S GMTSIEN=0 F S GMTSIEN=$O(^GMT(142,"B",GMTSIV,GMTSIEN)) Q:+GMTSIEN=0 Q:GMTSE D CK Q:GMTSE
30BQ ; Quit "B" Index search
31 K:+($G(GMTSDS))>0 GMTSDICS K:+($G(GMTSD0))>0 GMTSDIC0 K:+($G(GMTSDW))>0 GMTSDICW
32 D REO
33 Q
34 ;
35 ; Build list
36CK ; Check Entry
37 N GMTSCK,GMTSNM,GMTSTL,GMTSOW,GMTSCMP,GMTSOKS,GMTSDT,GMTSDT2 S GMTSTL=$P($G(^GMT(142,+GMTSIEN,"T")),U,1),GMTSNM=$P($G(^GMT(142,+GMTSIEN,0)),U,1)
38 S GMTSDT=GMTSNM S:$$UP(GMTSNM)'=$$UP(GMTSTL)&($L(GMTSTL)) GMTSDT=GMTSNM_" ("_GMTSTL_")"
39 S GMTSOW=+($P($G(^GMT(142,+GMTSIEN,0)),U,3)) S:GMTSOW<1 GMTSOW="" S:+GMTSOW>0 GMTSOW=$P($G(^VA(200,+GMTSOW,0)),U,1)
40 S GMTSCMP=$$CM^GMTSULT2(GMTSIEN) S:$D(GMTSDICW) GMTSDT=GMTSNM S GMTSDT=$$MX(GMTSDT),GMTSOKS=+($$DICS^GMTSULT2($G(GMTSDICS),GMTSNM,+GMTSIEN)) Q:'GMTSOKS S GMTSCK="GMTSNM"
41 I +($G(GMTSEO)) I $L($G(X))>0,$$UP($G(X))=$$UP($G(GMTSNM)) S GMTSE=1,GMTSCK="GMTSNM" D EA Q
42 I $L($G(X))>0,$$UP($G(X))=$$UP($G(GMTSNM)) S GMTSCK="GMTSNM" D EA Q
43 D MA Q
44MA ; Add Match
45 Q:$D(^TMP("GMTSULT2",$J,"IEN",+GMTSIEN))
46 S GMTSC=+($G(GMTSC))+1,^TMP("GMTSULT2",$J,GMTSC)=$$ASM,^TMP("GMTSULT2",$J,0)=GMTSC,^TMP("GMTSULT2",$J,"B",(GMTSNM_" "),GMTSC)=""
47 Q
48EA ; Add Exact Match
49 S GMTSC=+($G(GMTSC))+1 S GMTSCMP=$$CM^GMTSULT2(GMTSIEN) S ^TMP("GMTSULT2",$J,"EM")=+GMTSIEN,^TMP("GMTSULT2",$J,"IEN",+GMTSIEN)="",^TMP("GMTSULT2",$J,"B",(GMTSNM_" "),GMTSC)="",^TMP("GMTSULT2",$J,"EMI")=GMTSC
50 S ^TMP("GMTSULT2",$J,"EMB")=GMTSNM_" ",^TMP("GMTSULT2",$J,GMTSC)=$$ASM,^TMP("GMTSULT2",$J,0)=GMTSC,^TMP("GMTSULT2",$J,"B",(GMTSNM_" "))=""
51 Q
52ASM(X) ; Assemble string to store in list
53 N GMTST S GMTST=$G(GMTSTL) S:$L($G(GMTSDT))&($G(GMTSDT)'=$G(GMTST)) GMTST=GMTSDT
54 S X=+($G(GMTSIEN)),X=X_U_$G(GMTSNM)_U_$G(GMTSTL)_U_$G(GMTSOW)_U_U_$G(GMTSCMP)_U_GMTST
55 Q X
56 ;
57REO ; Reorder List
58 N GMTSC,GMTSFND,GMTSG,GMTSI,GMTSIEN,GMTSKEY,GMTSL,GMTSCMP,GMTSOW,GMTSTTL,GMTSLOC,GMTSMN,GMTSNM
59 S GMTSI=0,GMTSFND=""
60 ; Add exact match to the top of the selection list
61 I '$D(^TMP("GMTSULT2",$J,"EMI")),+($G(GMTSEO)) K ^TMP("GMTSULT2",$J)
62 I $D(^TMP("GMTSULT2",$J,"EMI")) D
63 . S GMTSI=0,GMTSC=$G(^TMP("GMTSULT2",$J,"EMI")) D ADD
64 . S ^TMP("GMTSULT",$J,0)=GMTSI K ^TMP("GMTSULT2",$J,"EMI")
65 . ; Kill global (quit) if Exact Match is found
66 . ; and DIR(0) either contains OE or X
67 . K:+($G(GMTSEQ)) ^TMP("GMTSULT2",$J) K:+($G(GMTSEO)) ^TMP("GMTSULT2",$J)
68 ; Kill global (quit) if Exact Match is not
69 ; found and DIR(0)["OE"
70 I '$D(^TMP("GMTSULT2",$J,"EMI")),+($G(GMTSEO)) K ^TMP("GMTSULT2",$J)
71 ; Add other entries in Alphabetical Order
72 S GMTSFND=0 Q:'$D(^TMP("GMTSULT2",$J,"B")) F S GMTSFND=$O(^TMP("GMTSULT2",$J,"B",GMTSFND)) Q:GMTSFND="" D
73 . S GMTSC=0 F S GMTSC=$O(^TMP("GMTSULT2",$J,"B",GMTSFND,GMTSC)) Q:+GMTSC=0 D ADD
74 D CLEAN^GMTSULT
75 Q
76ADD ; Add to the reordered list
77 N GMTS0,GMTS1,GMTS2,GMTS3,GMTS4,GMTS5,GMTS6,GMTS7
78 S GMTSI=+($G(GMTSI))+1,GMTS0=$G(^TMP("GMTSULT2",$J,GMTSC)) S (GMTSG,GMTSMN,GMTS2)=$$MX($P(GMTS0,U,2)) S (GMTS1,GMTSIEN)=+($P(GMTS0,U,1)) S GMTSNM=$$UP(GMTSMN)
79 S (GMTS4,GMTSOW)=$$MX($P(GMTS0,U,4)),GMTSOW=GMTSOW_")" S (GMTS3,GMTSTTL)=$$MX($P(GMTS0,U,3)),GMTSTTL=GMTSTTL_")" S (GMTS5,GMTSLOC)=$$MX($P(GMTS0,U,5)),GMTSLOC=GMTSLOC_")"
80 S (GMTS6,GMTSCMP)=$P(GMTS0,U,6),GMTSL=$P(GMTS0,U,4),GMTSG=$P(GMTS0,U,7)
81 S:$L(GMTSG)&(GMTSG'[")")&(GMTSG'["(")&(+GMTS6=0)&($L(GMTS6)) GMTSG=GMTSG_" ("_GMTS6_")"
82 S GMTS7=GMTSG S ^TMP("GMTSULT",$J,GMTSI)=GMTS1_U_GMTS2_U_GMTS3_U_GMTS4_U_GMTS5_U_GMTS6_U_GMTS7
83 S ^TMP("GMTSULT",$J,0)=GMTSI
84 Q
85 ;
86 ; Miscellaneous
87UP(X) ; Uppercase
88 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
89LO(X) ; Lowercase
90 Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
91MX(X) ; Mix Case
92 Q $$EN^GMTSUMX(X)
93DUP(X) ; Check for Duplicate
94 S X=$G(X) Q:'$L(X) 0 N GMTSE,GMTSI S (GMTSE,GMTSI)=0
95 F S GMTSI=$O(^GMT(142,"B",$E(X,1,30),GMTSI)) Q:+GMTSI=0 D Q:GMTSE
96 . S GMTSN=$P($G(^GMT(142,+GMTSI,0)),"^",1) S:$$UP^GMTSULT2(X)=$$UP^GMTSULT2(GMTSN) GMTSE=1
97 S X=+($G(GMTSE)) Q X
Note: See TracBrowser for help on using the repository browser.