source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULS.m@ 836

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

initial load of WorldVistAEHR

File size: 4.7 KB
RevLine 
[613]1TIULS ; SLC/JER - String Library functions ;10/7/94 17:18 [1/5/04 11:29am]
2 ;;1.0;TEXT INTEGRATION UTILITIES;**178**;Jun 20, 1997
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 ;
16TIME(X,FMT) ; Recieves X as 2910419.01 and FMT=Return Format of time (HH:MM:SS).
17 N HR,MIN,SEC,TIUI
18 I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT="HR:MIN"
19 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)))
20 F TIUI="HR","MIN","SEC" S:FMT[TIUI FMT=$P(FMT,TIUI)_@TIUI_$P(FMT,TIUI,2)
21 Q FMT
22DATE(X,FMT) ; Call with X=2910419.01 and FMT=Return Format of date ("MM/DD")
23 N AMTH,MM,CC,DD,YY,TIUI,TIUTMP
24 I +X'>0 S $P(TIUTMP," ",$L($G(FMT))+1)="",FMT=TIUTMP G QDATE
25 I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT="MM/DD/YY"
26 S MM=$E(X,4,5),DD=$E(X,6,7),YY=$E(X,2,3),CC=17+$E(X)
27 S:FMT["AMTH" AMTH=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+MM)
28 F TIUI="AMTH","MM","DD","CC","YY" S:FMT[TIUI FMT=$P(FMT,TIUI)_@TIUI_$P(FMT,TIUI,2)
29 I FMT["HR" S FMT=$$TIME(X,FMT)
30QDATE Q FMT
31NAME(X,FMT) ; Call with X="LAST,FIRST MI", FMT=Return Format ("LAST, FI")
32 N TIULAST,TIULI,TIUFIRST,TIUFI,TIUMI,TIUI
33 I X']"" S FMT="" G NAMEX
34 I $S('$D(FMT):1,'$L(FMT):1,1:0) S FMT="LAST,FIRST"
35 S FMT=$$LOWER(FMT)
36 S TIULAST=$P(X,","),TIULI=$E(TIULAST),TIUFIRST=$P(X,",",2)
37 S TIUFI=$E(TIUFIRST)
38 S TIUMI=$S($P(TIUFIRST," ",2)'="NMI":$E($P(TIUFIRST," ",2)),1:"")
39 S TIUFIRST=$P(TIUFIRST," ")
40 F TIUI="last","li","first","fi","mi" I FMT[TIUI S FMT=$P(FMT,TIUI)_@("TIU"_$$UPPER(TIUI))_$P(FMT,TIUI,2)
41NAMEX Q FMT
42INAME(X) ; Call with X="FIRST MI[.] LAST[,M.D.]", RETURNS "LAST,FIRST MI"
43 N LAST,FIRST,MIDDLE,NAME,MI
44 I X'?1.A1" ".E S NAME=X G INAMEX
45 S NAME=$P(X,","),FIRST=$P(NAME," "),MIDDLE=$S($L(NAME," ")=3:$P(NAME," ",2),1:"")
46 S LAST=$P(NAME," ",$L(NAME," ")),MI=$S($L(MIDDLE):$E(MIDDLE),1:"")
47 S NAME=LAST_","_FIRST_$S($L(MI):" "_MI,1:"")
48INAMEX Q NAME
49WORD(X,FMT) ; Call with X=Word Processing array root, FMT=Wrap Width
50 N X,DIWL,DIWF,TIUI K ^UTILITY($J,"W")
51 S DIWL=2,DIWF="WRC"_FMT
52 S TIUI=0 F S TIUI=$O(@X@(TIUI)) Q:TIUI'>0 S X=^(TIUI,0) D ^DIWP
53 D ^DIWW K ^UTILITY($J,"W")
54 Q ""
55UPPER(X) ; Convert lower case X to UPPER CASE
56 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
57LOWER(X) ; Convert UPPER CASE X to lower case
58 Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
59MIXED(X) ; Return Mixed Case X
60 N TIUI,WORD,TMP
61 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)
62 Q TMP
63STRIP(TEXT) ; Strips white space from text
64 N TIUTI,TIUX
65 ; First remove TABS
66 F TIUTI=1:1:$L(TEXT) S:$A(TEXT,TIUTI)=9 TEXT=$E(TEXT,1,(TIUTI-1))_" "_$E(TEXT,(TIUTI+1),$L(TEXT))
67 S TIUX="" F TIUTI=1:1:$L(TEXT," ") S:$A($P(TEXT," ",TIUTI))>0 TIUX=TIUX_$S(TIUTI=1:"",1:" ")_$P(TEXT," ",TIUTI)
68 S TEXT=TIUX S:$P(TEXT," ")']"" TEXT=$P(TEXT," ",2,$L(TEXT," "))
69 Q TEXT
70SIGNAME(TIUDA) ; Get/Return Signature Block Printed Name
71 Q $P($G(^VA(200,+TIUDA,20)),U,2)
72SIGTITL(TIUDA) ; Get/Return Signature Block Printed Name
73 Q $P($G(^VA(200,+TIUDA,20)),U,3)
74CENTER(X) ; Center X
75 N SP
76 S $P(SP," ",((IOM-$L(X))\2))=""
77 Q $G(SP)_X
78URGENCY(X) ; Input transform for urgency codes
79 Q $S($$UPPER(X)="STAT":"P",1:$E(X))
80FILL(X,Y,LEN) ; Append ", "_X to Y, unless Y would excede LEN
81 Q $S('$L(Y):X,($L(Y_$C(44)_" "_X)'>LEN):Y_$C(44)_" "_X,1:X)
82PARSE(X,Y) ; Parse string X, return array Y with list of words from X
83 N I,WORD
84 F I=1:1:$L(X," ") D
85 . S WORD=$P(X," ",I),WORD=$TR(WORD,".,!&?/|\{}[];:=+*^%$#@~`""><")
86 . S:WORD]"" Y(I)=$$UPPER(WORD)
87 Q
88HASNUM(X) ; Boolean - evaluates whether X contains a number
89 N I,Y F I=0:1:9 I X[I S Y=1
90 Q +$G(Y)
91WRAP(TEXT,LENGTH) ; Breaks text string into substrings of length LENGTH
92 N TIUI,TIUJ,LINE,TIUX,TIUX1,TIUX2,TIUY
93 I $G(TEXT)']"" Q ""
94 F TIUI=1:1 D Q:TIUI=$L(TEXT," ")
95 . S TIUX=$P(TEXT," ",TIUI)
96 . I $L(TIUX)>LENGTH D
97 . . S TIUX1=$E(TIUX,1,LENGTH),TIUX2=$E(TIUX,LENGTH+1,$L(TIUX))
98 . . S $P(TEXT," ",TIUI)=TIUX1_" "_TIUX2
99 S LINE=1,TIUX(1)=$P(TEXT," ")
100 F TIUI=2:1 D Q:TIUI'<$L(TEXT," ")
101 . S:$L($G(TIUX(LINE))_" "_$P(TEXT," ",TIUI))>LENGTH LINE=LINE+1,TIUY=1
102 . S TIUX(LINE)=$G(TIUX(LINE))_$S(+$G(TIUY):"",1:" ")_$P(TEXT," ",TIUI),TIUY=0
103 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)
104 Q TEXT
Note: See TracBrowser for help on using the repository browser.