source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRAFUNC.m@ 1061

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

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1LRAFUNC ;SLC/MRH/FHS - FUNCTION CALLS A5AFUNC
2 ;;5.2;LAB SERVICE;**286**;Sep 27, 1994
3 ;
4 N I,X
5 W !!,"Routine: "_$T(+0),! F I=8:1 S X=$T(LRAFUNC+I) Q:'$L(X) I X[";;" W !,X
6 W !!
7 Q
8 ;;
9UPCASE(X) ;; $$UPCASE(X)
10 ;; Call by value
11 ;; X in lowercase
12 ;; Returns uppercase
13 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
14 ;;
15LOWCASE(X) ;; $$LOWCASE(X)
16 ;; Call by value
17 ;; X in uppercase
18 ;; Returns lowercase
19 Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
20 ;;
21STRIP(X,Y) ;; Strips all instances of character 'Y' in string 'X'
22 ;; Call by value
23 ;; X contains string on which to perform the strip operation
24 ;; Y contains character(s) to strip
25 Q $TR($G(X),$G(Y),"")
26 ;;
27REPLACE(STR,X,Y) ;; Performs a character in 'Y' for character
28 ;; in 'X' replace within string 'STR'.
29 ;; Call by value
30 ;; STR is the string on which to perform the replace operation
31 ;; X is the characters to replace
32 ;; Y is the translated characters
33 ;; ** NOTE ** X AND Y MUST BE IN THE EXACT SAME ORDER ****
34 ;; X="ABC" Y="XYZ" all occurances of A will be replaced with X
35 ;; B with Y and C with Z
36 ;; X="AKZ" Y="Z" every occurance of A will be replaced with Z
37 ;; and K and Z will be replaced by "" (NULL)
38 Q $TR($G(STR),$G(X),$G(Y))
39 ;;
40REPEAT(X,Y) ;;
41 ;; Call by value
42 ;; X is the character that you wish repeated
43 ;; Y is the number of repetitions
44 ;;** NOTE ** $L(X)*Y must not be greater than 254
45 ;; eg. S X=$$REPEAT("-",10) returns "----------"
46 N LRPER
47 I $L($G(X))*$G(Y)>254 Q ""
48 S LRPER="",$P(LRPER,$G(X),+$G(Y)+1)=""
49 Q LRPER
50 ;;
51INVERT(X) ;;
52 ;; Call by value
53 ;; Returns String in X in inverted order ABC => CBA
54 N I,Y
55 I $L($G(X))>254 Q ""
56 S Y=""
57 F I=$L(X):-1:0 S Y=Y_$E(X,I)
58 Q Y
59 ;;
60GLBR(LRR) ;;
61 ;; Call by value
62 ;; Returns the global root with extended systax if the global
63 ;; is translated. Useful when using $Q on MSM systems
64 N LRC,LRF,LRG,LRI,LRR1,LRR2,LRZ
65 S LRR1=$P(LRR,"(")_"(" I $E(LRR1)="^" S LRR2=$P($Q(@(LRR1_""""")")),"(")_"(" S:$P(LRR2,"(")]"" LRR1=LRR2
66 S LRR2=$P($E(LRR,1,($L(LRR)-($E(LRR,$L(LRR))=")"))),"(",2,99)
67 S LRC=$L(LRR2,","),LRF=1 F LRI=1:1:LRC S LRG=$P(LRR2,",",LRF,LRI) Q:LRG="" D
68 . I ($L(LRG,"(")=$L(LRG,")")&($L(LRG,"""")#2))!(($L(LRG,"""")#2)&($E(LRG)="""")&($E(LRG,$L(LRG))="""")) S LRG=$$S(LRG),$P(LRR2,",",LRF,LRI)=LRG,LRF=LRF+$L(LRG,","),LRI=LRF-1
69 Q LRR1_LRR2
70S(LRZ) ;
71 I $G(LRZ)']"" Q ""
72 I $E(LRZ)'="""",$L(LRZ,"E")=2,+$P(LRZ,"E")=$P(LRZ,"E"),+$P(LRZ,"E",2)=$P(LRZ,"E",2) Q +LRZ
73 I +LRZ=LRZ Q LRZ
74 I LRZ="""""" Q ""
75 I $E(LRZ)'?1A,"LR$+@"'[$E(LRZ) Q LRZ
76 I "+$"[$E(LRZ) X "S LRZ="_LRZ Q $$Q(LRZ)
77 I $D(@LRZ) Q $$Q(@LRZ)
78 Q LRZ
79Q(LRZ) ;
80 S LRZ(LRZ)="",LRZ=$Q(LRZ("")) Q $E(LRZ,4,$L(LRZ)-1)
81 ;;
82 ;;
83 Q
84LRPNM(X) ;;Call by value
85 ;; change value to upper case string
86 ;; removes spaces after comma
87 ;; removes double spaces and spaces at the end of the string
88 ;; generally used to format patient names
89 N Y,I
90 S X=$$UPCASE(X)
91 ; -- no space after comma and no double spaces
92 F Y=", "," " F Q:'$F(X,Y) S X=$E(X,1,($F(X,Y)-2))_$E(X,$F(X,Y),$L(X))
93 ; -- no space at the end
94 F Q:$E(X,$L(X))'=" " S X=$E(X,1,$L(X)-1)
95 Q X
Note: See TracBrowser for help on using the repository browser.