Return to DILIBF.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DILIBF.m, revision 1.1

1.1     ! snw         1: DILIBF ;SFISC/STAFF-LIBRARY OF FUNCTIONS ;12/1/94  13:22
        !             2:        ;;21.0;VA FileMan;;Dec 28, 1994
        !             3:        ;Per VHA Directive 10-93-142, this routine should not be modified.
        !             4: HTFM(%H,%F)    ;$H to FM
        !             5:        N X,%,%Y,%M,%D S:'$D(%F) %F=0
        !             6:        S %=%H>21608+%H-.1,%Y=%\365.25+141,%=%#365.25\1
        !             7:        S %D=%+306#(%Y#4=0+365)#153#61#31+1,%M=%-%D\29+1
        !             8:        S X=%Y_"00"+%M_"00"+%D,%=$P(%H,",",2)
        !             9:        S %=%#60/100+(%#3600\60)/100+(%\3600)/100
        !            10:        S:%&('%F) X=X_% Q X
        !            11:        ;
        !            12: FMTH(X,%F)     ;FM to $H
        !            13:        N %Y,%H S:'$D(%F) %F=0 D H S:%F %H=+%H Q %H
        !            14: H      ;
        !            15:        N %,%M,%D,%T I X<1410000 S %H=0,%Y=-1 Q
        !            16:        S %Y=$E(X,1,3),%M=$E(X,4,5),%D=$E(X,6,7)
        !            17:        S %T=$E(X_0,9,10)*60+$E(X_"000",11,12)*60+$E(X_"00000",13,14)
        !            18:        S %H=%M>2&'(%Y#4)+$P("^31^59^90^120^151^181^212^243^273^304^334","^",%M)+%D
        !            19:        S %='%M!'%D,%Y=%Y-141,%H=(%H+(%Y*365)+(%Y\4)-(%Y>59)+%)_","_%T,%Y=$S(%:-1,1:%H+4#7)
        !            20:        Q
        !            21:        ;
        !            22: HTE(%H,%F)     ;$H to external
        !            23:        Q:%H'>0 %H N Y,%T,%R S %F=$G(%F) S Y=$$HTFM(%H,0) G T2
        !            24: FMTE(Y,%F)     ;FM to external
        !            25:        Q:'$G(Y) $G(Y) S %F=$G(%F) Q:($G(DUZ("LANG"))>1) $$OUT^DIALOGU(Y,"FMTE",%F)
        !            26:        N %T,%R
        !            27: T2     S %T="."_$E($P(Y,".",2)_"000000",1,7) D @("F"_$S(%F<1:1,%F>7:1,1:+%F\1)) Q %R
        !            28: DOW(X,Y)       ;Day of Week
        !            29:        N %Y,%M,%D,%H,%T D H I $G(Y) Q %Y
        !            30:        Q $P("Sun^Mon^Tues^Wednes^Thurs^Fri^Satur","^",%Y+1)_"day"
        !            31:        ;
        !            32: FMDIFF(X1,X2,X3)       ;FM diff in two dates in days if x3=1 seconds if x3=2.
        !            33:        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
        !            34: D2     S X=(X1-%H) S:X3>1 X=X*86400+(X1(1)-$P(%H,",",2))
        !            35:        I X3=3 S %=X,X="" S:%>86400 X=(%\86400) S:%#86400 X=X_" "_(%#86400\3600)_":"_$E(%#3600\60+100,2,3)_":"_$E(%#60+100,2,3)
        !            36:        Q X
        !            37: HDIFF(X1,X2,X3)        ;$H diff in two dates, X3 same as FMDIFF.
        !            38:        N X,%H,%T S:'$D(X3) X3=1 S X1(1)=$P(X1,",",2),X1=+X1,%H=X2
        !            39:        G D2
        !            40: HADD(X,D,H,M,S)        ;Add to $H date
        !            41:        N %H,%T S %H=+X,%T=$P(X,",",2) D A2 Q %H_","_%T
        !            42: A2     S %H=%H+$G(D),%T=%T+($G(H)*3600)+($G(M)*60)+$G(S)
        !            43:        S:%T>86400 %H=%H+(%T\86400),%T=%T#86400 S:%T<0 %H=%H+(%T\86400)-1,%T=%T#86400
        !            44:        Q
        !            45: FMADD(X,D,H,M,S)       ;Add to FM date
        !            46:        N %H,%T S %H=$$FMTH(X,0),%T=$P(%H,",",2) D A2 Q $$HTFM(%H_","_%T)
        !            47: CONVQQ(X)      ; CONVERT SINGLE TO DOUBLE QUOTES IN STRING X
        !            48:        N Q,F S Q=""""
        !            49:        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
        !            50:        Q X
        !            51: CONVQ(X)       ; CONVERT DOUBLE TO SINGLE QUOTES IN STRING X
        !            52:        N Q,F,D S Q="""",D=""""""
        !            53:        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
        !            54:        Q X
        !            55: QUOTE(X)       ; PUT QUOTES AROUND STRING
        !            56:        S X=""""_$G(X)_"""" Q X
        !            57: FNO(X) ; gets a subfile's top level file number
        !            58:        N Y S X=+X
        !            59:        I $G(^DIC(X,0))]"" Q X
        !            60:        F  S Y=+$G(^DD(X,0,"UP")) D  Q:'$D(X)!(Y'>0)
        !            61:        . I $G(^DIC(Y,0))]"" K X Q
        !            62:        . S X=Y
        !            63:        . Q
        !            64:        Q Y
        !            65: GLO(Z) ; gets the file number from a global root
        !            66:        I '$D(@(Z_"0)"))#2 Q 0
        !            67:        N Y
        !            68:        S Y=+$P($G(@(Z_"0)")),U,2)
        !            69:        Q $$FNO(+Y)
        !            70: UP(X)  ; convert string X to uppercase
        !            71:        I X?.UNP Q X
        !            72:        N A,B,C S C=""
        !            73:        F A=1:1:$L(X) S B=$E(X,A) S C=C_$S(B?1L:$C($A(B)-32),1:B)
        !            74:        Q C
        !            75: ROUEXIST(X)    ; Execute routine existence test
        !            76:        G:X="" QRER I '$D(DISYS) N DISYS D OS^DII
        !            77:        I $G(^%ZOSF("TEST"))]"" X ^("TEST") Q $T
        !            78:        I $G(^DD("OS",DISYS,18))]"" X ^(18) Q $T
        !            79: QRER   Q 0
        !            80: F5     ;
        !            81: 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)
        !            82: TM     Q:%T'>0!(%F["D")
        !            83:        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:"   "))
        !            84:        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:" pm",1:" am")
        !            85:        Q
        !            86: M      ;; Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
        !            87: MU     ;; JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC
        !            88: F2     S %R=+$E(Y,4,5)_"/"_(+$E(Y,6,7))_"/"_$E(Y,2,3)
        !            89:        G TM
        !            90: F3     S %R=+$E(Y,6,7)_"/"_(+$E(Y,4,5))_"/"_$E(Y,2,3)
        !            91:        G TM
        !            92: F4     S %R=$E(Y,2,3)_"/"_$E(Y,4,5)_"/"_$E(Y,6,7)
        !            93:        G TM
        !            94: 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))
        !            95:        G TM
        !            96: 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))
        !            97:        G TM
        !            98:        ;
        !            99: HKERR(DIFILE,DIIENS,DIFLD,DIHOOK)      ;
        !           100:        N DIEXT
        !           101:        S DIEXT("FILE")=$G(DIFILE)
        !           102:        S DIEXT("FIELD")=$G(DIFLD)
        !           103:        S DIEXT("IENS")=$G(DIIENS)
        !           104:        S DIEXT(1)=$G(DIHOOK)
        !           105:        D BLD^DIALOG(120,DIHOOK,.DIEXT)
        !           106:        Q
        !           107:        ;