- SDECFUNC ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
- ;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
- ;
- Q
- ;
- FNDPATRN(STR,PAT) ;PEP - Find pattern in string. Return beginning position.
- ;
- ; E.g.: $$FNDPATRN^SDECFUNC("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^SDECFUNC("ABC8RX","1A1N") will return "C8".
- ;
- I '$L($G(STR))!('$L($G(PAT))) Q ""
- NEW I,S
- S I=$$FNDPATRN^SDECFUNC(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^SDECFUNC(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^SDECFUNC(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^SDECFUNC(.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
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECFUNC 3398 printed Jan 18, 2025@03:53:15 Page 2
- SDECFUNC ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
- +1 ;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
- +2 ;
- +3 QUIT
- +4 ;
- FNDPATRN(STR,PAT) ;PEP - Find pattern in string. Return beginning position.
- +1 ;
- +2 ; E.g.: $$FNDPATRN^SDECFUNC("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^SDECFUNC("ABC8RX","1A1N") will return "C8".
- +3 ;
- +4 IF '$LENGTH($GET(STR))!('$LENGTH($GET(PAT)))
- QUIT ""
- +5 NEW I,S
- +6 SET I=$$FNDPATRN^SDECFUNC(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^SDECFUNC(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^SDECFUNC(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^SDECFUNC(.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 ;