source: IHS-VA_UTILITIES-XB/trunk/XBFUNC.m@ 1716

Last change on this file since 1716 was 642, checked in by Sam Habiel, 15 years ago

Modified directory structure; moved routines.
File size: 3.2 KB
Line 
1XBFUNC ; IHS/ADC/GTH - FUNCTION LIBRARY ; [ 10/29/2002 7:42 AM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ;
4FNDPATRN(STR,PAT) ;PEP - Find pattern in string. Return beginning position.
5 ;
6 ; E.g.: $$FNDPATRN^XBFUNC("ABC8RX","1A1N") will return 3.
7 ;
8 I '$L($G(STR))!('$L($G(PAT))) Q 0
9 I STR'?@(".E"_PAT_".E") Q 0
10 NEW I,J
11 S J=0
12 F I=1:1:$L(STR) I $E(STR,I,$L(STR))?@(PAT_".E") S J=I Q
13 Q J
14 ;
15GETPATRN(STR,PAT) ;PEP - Retrieve pattern from string.
16 ;
17 ; E.g.: $$GETPATRN^XBFUNC("ABC8RX","1A1N") will return "C8".
18 ;
19 I '$L($G(STR))!('$L($G(PAT))) Q ""
20 NEW I,S
21 S I=$$FNDPATRN^XBFUNC(STR,PAT)
22 I 'I Q ""
23 S S=$E(STR,I,$L(STR))
24 F I=1:1 Q:(S="")!(S?@PAT) S S=$E(S,1,$L(S)-1)
25 Q S
26 ;
27INTSET(FILE,FIELD,EXTVAL) ;PEP - Get Intnl Field Value Given Extnl Field Value
28 ; For a set of codes type field
29 ;
30 ; E.g.: $$INTSET^XBFUNC(9000001,.21,"RETIRED") returns 5.
31 ;
32 I '$G(FILE)!('$G(FIELD)) Q ""
33 I $G(EXTVAL)="" Q ""
34 I '$D(^DD(FILE,FIELD)) Q ""
35 S EXTVAL=":"_EXTVAL_";"
36 I $P(^DD(FILE,FIELD,0),"^",3)'[EXTVAL Q ""
37 NEW %,%A,%B
38 S %=$P(^DD(FILE,FIELD,0),"^",3),%A=$P(%,EXTVAL),%B=$L(%A,";")
39 Q $P(%A,";",%B)
40 ;
41EXTSET(FILE,FIELD,INTVAL) ;PEP - Get Extnl Field Value Given Intnl Field Value
42 ; For a set of codes type field
43 ;
44 ; E.g.: $$EXTSET^XBFUNC(9000001,.21,5) returns "RETIRED".
45 ;
46 I '$G(FILE)!('$G(FIELD)) Q ""
47 I $G(INTVAL)="" Q ""
48 I '$D(^DD(FILE,FIELD)) Q ""
49 I $P(^DD(FILE,FIELD,0),"^",3)'[INTVAL Q ""
50 NEW %,%A
51 S %=$P(^DD(FILE,FIELD,0),"^",3),%A=$P(%,(INTVAL_":"),2)
52 Q $P(%A,";")
53 ;
54DECFRAC(X) ;PEP - Convert Decimal to Fraction (X contains Decimal number).
55 ;
56 ; E.g.: $$DECFRAC^XBFUNC(.25) returns "1/4".
57 ;
58 Q:'$D(X) ""
59 Q:$E(X)'="." ""
60 NEW D,N
61 S N=+$P(X,".",2)
62 Q:'N ""
63 S $P(D,"0",$L(+X))="" S D="1"_D
64 F Q:(N#2) S N=N/2,D=D/2
65 F Q:(N#5) S N=N/5,D=D/5
66 Q N_"/"_D
67 ;
68C(X,Y) ;PEP - Center X in field length Y/IOM/80.
69 Q $J("",$S($D(Y):Y,$G(IOM):IOM,1:80)-$L(X)\2)_X
70 ;
71GDT(JDT) ;PEP - Return Gregorian Date, given Julian Date.
72 Q:'$G(JDT) -1
73 S:'$D(DT) DT=$$DT^XLFDT
74 Q $$HTE^XLFDT($P($$FMTH^XLFDT($E(DT,1,3)_"0101"),",")+JDT-1)
75 ;
76JDT(XBDT) ;PEP - Return Julian Date, given FM date.
77 Q:'$D(XBDT) -1
78 Q:'(XBDT?7N) -1
79 S:'$D(DT) DT=$$DT^XLFDT
80 Q $$FMDIFF^XLFDT(XBDT,$E(DT,1,3)_"0101")+1
81 ;
82USR() ;PEP - Return name of current user for ^VA(200.
83 Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
84 ;
85LOC() ;PEP - Return location name from file 4 based on DUZ(2).
86 Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
87 ;
88CV(X) ;PEP - Given a Namespace, return current version.
89 Q $$VERSION^XPDUTL(X) ;IHS/SET/GTH XB*3*9 10/29/2002
90 Q:'$L($G(X)) -1
91 S X=$O(^DIC(9.4,"C",X,0))
92 Q:'X -1
93 Q $G(^DIC(9.4,X,"VERSION"),-1)
94 ;
95 ;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002
96FNAME(N) ;PEP - Given File number, return File Name.
97 Q:'$L($G(N)) -1
98 S N=$O(^DD(N,0,"NM",""))
99 Q:'$L(N) -1
100 Q N
101 ;
102FGLOB(N) ;PEP - Given File number, return File Global.
103 Q:'$L($G(N)) -1
104 Q $G(^DIC(N,0,"GL"),-1)
105 ;
106ZEROTH(A,B,C,D,E,F,G,H,I,J,K) ;PEP - Return dd 0th node. A is file #, rest fields.
107 I '$G(A) Q -1
108 I '$G(B) Q -1
109 F %=67:1:75 Q:'$G(@($C(%))) S A=+$P(^DD(A,B,0),U,2),B=@($C(%))
110 I 'A!('B) Q -1
111 I '$D(^DD(A,B,0)) Q -1
112 Q U_$P(^DD(A,B,0),U,2)
113 ;End New Code;IHS/SET/GTH XB*3*9 10/29/2002
114 ;
Note: See TracBrowser for help on using the repository browser.