Annotation of freem_fileman/USER/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
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DIP1.m CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem_fileman / USER