Return to DIP1.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DIP1.m, revision 1.1.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