| 1 | LRAFUNC ;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 | ;;
|
|---|
| 9 | UPCASE(X) ;; $$UPCASE(X)
|
|---|
| 10 | ;; Call by value
|
|---|
| 11 | ;; X in lowercase
|
|---|
| 12 | ;; Returns uppercase
|
|---|
| 13 | Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
|---|
| 14 | ;;
|
|---|
| 15 | LOWCASE(X) ;; $$LOWCASE(X)
|
|---|
| 16 | ;; Call by value
|
|---|
| 17 | ;; X in uppercase
|
|---|
| 18 | ;; Returns lowercase
|
|---|
| 19 | Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
|
|---|
| 20 | ;;
|
|---|
| 21 | STRIP(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 | ;;
|
|---|
| 27 | REPLACE(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 | ;;
|
|---|
| 40 | REPEAT(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 | ;;
|
|---|
| 51 | INVERT(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 | ;;
|
|---|
| 60 | GLBR(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
|
|---|
| 70 | S(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
|
|---|
| 79 | Q(LRZ) ;
|
|---|
| 80 | S LRZ(LRZ)="",LRZ=$Q(LRZ("")) Q $E(LRZ,4,$L(LRZ)-1)
|
|---|
| 81 | ;;
|
|---|
| 82 | ;;
|
|---|
| 83 | Q
|
|---|
| 84 | LRPNM(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
|
|---|
