Return to DIP1.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DIP1.m, revision 1.1

1.1     ! snw         1: DIP1   ;SFISC/GFT,TKW-PROCESS FROM-TO ;11/16/94  10:29
        !             2:        ;;21.0;VA FileMan;;Dec 28, 1994
        !             3:        ;Per VHA Directive 10-93-142, this routine should not be modified.
        !             4:        D DJ Q
        !             5: DUP    D DPQ G DIP1^DIQQQ:$D(A(1))
        !             6:        I '$D(BY),$D(DPP(2,"T"))!$D(DPP(3))!$D(DXS) S DK=S G S^DIBT
        !             7: DIP2   S DC=0 D:'$D(DISYS) OS^DII G ^DIP2
        !             8:        ;
        !             9: FTEM   I $G(DIBT1),$O(^DIBT(DIBT1,2,0)) D
        !            10:        .I $D(DIBTOLD) D SNEW^DIBT Q
        !            11:        .D US^DIBT Q
        !            12: N      ;
        !            13:        S DCC=DI,C="," G DIP2
        !            14:        ;
        !            15: DPQ    K A F X=1:1 Q:$D(DPP(X))#2=0  S A=$E($P(DPP(X),U,1,3),1,30),Y=$P(DPP(X),U,4),DPP=X S:Y'["'" (A($D(A(A))),A(A))=0 I Y'["@",Y'["'" S DPQ(+DPP(X),$P(Y,"""",2)+$P(DPP(X),U,2))=""
        !            16:        K DPP(X) Q
        !            17:        ;
        !            18: DJ     N DIFLD,DIFLDREG D DTYP I $D(DPP(DJ,"F")) D OPT^DIP12 Q
        !            19: J      ;
        !            20:        S DC=$S($D(^DD(+DPP(DJ),$S(DIFLD:DIFLD,DIFLDREG="":U,1:.001),0)):$P(^(0),U,2,3),1:$P(DPP(DJ),U,7,8)),R=$P(DPP(DJ),U,3)
        !            21:        K DIC,DIARE,DIARS N DIFRTO
        !            22: S      K DIERR,DPP(DJ,"SRTTXT")
        !            23:        S DIPR=$P(DPP(DJ),";""",2,99),DIPR=$P(DIPR,"""",1,$L(DIPR,"""")-1),DIPR=$S(DIPR'="":DIPR,1:R),%=$E(DIPR,$L(DIPR)-1,$L(DIPR)),%=$S(%=": ":2,$E(%,2)=":":1,1:0) I % S DIPR=$E(DIPR,1,$L(DIPR)-%)
        !            24:        S A="FIRST",DIFRTO="?" I 'L I $D(FR)#2!($O(FR(0))) S %="FR" D Z I DIFRTO'="?" G S0
        !            25:        I $D(DISV) D FROM^DIARCALC
        !            26:        K DIR S %="",%(1)=$G(DPP(DJ,"TXT")) S:%(1)="" %(1)=$G(DIPP(DIJ,"TXT")) S:%(1)]"" $P(%," ",(DJ+DJ-1))="",DIR("A",1)=%_"* Previous selection: "_%(1) K %
        !            27:        S DIR(0)="FO^1:245",%="",$P(%," ",(DJ+DJ-1))="",DIR("A")=%_"START WITH "_DIPR,DIR("?")="^D DIP1F^DIQQ" S:A]"" DIR("B")=A
        !            28:        D ^DIR W:$D(DTOUT) $C(7) G Q:$D(DTOUT)!($D(DUOUT))
        !            29:        I $G(DIR("B"))="FIRST",X="FIRST" S A="FIRST",X=""
        !            30:        K DIR,DIRUT,DIROUT,DIERR
        !            31: S0     I X="",A="FIRST" D:$P(DPP(DJ),U,5)[";TXT" STXT(DJ,"","",DITYP) D OPT^DIP12 Q
        !            32:        S Y(0)="" D CK^DIP12:X'="" I X'="" I X'?.ANP!($D(DIERR)) G:DIFRTO="?" S G Q
        !            33:        S M=1 D PAR
        !            34:        D FRV
        !            35:        S Y=Y_U_X S:Y(0)]"" Y=Y_U_Y(0) S (B,DPP(DJ,"F"))=Y
        !            36: T      K DIERR S Y="z",A="LAST",DIFRTO="?" I 'L I $D(TO)#2!($O(TO(0))) S %="TO" D Z I DIFRTO'="?" G T0
        !            37:        I $D(DISV) D TO^DIARCALC
        !            38:        G T0:$G(DIAR)=4
        !            39:        K DIR S %="",$P(%," ",(DJ+DJ-1))="",DIR(0)="FO^1:245",DIR("A")=%_"GO TO "_DIPR,DIR("?")="^D DIP1T^DIQQ" S:A]"" DIR("B")=A
        !            40:        D ^DIR W:$D(DTOUT) $C(7) G Q:$D(DUOUT)!($D(DTOUT))
        !            41:        I X="LAST",$G(DIR("B"))="LAST" S X="",Y="z"
        !            42:        K DIR,DIRUT,DIROUT,DIERR
        !            43: T0     S Y(0)="" I DITYP=1,X]"",$D(DITYP("D"))#2 D
        !            44:        . N I,J S I=$S(X["@":"@",X[".":".",1:"")
        !            45:        . I I]"" S J=$P(X,I,2),J=$P(J,":")_$P(J,":",2)_$P(J,":",3) I $E(J,1,2)>23!($E(J,1,4)>2359)!($E(J,1,6)>235959) S X=$P(X,I),I=""
        !            46:        . Q:I]""
        !            47:        . S X=$S(DITYP("D")["S":X_"@23:59:59",DITYP("D")["T":X_"@23:59",1:X)
        !            48:        . Q
        !            49:        D STXT(DJ,B,"^"_X,DITYP) I $D(DPP(DJ,"SRTTXT")) S:$G(DPP(DJ,"F"))]"" B=DPP(DJ,"F") S X=" "_X
        !            50:        D:X]"" CK^DIP12 I $D(DIERR) G:DIFRTO="?" T G Q
        !            51:        S M=2 D PAR:Y'="z"
        !            52:        S Y=Y_U_X S:Y(0)]"" Y=Y_U_Y(0) S DPP(DJ,"T")=Y
        !            53:        I B["?z"!($P(Y,U)="@") D OPT^DIP12 Q
        !            54:        I $$BEF^DIU5($P(Y,U),$P(B,U)) D:'$G(DIQUIET) FER1^DIQQ G:DIFRTO="?" T G Q
        !            55:        D OPT^DIP12 Q
        !            56:        ;
        !            57: FRV    N M I +$P(Y,"E")=Y S Y=Y-$S(Y:.00001,$P(DPP(DJ),U,2)'=0&$L(DC):1,1:0) Q
        !            58:        F %=$L($E(Y,1,30)):-1:1 S M=$A(Y,%) I M>32 S Y=$E(Y,1,%-1)_$C(M-1)_$C(122) Q
        !            59:        Q
        !            60:        ;
        !            61: DTYP   N S S DIFLDREG=$P(DPP(DJ),U,2),DIFLD=DIFLDREG+$P($P(DPP(DJ),U,4),"""",2) I 'DIFLD,DIFLDREG'="" S DIFLD=.001
        !            62:        S S=$P(DPP(DJ),U)
        !            63: D1     K DITYP S DITYP=""
        !            64:        I S,DIFLD D DTYP^DIOU(S,DIFLD,.DITYP) I $G(^DD(S,DIFLD,2))]"",DITYP'=1 S DITYP=4
        !            65:        I DITYP=6,$G(DITYP("T"))=1 S DITYP("D")="TS"
        !            66:        S:$G(DITYP("T")) DITYP=DITYP("T")
        !            67:        I DITYP="",'DIFLD,$P(DPP(DJ),U,7)]"" D
        !            68:        . N I,X S X=$P(DPP(DJ),U,7),I=""
        !            69:        . F  S I=$O(^DI(.81,"C",I)) Q:I=""  I X[I S DITYP=$O(^(I,0)) Q
        !            70:        . Q
        !            71:        S:'DITYP DITYP=4
        !            72: DTYPQ  S $P(DPP(DJ),U,10)=DITYP Q
        !            73:        ;
        !            74: Q      K DITYP,DIERR,DIR S:$D(DTOUT) X="^" G Q^DIP
        !            75:        ;
        !            76: PAR    S M=$P($P($P($P(DPP(DJ),U,5),";P",2),";",1),"-",M)
        !            77:        I M]"",M?.ANP S DIPA($E(M,1,30))=Y
        !            78:        Q
        !            79:        ;
        !            80: Z      I %="FR" S X=$S($D(FR)#2:$P(FR,C,DJ),$D(FR(DJ))#2:FR(DJ),1:"?")
        !            81:        I %="TO" S X=$S($D(TO)#2:$P(TO,C,DJ),$D(TO(DJ))#2:TO(DJ),1:"?")
        !            82:        I X'="?" S DIFRTO=""
        !            83:        Q
        !            84:        ;
        !            85: STXT(DJ,F,T,DITYP)     ;DETERMINE IF USER WANTS TO SORT FREE-TEXT FIELDS CONTAINING NUMBERS AS TEXT.
        !            86:        K DPP(DJ,"SRTTXT") I $P($G(DPP(DJ)),U,5)[";TXT" D  G N2
        !            87:        . N Y S Y=$P(DPP(DJ),U,10) S:Y<3 $P(DPP(DJ),U,10)=4
        !            88:        . S DPP(DJ,"SRTTXT")="SORT" Q
        !            89:        Q:DITYP'=4
        !            90:        N Y S Y=$P(F,U,2) I Y?1.N.1"."1.N,+Y'=Y S DPP(DJ,"SRTTXT")="RANGE"
        !            91:        S Y=$P(T,U,2) I $D(DPP(DJ,"SRTTXT")) D  Q:'$D(DPP(DJ,"SRTTXT"))  G N2
        !            92:        . Q:Y'?1.N.1"."1.N  Q:+Y=Y  K DPP(DJ,"SRTTXT") Q
        !            93:        I Y?1.N.1"."1.N,+Y'=Y S DPP(DJ,"SRTTXT")="RANGE"
        !            94:        Q:'$D(DPP(DJ,"SRTTXT"))
        !            95: N2     K DPP(DJ,"IX"),DPP(DJ,"PTRIX")
        !            96:        I F]"" S Y=" "_$P(F,U,2) D FRV S:$G(DPP(DJ,"F"))]"" DPP(DJ,"F")=Y_U_" "_$P(F,U,2)_U_$P(F,U,3)
        !            97:        Q:T=""  Q:$G(DPP(DJ,"T"))=""
        !            98:        S DPP(DJ,"T")=" "_$P(T,U)_U_" "_$P(T,U,2)_U_$P(T,U,3) Q