source: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGUT.m@ 1424

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

initial load of FOIAVistA 6/30/08 version

File size: 5.5 KB
Line 
1RGUT ;CAIRO/DKM - General purpose utilities;17-Sep-1998 14:14;DKM
2 ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
3 ;=================================================================
4 ; Replaces delimited arguments in string, returning result
5MSG(%RGTXT,%RGDLM) ;
6 N %RGZ1,%RGZ2
7 I $$NEWERR^%ZTER N $ET S $ET=""
8 S:$G(%RGDLM)="" %RGDLM="%"
9 S %RGZ2="",%RGTXT=$TR(%RGTXT,"~","^"),@$$TRAP^RGZOSF("M1^RGUT")
10 F Q:%RGTXT="" D
11 .S %RGZ2=%RGZ2_$P(%RGTXT,%RGDLM),%RGZ1=$P(%RGTXT,%RGDLM,2),%RGTXT=$P(%RGTXT,%RGDLM,3,999)
12 .I %RGZ1="" S:%RGTXT'="" %RGZ2=%RGZ2_%RGDLM
13 .E X "S %RGZ2=%RGZ2_("_%RGZ1_")"
14M1 Q %RGZ2
15 ; Case-insensitive string comparison
16 ; Returns 0: X=Y, 1: X>Y, -1: X<Y
17STRICMP(X,Y) ;
18 S X=$$UP^XLFSTR(X),Y=$$UP^XLFSTR(Y)
19 Q $S(X=Y:0,X]]Y:1,1:-1)
20 ; Output an underline X bytes long
21UND(X) Q $$REPEAT^XLFSTR("-",$G(X,$G(IOM,80)))
22 ; Truncate a string if > Y bytes long
23TRUNC(X,Y) ;
24 Q $S($L(X)'>Y:X,1:$E(X,1,Y-3)_"...")
25 ; Formatting for singular/plural
26SNGPLR(RGNUM,RGSNG,RGPLR) ;
27 N RGZ
28 S RGZ=RGSNG?.E1L.E,RGPLR=$G(RGPLR,RGSNG_$S(RGZ:"s",1:"S"))
29 Q $S('RGNUM:$S(RGZ:"no ",1:"NO ")_RGPLR,RGNUM=1:"1 "_RGSNG,1:RGNUM_" "_RGPLR)
30 ; Convert code to external form from set of codes
31SET(RGCODE,RGSET) ;
32 N RGZ,RGZ1
33 F RGZ=1:1:$L(RGSET,";") D Q:RGZ1'=""
34 .S RGZ1=$P(RGSET,";",RGZ),RGZ1=$S($P(RGZ1,":")=RGCODE:$P(RGZ1,":",2),1:"")
35 Q RGZ1
36 ; Replace each occurrence of RGOLD in RGSTR with RGNEW
37SUBST(RGSTR,RGOLD,RGNEW) ;
38 N RGP,RGL1,RGL2
39 S RGNEW=$G(RGNEW),RGP=0,RGL1=$L(RGOLD),RGL2=$L(RGNEW)
40 F S RGP=$F(RGSTR,RGOLD,RGP) Q:'RGP D
41 .S RGSTR=$E(RGSTR,1,RGP-RGL1-1)_RGNEW_$E(RGSTR,RGP,9999)
42 .S RGP=RGP-RGL1+RGL2
43 Q RGSTR
44 ; Trim leading (Y=-1)/trailing (Y=1)/leading & trailing (Y=0) spaces
45TRIM(X,Y) ;
46 N RGZ1,RGZ2
47 S Y=+$G(Y),RGZ1=1,RGZ2=$L(X)
48 I Y'>0 F RGZ1=1:1 Q:$A(X,RGZ1)'=32
49 I Y'<0 F RGZ2=RGZ2:-1 Q:$A(X,RGZ2)'=32
50 Q $E(X,RGZ1,RGZ2)
51 ; Format a number with commas
52FMTNUM(RGNUM) ;
53 N RGZ,RGZ1,RGZ2
54 S:RGNUM<0 RGNUM=-RGNUM,RGZ2="-"
55 F RGZ=$L(RGNUM):-3:1 S RGZ1=$E(RGNUM,RGZ-2,RGZ)_$S($D(RGZ1):","_RGZ1,1:"")
56 Q $G(RGZ2)_$G(RGZ1)
57 ; Convert X to base Y padded to length L
58BASE(X,Y,L) ;
59 Q:(Y<2)!(Y>62) ""
60 N RGZ,RGZ1
61 S RGZ1="",X=$S(X<0:-X,1:X)
62 F S RGZ=X#Y,X=X\Y,RGZ1=$C($S(RGZ<10:RGZ+48,RGZ<36:RGZ+55,1:RGZ+61))_RGZ1 Q:'X
63 Q $S('$G(L):RGZ1,1:$$REPEAT^XLFSTR(0,L-$L(RGZ1))_$E(RGZ1,1,L))
64 ; Convert a string to its SOUNDEX equivalent
65SOUNDEX(RGVALUE) ;
66 N RGCODE,RGSOUND,RGPREV,RGCHAR,RGPOS,RGTRANS
67 S RGCODE="01230129022455012623019202"
68 S RGSOUND=$C($A(RGVALUE)-(RGVALUE?1L.E*32))
69 S RGPREV=$E(RGCODE,$A(RGVALUE)-64)
70 F RGPOS=2:1 S RGCHAR=$E(RGVALUE,RGPOS) Q:","[RGCHAR D Q:$L(RGSOUND)=4
71 .Q:RGCHAR'?1A
72 .S RGTRANS=$E(RGCODE,$A(RGCHAR)-$S(RGCHAR?1U:64,1:96))
73 .Q:RGTRANS=RGPREV!(RGTRANS=9)
74 .S RGPREV=RGTRANS
75 .S:RGTRANS'=0 RGSOUND=RGSOUND_RGTRANS
76 Q $E(RGSOUND_"000",1,4)
77 ; Display formatted title
78TITLE(RGTTL,RGVER,RGFN) ;
79 I '$D(IOM) N IOM,IOF S IOM=80,IOF="#"
80 S RGVER=$G(RGVER,"1.0")
81 S:RGVER RGVER="Version "_RGVER
82 U $G(IO,$I)
83 W @IOF,$S(IO=IO(0):$C(27,91,55,109),1:""),*13,$$^RGCVTDT(+$H_","),?(IOM-$L(RGTTL)\2),RGTTL,?(IOM-$L(RGVER)),RGVER,!,$S(IO=IO(0):$C(27,91,109),1:$$UND),!
84 W:$D(RGFN) ?(IOM-$L(RGFN)\2),RGFN,!
85 Q
86 ; Create a unique 8.3 filename
87UFN(Y) N X
88 S Y=$E($G(Y),1,3),X=$$BASE($R(100)_$J_$TR($H,","),36,$S($L(Y):8,1:11))_Y
89 Q $E(X,1,8)_"."_$E(X,9,11)
90 ; Return formatted SSN
91SSN(X) Q $S(X="":X,1:$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,12))
92 ; Performs security check on patient access
93DGSEC(Y) N DIC
94 S DIC(0)="E"
95 D ^DGSEC
96 Q $S(Y<1:0,1:Y)
97 ; Displays spinning icon to indicate progress
98WORKING(RGST,RGP,RGS) ;
99 Q:'$D(IO(0))!$D(ZTQUEUED) 0
100 N RGZ
101 S RGZ(0)=$I,RGS=$G(RGS,"|/-\"),RGST=+$G(RGST)
102 S RGST=$S(RGST<0:0,1:RGST#$L(RGS)+1)
103 U IO(0)
104 W:'$G(RGP) *8,$S(RGST:$E(RGS,RGST),1:" ")
105 R *RGZ:0
106 U RGZ(0)
107 Q RGZ=94
108 ; Ask for Y/N response
109ASK(RGP,RGD,RGZ) ;
110 S RGD=$G(RGD,"N")
111 S RGZ=$$GETCH(RGP_"? ","YN")
112 S:RGZ="" RGZ=$E(RGD)
113 W !
114 Q $S(RGZ[U:"",1:RGZ="Y")
115 ; Pause for user response
116PAUSE(RGP,RGX,RGY) ;
117 Q $$GETCH($G(RGP,"Press RETURN or ENTER to continue..."),U,.RGX,.RGY)
118 ; Single character read
119GETCH(RGP,RGV,RGX,RGY,RGT,RGD) ;
120 N RGZ,RGC
121 W:$D(RGX)!$D(RGY) $$XY($G(RGX,$X),$G(RGY,$Y))
122 W $G(RGP)
123 S RGT=$G(RGT,$G(DTIME,999999999999)),RGD=$G(RGD,U),RGC=""
124 S:$D(RGV) RGV=$$UP^XLFSTR(RGV)_U
125 F D Q:'$L(RGZ)
126 .R RGZ#1:RGT
127 .E S RGC=RGD Q
128 .W *8
129 .Q:'$L(RGZ)
130 .S RGZ=$$UP^XLFSTR(RGZ)
131 .I $D(RGV) D
132 ..I RGV[RGZ S RGC=RGZ
133 ..E W *7,*32,*8 S RGC=""
134 .E S RGC=RGZ
135 W !
136 Q RGC
137 ; Position cursor
138XY(DX,DY) ;
139 D:$G(IOXY)="" HOME^%ZIS
140 S DX=$S(+$G(DX)>0:+DX,1:0),DY=$S(+$G(DY)>0:+DY,1:0),$X=0
141 X IOXY
142 S $X=DX,$Y=DY
143 Q ""
144 ; Parameterized calls to date routines
145%DT(RGD,RGX) ;
146 N %D,%P,%C,%H,%I,%X,%Y,RGZ
147 D DT^DILF($G(RGX),RGD,.RGZ)
148 W:$D(RGZ(0)) RGZ(0),!
149 Q $G(RGZ,-1)
150%DTC(X1,X2) ;
151 N X3
152 S X2=$$%DTF(X1)+X2,X1=X1\1,X3=X2\1,X2=X2-X3
153 S:X2<0 X3=X3-1,X2=X2+1
154 Q $$FMADD^XLFDT(X1,X3)+$J($$%DTT(X2),0,6)
155%DTD(X1,X2) ;
156 Q $$FMDIFF^XLFDT(X1\1,X2\1)+($$%DTF(X1)-$$%DTF(X2))
157%DTF(X) S X=X#1*100
158 Q X\1*3600+(X*100#100\1*60)+(X*10000#100)/86400
159%DTT(X) S X=X*86400
160 Q X\3600*100+(X#3600/3600*60)/10000
161 ; THE FOLLOWING ENTRY POINTS WILL BE PHASED OUT IN FAVOR OF
162 ; THEIR EQUIVALENTS WITHIN KERNEL
163 ; Normalize global root
164GBL(RGGBL) ;
165 Q $$CREF^DILF(RGGBL)
166 ; Convert lower to upper case
167UPCASE(X) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
168 ; Convert upper to lower case
169LOCASE(X) Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
170 ; Return a string of X repeated Y times
171RPT(X,Y) Q $$REPEAT^XLFSTR(X,Y)
172%DTDW(X) Q $$DOW^XLFDT(X)
173%DTDOW(X) ;
174 Q $$DOW^XLFDT(X,1)
175%DTNOW() Q $$NOW^XLFDT
176%DTH(X) Q $$FMTH^XLFDT(X)
177%DTYX(X) Q $$HTFM^XLFDT(X)
Note: See TracBrowser for help on using the repository browser.