DILIBF ;SFISC/STAFF-LIBRARY OF FUNCTIONS ;1:48 PM 20 Feb 2013
;;22.0;VA FileMan;**48,71,169**;Mar 30, 1999;Build 28
;Per VHA Directive 2004-038, this routine should not be modified.
HTFM(%H,%F) ;$H to FM
N X,%,%Y,%M,%D S:'$D(%F) %F=0
S:%H[",0" %H=%H-1_",86400"
S %=(%H>21608)+(%H>94657)+%H-.1,%Y=%\365.25+141,%=%#365.25\1
S %D=%+306#(%Y#4=0+365)#153#61#31+1,%M=%-%D\29+1
S X=%Y_"00"+%M_"00"+%D,%=$P(%H,",",2)
S %=%#60/100+(%#3600\60)/100+(%\3600)/100
S:%&('%F) X=X_% Q X
;
FMTH(X,%F) ;FM to $H
N %Y,%H S:'$D(%F) %F=0 D H S:%F %H=+%H Q %H
H ;
N %,%M,%D,%T I X<1410000 S %H=0,%Y=-1 Q
S %Y=$E(X,1,3),%M=$E(X,4,5),%D=$E(X,6,7)
S %T=$E(X_0,9,10)*60+$E(X_"000",11,12)*60+$E(X_"00000",13,14)
N DILEAP D
. N Y S Y=%Y+1700 S:%M<3 Y=Y-1
. S DILEAP=(Y\4)-(Y\100)+(Y\400)-446 Q
S %H=$P("^31^59^90^120^151^181^212^243^273^304^334","^",%M)+%D
S %='%M!'%D,%Y=%Y-141
S %H=%H+(%Y*365)+DILEAP+%
S:%T=86400 %H=%H+1,%T=0
S %H=%H_","_%T
S %Y=$S(%:-1,1:%H+4#7)
Q
;
HTE(%H,%F) ;$H to external
Q:%H'>0 %H N Y,%T,%R S %F=$G(%F) S Y=$$HTFM(%H,0) G T2
FMTE(Y,%F) ;FM to external
Q:'$G(Y) $G(Y) S %F=$G(%F) Q:($G(DUZ("LANG"))>1) $$OUT^DIALOGU(Y,"FMTE",%F)
N %T,%R
T2 S %T="."_$E($P(Y,".",2)_"000000",1,7) D @("F"_$S(%F<1:1,%F>7:1,1:+%F\1)) Q %R
DOW(X,Y) ;Day of Week
N %Y,%M,%D,%H,%T D H I $G(Y) Q %Y
Q $P("Sun^Mon^Tues^Wednes^Thurs^Fri^Satur","^",%Y+1)_"day"
;
FMDIFF(X1,X2,X3) ;FM diff in two dates in days if x3=1 seconds if x3=2.
N %H,%Y,X S:'$D(X3) X3=1 S X=X1 D H S X1=+%H,X1(1)=$P(%H,",",2),X=X2 D H
D2 S X=(X1-%H) S:X3>1 X=X*86400+(X1(1)-$P(%H,",",2))
I X3=3 D
. S %=X,X=""
. I %'<86400 S X=(%\86400)
. I %<0 S:(-%)'<86400 X=(%\86400) S %=-%
. S:%#86400 X=X_" "_(%#86400\3600)_":"_$E(%#3600\60+100,2,3)_":"_$E(%#60+100,2,3)
. Q
Q X
;
HDIFF(X1,X2,X3) ;$H diff in two dates, X3 same as FMDIFF.
N X,%H,%T S:'$D(X3) X3=1 S X1(1)=$P(X1,",",2),X1=+X1,%H=X2
G D2
HADD(X,D,H,M,S) ;Add to $H date
N %H,%T S %H=+X,%T=$P(X,",",2) D A2 Q %H_","_%T
A2 S %H=%H+$G(D),%T=%T+($G(H)*3600)+($G(M)*60)+$G(S)
S:%T'<86400 %H=%H+(%T\86400),%T=%T#86400 S:%T<0 %H=%H+(%T\86400)-1,%T=%T#86400
Q
;
FMADD(X,D,H,M,S) ;Add to FM date
N %H,%T S %H=$$FMTH(X,0),%T=$P(%H,",",2) D A2 Q $$HTFM(%H_","_%T)
;
CONVQQ(X) ; CONVERT SINGLE TO DOUBLE QUOTES IN STRING X
N Q,F S Q=""""
F F=0:0 S F=$F(X,Q,F) Q:F=0 S X=$E(X,1,F-2)_Q_Q_$E(X,F,256),F=F+1
Q X
;
CONVQ(X) ; CONVERT DOUBLE TO SINGLE QUOTES IN STRING X
N Q,F,D S Q="""",D=""""""
F F=0:0 S F=$F(X,D,F) Q:F=0 S X=$E(X,1,F-3)_Q_$E(X,F,256),F=F-1
Q X
;
QUOTE(X) ; PUT QUOTES AROUND STRING
S X=""""_$G(X)_"""" Q X
;
FNO(X) ; gets a subfile's top level file number
N Y S X=+X
I $G(^DIC(X,0))]"" Q X
F S Y=+$G(^DD(X,0,"UP")) D Q:'$D(X)!(Y'>0)
. I $G(^DIC(Y,0))]"" K X Q
. S X=Y
. Q
Q Y
;
GLO(Z) ; gets the file number from a global root
I '$D(@(Z_"0)"))#2 Q 0
N Y
S Y=+$P($G(@(Z_"0)")),U,2)
Q $$FNO(+Y)
;
UP(X) ; convert string X to uppercase
I X?.UNP Q X
N A,L,B,C S C=""
F A=1:1:$L(X) S L=$E(X,A),B=$C($A(L)-32) S C=C_$S(L'?1L:L,B?1L:"Z",1:B) ;$C(255) matches lower-case, and so does $C(255-32), so lamely return "Z"
Q C
;
ROUEXIST(X) ; Execute routine existence test
G:X="" QRER I '$D(DISYS) N DISYS D OS^DII
I $G(^%ZOSF("TEST"))]"" X ^("TEST") Q $T
I $G(^DD("OS",DISYS,18))]"" X ^(18) Q $T
QRER Q 0
;
;
F5 ;
F1 S %R=$P($S(%F'["U":$T(M),1:$T(MU))," ",$S($E(Y,4,5):$E(Y,4,5)+2,1:0))_$S($E(Y,4,5):" ",1:"")_$S($E(Y,6,7):$S((%F\1'=5):$E(Y,6,7),1:+$E(Y,6,7))_$E(", ",1,1+(%F\1'=5)),1:"")_($E(Y,1,3)+1700)
TM Q:%T'>0!(%F["D")
I %F'["P" S %R=%R_$S(%F\1'=6:"@",1:" @ ")_$E(%T,2,3)_":"_$E(%T,4,5)_$S($E(%T,6,7)!(%F["S"):":"_$E(%T,6,7),1:$S(%F\1'=6:"",1:" "))
I %F["P" S %R=%R_" "_$S($E(%T,2,3)>12:$E(%T,2,3)-12,1:+$E(%T,2,3))_":"_$E(%T,4,5)_$S($E(%T,6,7)!(%F["S"):":"_$E(%T,6,7),1:"")_$S($E(%T,2,5)\1200=1:" pm",1:" am")
Q
M ;; Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
MU ;; JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC
F2 S %R=+$E(Y,4,5)_"/"_(+$E(Y,6,7))_"/"_$E(Y,2,3)
G TM
F3 S %R=+$E(Y,6,7)_"/"_(+$E(Y,4,5))_"/"_$E(Y,2,3)
G TM
F4 S %R=$E(Y,2,3)_"/"_$E(Y,4,5)_"/"_$E(Y,6,7)
G TM
F6 S %R=$S($E(Y,4,5):$E(Y,4,5)_"-",1:"")_$S($E(Y,6,7):$E(Y,6,7)_"-",1:"")_(1700+$E(Y,1,3))
G TM
F7 S %R=$S($E(Y,4,5):+$E(Y,4,5)_"-",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_"-",1:"")_(1700+$E(Y,1,3))
G TM
;
HKERR(DIFILE,DIIENS,DIFLD,DIHOOK) ;
N DIEXT
S DIEXT("FILE")=$G(DIFILE)
S DIEXT("FIELD")=$G(DIFLD)
S DIEXT("IENS")=$G(DIIENS)
S DIEXT(1)=$G(DIHOOK)
D BLD^DIALOG(120,DIHOOK,.DIEXT)
Q
;
FILENUM(DIGREF) ;Return file/subfile number from open global reference
Q:$G(DIGREF)'?1"^".1"%"1U.UN1"(".E ""
I $E(DIGREF,1,8)="^DIC(.2," Q .2
N F,X,DIFILE,S
S DIFILE=+$P($G(@(DIGREF_"0)")),U,2) I DIFILE Q DIFILE
S DIGREF=$$CREF^DILF(DIGREF)
F X=$QL($NA(@DIGREF)):-2:0 S X(X)=$QS(DIGREF,X),X(X,0)=$$CREF^DILF($NA(@DIGREF,X))
S X=$O(X("")) I X="" Q ""
I X(X)="^DIC" S F=1
E I X(X)="^DD" S F=0
E S S=$P($G(@X(X,0)@(0)),U,2),F=+S I S="" Q ""
F X=X:0 S X=$O(X(X)) Q:X="" S DIFILE=$O(^DD(F,"GL",X(X),0,"")) Q:DIFILE="" S (F,DIFILE)=+$P($G(^DD(F,DIFILE,0)),U,2) Q:'F
Q DIFILE
;
DILIBF ;SFISC/STAFF-LIBRARY OF FUNCTIONS ;1:48 PM 20 Feb 2013
+1 ;;22.0;VA FileMan;**48,71,169**;Mar 30, 1999;Build 28
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
HTFM(%H,%F) ;$H to FM
+1 NEW X,%,%Y,%M,%D
IF '$DATA(%F)
SET %F=0
+2 IF %H[",0"
SET %H=%H-1_",86400"
+3 SET %=(%H>21608)+(%H>94657)+%H-.1
SET %Y=%\365.25+141
SET %=%#365.25\1
+4 SET %D=%+306#(%Y#4=0+365)#153#61#31+1
SET %M=%-%D\29+1
+5 SET X=%Y_"00"+%M_"00"+%D
SET %=$PIECE(%H,",",2)
+6 SET %=%#60/100+(%#3600\60)/100+(%\3600)/100
+7 IF %&('%F)
SET X=X_%
QUIT X
+8 ;
FMTH(X,%F) ;FM to $H
+1 NEW %Y,%H
IF '$DATA(%F)
SET %F=0
DO H
IF %F
SET %H=+%H
QUIT %H
H ;
+1 NEW %,%M,%D,%T
IF X<1410000
SET %H=0
SET %Y=-1
QUIT
+2 SET %Y=$EXTRACT(X,1,3)
SET %M=$EXTRACT(X,4,5)
SET %D=$EXTRACT(X,6,7)
+3 SET %T=$EXTRACT(X_0,9,10)*60+$EXTRACT(X_"000",11,12)*60+$EXTRACT(X_"00000",13,14)
+4 NEW DILEAP
Begin DoDot:1
+5 NEW Y
SET Y=%Y+1700
IF %M<3
SET Y=Y-1
+6 SET DILEAP=(Y\4)-(Y\100)+(Y\400)-446
QUIT
End DoDot:1
+7 SET %H=$PIECE("^31^59^90^120^151^181^212^243^273^304^334","^",%M)+%D
+8 SET %='%M!'%D
SET %Y=%Y-141
+9 SET %H=%H+(%Y*365)+DILEAP+%
+10 IF %T=86400
SET %H=%H+1
SET %T=0
+11 SET %H=%H_","_%T
+12 SET %Y=$SELECT(%:-1,1:%H+4#7)
+13 QUIT
+14 ;
HTE(%H,%F) ;$H to external
+1 IF %H'>0
QUIT %H
NEW Y,%T,%R
SET %F=$GET(%F)
SET Y=$$HTFM(%H,0)
GOTO T2
FMTE(Y,%F) ;FM to external
+1 IF '$GET(Y)
QUIT $GET(Y)
SET %F=$GET(%F)
IF ($GET(DUZ("LANG"))>1)
QUIT $$OUT^DIALOGU(Y,"FMTE",%F)
+2 NEW %T,%R
T2 SET %T="."_$EXTRACT($PIECE(Y,".",2)_"000000",1,7)
DO @("F"_$SELECT(%F<1:1,%F>7:1,1:+%F\1))
QUIT %R
DOW(X,Y) ;Day of Week
+1 NEW %Y,%M,%D,%H,%T
DO H
IF $GET(Y)
QUIT %Y
+2 QUIT $PIECE("Sun^Mon^Tues^Wednes^Thurs^Fri^Satur","^",%Y+1)_"day"
+3 ;
FMDIFF(X1,X2,X3) ;FM diff in two dates in days if x3=1 seconds if x3=2.
+1 NEW %H,%Y,X
IF '$DATA(X3)
SET X3=1
SET X=X1
DO H
SET X1=+%H
SET X1(1)=$PIECE(%H,",",2)
SET X=X2
DO H
D2 SET X=(X1-%H)
IF X3>1
SET X=X*86400+(X1(1)-$PIECE(%H,",",2))
+1 IF X3=3
Begin DoDot:1
+2 SET %=X
SET X=""
+3 IF %'<86400
SET X=(%\86400)
+4 IF %<0
IF (-%)'<86400
SET X=(%\86400)
SET %=-%
+5 IF %#86400
SET X=X_" "_(%#86400\3600)_":"_$EXTRACT(%#3600\60+100,2,3)_":"_$EXTRACT(%#60+100,2,3)
+6 QUIT
End DoDot:1
+7 QUIT X
+8 ;
HDIFF(X1,X2,X3) ;$H diff in two dates, X3 same as FMDIFF.
+1 NEW X,%H,%T
IF '$DATA(X3)
SET X3=1
SET X1(1)=$PIECE(X1,",",2)
SET X1=+X1
SET %H=X2
+2 GOTO D2
HADD(X,D,H,M,S) ;Add to $H date
+1 NEW %H,%T
SET %H=+X
SET %T=$PIECE(X,",",2)
DO A2
QUIT %H_","_%T
A2 SET %H=%H+$GET(D)
SET %T=%T+($GET(H)*3600)+($GET(M)*60)+$GET(S)
+1 IF %T'<86400
SET %H=%H+(%T\86400)
SET %T=%T#86400
IF %T<0
SET %H=%H+(%T\86400)-1
SET %T=%T#86400
+2 QUIT
+3 ;
FMADD(X,D,H,M,S) ;Add to FM date
+1 NEW %H,%T
SET %H=$$FMTH(X,0)
SET %T=$PIECE(%H,",",2)
DO A2
QUIT $$HTFM(%H_","_%T)
+2 ;
CONVQQ(X) ; CONVERT SINGLE TO DOUBLE QUOTES IN STRING X
+1 NEW Q,F
SET Q=""""
+2 FOR F=0:0
SET F=$FIND(X,Q,F)
IF F=0
QUIT
SET X=$EXTRACT(X,1,F-2)_Q_Q_$EXTRACT(X,F,256)
SET F=F+1
+3 QUIT X
+4 ;
CONVQ(X) ; CONVERT DOUBLE TO SINGLE QUOTES IN STRING X
+1 NEW Q,F,D
SET Q=""""
SET D=""""""
+2 FOR F=0:0
SET F=$FIND(X,D,F)
IF F=0
QUIT
SET X=$EXTRACT(X,1,F-3)_Q_$EXTRACT(X,F,256)
SET F=F-1
+3 QUIT X
+4 ;
QUOTE(X) ; PUT QUOTES AROUND STRING
+1 SET X=""""_$GET(X)_""""
QUIT X
+2 ;
FNO(X) ; gets a subfile's top level file number
+1 NEW Y
SET X=+X
+2 IF $GET(^DIC(X,0))]""
QUIT X
+3 FOR
SET Y=+$GET(^DD(X,0,"UP"))
Begin DoDot:1
+4 IF $GET(^DIC(Y,0))]""
KILL X
QUIT
+5 SET X=Y
+6 QUIT
End DoDot:1
IF '$DATA(X)!(Y'>0)
QUIT
+7 QUIT Y
+8 ;
GLO(Z) ; gets the file number from a global root
+1 IF '$DATA(@(Z_"0)"))#2
QUIT 0
+2 NEW Y
+3 SET Y=+$PIECE($GET(@(Z_"0)")),U,2)
+4 QUIT $$FNO(+Y)
+5 ;
UP(X) ; convert string X to uppercase
+1 IF X?.UNP
QUIT X
+2 NEW A,L,B,C
SET C=""
+3 ;$C(255) matches lower-case, and so does $C(255-32), so lamely return "Z"
FOR A=1:1:$LENGTH(X)
SET L=$EXTRACT(X,A)
SET B=$CHAR($ASCII(L)-32)
SET C=C_$SELECT(L'?1L:L,B?1L:"Z",1:B)
+4 QUIT C
+5 ;
ROUEXIST(X) ; Execute routine existence test
+1 IF X=""
GOTO QRER
IF '$DATA(DISYS)
NEW DISYS
DO OS^DII
+2 IF $GET(^%ZOSF("TEST"))]""
XECUTE ^("TEST")
QUIT $TEST
+3 IF $GET(^DD("OS",DISYS,18))]""
XECUTE ^(18)
QUIT $TEST
QRER QUIT 0
+1 ;
+2 ;
F5 ;
F1 SET %R=$PIECE($SELECT(%F'["U":$TEXT(M),1:$TEXT(MU))," ",$SELECT($EXTRACT(Y,4,5):$EXTRACT(Y,4,5)+2,1:0))_$SELECT($EXTRACT(Y,4,5):" ",1:"")_$SELECT($EXTRACT(Y,6,7):$SELECT((%F\1'=5):$EXTRACT(Y,6,7),1:+...
... $EXTRACT(Y,6,7))_$EXTRACT(", ",1,1+(%F\1'=5)),1:"")_($EXTRACT(Y,1,3)+1700)
TM IF %T'>0!(%F["D")
QUIT
+1 IF %F'["P"
SET %R=%R_$SELECT(%F\1'=6:"@",1:" @ ")_$EXTRACT(%T,2,3)_":"_$EXTRACT(%T,4,5)_$SELECT($EXTRACT(%T,6,7)!(%F["S"):":"_$EXTRACT(%T,6,7),1:$SELECT(%F\1'=6:"",1:" "))
+2 IF %F["P"
SET %R=%R_" "_$SELECT($EXTRACT(%T,2,3)>12:$EXTRACT(%T,2,3)-12,1:+$EXTRACT(%T,2,3))_":"_$EXTRACT(%T,4,5)_$SELECT($EXTRACT(%T,6,7)!(%F["S"):":"_$EXTRACT(%T,6,7),1:"")_$SELECT($EXTRACT(%T,2,5)\1200=1:" pm",1:" am")
+3 QUIT
M ;; Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
MU ;; JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC
F2 SET %R=+$EXTRACT(Y,4,5)_"/"_(+$EXTRACT(Y,6,7))_"/"_$EXTRACT(Y,2,3)
+1 GOTO TM
F3 SET %R=+$EXTRACT(Y,6,7)_"/"_(+$EXTRACT(Y,4,5))_"/"_$EXTRACT(Y,2,3)
+1 GOTO TM
F4 SET %R=$EXTRACT(Y,2,3)_"/"_$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)
+1 GOTO TM
F6 SET %R=$SELECT($EXTRACT(Y,4,5):$EXTRACT(Y,4,5)_"-",1:"")_$SELECT($EXTRACT(Y,6,7):$EXTRACT(Y,6,7)_"-",1:"")_(1700+$EXTRACT(Y,1,3))
+1 GOTO TM
F7 SET %R=$SELECT($EXTRACT(Y,4,5):+$EXTRACT(Y,4,5)_"-",1:"")_$SELECT($EXTRACT(Y,6,7):+$EXTRACT(Y,6,7)_"-",1:"")_(1700+$EXTRACT(Y,1,3))
+1 GOTO TM
+2 ;
HKERR(DIFILE,DIIENS,DIFLD,DIHOOK) ;
+1 NEW DIEXT
+2 SET DIEXT("FILE")=$GET(DIFILE)
+3 SET DIEXT("FIELD")=$GET(DIFLD)
+4 SET DIEXT("IENS")=$GET(DIIENS)
+5 SET DIEXT(1)=$GET(DIHOOK)
+6 DO BLD^DIALOG(120,DIHOOK,.DIEXT)
+7 QUIT
+8 ;
FILENUM(DIGREF) ;Return file/subfile number from open global reference
+1 IF $GET(DIGREF)'?1"^".1"%"1U.UN1"(".E
QUIT ""
+2 IF $EXTRACT(DIGREF,1,8)="^DIC(.2,"
QUIT .2
+3 NEW F,X,DIFILE,S
+4 SET DIFILE=+$PIECE($GET(@(DIGREF_"0)")),U,2)
IF DIFILE
QUIT DIFILE
+5 SET DIGREF=$$CREF^DILF(DIGREF)
+6 FOR X=$QLENGTH($NAME(@DIGREF)):-2:0
SET X(X)=$QSUBSCRIPT(DIGREF,X)
SET X(X,0)=$$CREF^DILF($NAME(@DIGREF,X))
+7 SET X=$ORDER(X(""))
IF X=""
QUIT ""
+8 IF X(X)="^DIC"
SET F=1
+9 IF '$TEST
IF X(X)="^DD"
SET F=0
+10 IF '$TEST
SET S=$PIECE($GET(@X(X,0)@(0)),U,2)
SET F=+S
IF S=""
QUIT ""
+11 FOR X=X:0
SET X=$ORDER(X(X))
IF X=""
QUIT
SET DIFILE=$ORDER(^DD(F,"GL",X(X),0,""))
IF DIFILE=""
QUIT
SET (F,DIFILE)=+$PIECE($GET(^DD(F,DIFILE,0)),U,2)
IF 'F
QUIT
+12 QUIT DIFILE
+13 ;
