XBFUNC ; IHS/ADC/GTH - FUNCTION LIBRARY ; [ 10/29/2002 7:42 AM ]
;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997
;
FNDPATRN(STR,PAT) ;PEP - Find pattern in string. Return beginning position.
;
; E.g.: $$FNDPATRN^XBFUNC("ABC8RX","1A1N") will return 3.
;
I '$L($G(STR))!('$L($G(PAT))) Q 0
I STR'?@(".E"_PAT_".E") Q 0
NEW I,J
S J=0
F I=1:1:$L(STR) I $E(STR,I,$L(STR))?@(PAT_".E") S J=I Q
Q J
;
GETPATRN(STR,PAT) ;PEP - Retrieve pattern from string.
;
; E.g.: $$GETPATRN^XBFUNC("ABC8RX","1A1N") will return "C8".
;
I '$L($G(STR))!('$L($G(PAT))) Q ""
NEW I,S
S I=$$FNDPATRN^XBFUNC(STR,PAT)
I 'I Q ""
S S=$E(STR,I,$L(STR))
F I=1:1 Q:(S="")!(S?@PAT) S S=$E(S,1,$L(S)-1)
Q S
;
INTSET(FILE,FIELD,EXTVAL) ;PEP - Get Intnl Field Value Given Extnl Field Value
; For a set of codes type field
;
; E.g.: $$INTSET^XBFUNC(9000001,.21,"RETIRED") returns 5.
;
I '$G(FILE)!('$G(FIELD)) Q ""
I $G(EXTVAL)="" Q ""
I '$D(^DD(FILE,FIELD)) Q ""
S EXTVAL=":"_EXTVAL_";"
I $P(^DD(FILE,FIELD,0),"^",3)'[EXTVAL Q ""
NEW %,%A,%B
S %=$P(^DD(FILE,FIELD,0),"^",3),%A=$P(%,EXTVAL),%B=$L(%A,";")
Q $P(%A,";",%B)
;
EXTSET(FILE,FIELD,INTVAL) ;PEP - Get Extnl Field Value Given Intnl Field Value
; For a set of codes type field
;
; E.g.: $$EXTSET^XBFUNC(9000001,.21,5) returns "RETIRED".
;
I '$G(FILE)!('$G(FIELD)) Q ""
I $G(INTVAL)="" Q ""
I '$D(^DD(FILE,FIELD)) Q ""
I $P(^DD(FILE,FIELD,0),"^",3)'[INTVAL Q ""
NEW %,%A
S %=$P(^DD(FILE,FIELD,0),"^",3),%A=$P(%,(INTVAL_":"),2)
Q $P(%A,";")
;
DECFRAC(X) ;PEP - Convert Decimal to Fraction (X contains Decimal number).
;
; E.g.: $$DECFRAC^XBFUNC(.25) returns "1/4".
;
Q:'$D(X) ""
Q:$E(X)'="." ""
NEW D,N
S N=+$P(X,".",2)
Q:'N ""
S $P(D,"0",$L(+X))="" S D="1"_D
F Q:(N#2) S N=N/2,D=D/2
F Q:(N#5) S N=N/5,D=D/5
Q N_"/"_D
;
C(X,Y) ;PEP - Center X in field length Y/IOM/80.
Q $J("",$S($D(Y):Y,$G(IOM):IOM,1:80)-$L(X)\2)_X
;
GDT(JDT) ;PEP - Return Gregorian Date, given Julian Date.
Q:'$G(JDT) -1
S:'$D(DT) DT=$$DT^XLFDT
Q $$HTE^XLFDT($P($$FMTH^XLFDT($E(DT,1,3)_"0101"),",")+JDT-1)
;
JDT(XBDT) ;PEP - Return Julian Date, given FM date.
Q:'$D(XBDT) -1
Q:'(XBDT?7N) -1
S:'$D(DT) DT=$$DT^XLFDT
Q $$FMDIFF^XLFDT(XBDT,$E(DT,1,3)_"0101")+1
;
USR() ;PEP - Return name of current user for ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;
LOC() ;PEP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;
CV(X) ;PEP - Given a Namespace, return current version.
Q $$VERSION^XPDUTL(X) ;IHS/SET/GTH XB*3*9 10/29/2002
Q:'$L($G(X)) -1
S X=$O(^DIC(9.4,"C",X,0))
Q:'X -1
Q $G(^DIC(9.4,X,"VERSION"),-1)
;
;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002
FNAME(N) ;PEP - Given File number, return File Name.
Q:'$L($G(N)) -1
S N=$O(^DD(N,0,"NM",""))
Q:'$L(N) -1
Q N
;
FGLOB(N) ;PEP - Given File number, return File Global.
Q:'$L($G(N)) -1
Q $G(^DIC(N,0,"GL"),-1)
;
ZEROTH(A,B,C,D,E,F,G,H,I,J,K) ;PEP - Return dd 0th node. A is file #, rest fields.
I '$G(A) Q -1
I '$G(B) Q -1
F %=67:1:75 Q:'$G(@($C(%))) S A=+$P(^DD(A,B,0),U,2),B=@($C(%))
I 'A!('B) Q -1
I '$D(^DD(A,B,0)) Q -1
Q U_$P(^DD(A,B,0),U,2)
;End New Code;IHS/SET/GTH XB*3*9 10/29/2002
;
XBFUNC ; IHS/ADC/GTH - FUNCTION LIBRARY ; [ 10/29/2002 7:42 AM ]
+1 ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997
+2 ;
FNDPATRN(STR,PAT) ;PEP - Find pattern in string. Return beginning position.
+1 ;
+2 ; E.g.: $$FNDPATRN^XBFUNC("ABC8RX","1A1N") will return 3.
+3 ;
+4 IF '$LENGTH($GET(STR))!('$LENGTH($GET(PAT)))
QUIT 0
+5 IF STR'?@(".E"_PAT_".E")
QUIT 0
+6 NEW I,J
+7 SET J=0
+8 FOR I=1:1:$LENGTH(STR)
IF $EXTRACT(STR,I,$LENGTH(STR))?@(PAT_".E")
SET J=I
QUIT
+9 QUIT J
+10 ;
GETPATRN(STR,PAT) ;PEP - Retrieve pattern from string.
+1 ;
+2 ; E.g.: $$GETPATRN^XBFUNC("ABC8RX","1A1N") will return "C8".
+3 ;
+4 IF '$LENGTH($GET(STR))!('$LENGTH($GET(PAT)))
QUIT ""
+5 NEW I,S
+6 SET I=$$FNDPATRN^XBFUNC(STR,PAT)
+7 IF 'I
QUIT ""
+8 SET S=$EXTRACT(STR,I,$LENGTH(STR))
+9 FOR I=1:1
IF (S="")!(S?@PAT)
QUIT
SET S=$EXTRACT(S,1,$LENGTH(S)-1)
+10 QUIT S
+11 ;
INTSET(FILE,FIELD,EXTVAL) ;PEP - Get Intnl Field Value Given Extnl Field Value
+1 ; For a set of codes type field
+2 ;
+3 ; E.g.: $$INTSET^XBFUNC(9000001,.21,"RETIRED") returns 5.
+4 ;
+5 IF '$GET(FILE)!('$GET(FIELD))
QUIT ""
+6 IF $GET(EXTVAL)=""
QUIT ""
+7 IF '$DATA(^DD(FILE,FIELD))
QUIT ""
+8 SET EXTVAL=":"_EXTVAL_";"
+9 IF $PIECE(^DD(FILE,FIELD,0),"^",3)'[EXTVAL
QUIT ""
+10 NEW %,%A,%B
+11 SET %=$PIECE(^DD(FILE,FIELD,0),"^",3)
SET %A=$PIECE(%,EXTVAL)
SET %B=$LENGTH(%A,";")
+12 QUIT $PIECE(%A,";",%B)
+13 ;
EXTSET(FILE,FIELD,INTVAL) ;PEP - Get Extnl Field Value Given Intnl Field Value
+1 ; For a set of codes type field
+2 ;
+3 ; E.g.: $$EXTSET^XBFUNC(9000001,.21,5) returns "RETIRED".
+4 ;
+5 IF '$GET(FILE)!('$GET(FIELD))
QUIT ""
+6 IF $GET(INTVAL)=""
QUIT ""
+7 IF '$DATA(^DD(FILE,FIELD))
QUIT ""
+8 IF $PIECE(^DD(FILE,FIELD,0),"^",3)'[INTVAL
QUIT ""
+9 NEW %,%A
+10 SET %=$PIECE(^DD(FILE,FIELD,0),"^",3)
SET %A=$PIECE(%,(INTVAL_":"),2)
+11 QUIT $PIECE(%A,";")
+12 ;
DECFRAC(X) ;PEP - Convert Decimal to Fraction (X contains Decimal number).
+1 ;
+2 ; E.g.: $$DECFRAC^XBFUNC(.25) returns "1/4".
+3 ;
+4 IF '$DATA(X)
QUIT ""
+5 IF $EXTRACT(X)'="."
QUIT ""
+6 NEW D,N
+7 SET N=+$PIECE(X,".",2)
+8 IF 'N
QUIT ""
+9 SET $PIECE(D,"0",$LENGTH(+X))=""
SET D="1"_D
+10 FOR
IF (N#2)
QUIT
SET N=N/2
SET D=D/2
+11 FOR
IF (N#5)
QUIT
SET N=N/5
SET D=D/5
+12 QUIT N_"/"_D
+13 ;
C(X,Y) ;PEP - Center X in field length Y/IOM/80.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,$GET(IOM):IOM,1:80)-$LENGTH(X)\2)_X
+2 ;
GDT(JDT) ;PEP - Return Gregorian Date, given Julian Date.
+1 IF '$GET(JDT)
QUIT -1
+2 IF '$DATA(DT)
SET DT=$$DT^XLFDT
+3 QUIT $$HTE^XLFDT($PIECE($$FMTH^XLFDT($EXTRACT(DT,1,3)_"0101"),",")+JDT-1)
+4 ;
JDT(XBDT) ;PEP - Return Julian Date, given FM date.
+1 IF '$DATA(XBDT)
QUIT -1
+2 IF '(XBDT?7N)
QUIT -1
+3 IF '$DATA(DT)
SET DT=$$DT^XLFDT
+4 QUIT $$FMDIFF^XLFDT(XBDT,$EXTRACT(DT,1,3)_"0101")+1
+5 ;
USR() ;PEP - Return name of current user for ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;
LOC() ;PEP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;
CV(X) ;PEP - Given a Namespace, return current version.
+1 ;IHS/SET/GTH XB*3*9 10/29/2002
QUIT $$VERSION^XPDUTL(X)
+2 IF '$LENGTH($GET(X))
QUIT -1
+3 SET X=$ORDER(^DIC(9.4,"C",X,0))
+4 IF 'X
QUIT -1
+5 QUIT $GET(^DIC(9.4,X,"VERSION"),-1)
+6 ;
+7 ;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002
FNAME(N) ;PEP - Given File number, return File Name.
+1 IF '$LENGTH($GET(N))
QUIT -1
+2 SET N=$ORDER(^DD(N,0,"NM",""))
+3 IF '$LENGTH(N)
QUIT -1
+4 QUIT N
+5 ;
FGLOB(N) ;PEP - Given File number, return File Global.
+1 IF '$LENGTH($GET(N))
QUIT -1
+2 QUIT $GET(^DIC(N,0,"GL"),-1)
+3 ;
ZEROTH(A,B,C,D,E,F,G,H,I,J,K) ;PEP - Return dd 0th node. A is file #, rest fields.
+1 IF '$GET(A)
QUIT -1
+2 IF '$GET(B)
QUIT -1
+3 FOR %=67:1:75
IF '$GET(@($CHAR(%)))
QUIT
SET A=+$PIECE(^DD(A,B,0),U,2)
SET B=@($CHAR(%))
+4 IF 'A!('B)
QUIT -1
+5 IF '$DATA(^DD(A,B,0))
QUIT -1
+6 QUIT U_$PIECE(^DD(A,B,0),U,2)
+7 ;End New Code;IHS/SET/GTH XB*3*9 10/29/2002
+8 ;
