TIULS ; SLC/JER - String Library functions ;26-Feb-2010 11:56;MGH
;;1.0;TEXT INTEGRATION UTILITIES;**178,1007**;Jun 20, 1997;Build 5
;IHS/MSC/MGH IHS mods reintroduced on name lookup on upload
;
; **** WARNING ****
;
; Any patch which makes ANY changes to this rtn must include a
;note in the patch desc reminding sites to update the Imaging
;Gateway. See IA # 3622.
; IN ADDITION, if changes are made to components used by Imaging,
;namely, MIXED, backward compatibility may not be enough. If
;changes call additional rtns, TIU should consult with Imaging
;on need to add additional rtns to list of TIU rtns copied for
;Imaging Gateway.
; ****
;
TIME(X,FMT) ; Recieves X as 2910419.01 and FMT=Return Format of time (HH:MM:SS).
N HR,MIN,SEC,TIUI
I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT="HR:MIN"
S X=$P(X,".",2),HR=$E(X,1,2)_$E("00",0,2-$L($E(X,1,2))),MIN=$E(X,3,4)_$E("00",0,2-$L($E(X,3,4))),SEC=$E(X,5,6)_$E("00",0,2-$L($E(X,5,6)))
F TIUI="HR","MIN","SEC" S:FMT[TIUI FMT=$P(FMT,TIUI)_@TIUI_$P(FMT,TIUI,2)
Q FMT
DATE(X,FMT) ; Call with X=2910419.01 and FMT=Return Format of date ("MM/DD")
N AMTH,MM,CC,DD,YY,TIUI,TIUTMP
I +X'>0 S $P(TIUTMP," ",$L($G(FMT))+1)="",FMT=TIUTMP G QDATE
I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT="MM/DD/YY"
S MM=$E(X,4,5),DD=$E(X,6,7),YY=$E(X,2,3),CC=17+$E(X)
S:FMT["AMTH" AMTH=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+MM)
F TIUI="AMTH","MM","DD","CC","YY" S:FMT[TIUI FMT=$P(FMT,TIUI)_@TIUI_$P(FMT,TIUI,2)
I FMT["HR" S FMT=$$TIME(X,FMT)
QDATE Q FMT
NAME(X,FMT) ; Call with X="LAST,FIRST MI", FMT=Return Format ("LAST, FI")
N TIULAST,TIULI,TIUFIRST,TIUFI,TIUMI,TIUI
I X']"" S FMT="" G NAMEX
I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT="LAST,FIRST"
S FMT=$$LOWER(FMT)
S TIULAST=$P(X,","),TIULI=$E(TIULAST),TIUFIRST=$P(X,",",2)
S TIUFI=$E(TIUFIRST)
S TIUMI=$S($P(TIUFIRST," ",2)'="NMI":$E($P(TIUFIRST," ",2)),1:"")
S TIUFIRST=$P(TIUFIRST," ")
F TIUI="last","li","first","fi","mi" I FMT[TIUI S FMT=$P(FMT,TIUI)_@("TIU"_$$UPPER(TIUI))_$P(FMT,TIUI,2)
NAMEX Q FMT
INAME(X) ; Call with X="FIRST MI[.] LAST[,M.D.]", RETURNS "LAST,FIRST MI"
N LAST,FIRST,MIDDLE,NAME,MI
S X=$$STRIP^XLFSTR(X,".") ;IHS/ITSC/LJF 02/26/2003 added
;I X'?1.A1" ".E S NAME=X G INAMEX ;IHS/ITSC/LJF 02/26/2003 commented out
S NAME=$P(X,","),FIRST=$P(NAME," "),MIDDLE=$S($L(NAME," ")=3:$P(NAME," ",2),1:"")
S LAST=$P(NAME," ",$L(NAME," ")),MI=$S($L(MIDDLE):$E(MIDDLE),1:"")
S NAME=LAST_","_FIRST_$S($L(MI):" "_MI,1:"")
INAMEX Q NAME
WORD(X,FMT) ; Call with X=Word Processing array root, FMT=Wrap Width
N X,DIWL,DIWF,TIUI K ^UTILITY($J,"W")
S DIWL=2,DIWF="WRC"_FMT
S TIUI=0 F S TIUI=$O(@X@(TIUI)) Q:TIUI'>0 S X=^(TIUI,0) D ^DIWP
D ^DIWW K ^UTILITY($J,"W")
Q ""
UPPER(X) ; Convert lower case X to UPPER CASE
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
LOWER(X) ; Convert UPPER CASE X to lower case
Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
MIXED(X) ; Return Mixed Case X
N TIUI,WORD,TMP
S TMP="" F TIUI=1:1:$L(X," ") S WORD=$$UPPER($E($P(X," ",TIUI)))_$$LOWER($E($P(X," ",TIUI),2,$L($P(X," ",TIUI)))),TMP=$S(TMP="":WORD,1:TMP_" "_WORD)
Q TMP
STRIP(TEXT) ; Strips white space from text
N TIUTI,TIUX
; First remove TABS
F TIUTI=1:1:$L(TEXT) S:$A(TEXT,TIUTI)=9 TEXT=$E(TEXT,1,(TIUTI-1))_" "_$E(TEXT,(TIUTI+1),$L(TEXT))
S TIUX="" F TIUTI=1:1:$L(TEXT," ") S:$A($P(TEXT," ",TIUTI))>0 TIUX=TIUX_$S(TIUTI=1:"",1:" ")_$P(TEXT," ",TIUTI)
S TEXT=TIUX S:$P(TEXT," ")']"" TEXT=$P(TEXT," ",2,$L(TEXT," "))
Q TEXT
SIGNAME(TIUDA) ; Get/Return Signature Block Printed Name
Q $P($G(^VA(200,+TIUDA,20)),U,2)
SIGTITL(TIUDA) ; Get/Return Signature Block Printed Name
Q $P($G(^VA(200,+TIUDA,20)),U,3)
CENTER(X) ; Center X
N SP
S $P(SP," ",((IOM-$L(X))\2))=""
Q $G(SP)_X
URGENCY(X) ; Input transform for urgency codes
Q $S($$UPPER(X)="STAT":"P",1:$E(X))
FILL(X,Y,LEN) ; Append ", "_X to Y, unless Y would excede LEN
Q $S('$L(Y):X,($L(Y_$C(44)_" "_X)'>LEN):Y_$C(44)_" "_X,1:X)
PARSE(X,Y) ; Parse string X, return array Y with list of words from X
N I,WORD
F I=1:1:$L(X," ") D
. S WORD=$P(X," ",I),WORD=$TR(WORD,".,!&?/|\{}[];:=+*^%$#@~`""><")
. S:WORD]"" Y(I)=$$UPPER(WORD)
Q
HASNUM(X) ; Boolean - evaluates whether X contains a number
N I,Y F I=0:1:9 I X[I S Y=1
Q +$G(Y)
WRAP(TEXT,LENGTH) ; Breaks text string into substrings of length LENGTH
N TIUI,TIUJ,LINE,TIUX,TIUX1,TIUX2,TIUY
I $G(TEXT)']"" Q ""
F TIUI=1:1 D Q:TIUI=$L(TEXT," ")
. S TIUX=$P(TEXT," ",TIUI)
. I $L(TIUX)>LENGTH D
. . S TIUX1=$E(TIUX,1,LENGTH),TIUX2=$E(TIUX,LENGTH+1,$L(TIUX))
. . S $P(TEXT," ",TIUI)=TIUX1_" "_TIUX2
S LINE=1,TIUX(1)=$P(TEXT," ")
F TIUI=2:1 D Q:TIUI'<$L(TEXT," ")
. S:$L($G(TIUX(LINE))_" "_$P(TEXT," ",TIUI))>LENGTH LINE=LINE+1,TIUY=1
. S TIUX(LINE)=$G(TIUX(LINE))_$S(+$G(TIUY):"",1:" ")_$P(TEXT," ",TIUI),TIUY=0
S TIUJ=0,TEXT="" F TIUI=1:1 S TIUJ=$O(TIUX(TIUJ)) Q:+TIUJ'>0 S TEXT=TEXT_$S(TIUI=1:"",1:"|")_TIUX(TIUJ)
Q TEXT
TIULS ; SLC/JER - String Library functions ;26-Feb-2010 11:56;MGH
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**178,1007**;Jun 20, 1997;Build 5
+2 ;IHS/MSC/MGH IHS mods reintroduced on name lookup on upload
+3 ;
+4 ; **** WARNING ****
+5 ;
+6 ; Any patch which makes ANY changes to this rtn must include a
+7 ;note in the patch desc reminding sites to update the Imaging
+8 ;Gateway. See IA # 3622.
+9 ; IN ADDITION, if changes are made to components used by Imaging,
+10 ;namely, MIXED, backward compatibility may not be enough. If
+11 ;changes call additional rtns, TIU should consult with Imaging
+12 ;on need to add additional rtns to list of TIU rtns copied for
+13 ;Imaging Gateway.
+14 ; ****
+15 ;
TIME(X,FMT) ; Recieves X as 2910419.01 and FMT=Return Format of time (HH:MM:SS).
+1 NEW HR,MIN,SEC,TIUI
+2 IF $SELECT('$DATA(FMT):1,'$LENGTH(FMT):1,1:0)
SET FMT="HR:MIN"
+3 SET X=$PIECE(X,".",2)
SET HR=$EXTRACT(X,1,2)_$EXTRACT("00",0,2-$LENGTH($EXTRACT(X,1,2)))
SET MIN=$EXTRACT(X,3,4)_$EXTRACT("00",0,2-$LENGTH($EXTRACT(X,3,4)))
SET SEC=$EXTRACT(X,5,6)_$EXTRACT("00",0,2-$LENGTH($EXTRACT(X,5,6)))
+4 FOR TIUI="HR","MIN","SEC"
IF FMT[TIUI
SET FMT=$PIECE(FMT,TIUI)_@TIUI_$PIECE(FMT,TIUI,2)
+5 QUIT FMT
DATE(X,FMT) ; Call with X=2910419.01 and FMT=Return Format of date ("MM/DD")
+1 NEW AMTH,MM,CC,DD,YY,TIUI,TIUTMP
+2 IF +X'>0
SET $PIECE(TIUTMP," ",$LENGTH($GET(FMT))+1)=""
SET FMT=TIUTMP
GOTO QDATE
+3 IF $SELECT('$DATA(FMT):1,'$LENGTH(FMT):1,1:0)
SET FMT="MM/DD/YY"
+4 SET MM=$EXTRACT(X,4,5)
SET DD=$EXTRACT(X,6,7)
SET YY=$EXTRACT(X,2,3)
SET CC=17+$EXTRACT(X)
+5 IF FMT["AMTH"
SET AMTH=$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+MM)
+6 FOR TIUI="AMTH","MM","DD","CC","YY"
IF FMT[TIUI
SET FMT=$PIECE(FMT,TIUI)_@TIUI_$PIECE(FMT,TIUI,2)
+7 IF FMT["HR"
SET FMT=$$TIME(X,FMT)
QDATE QUIT FMT
NAME(X,FMT) ; Call with X="LAST,FIRST MI", FMT=Return Format ("LAST, FI")
+1 NEW TIULAST,TIULI,TIUFIRST,TIUFI,TIUMI,TIUI
+2 IF X']""
SET FMT=""
GOTO NAMEX
+3 IF $SELECT('$DATA(FMT):1,'$LENGTH(FMT):1,1:0)
SET FMT="LAST,FIRST"
+4 SET FMT=$$LOWER(FMT)
+5 SET TIULAST=$PIECE(X,",")
SET TIULI=$EXTRACT(TIULAST)
SET TIUFIRST=$PIECE(X,",",2)
+6 SET TIUFI=$EXTRACT(TIUFIRST)
+7 SET TIUMI=$SELECT($PIECE(TIUFIRST," ",2)'="NMI":$EXTRACT($PIECE(TIUFIRST," ",2)),1:"")
+8 SET TIUFIRST=$PIECE(TIUFIRST," ")
+9 FOR TIUI="last","li","first","fi","mi"
IF FMT[TIUI
SET FMT=$PIECE(FMT,TIUI)_@("TIU"_$$UPPER(TIUI))_$PIECE(FMT,TIUI,2)
NAMEX QUIT FMT
INAME(X) ; Call with X="FIRST MI[.] LAST[,M.D.]", RETURNS "LAST,FIRST MI"
+1 NEW LAST,FIRST,MIDDLE,NAME,MI
+2 ;IHS/ITSC/LJF 02/26/2003 added
SET X=$$STRIP^XLFSTR(X,".")
+3 ;I X'?1.A1" ".E S NAME=X G INAMEX ;IHS/ITSC/LJF 02/26/2003 commented out
+4 SET NAME=$PIECE(X,",")
SET FIRST=$PIECE(NAME," ")
SET MIDDLE=$SELECT($LENGTH(NAME," ")=3:$PIECE(NAME," ",2),1:"")
+5 SET LAST=$PIECE(NAME," ",$LENGTH(NAME," "))
SET MI=$SELECT($LENGTH(MIDDLE):$EXTRACT(MIDDLE),1:"")
+6 SET NAME=LAST_","_FIRST_$SELECT($LENGTH(MI):" "_MI,1:"")
INAMEX QUIT NAME
WORD(X,FMT) ; Call with X=Word Processing array root, FMT=Wrap Width
+1 NEW X,DIWL,DIWF,TIUI
KILL ^UTILITY($JOB,"W")
+2 SET DIWL=2
SET DIWF="WRC"_FMT
+3 SET TIUI=0
FOR
SET TIUI=$ORDER(@X@(TIUI))
IF TIUI'>0
QUIT
SET X=^(TIUI,0)
DO ^DIWP
+4 DO ^DIWW
KILL ^UTILITY($JOB,"W")
+5 QUIT ""
UPPER(X) ; Convert lower case X to UPPER CASE
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
LOWER(X) ; Convert UPPER CASE X to lower case
+1 QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
MIXED(X) ; Return Mixed Case X
+1 NEW TIUI,WORD,TMP
+2 SET TMP=""
FOR TIUI=1:1:$LENGTH(X," ")
SET WORD=$$UPPER($EXTRACT($PIECE(X," ",TIUI)))_$$LOWER($EXTRACT($PIECE(X," ",TIUI),2,$LENGTH($PIECE(X," ",TIUI))))
SET TMP=$SELECT(TMP="":WORD,1:TMP_" "_WORD)
+3 QUIT TMP
STRIP(TEXT) ; Strips white space from text
+1 NEW TIUTI,TIUX
+2 ; First remove TABS
+3 FOR TIUTI=1:1:$LENGTH(TEXT)
IF $ASCII(TEXT,TIUTI)=9
SET TEXT=$EXTRACT(TEXT,1,(TIUTI-1))_" "_$EXTRACT(TEXT,(TIUTI+1),$LENGTH(TEXT))
+4 SET TIUX=""
FOR TIUTI=1:1:$LENGTH(TEXT," ")
IF $ASCII($PIECE(TEXT," ",TIUTI))>0
SET TIUX=TIUX_$SELECT(TIUTI=1:"",1:" ")_$PIECE(TEXT," ",TIUTI)
+5 SET TEXT=TIUX
IF $PIECE(TEXT," ")']""
SET TEXT=$PIECE(TEXT," ",2,$LENGTH(TEXT," "))
+6 QUIT TEXT
SIGNAME(TIUDA) ; Get/Return Signature Block Printed Name
+1 QUIT $PIECE($GET(^VA(200,+TIUDA,20)),U,2)
SIGTITL(TIUDA) ; Get/Return Signature Block Printed Name
+1 QUIT $PIECE($GET(^VA(200,+TIUDA,20)),U,3)
CENTER(X) ; Center X
+1 NEW SP
+2 SET $PIECE(SP," ",((IOM-$LENGTH(X))\2))=""
+3 QUIT $GET(SP)_X
URGENCY(X) ; Input transform for urgency codes
+1 QUIT $SELECT($$UPPER(X)="STAT":"P",1:$EXTRACT(X))
FILL(X,Y,LEN) ; Append ", "_X to Y, unless Y would excede LEN
+1 QUIT $SELECT('$LENGTH(Y):X,($LENGTH(Y_$CHAR(44)_" "_X)'>LEN):Y_$CHAR(44)_" "_X,1:X)
PARSE(X,Y) ; Parse string X, return array Y with list of words from X
+1 NEW I,WORD
+2 FOR I=1:1:$LENGTH(X," ")
Begin DoDot:1
+3 SET WORD=$PIECE(X," ",I)
SET WORD=$TRANSLATE(WORD,".,!&?/|\{}[];:=+*^%$#@~`""><")
+4 IF WORD]""
SET Y(I)=$$UPPER(WORD)
End DoDot:1
+5 QUIT
HASNUM(X) ; Boolean - evaluates whether X contains a number
+1 NEW I,Y
FOR I=0:1:9
IF X[I
SET Y=1
+2 QUIT +$GET(Y)
WRAP(TEXT,LENGTH) ; Breaks text string into substrings of length LENGTH
+1 NEW TIUI,TIUJ,LINE,TIUX,TIUX1,TIUX2,TIUY
+2 IF $GET(TEXT)']""
QUIT ""
+3 FOR TIUI=1:1
Begin DoDot:1
+4 SET TIUX=$PIECE(TEXT," ",TIUI)
+5 IF $LENGTH(TIUX)>LENGTH
Begin DoDot:2
+6 SET TIUX1=$EXTRACT(TIUX,1,LENGTH)
SET TIUX2=$EXTRACT(TIUX,LENGTH+1,$LENGTH(TIUX))
+7 SET $PIECE(TEXT," ",TIUI)=TIUX1_" "_TIUX2
End DoDot:2
End DoDot:1
IF TIUI=$LENGTH(TEXT," ")
QUIT
+8 SET LINE=1
SET TIUX(1)=$PIECE(TEXT," ")
+9 FOR TIUI=2:1
Begin DoDot:1
+10 IF $LENGTH($GET(TIUX(LINE))_" "_$PIECE(TEXT," ",TIUI))>LENGTH
SET LINE=LINE+1
SET TIUY=1
+11 SET TIUX(LINE)=$GET(TIUX(LINE))_$SELECT(+$GET(TIUY):"",1:" ")_$PIECE(TEXT," ",TIUI)
SET TIUY=0
End DoDot:1
IF TIUI'<$LENGTH(TEXT," ")
QUIT
+12 SET TIUJ=0
SET TEXT=""
FOR TIUI=1:1
SET TIUJ=$ORDER(TIUX(TIUJ))
IF +TIUJ'>0
QUIT
SET TEXT=TEXT_$SELECT(TIUI=1:"",1:"|")_TIUX(TIUJ)
+13 QUIT TEXT
