DIP12 ;SFISC/TKW - PROCESS FROM-TO (CONT.) ;2SEP2015
;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
OPT ;For one SORT level (#DJ), build code to extract field & test sort criteria, build sort description. Called from DIP1 & DIP11
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")=""
GET I +$P(S,"E")=S,F D
.N DIT,DIFLAG,DITT
.S DIT=$$GETMETH^DIETLIBF(S,F,"TRANSFORM FOR SORT") I DIT]"" S DIFLAG="I"
.D GET^DIOU(S,F,X,.%,$G(DIFLAG))
.I '$D(%) S $P(DPP(DJ),U,2)=0,DPP(DJ,"GET")="S "_X_"=""""" Q ;IF THERE IS NO SUCH FIELD ANYMORE
.I DIT]"" D ;TRANSFORM FOR SORT PURPOSES
..S DITT="^UTILITY($J,""TRANSF"","_DJ_",",DPP(DJ,"OUT")="S:Y]"""" Y=$G("_DITT_"Y))"
..S %=%_" N X,DIT S (X,DIT)="_X_" "_DIT_" S "_X_"=X S:X]"""" "_DITT_"X)=DIT"
.S DPP(DJ,"GET")=%
.I N=$P($G(^DD(S,F,0)),U) S %=$$LABEL^DIALOGZ(S,F) I %]"" S DPP(DJ,"LANG")=N,(DPP(DJ,"LANG",+$G(DUZ("LANG"))),N)=%,$P(DPP(DJ),U,3)=N ;FIELD LABEL
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 ;SORTING BY A BOOLEAN EXPRESSION, SO NO 'FROM' OR 'TO'
I S,F=0 D BIJ^DIOU(S,.01,.%,.F) S X="D"_$G(%(S)) K %,F ;SORTING BY IEN
NOTNULL I '$D(DPP(DJ,"F")) S %=$$NULL^DIOC(X,"'"),DPP(DJ,"TXT")=$$EZBLD^DIALOG(7093,N) G O2 ;'NOT NULL'
RANGE D FT S DIRANGE="" S:$G(DPP(DJ,"SRTTXT"))="RANGE" DIRANGE=""" ""_"
S %=""
I F1="?z" D G O2
ALL . I T1="z" S %="1",DPP(DJ,"TXT")="All "_N_$$EZBLD^DIALOG(7094) Q ;'INCLUDES NULLS'
NULL . I T1="@" S %=$$NULL^DIOC(X),DPP(DJ,"TXT")=$$EZBLD^DIALOG(7092,N) Q ;'IS NULL'
. S %=$$AFT^DIOC(DIRANGE_X,T1,"'")
NULLPLUS . S DPP(DJ,"TXT")=N_$S(T3]"":" to "_T3,1:"")_$$EZBLD^DIALOG(7094) ;'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")_$$EZBLD^DIALOG(7094),%=$$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 ;'FROM' AND 'TO' VALUES. ALSO CALLED BY DIP1
;BUILD 'F1', THE INTERNAL VALUE OF 'FROM'
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
I $G(DPP(DJ,"FCOMPUTED"))]"" N X M X=DPP(DJ,"FCOMPUTED") X X S Y=X D PAR^DIP1(1,Y),FRV^DIP1 S $P(DPP(1,"F"),U)=Y,(F2,F1)=X ;DO COMPUTATION NOW!!
;BUILD 'T1', THE INTERNAL VALUE OF 'TO'
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
I $G(DPP(DJ,"TCOMPUTED"))]"" N X M X=DPP(DJ,"TCOMPUTED") X X S Y=X D PAR^DIP1(2,Y) S:DITYP=1&Y&(Y'[".") Y=Y_".24" S $P(DPP(1,"T"),U)=Y,(T2,T1)=X ;DO COMPUTATION NOW!!
Q
;
CK ;VALIDATE FIELDS/DATA. CALLED BY DIP1
G QQ:X[U I X="@" S Y=X K DPP(DJ,"IX"),DPP(DJ,"PTRIX") Q
I $D(DITYP("D")) D G:Y=-1 QQ Q ;ASK FOR A DATE EXTENDED DATA TYPE MIGHT BE DATE-VALUED
.N %DT S %DT=""
.S:$G(DITYP("D"))["T" %DT="T"
.S:$G(DITYP("D"))["S" %DT=%DT_"S"
.S %DT=%DT_$E("E",(DIFRTO="?"))
.D ^%DT I Y>0 D S Y(0)=%DT
..S %DT=Y N Y S Y=%DT X ^DD("DD") S %DT=Y
I $D(DITYP("S"))>9 D G:Y=-1 QQ Q ;ASK FOR A 'SET' VALUE EXTENDED DATA TYPE MIGHT HAVE 'SET OF CODES'
. S Y=$G(DITYP("S","E",X)) I Y]"" S Y(0)=Y_" ("_X_")" W:DIFRTO="?" " ",$$EZBLD^DIALOG(8146,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)_" ",$$EZBLD^DIALOG(8146,Y) Q ;'USES INTERNAL CODE SUCH&SUCH'
. 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 D Q:$G(DIQUIET)
.N I S I(1)=X,I(2)=$P($G(^DI(.81,DITYP,0)),U),DIERR=$$EZBLD^DIALOG(330,.I) ;'INVALID ENTRY'
W $C(7),"??",!?8,DIERR Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIP12 4557 printed Jan 18, 2025@03:53:39 Page 2
DIP12 ;SFISC/TKW - PROCESS FROM-TO (CONT.) ;2SEP2015
+1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
OPT ;For one SORT level (#DJ), build code to extract field & test sort criteria, build sort description. Called from DIP1 & DIP11
+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")=""
GET IF +$PIECE(S,"E")=S
IF F
Begin DoDot:1
+1 NEW DIT,DIFLAG,DITT
+2 SET DIT=$$GETMETH^DIETLIBF(S,F,"TRANSFORM FOR SORT")
IF DIT]""
SET DIFLAG="I"
+3 DO GET^DIOU(S,F,X,.%,$GET(DIFLAG))
+4 ;IF THERE IS NO SUCH FIELD ANYMORE
IF '$DATA(%)
SET $PIECE(DPP(DJ),U,2)=0
SET DPP(DJ,"GET")="S "_X_"="""""
QUIT
+5 ;TRANSFORM FOR SORT PURPOSES
IF DIT]""
Begin DoDot:2
+6 SET DITT="^UTILITY($J,""TRANSF"","_DJ_","
SET DPP(DJ,"OUT")="S:Y]"""" Y=$G("_DITT_"Y))"
+7 SET %=%_" N X,DIT S (X,DIT)="_X_" "_DIT_" S "_X_"=X S:X]"""" "_DITT_"X)=DIT"
End DoDot:2
+8 SET DPP(DJ,"GET")=%
+9 ;FIELD LABEL
IF N=$PIECE($GET(^DD(S,F,0)),U)
SET %=$$LABEL^DIALOGZ(S,F)
IF %]""
SET DPP(DJ,"LANG")=N
SET (DPP(DJ,"LANG",+$GET(DUZ("LANG"))),N)=%
SET $PIECE(DPP(DJ),U,3)=N
End DoDot:1
+10 IF $DATA(DPP(DJ,"CM"))
SET DPP(DJ,"GET")=DPP(DJ,"CM")
+11 IF $GET(DPP(DJ,"SRTTXT"))="SORT"
SET DPP(DJ,"GET")=DPP(DJ,"GET")_" S:"_X_"]"""" "_X_"="_""" ""_"_X
+12 IF +$PIECE(S,"E")=S
IF F
IF $PIECE(DPP(DJ),U,10)=2
Begin DoDot:1
+13 NEW %
SET %=$PIECE($GET(^DD(S,F,0)),U,2)
IF %'["C"
IF %'["N"
QUIT
+14 SET DPP(DJ,"GET")=DPP(DJ,"GET")_" S:"_X_"]"""" "_X_"=+"_X
+15 QUIT
End DoDot:1
+16 ;SORTING BY A BOOLEAN EXPRESSION, SO NO 'FROM' OR 'TO'
IF $PIECE(DPP(DJ),U,4)["@B"
SET %=X
SET DPP(DJ,"TXT")=N
GOTO O2
+17 ;SORTING BY IEN
IF S
IF F=0
DO BIJ^DIOU(S,.01,.%,.F)
SET X="D"_$GET(%(S))
KILL %,F
NOTNULL ;'NOT NULL'
IF '$DATA(DPP(DJ,"F"))
SET %=$$NULL^DIOC(X,"'")
SET DPP(DJ,"TXT")=$$EZBLD^DIALOG(7093,N)
GOTO O2
RANGE DO FT
SET DIRANGE=""
if $GET(DPP(DJ,"SRTTXT"))="RANGE"
SET DIRANGE=""" ""_"
+1 SET %=""
+2 IF F1="?z"
Begin DoDot:1
ALL ;'INCLUDES NULLS'
IF T1="z"
SET %="1"
SET DPP(DJ,"TXT")="All "_N_$$EZBLD^DIALOG(7094)
QUIT
NULL ;'IS NULL'
IF T1="@"
SET %=$$NULL^DIOC(X)
SET DPP(DJ,"TXT")=$$EZBLD^DIALOG(7092,N)
QUIT
+1 SET %=$$AFT^DIOC(DIRANGE_X,T1,"'")
NULLPLUS ;'INCLUDES NULLS'
SET DPP(DJ,"TXT")=N_$SELECT(T3]"":" to "_T3,1:"")_$$EZBLD^DIALOG(7094)
+1 QUIT
End DoDot:1
GOTO O2
+2 SET DPP(DJ,"TXT")=N_$SELECT(F3]"":" from "_F3,1:"")
+3 IF T1="@"!(T1="z")
Begin DoDot:1
+4 SET %=""
IF T1="@"
SET DPP(DJ,"TXT")=DPP(DJ,"TXT")_$$EZBLD^DIALOG(7094)
SET %=$$NULL^DIOC(X)_"!("
+5 SET %=%_$$AFT^DIOC(DIRANGE_X,F1)
if T1="@"
SET %=%_")"
+6 QUIT
End DoDot:1
GOTO O2
+7 IF F3]""
IF F3=T3
SET %=$$EQ^DIOC(X,T1)
SET DPP(DJ,"TXT")=N_" equals "_F3
GOTO O2
+8 SET %=$$BTWI^DIOC(DIRANGE_X,F1,T1,"","SORT")
+9 IF T3]""
SET DPP(DJ,"TXT")=DPP(DJ,"TXT")_" to "_T3
O2 SET DPP(DJ,"QCON")="I "_%
+1 KILL DITYP
QUIT
+2 ;
FT ;'FROM' AND 'TO' VALUES. ALSO CALLED BY DIP1
+1 ;BUILD 'F1', THE INTERNAL VALUE OF 'FROM'
+2 SET %=$GET(DPP(DJ,"F"))
IF %=""
SET %=$GET(DIPP(+$GET(DIJ),"F"))
+3 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
+4 ;DO COMPUTATION NOW!!
IF $GET(DPP(DJ,"FCOMPUTED"))]""
NEW X
MERGE X=DPP(DJ,"FCOMPUTED")
XECUTE X
SET Y=X
DO PAR^DIP1(1,Y)
DO FRV^DIP1
SET $PIECE(DPP(1,"F"),U)=Y
SET (F2,F1)=X
+5 ;BUILD 'T1', THE INTERNAL VALUE OF 'TO'
+6 SET %=$GET(DPP(DJ,"T"))
IF %=""
SET %=$GET(DIPP(+$GET(DIJ),"T"))
+7 SET T1=$PIECE(%,U)
SET T2=$PIECE(%,U,2)
SET T3=$PIECE(%,U,3)
if T3=""
SET T3=T2
+8 ;DO COMPUTATION NOW!!
IF $GET(DPP(DJ,"TCOMPUTED"))]""
NEW X
MERGE X=DPP(DJ,"TCOMPUTED")
XECUTE X
SET Y=X
DO PAR^DIP1(2,Y)
if DITYP=1&Y&(Y'[".")
SET Y=Y_".24"
SET $PIECE(DPP(1,"T"),U)=Y
SET (T2,T1)=X
+9 QUIT
+10 ;
CK ;VALIDATE FIELDS/DATA. CALLED BY DIP1
+1 if X[U
GOTO QQ
IF X="@"
SET Y=X
KILL DPP(DJ,"IX"),DPP(DJ,"PTRIX")
QUIT
+2 ;ASK FOR A DATE EXTENDED DATA TYPE MIGHT BE DATE-VALUED
IF $DATA(DITYP("D"))
Begin DoDot:1
+3 NEW %DT
SET %DT=""
+4 if $GET(DITYP("D"))["T"
SET %DT="T"
+5 if $GET(DITYP("D"))["S"
SET %DT=%DT_"S"
+6 SET %DT=%DT_$EXTRACT("E",(DIFRTO="?"))
+7 DO ^%DT
IF Y>0
Begin DoDot:2
+8 SET %DT=Y
NEW Y
SET Y=%DT
XECUTE ^DD("DD")
SET %DT=Y
End DoDot:2
SET Y(0)=%DT
End DoDot:1
if Y=-1
GOTO QQ
QUIT
+9 ;ASK FOR A 'SET' VALUE EXTENDED DATA TYPE MIGHT HAVE 'SET OF CODES'
IF $DATA(DITYP("S"))>9
Begin DoDot:1
+10 SET Y=$GET(DITYP("S","E",X))
IF Y]""
SET Y(0)=Y_" ("_X_")"
if DIFRTO="?"
WRITE " ",$$EZBLD^DIALOG(8146,Y)
QUIT
+11 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
+12 ;'USES INTERNAL CODE SUCH&SUCH'
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)_" ",$$EZBLD^DIALOG(8146,Y)
QUIT
+13 IF DIFRTO'="?"
SET Y=X
QUIT
+14 SET Y=-1
QUIT
End DoDot:1
if Y=-1
GOTO QQ
QUIT
+15 IF +$PIECE(X,"E")=X!(DITYP'=2)
SET Y=X
QUIT
QQ SET Y=-1
Begin DoDot:1
+1 ;'INVALID ENTRY'
NEW I
SET I(1)=X
SET I(2)=$PIECE($GET(^DI(.81,DITYP,0)),U)
SET DIERR=$$EZBLD^DIALOG(330,.I)
End DoDot:1
if $GET(DIQUIET)
QUIT
+2 WRITE $CHAR(7),"??",!?8,DIERR
QUIT
