LRAFUNC ;SLC/MRH/FHS - FUNCTION CALLS A5AFUNC
;;5.2;LAB SERVICE;**286**;Sep 27, 1994
;
N I,X
W !!,"Routine: "_$T(+0),! F I=8:1 S X=$T(LRAFUNC+I) Q:'$L(X) I X[";;" W !,X
W !!
Q
;;
UPCASE(X) ;; $$UPCASE(X)
;; Call by value
;; X in lowercase
;; Returns uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;;
LOWCASE(X) ;; $$LOWCASE(X)
;; Call by value
;; X in uppercase
;; Returns lowercase
Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
;;
STRIP(X,Y) ;; Strips all instances of character 'Y' in string 'X'
;; Call by value
;; X contains string on which to perform the strip operation
;; Y contains character(s) to strip
Q $TR($G(X),$G(Y),"")
;;
REPLACE(STR,X,Y) ;; Performs a character in 'Y' for character
;; in 'X' replace within string 'STR'.
;; Call by value
;; STR is the string on which to perform the replace operation
;; X is the characters to replace
;; Y is the translated characters
;; ** NOTE ** X AND Y MUST BE IN THE EXACT SAME ORDER ****
;; X="ABC" Y="XYZ" all occurances of A will be replaced with X
;; B with Y and C with Z
;; X="AKZ" Y="Z" every occurance of A will be replaced with Z
;; and K and Z will be replaced by "" (NULL)
Q $TR($G(STR),$G(X),$G(Y))
;;
REPEAT(X,Y) ;;
;; Call by value
;; X is the character that you wish repeated
;; Y is the number of repetitions
;;** NOTE ** $L(X)*Y must not be greater than 254
;; eg. S X=$$REPEAT("-",10) returns "----------"
N LRPER
I $L($G(X))*$G(Y)>254 Q ""
S LRPER="",$P(LRPER,$G(X),+$G(Y)+1)=""
Q LRPER
;;
INVERT(X) ;;
;; Call by value
;; Returns String in X in inverted order ABC => CBA
N I,Y
I $L($G(X))>254 Q ""
S Y=""
F I=$L(X):-1:0 S Y=Y_$E(X,I)
Q Y
;;
GLBR(LRR) ;;
;; Call by value
;; Returns the global root with extended systax if the global
;; is translated. Useful when using $Q on MSM systems
N LRC,LRF,LRG,LRI,LRR1,LRR2,LRZ
S LRR1=$P(LRR,"(")_"(" I $E(LRR1)="^" S LRR2=$P($Q(@(LRR1_""""")")),"(")_"(" S:$P(LRR2,"(")]"" LRR1=LRR2
S LRR2=$P($E(LRR,1,($L(LRR)-($E(LRR,$L(LRR))=")"))),"(",2,99)
S LRC=$L(LRR2,","),LRF=1 F LRI=1:1:LRC S LRG=$P(LRR2,",",LRF,LRI) Q:LRG="" D
. 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
Q LRR1_LRR2
S(LRZ) ;
I $G(LRZ)']"" Q ""
I $E(LRZ)'="""",$L(LRZ,"E")=2,+$P(LRZ,"E")=$P(LRZ,"E"),+$P(LRZ,"E",2)=$P(LRZ,"E",2) Q +LRZ
I +LRZ=LRZ Q LRZ
I LRZ="""""" Q ""
I $E(LRZ)'?1A,"LR$+@"'[$E(LRZ) Q LRZ
I "+$"[$E(LRZ) X "S LRZ="_LRZ Q $$Q(LRZ)
I $D(@LRZ) Q $$Q(@LRZ)
Q LRZ
Q(LRZ) ;
S LRZ(LRZ)="",LRZ=$Q(LRZ("")) Q $E(LRZ,4,$L(LRZ)-1)
;;
;;
Q
LRPNM(X) ;;Call by value
;; change value to upper case string
;; removes spaces after comma
;; removes double spaces and spaces at the end of the string
;; generally used to format patient names
N Y,I
S X=$$UPCASE(X)
; -- no space after comma and no double spaces
F Y=", "," " F Q:'$F(X,Y) S X=$E(X,1,($F(X,Y)-2))_$E(X,$F(X,Y),$L(X))
; -- no space at the end
F Q:$E(X,$L(X))'=" " S X=$E(X,1,$L(X)-1)
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAFUNC 3199 printed Dec 13, 2024@02:06:42 Page 2
LRAFUNC ;SLC/MRH/FHS - FUNCTION CALLS A5AFUNC
+1 ;;5.2;LAB SERVICE;**286**;Sep 27, 1994
+2 ;
+3 NEW I,X
+4 WRITE !!,"Routine: "_$TEXT(+0),!
FOR I=8:1
SET X=$TEXT(LRAFUNC+I)
if '$LENGTH(X)
QUIT
IF X[";;"
WRITE !,X
+5 WRITE !!
+6 QUIT
+7 ;;
UPCASE(X) ;; $$UPCASE(X)
+1 ;; Call by value
+2 ;; X in lowercase
+3 ;; Returns uppercase
+4 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+5 ;;
LOWCASE(X) ;; $$LOWCASE(X)
+1 ;; Call by value
+2 ;; X in uppercase
+3 ;; Returns lowercase
+4 QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
+5 ;;
STRIP(X,Y) ;; Strips all instances of character 'Y' in string 'X'
+1 ;; Call by value
+2 ;; X contains string on which to perform the strip operation
+3 ;; Y contains character(s) to strip
+4 QUIT $TRANSLATE($GET(X),$GET(Y),"")
+5 ;;
REPLACE(STR,X,Y) ;; Performs a character in 'Y' for character
+1 ;; in 'X' replace within string 'STR'.
+2 ;; Call by value
+3 ;; STR is the string on which to perform the replace operation
+4 ;; X is the characters to replace
+5 ;; Y is the translated characters
+6 ;; ** NOTE ** X AND Y MUST BE IN THE EXACT SAME ORDER ****
+7 ;; X="ABC" Y="XYZ" all occurances of A will be replaced with X
+8 ;; B with Y and C with Z
+9 ;; X="AKZ" Y="Z" every occurance of A will be replaced with Z
+10 ;; and K and Z will be replaced by "" (NULL)
+11 QUIT $TRANSLATE($GET(STR),$GET(X),$GET(Y))
+12 ;;
REPEAT(X,Y) ;;
+1 ;; Call by value
+2 ;; X is the character that you wish repeated
+3 ;; Y is the number of repetitions
+4 ;;** NOTE ** $L(X)*Y must not be greater than 254
+5 ;; eg. S X=$$REPEAT("-",10) returns "----------"
+6 NEW LRPER
+7 IF $LENGTH($GET(X))*$GET(Y)>254
QUIT ""
+8 SET LRPER=""
SET $PIECE(LRPER,$GET(X),+$GET(Y)+1)=""
+9 QUIT LRPER
+10 ;;
INVERT(X) ;;
+1 ;; Call by value
+2 ;; Returns String in X in inverted order ABC => CBA
+3 NEW I,Y
+4 IF $LENGTH($GET(X))>254
QUIT ""
+5 SET Y=""
+6 FOR I=$LENGTH(X):-1:0
SET Y=Y_$EXTRACT(X,I)
+7 QUIT Y
+8 ;;
GLBR(LRR) ;;
+1 ;; Call by value
+2 ;; Returns the global root with extended systax if the global
+3 ;; is translated. Useful when using $Q on MSM systems
+4 NEW LRC,LRF,LRG,LRI,LRR1,LRR2,LRZ
+5 SET LRR1=$PIECE(LRR,"(")_"("
IF $EXTRACT(LRR1)="^"
SET LRR2=$PIECE($QUERY(@(LRR1_""""")")),"(")_"("
if $PIECE(LRR2,"(")]""
SET LRR1=LRR2
+6 SET LRR2=$PIECE($EXTRACT(LRR,1,($LENGTH(LRR)-($EXTRACT(LRR,$LENGTH(LRR))=")"))),"(",2,99)
+7 SET LRC=$LENGTH(LRR2,",")
SET LRF=1
FOR LRI=1:1:LRC
SET LRG=$PIECE(LRR2,",",LRF,LRI)
if LRG=""
QUIT
Begin DoDot:1
+8 IF ($LENGTH(LRG,"(")=$LENGTH(LRG,")")&($LENGTH(LRG,"""")#2))!(($LENGTH(LRG,"""")#2)&($EXTRACT(LRG)="""")&($EXTRACT(LRG,$LENGTH(LRG))=""""))
SET LRG=$$S(LRG)
SET $PIECE(LRR2,",",LRF,LRI)=LRG
SET LRF=LRF+$LENGTH(LRG,",")
SET LRI=LRF-1
End DoDot:1
+9 QUIT LRR1_LRR2
S(LRZ) ;
+1 IF $GET(LRZ)']""
QUIT ""
+2 IF $EXTRACT(LRZ)'=""""
IF $LENGTH(LRZ,"E")=2
IF +$PIECE(LRZ,"E")=$PIECE(LRZ,"E")
IF +$PIECE(LRZ,"E",2)=$PIECE(LRZ,"E",2)
QUIT +LRZ
+3 IF +LRZ=LRZ
QUIT LRZ
+4 IF LRZ=""""""
QUIT ""
+5 IF $EXTRACT(LRZ)'?1A
IF "LR$+@"'[$EXTRACT(LRZ)
QUIT LRZ
+6 IF "+$"[$EXTRACT(LRZ)
XECUTE "S LRZ="_LRZ
QUIT $$Q(LRZ)
+7 IF $DATA(@LRZ)
QUIT $$Q(@LRZ)
+8 QUIT LRZ
Q(LRZ) ;
+1 SET LRZ(LRZ)=""
SET LRZ=$QUERY(LRZ(""))
QUIT $EXTRACT(LRZ,4,$LENGTH(LRZ)-1)
+2 ;;
+3 ;;
+4 QUIT
LRPNM(X) ;;Call by value
+1 ;; change value to upper case string
+2 ;; removes spaces after comma
+3 ;; removes double spaces and spaces at the end of the string
+4 ;; generally used to format patient names
+5 NEW Y,I
+6 SET X=$$UPCASE(X)
+7 ; -- no space after comma and no double spaces
+8 FOR Y=", "," "
FOR
if '$FIND(X,Y)
QUIT
SET X=$EXTRACT(X,1,($FIND(X,Y)-2))_$EXTRACT(X,$FIND(X,Y),$LENGTH(X))
+9 ; -- no space at the end
+10 FOR
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+11 QUIT X
