Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: TIULS

TIULS.m

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