DIP1 ;SFISC/GFT,TKW-PROCESS FROM-TO ;02:37 PM 30 Apr 2002 [ 12/09/2003 4:16 PM ]
;;22.0;VA FileMan;**2,25,34,64,79,97,1002**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
D DJ Q
DUP D DPQ G DIP1^DIQQQ:$D(A(1))
I '($D(BY)#2),$D(DPP((+$G(DPP(0))+2),"T"))!$D(DPP((+$G(DPP(0))+3)))!$D(DPP(0))!$D(DXS) S DK=S G S^DIBT
DIP2 S DC=0 D:'$D(DISYS) OS^DII G ^DIP2
;
FTEM I $G(DIBT1) I $O(^DIBT(DIBT1,2,0))!$G(^DIBT(DIBT1,"BY0"))]"" D
.I $D(DIBTOLD) D SNEW^DIBT Q
.D US^DIBT Q
N ;
S DCC=DI,C="," G DIP2
;
DPQ K A S DPP=$G(DPP(0)) F X=DPP+1:1 Q:$D(DPP(X))#2=0 S A=$E($P(DPP(X),U,1,3),1,60),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))=""
K DPP(X) Q
;
DIP11 ;FROM DIP11
N F1,F2,F3,T1,T2,T3 D FT^DIP12
K DPP(DJ,"F"),DPP(DJ,"T"),DIARS,DIARE G J
;
DJ ;CALLED FROM DIP ROUTINE AT 2 PLACES
N F1,F2,F3,T1,T2,T3,DIFLD,DIFLDREG
D DTYP I $D(DPP(DJ,"F")) D OPT^DIP12 Q
D FT^DIP12
J ;
N DIFRO,DIPR
S A=+DPP(DJ),R=$P(DPP(DJ),U,3)
I $P(DPP(DJ),U,10)=3 S T3=$G(T2),F3=$G(F2)
I $P(DPP(DJ),U,10)=1,T3?.E1"@24:00" S T3=$P(T3,"@")
I DIFLD,$D(^DD(A,DIFLD,0)) S DC=$P(^(0),U,2,3),DIPR=$P(^(0),U)
E I DIFLDREG]"",$D(^DD(A,.001,0)) S DC=$P(^(0),U,2,3),DIPR=$P(^(0),U)
E S DC=$P(DPP(DJ),U,7,8),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)-%)
K DIC,DIARE,DIARS N DIFRTO
S K DIERR,DPP(DJ,"SRTTXT")
S A="FIRST",DIFRTO="?" I 'L I $D(FR)#2!($O(FR(0))) D Z("FR") I DIFRTO'="?" G S0
I $D(DISV) D FROM^DIARCALC
PREV K DIR I $G(F3)]"" S A=F3,X=$G(DPP(DJ,"TXT")) S:X="" X=$G(DIPP(DIJ,"TXT")) I X]"" S DIR("A",1)=$J("",DJ-1*2)_"* Previous selection: "_X
S DIR(0)="FO^1:245",DIR("A")=$J("",DJ-1*2)_"START WITH "_DIPR,DIR("?")="^D DIP1^DIQQ(1)" S:A]"" DIR("B")=A
D ^DIR W:$D(DTOUT) $C(7) G Q:$D(DTOUT)!$D(DUOUT)
I X="FIRST" S A="FIRST",X=""
K DIR,DIRUT,DIROUT,DIERR
S0 I X="",A="FIRST" D:$P(DPP(DJ),U,5)[";TXT" STXT(DJ,"","",DITYP) D OPT^DIP12 Q
S Y(0)="" D CK^DIP12:X'="" I X'="" I X'?.ANP!($D(DIERR)) G:DIFRTO="?" S G Q
QUOTE I $A(X)=34,'$G(DIQUIET),DIFRTO="?" W !,"(Note that this value, starting with a quote (""""), precedes all alphanumerics)"
D PAR(1)
D FRV
S Y=Y_U_X S:Y(0)]"" Y=Y_U_Y(0) S (B,DPP(DJ,"F"))=Y
T K DIERR S Y="z",A="LAST",DIFRTO="?" I 'L I $D(TO)#2!($O(TO(0))) D Z("TO") I DIFRTO'="?" G T0
I $D(DISV) D TO^DIARCALC
G T0:$G(DIAR)=4
TOPR K DIR S DIR(0)="FO^1:245",DIR("A")=$J("",DJ-1*2)_"GO TO "_DIPR,DIR("?")="^D DIP1^DIQQ(2)" D S:A]"" DIR("B")=A
.I $G(T3)]"" S A=T3 I $G(T1)]"",$$BEF^DIU5(T1,$P(B,U)) S A="LAST"
D ^DIR W:$D(DTOUT) $C(7) G Q:$D(DUOUT)!($D(DTOUT))
I X="LAST" S X="",Y="z"
K DIR,DIRUT,DIROUT,DIERR
T0 S Y(0)=""
D STXT(DJ,B,"^"_X,DITYP)
I $D(DPP(DJ,"SRTTXT")) S:$G(DPP(DJ,"F"))]"" B=DPP(DJ,"F")
D:X]"" CK^DIP12 I $D(DIERR) G:DIFRTO="?" T G Q
2400 I DITYP=1,Y,Y'["." S Y=Y_".24",X=X_"@2400",Y(0)=Y(0)_"@24:00"
I Y'="z" D PAR(2)
S:$D(DPP(DJ,"SRTTXT")) Y=$P(" ",U,(X'="@"))_Y S Y=Y_U_X S:Y(0)]"" Y=Y_U_Y(0) S DPP(DJ,"T")=Y
I B["?z"!($P(Y,U)="@") D OPT^DIP12 Q
I $$BEF^DIU5($P(Y,U),$P(B,U)) D:'$G(DIQUIET) FER1^DIQQ G:DIFRTO="?" T G Q
D OPT^DIP12 Q
;
FRV N M I +$P(Y,"E")=Y S Y=Y-$S(Y:.000001,$P(DPP(DJ),U,2)'=0&$L(DC):1,1:0) Q
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
Q
;
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
S S=$P(DPP(DJ),U)
D1 K DITYP S DITYP=""
I DIFLD D DTYP^DIOU(+S,DIFLD,.DITYP) I $G(^DD(S,DIFLD,2))]"",DITYP'=1 S DITYP=4 ;GFT
I DITYP=6,$G(DITYP("T"))=1 S DITYP("D")="TS"
S:$G(DITYP("T")) DITYP=DITYP("T")
I DITYP="",'DIFLD,$P(DPP(DJ),U,7)]"" D
. N I,X S X=$P(DPP(DJ),U,7),I=""
. F S I=$O(^DI(.81,"C",I)) Q:I="" I X[I S DITYP=$O(^(I,0)) Q
. S:DITYP=1 DITYP("D")="TS"
. Q
S:'DITYP DITYP=4
DTYPQ S $P(DPP(DJ),U,10)=DITYP Q
;
Q K DITYP,DIERR,DIR S:$D(DTOUT) X="^" G Q^DIP
;
PAR(M) S M=$P($P($P($P(DPP(DJ),U,5),";P",2),";",1),"-",M)
I M?1.ANP S DIPA($E(M,1,30))=Y
Q
;
Z(%) I %="FR" S X=$S($D(FR)#2:$P(FR,",",DJ),$D(FR(DJ))#2:FR(DJ),1:"?")
I %="TO" S X=$S($D(TO)#2:$P(TO,",",DJ),$D(TO(DJ))#2:TO(DJ),1:"?")
I X'="?" S DIFRTO=""
Q
;
STXT(DJ,F,T,DITYP) ;DETERMINE IF USER WANTS TO SORT FREE-TEXT FIELDS CONTAINING NUMBERS AS TEXT.
K DPP(DJ,"SRTTXT") Q:"3,4"'[DITYP
N F2,T2 S F2=$P(F,U,2),T2=$P(T,U,2)
I F2]"" Q:F2=T2 Q:($E(F2,1)?1A)&($E(T2,1)?1A) I F2?1.N.1".".N,T2?1.N.1".".N Q:+F2'=F2&(+T2'=T2)
I $P($G(DPP(DJ)),U,5)[";TXT" S DPP(DJ,"SRTTXT")="SORT" G N2
Q:+$E(F2,"E")=F2&(+$E(T2,"E")=T2)
I F2?1.N.1".".N,+F2'=F2 S DPP(DJ,"SRTTXT")="RANGE"
I T2?1.N.1".".N,+T2'=T2 S DPP(DJ,"SRTTXT")="RANGE"
N2 Q:'$D(DPP(DJ,"SRTTXT"))
K DPP(DJ,"IX"),DPP(DJ,"PTRIX")
I F]"",$P(F,U)'="?z",$G(DPP(DJ,"F"))]"" N Y D S DPP(DJ,"F")=Y_U_$P(F,U,2,3)
. S Y=$P(F,U) I F2]"" S Y=" "_F2 D FRV
. Q
Q:$G(DPP(DJ,"T"))=""!("@"[$P(T,U))
S DPP(DJ,"T")=$S($P(T,U,2)]"":" "_$P(T,U,2)_U_$P(T,U,2,3),1:T) Q
DIP1 ;SFISC/GFT,TKW-PROCESS FROM-TO ;02:37 PM 30 Apr 2002 [ 12/09/2003 4:16 PM ]
+1 ;;22.0;VA FileMan;**2,25,34,64,79,97,1002**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO DJ
QUIT
DUP DO DPQ
IF $DATA(A(1))
GOTO DIP1^DIQQQ
+1 IF '($DATA(BY)#2)
IF $DATA(DPP((+$GET(DPP(0))+2),"T"))!$DATA(DPP((+$GET(DPP(0))+3)))!$DATA(DPP(0))!$DATA(DXS)
SET DK=S
GOTO S^DIBT
DIP2 SET DC=0
IF '$DATA(DISYS)
DO OS^DII
GOTO ^DIP2
+1 ;
FTEM IF $GET(DIBT1)
IF $ORDER(^DIBT(DIBT1,2,0))!$GET(^DIBT(DIBT1,"BY0"))]""
Begin DoDot:1
+1 IF $DATA(DIBTOLD)
DO SNEW^DIBT
QUIT
+2 DO US^DIBT
QUIT
End DoDot:1
N ;
+1 SET DCC=DI
SET C=","
GOTO DIP2
+2 ;
DPQ KILL A
SET DPP=$GET(DPP(0))
FOR X=DPP+1:1
IF $DATA(DPP(X))#2=0
QUIT
SET A=$EXTRACT($PIECE(DPP(X),U,1,3),1,60)
SET Y=$PIECE(DPP(X),U,4)
SET DPP=X
IF Y'["'"
SET (A($DATA(A(A))),A(A))=0
IF Y'["@"
IF Y'["'"
SET DPQ(+DPP(X),$PIECE(Y,"""",2)+$PIECE(DPP(X),U,2))=""
+1 KILL DPP(X)
QUIT
+2 ;
DIP11 ;FROM DIP11
+1 NEW F1,F2,F3,T1,T2,T3
DO FT^DIP12
+2 KILL DPP(DJ,"F"),DPP(DJ,"T"),DIARS,DIARE
GOTO J
+3 ;
DJ ;CALLED FROM DIP ROUTINE AT 2 PLACES
+1 NEW F1,F2,F3,T1,T2,T3,DIFLD,DIFLDREG
+2 DO DTYP
IF $DATA(DPP(DJ,"F"))
DO OPT^DIP12
QUIT
+3 DO FT^DIP12
J ;
+1 NEW DIFRO,DIPR
+2 SET A=+DPP(DJ)
SET R=$PIECE(DPP(DJ),U,3)
+3 IF $PIECE(DPP(DJ),U,10)=3
SET T3=$GET(T2)
SET F3=$GET(F2)
+4 IF $PIECE(DPP(DJ),U,10)=1
IF T3?.E1"@24:00"
SET T3=$PIECE(T3,"@")
+5 IF DIFLD
IF $DATA(^DD(A,DIFLD,0))
SET DC=$PIECE(^(0),U,2,3)
SET DIPR=$PIECE(^(0),U)
+6 IF '$TEST
IF DIFLDREG]""
IF $DATA(^DD(A,.001,0))
SET DC=$PIECE(^(0),U,2,3)
SET DIPR=$PIECE(^(0),U)
+7 IF '$TEST
SET DC=$PIECE(DPP(DJ),U,7,8)
SET DIPR=$PIECE(DPP(DJ),";""",2,99)
SET DIPR=$PIECE(DIPR,"""",1,$LENGTH(DIPR,"""")-1)
SET DIPR=$SELECT(DIPR'="":DIPR,1:R)
SET %=$EXTRACT(DIPR,$LENGTH(DIPR)-1,$LENGTH(DIPR))
SET %=$SELECT(%=": ":2,$EXTRACT(%,2)=":":1,1:0)
IF %
SET DIPR=$EXTRACT(DIPR,1,$LENGTH(DIPR)-%)
+8 KILL DIC,DIARE,DIARS
NEW DIFRTO
S KILL DIERR,DPP(DJ,"SRTTXT")
+1 SET A="FIRST"
SET DIFRTO="?"
IF 'L
IF $DATA(FR)#2!($ORDER(FR(0)))
DO Z("FR")
IF DIFRTO'="?"
GOTO S0
+2 IF $DATA(DISV)
DO FROM^DIARCALC
PREV KILL DIR
IF $GET(F3)]""
SET A=F3
SET X=$GET(DPP(DJ,"TXT"))
IF X=""
SET X=$GET(DIPP(DIJ,"TXT"))
IF X]""
SET DIR("A",1)=$JUSTIFY("",DJ-1*2)_"* Previous selection: "_X
+1 SET DIR(0)="FO^1:245"
SET DIR("A")=$JUSTIFY("",DJ-1*2)_"START WITH "_DIPR
SET DIR("?")="^D DIP1^DIQQ(1)"
IF A]""
SET DIR("B")=A
+2 DO ^DIR
IF $DATA(DTOUT)
WRITE $CHAR(7)
IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO Q
+3 IF X="FIRST"
SET A="FIRST"
SET X=""
+4 KILL DIR,DIRUT,DIROUT,DIERR
S0 IF X=""
IF A="FIRST"
IF $PIECE(DPP(DJ),U,5)[";TXT"
DO STXT(DJ,"","",DITYP)
DO OPT^DIP12
QUIT
+1 SET Y(0)=""
IF X'=""
DO CK^DIP12
IF X'=""
IF X'?.ANP!($DATA(DIERR))
IF DIFRTO="?"
GOTO S
GOTO Q
QUOTE IF $ASCII(X)=34
IF '$GET(DIQUIET)
IF DIFRTO="?"
WRITE !,"(Note that this value, starting with a quote (""""), precedes all alphanumerics)"
+1 DO PAR(1)
+2 DO FRV
+3 SET Y=Y_U_X
IF Y(0)]""
SET Y=Y_U_Y(0)
SET (B,DPP(DJ,"F"))=Y
T KILL DIERR
SET Y="z"
SET A="LAST"
SET DIFRTO="?"
IF 'L
IF $DATA(TO)#2!($ORDER(TO(0)))
DO Z("TO")
IF DIFRTO'="?"
GOTO T0
+1 IF $DATA(DISV)
DO TO^DIARCALC
+2 IF $GET(DIAR)=4
GOTO T0
TOPR KILL DIR
SET DIR(0)="FO^1:245"
SET DIR("A")=$JUSTIFY("",DJ-1*2)_"GO TO "_DIPR
SET DIR("?")="^D DIP1^DIQQ(2)"
Begin DoDot:1
+1 IF $GET(T3)]""
SET A=T3
IF $GET(T1)]""
IF $$BEF^DIU5(T1,$PIECE(B,U))
SET A="LAST"
End DoDot:1
IF A]""
SET DIR("B")=A
+2 DO ^DIR
IF $DATA(DTOUT)
WRITE $CHAR(7)
IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO Q
+3 IF X="LAST"
SET X=""
SET Y="z"
+4 KILL DIR,DIRUT,DIROUT,DIERR
T0 SET Y(0)=""
+1 DO STXT(DJ,B,"^"_X,DITYP)
+2 IF $DATA(DPP(DJ,"SRTTXT"))
IF $GET(DPP(DJ,"F"))]""
SET B=DPP(DJ,"F")
+3 IF X]""
DO CK^DIP12
IF $DATA(DIERR)
IF DIFRTO="?"
GOTO T
GOTO Q
2400 IF DITYP=1
IF Y
IF Y'["."
SET Y=Y_".24"
SET X=X_"@2400"
SET Y(0)=Y(0)_"@24:00"
+1 IF Y'="z"
DO PAR(2)
+2 IF $DATA(DPP(DJ,"SRTTXT"))
SET Y=$PIECE(" ",U,(X'="@"))_Y
SET Y=Y_U_X
IF Y(0)]""
SET Y=Y_U_Y(0)
SET DPP(DJ,"T")=Y
+3 IF B["?z"!($PIECE(Y,U)="@")
DO OPT^DIP12
QUIT
+4 IF $$BEF^DIU5($PIECE(Y,U),$PIECE(B,U))
IF '$GET(DIQUIET)
DO FER1^DIQQ
IF DIFRTO="?"
GOTO T
GOTO Q
+5 DO OPT^DIP12
QUIT
+6 ;
FRV NEW M
IF +$PIECE(Y,"E")=Y
SET Y=Y-$SELECT(Y:.000001,$PIECE(DPP(DJ),U,2)'=0&$LENGTH(DC):1,1:0)
QUIT
+1 FOR %=$LENGTH($EXTRACT(Y,1,30)):-1:1
SET M=$ASCII(Y,%)
IF M>32
SET Y=$EXTRACT(Y,1,%-1)_$CHAR(M-1)_$CHAR(122)
QUIT
+2 QUIT
+3 ;
DTYP NEW S
SET DIFLDREG=$PIECE(DPP(DJ),U,2)
SET DIFLD=DIFLDREG+$PIECE($PIECE(DPP(DJ),U,4),"""",2)
IF 'DIFLD
IF DIFLDREG'=""
SET DIFLD=.001
+1 SET S=$PIECE(DPP(DJ),U)
D1 KILL DITYP
SET DITYP=""
+1 ;GFT
IF DIFLD
DO DTYP^DIOU(+S,DIFLD,.DITYP)
IF $GET(^DD(S,DIFLD,2))]""
IF DITYP'=1
SET DITYP=4
+2 IF DITYP=6
IF $GET(DITYP("T"))=1
SET DITYP("D")="TS"
+3 IF $GET(DITYP("T"))
SET DITYP=DITYP("T")
+4 IF DITYP=""
IF 'DIFLD
IF $PIECE(DPP(DJ),U,7)]""
Begin DoDot:1
+5 NEW I,X
SET X=$PIECE(DPP(DJ),U,7)
SET I=""
+6 FOR
SET I=$ORDER(^DI(.81,"C",I))
IF I=""
QUIT
IF X[I
SET DITYP=$ORDER(^(I,0))
QUIT
+7 IF DITYP=1
SET DITYP("D")="TS"
+8 QUIT
End DoDot:1
+9 IF 'DITYP
SET DITYP=4
DTYPQ SET $PIECE(DPP(DJ),U,10)=DITYP
QUIT
+1 ;
Q KILL DITYP,DIERR,DIR
IF $DATA(DTOUT)
SET X="^"
GOTO Q^DIP
+1 ;
PAR(M) SET M=$PIECE($PIECE($PIECE($PIECE(DPP(DJ),U,5),";P",2),";",1),"-",M)
+1 IF M?1.ANP
SET DIPA($EXTRACT(M,1,30))=Y
+2 QUIT
+3 ;
Z(%) IF %="FR"
SET X=$SELECT($DATA(FR)#2:$PIECE(FR,",",DJ),$DATA(FR(DJ))#2:FR(DJ),1:"?")
+1 IF %="TO"
SET X=$SELECT($DATA(TO)#2:$PIECE(TO,",",DJ),$DATA(TO(DJ))#2:TO(DJ),1:"?")
+2 IF X'="?"
SET DIFRTO=""
+3 QUIT
+4 ;
STXT(DJ,F,T,DITYP) ;DETERMINE IF USER WANTS TO SORT FREE-TEXT FIELDS CONTAINING NUMBERS AS TEXT.
+1 KILL DPP(DJ,"SRTTXT")
IF "3,4"'[DITYP
QUIT
+2 NEW F2,T2
SET F2=$PIECE(F,U,2)
SET T2=$PIECE(T,U,2)
+3 IF F2]""
IF F2=T2
QUIT
IF ($EXTRACT(F2,1)?1A)&($EXTRACT(T2,1)?1A)
QUIT
IF F2?1.N.1".".N
IF T2?1.N.1".".N
IF +F2'=F2&(+T2'=T2)
QUIT
+4 IF $PIECE($GET(DPP(DJ)),U,5)[";TXT"
SET DPP(DJ,"SRTTXT")="SORT"
GOTO N2
+5 IF +$EXTRACT(F2,"E")=F2&(+$EXTRACT(T2,"E")=T2)
QUIT
+6 IF F2?1.N.1".".N
IF +F2'=F2
SET DPP(DJ,"SRTTXT")="RANGE"
+7 IF T2?1.N.1".".N
IF +T2'=T2
SET DPP(DJ,"SRTTXT")="RANGE"
N2 IF '$DATA(DPP(DJ,"SRTTXT"))
QUIT
+1 KILL DPP(DJ,"IX"),DPP(DJ,"PTRIX")
+2 IF F]""
IF $PIECE(F,U)'="?z"
IF $GET(DPP(DJ,"F"))]""
NEW Y
Begin DoDot:1
+3 SET Y=$PIECE(F,U)
IF F2]""
SET Y=" "_F2
DO FRV
+4 QUIT
End DoDot:1
SET DPP(DJ,"F")=Y_U_$PIECE(F,U,2,3)
+5 IF $GET(DPP(DJ,"T"))=""!("@"[$PIECE(T,U))
QUIT
+6 SET DPP(DJ,"T")=$SELECT($PIECE(T,U,2)]"":" "_$PIECE(T,U,2)_U_$PIECE(T,U,2,3),1:T)
QUIT
