- DIP12 ;SFISC/TKW-PROCESS FROM-TO (CONT.) ;06:54 PM 18 Feb 2002 [ 12/09/2003 4:17 PM ]
- ;;22.0;VA FileMan;**97,1002**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- OPT ;Build code to extract field & test sort criteria, build sort description.
- N S,F,X,%,F1,F2,F3,T1,T2,T3,N,DIRANGE
- S S=$P(DPP(DJ),U),F=$P(DPP(DJ),U,2),N=$P(DPP(DJ),U,3) S:N["""" N=$$CONVQQ^DILIBF(N),DIRANGE=""
- S X="DISX("_DJ_")",DPP(DJ,"GET")=""
- I +$P(S,"E")=S,F D GET^DIOU(S,F,X,.%) I $D(%)#10 S DPP(DJ,"GET")=%
- I $D(DPP(DJ,"CM")) S DPP(DJ,"GET")=DPP(DJ,"CM")
- I $G(DPP(DJ,"SRTTXT"))="SORT" S DPP(DJ,"GET")=DPP(DJ,"GET")_" S:"_X_"]"""" "_X_"="_""" ""_"_X
- I +$P(S,"E")=S,F,$P(DPP(DJ),U,10)=2 D
- . N % S %=$P($G(^DD(S,F,0)),U,2) I %'["C",%'["N" Q
- . S DPP(DJ,"GET")=DPP(DJ,"GET")_" S:"_X_"]"""" "_X_"=+"_X
- . Q
- I $P(DPP(DJ),U,4)["@B" S %=X,DPP(DJ,"TXT")=N G O2
- I S,F=0 D BIJ^DIOU(S,.01,.%,.F) S X="D"_$G(%(S)) K %,F
- I '$D(DPP(DJ,"F")) S %=$$NULL^DIOC(X,"'"),DPP(DJ,"TXT")=N_" not null" G O2
- RANGE D FT S DIRANGE="" S:$G(DPP(DJ,"SRTTXT"))="RANGE" DIRANGE=""" ""_"
- S %=""
- I F1="?z" D G O2
- . I T1="z" S %="1",DPP(DJ,"TXT")="All "_N_" (includes nulls)" Q
- . I T1="@" S %=$$NULL^DIOC(X),DPP(DJ,"TXT")=N_" is null" Q
- . S %=$$AFT^DIOC(DIRANGE_X,T1,"'")
- . S DPP(DJ,"TXT")=N_$S(T3]"":" to "_T3,1:"")_" (includes nulls)"
- . Q
- S DPP(DJ,"TXT")=N_$S(F3]"":" from "_F3,1:"")
- I T1="@"!(T1="z") D G O2
- . S %="" I T1="@" S DPP(DJ,"TXT")=DPP(DJ,"TXT")_" (includes nulls)",%=$$NULL^DIOC(X)_"!("
- . S %=%_$$AFT^DIOC(DIRANGE_X,F1) S:T1="@" %=%_")"
- . Q
- I F3]"",F3=T3 S %=$$EQ^DIOC(X,T1),DPP(DJ,"TXT")=N_" equals "_F3 G O2
- S %=$$BTWI^DIOC(DIRANGE_X,F1,T1,"","SORT")
- I T3]"" S DPP(DJ,"TXT")=DPP(DJ,"TXT")_" to "_T3
- O2 S DPP(DJ,"QCON")="I "_%
- K DITYP Q
- ;
- FT ;ALSO CALLED BY DIP1
- S %=$G(DPP(DJ,"F")) I %="" S %=$G(DIPP(+$G(DIJ),"F"))
- S F1=$P(%,U),F2=$P(%,U,2),F3=$P(%,U,3) S:F3="" F3=F2 S:$E(F1)="""" F1=""""_F1
- S %=$G(DPP(DJ,"T")) I %="" S %=$G(DIPP(+$G(DIJ),"T"))
- S T1=$P(%,U),T2=$P(%,U,2),T3=$P(%,U,3) S:T3="" T3=T2
- Q
- ;
- CK ;VALIDATE FIELDS/DATA
- G QQ:X[U I X="@" S Y=X K DPP(DJ,"IX"),DPP(DJ,"PTRIX") Q
- I DITYP=1 S %DT="" D D ^%DT K %DT G:Y=-1 QQ S Y(0)=$$FMTE^DILIBF(Y,5) Q
- . S:$G(DITYP("D"))["T" %DT="T"
- . S:$G(DITYP("D"))["S" %DT=%DT_"S"
- . S %DT=%DT_$E("E",(DIFRTO="?")) Q
- I DITYP=3 D G:Y=-1 QQ Q
- . S Y=$G(DITYP("S","E",X)) I Y]"" S Y(0)=Y_" ("_X_")" W:DIFRTO="?" " USES INTERNAL CODE: "_Y Q
- . I $D(DITYP("S","I",X)) S Y=X,Y(0)=X_" ("_DITYP("S","I",X)_")" W:DIFRTO="?" " "_DITYP("S","I",X) Q
- . S D=$O(DITYP("S","E",X)) I D]"",$P(D,X)="" S Y=DITYP("S","E",D),Y(0)=Y_" ("_D_")" W:DIFRTO="?" $P(D,X,2,9)_" USES INTERNAL CODE: "_Y Q
- . I DIFRTO'="?" S Y=X Q
- . S Y=-1 Q
- I +$P(X,"E")=X!(DITYP'=2) S Y=X Q
- QQ S Y=-1,DIERR="Invalid Entry" Q:$G(DIQUIET)
- W $C(7),"??",DIERR Q
- DIP12 ;SFISC/TKW-PROCESS FROM-TO (CONT.) ;06:54 PM 18 Feb 2002 [ 12/09/2003 4:17 PM ]
- +1 ;;22.0;VA FileMan;**97,1002**;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- OPT ;Build code to extract field & test sort criteria, build sort description.
- +1 NEW S,F,X,%,F1,F2,F3,T1,T2,T3,N,DIRANGE
- +2 SET S=$PIECE(DPP(DJ),U)
- SET F=$PIECE(DPP(DJ),U,2)
- SET N=$PIECE(DPP(DJ),U,3)
- IF N[""""
- SET N=$$CONVQQ^DILIBF(N)
- SET DIRANGE=""
- +3 SET X="DISX("_DJ_")"
- SET DPP(DJ,"GET")=""
- +4 IF +$PIECE(S,"E")=S
- IF F
- DO GET^DIOU(S,F,X,.%)
- IF $DATA(%)#10
- SET DPP(DJ,"GET")=%
- +5 IF $DATA(DPP(DJ,"CM"))
- SET DPP(DJ,"GET")=DPP(DJ,"CM")
- +6 IF $GET(DPP(DJ,"SRTTXT"))="SORT"
- SET DPP(DJ,"GET")=DPP(DJ,"GET")_" S:"_X_"]"""" "_X_"="_""" ""_"_X
- +7 IF +$PIECE(S,"E")=S
- IF F
- IF $PIECE(DPP(DJ),U,10)=2
- Begin DoDot:1
- +8 NEW %
- SET %=$PIECE($GET(^DD(S,F,0)),U,2)
- IF %'["C"
- IF %'["N"
- QUIT
- +9 SET DPP(DJ,"GET")=DPP(DJ,"GET")_" S:"_X_"]"""" "_X_"=+"_X
- +10 QUIT
- End DoDot:1
- +11 IF $PIECE(DPP(DJ),U,4)["@B"
- SET %=X
- SET DPP(DJ,"TXT")=N
- GOTO O2
- +12 IF S
- IF F=0
- DO BIJ^DIOU(S,.01,.%,.F)
- SET X="D"_$GET(%(S))
- KILL %,F
- +13 IF '$DATA(DPP(DJ,"F"))
- SET %=$$NULL^DIOC(X,"'")
- SET DPP(DJ,"TXT")=N_" not null"
- GOTO O2
- RANGE DO FT
- SET DIRANGE=""
- IF $GET(DPP(DJ,"SRTTXT"))="RANGE"
- SET DIRANGE=""" ""_"
- +1 SET %=""
- +2 IF F1="?z"
- Begin DoDot:1
- +3 IF T1="z"
- SET %="1"
- SET DPP(DJ,"TXT")="All "_N_" (includes nulls)"
- QUIT
- +4 IF T1="@"
- SET %=$$NULL^DIOC(X)
- SET DPP(DJ,"TXT")=N_" is null"
- QUIT
- +5 SET %=$$AFT^DIOC(DIRANGE_X,T1,"'")
- +6 SET DPP(DJ,"TXT")=N_$SELECT(T3]"":" to "_T3,1:"")_" (includes nulls)"
- +7 QUIT
- End DoDot:1
- GOTO O2
- +8 SET DPP(DJ,"TXT")=N_$SELECT(F3]"":" from "_F3,1:"")
- +9 IF T1="@"!(T1="z")
- Begin DoDot:1
- +10 SET %=""
- IF T1="@"
- SET DPP(DJ,"TXT")=DPP(DJ,"TXT")_" (includes nulls)"
- SET %=$$NULL^DIOC(X)_"!("
- +11 SET %=%_$$AFT^DIOC(DIRANGE_X,F1)
- IF T1="@"
- SET %=%_")"
- +12 QUIT
- End DoDot:1
- GOTO O2
- +13 IF F3]""
- IF F3=T3
- SET %=$$EQ^DIOC(X,T1)
- SET DPP(DJ,"TXT")=N_" equals "_F3
- GOTO O2
- +14 SET %=$$BTWI^DIOC(DIRANGE_X,F1,T1,"","SORT")
- +15 IF T3]""
- SET DPP(DJ,"TXT")=DPP(DJ,"TXT")_" to "_T3
- O2 SET DPP(DJ,"QCON")="I "_%
- +1 KILL DITYP
- QUIT
- +2 ;
- FT ;ALSO CALLED BY DIP1
- +1 SET %=$GET(DPP(DJ,"F"))
- IF %=""
- SET %=$GET(DIPP(+$GET(DIJ),"F"))
- +2 SET F1=$PIECE(%,U)
- SET F2=$PIECE(%,U,2)
- SET F3=$PIECE(%,U,3)
- IF F3=""
- SET F3=F2
- IF $EXTRACT(F1)=""""
- SET F1=""""_F1
- +3 SET %=$GET(DPP(DJ,"T"))
- IF %=""
- SET %=$GET(DIPP(+$GET(DIJ),"T"))
- +4 SET T1=$PIECE(%,U)
- SET T2=$PIECE(%,U,2)
- SET T3=$PIECE(%,U,3)
- IF T3=""
- SET T3=T2
- +5 QUIT
- +6 ;
- CK ;VALIDATE FIELDS/DATA
- +1 IF X[U
- GOTO QQ
- IF X="@"
- SET Y=X
- KILL DPP(DJ,"IX"),DPP(DJ,"PTRIX")
- QUIT
- +2 IF DITYP=1
- SET %DT=""
- Begin DoDot:1
- +3 IF $GET(DITYP("D"))["T"
- SET %DT="T"
- +4 IF $GET(DITYP("D"))["S"
- SET %DT=%DT_"S"
- +5 SET %DT=%DT_$EXTRACT("E",(DIFRTO="?"))
- QUIT
- End DoDot:1
- DO ^%DT
- KILL %DT
- IF Y=-1
- GOTO QQ
- SET Y(0)=$$FMTE^DILIBF(Y,5)
- QUIT
- +6 IF DITYP=3
- Begin DoDot:1
- +7 SET Y=$GET(DITYP("S","E",X))
- IF Y]""
- SET Y(0)=Y_" ("_X_")"
- IF DIFRTO="?"
- WRITE " USES INTERNAL CODE: "_Y
- QUIT
- +8 IF $DATA(DITYP("S","I",X))
- SET Y=X
- SET Y(0)=X_" ("_DITYP("S","I",X)_")"
- IF DIFRTO="?"
- WRITE " "_DITYP("S","I",X)
- QUIT
- +9 SET D=$ORDER(DITYP("S","E",X))
- IF D]""
- IF $PIECE(D,X)=""
- SET Y=DITYP("S","E",D)
- SET Y(0)=Y_" ("_D_")"
- IF DIFRTO="?"
- WRITE $PIECE(D,X,2,9)_" USES INTERNAL CODE: "_Y
- QUIT
- +10 IF DIFRTO'="?"
- SET Y=X
- QUIT
- +11 SET Y=-1
- QUIT
- End DoDot:1
- IF Y=-1
- GOTO QQ
- QUIT
- +12 IF +$PIECE(X,"E")=X!(DITYP'=2)
- SET Y=X
- QUIT
- QQ SET Y=-1
- SET DIERR="Invalid Entry"
- IF $GET(DIQUIET)
- QUIT
- +1 WRITE $CHAR(7),"??",DIERR
- QUIT
