DIP10 ;SFISC/TKW - PROCESS BY(0) INPUT VARIABLES ;12:59 PM 6 Aug 1999
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;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.
;
EN ;
N I,J,K,X,Y,DIR K DPP(0),DPP(1) I $G(BY(0))="" D BLD^DIALOG(201,"BY(0)")
I $G(BY(0))]"",$E($G(BY))="[" D BLD^DIALOG(201,"BY")
I $E(BY(0))'="[" D I Y=-1 D BLD^DIALOG(201,"BY(0)")
. N %,X S X=BY(0),Y="" I X'["(" S:X[")"!(X[",") Y=-1 Q:Y=-1 S X=X_"("
. S:$E(X)'=U X=U_X
. S %=$E(X,$L(X)) S:%=")" $E(X,$L(X))=",",%="," I ",("'[% S X=X_","
. S BY(0)=X Q
I $E(BY(0))="[" D I Y'<0 S BY(0)="^DIBT("_+Y_",1,",L(0)=1
.N DIC,DIBTFILE,DJ,DCC,DI,DNP,L S DIBTFILE=S N S
.S X=$P($E(BY(0),2,99),"]"),DIC="^DIBT(",DIC(0)="Q",DIC("S")="I '$P(^(0),U,8),$P(^(0),U,4)=DIBTFILE,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$O(^(1,0))"
.D ^DIC
.I Y<0 S I(1)=BY(0) D BLD^DIALOG(1500,.I)
.Q
I '$G(L(0))!($G(L(0))>8) D BLD^DIALOG(201,"L(0)")
G:$D(DIERR) EX
S DPP(0)=L(0)-1 K DISTXT
S J=8004 I BY(0)?1"^DIBT("1.N1",1," S J=+$P(BY(0),"^DIBT(",2) D ENT(0,J) S J=8003
I '$D(DISTXT) S I(1)=$S($E(BY(0),$L(BY(0)))=",":$E(BY(0),1,($L(BY(0))-1))_")",1:BY(0)) D BLD^DIALOG(J,.I,"","DIR") S DPP(0,"TXT")=DIR
DPP F I=1:1:L(0)-1 S DPP(I)=S_"^^SORT FIELD "_I_"^""@^^^^^^4",DPP(I,"SER")="999^999",(DPP(I,"GET"),DPP(I,"CM"))="S DISX("_I_")=DIOO"_(L(0)-I)
S DPP(0,"IX")=$E(U,$E(BY(0))'=U)_BY(0)_DCC_U_$S($D(L(0)):L(0),1:1)
F I=0:0 S I=$O(FR(0,I)) Q:'I I FR(0,I)]"",$D(DPP(I)) S (Y,K)=FR(0,I) D FRV^DIP1 S DPP(I,"F")=Y_U_K S:I=1 DPP(0,"F")=Y_U_K
F I=0:0 S I=$O(TO(0,I)) Q:'I I TO(0,I)]"",$D(DPP(I)) S DPP(I,"T")=TO(0,I)_U_TO(0,I)
F I=0:0 S I=$O(DISPAR(0,I)) Q:'I I DISPAR(0,I)]"" D
.S X="""",J=$P(DISPAR(0,I),U) F K="!","#","+","@" I J[K S X=X_K
.I X'["@",$P(DISPAR(0,I),U,2)'[";""" S X=X_"@"
.S $P(DPP(I),U,4)=X S $P(DPP(I),U,5)=$P(DISPAR(0,I),U,2)
.I $G(DISPAR(0,I,"OUT"))]"" S DPP(I,"OUT")=DISPAR(0,I,"OUT")
.Q
I $D(FR)#2!($D(TO)#2) S J="",$P(J,",",L(0))="" S:$D(FR)#2 FR=J_FR S:$D(TO)#2 TO=J_TO G ENX
S J=$O(FR(8),-1) I J F J=J:-1:0 I $D(FR(J))#2 S FR(J+DPP(0))=FR(J) K FR(J)
S J=$O(TO(8),-1) I J F J=J:-1:0 I $D(TO(J))#2 S TO(J+DPP(0))=TO(J) K TO(J)
ENX S DJ=L(0) K L(0),FR(0),TO(0),DISPAR(0)
Q
;
ENT(I,J) ;MOVE TEXT OF SEARCH AND GET CODE FROM SEARCH TEMPLATE TO DPP ARRAY
;I=Entry no.in DPP array, J=record number for search template
Q:$G(I)="" Q:'$G(J) N DIR,%X,%Y
D BLD^DIALOG(8003,$P($G(^DIBT(J,0)),U),"","DIR") D:$O(^DIBT(J,"O",0)) S DISTXT(99,0)=DIR
. S %X="^DIBT("_J_",""O"",",%Y="DISTXT(" D %XY^%RCR
. S DIR="("_DIR_")" Q
S:I DPP(I,"GET")="S DISX("_I_")=D0"
Q
;
EX K BY(0),L(0) I $G(DIQUIET) D CLEAN^DIEFU Q
D MSG^DIALOG("W") Q
;
;DIALOG #201 'The input variable...is missing or invalid.'
; #1500 'Search template...in BY(0) variable cannot be found...'
; #8003 'Records from list on...search template.
; #8004 'Sort using...'
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIP10 3108 printed Dec 13, 2024@02:52:38 Page 2
DIP10 ;SFISC/TKW - PROCESS BY(0) INPUT VARIABLES ;12:59 PM 6 Aug 1999
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+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 ;
EN ;
+1 NEW I,J,K,X,Y,DIR
KILL DPP(0),DPP(1)
IF $GET(BY(0))=""
DO BLD^DIALOG(201,"BY(0)")
+2 IF $GET(BY(0))]""
IF $EXTRACT($GET(BY))="["
DO BLD^DIALOG(201,"BY")
+3 IF $EXTRACT(BY(0))'="["
Begin DoDot:1
+4 NEW %,X
SET X=BY(0)
SET Y=""
IF X'["("
if X[")"!(X[",")
SET Y=-1
if Y=-1
QUIT
SET X=X_"("
+5 if $EXTRACT(X)'=U
SET X=U_X
+6 SET %=$EXTRACT(X,$LENGTH(X))
if %=")"
SET $EXTRACT(X,$LENGTH(X))=","
SET %=","
IF ",("'[%
SET X=X_","
+7 SET BY(0)=X
QUIT
End DoDot:1
IF Y=-1
DO BLD^DIALOG(201,"BY(0)")
+8 IF $EXTRACT(BY(0))="["
Begin DoDot:1
+9 NEW DIC,DIBTFILE,DJ,DCC,DI,DNP,L
SET DIBTFILE=S
NEW S
+10 SET X=$PIECE($EXTRACT(BY(0),2,99),"]")
SET DIC="^DIBT("
SET DIC(0)="Q"
SET DIC("S")="I '$P(^(0),U,8),$P(^(0),U,4)=DIBTFILE,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$O(^(1,0))"
+11 DO ^DIC
+12 IF Y<0
SET I(1)=BY(0)
DO BLD^DIALOG(1500,.I)
+13 QUIT
End DoDot:1
IF Y'<0
SET BY(0)="^DIBT("_+Y_",1,"
SET L(0)=1
+14 IF '$GET(L(0))!($GET(L(0))>8)
DO BLD^DIALOG(201,"L(0)")
+15 if $DATA(DIERR)
GOTO EX
+16 SET DPP(0)=L(0)-1
KILL DISTXT
+17 SET J=8004
IF BY(0)?1"^DIBT("1.N1",1,"
SET J=+$PIECE(BY(0),"^DIBT(",2)
DO ENT(0,J)
SET J=8003
+18 IF '$DATA(DISTXT)
SET I(1)=$SELECT($EXTRACT(BY(0),$LENGTH(BY(0)))=",":$EXTRACT(BY(0),1,($LENGTH(BY(0))-1))_")",1:BY(0))
DO BLD^DIALOG(J,.I,"","DIR")
SET DPP(0,"TXT")=DIR
DPP FOR I=1:1:L(0)-1
SET DPP(I)=S_"^^SORT FIELD "_I_"^""@^^^^^^4"
SET DPP(I,"SER")="999^999"
SET (DPP(I,"GET"),DPP(I,"CM"))="S DISX("_I_")=DIOO"_(L(0)-I)
+1 SET DPP(0,"IX")=$EXTRACT(U,$EXTRACT(BY(0))'=U)_BY(0)_DCC_U_$SELECT($DATA(L(0)):L(0),1:1)
+2 FOR I=0:0
SET I=$ORDER(FR(0,I))
if 'I
QUIT
IF FR(0,I)]""
IF $DATA(DPP(I))
SET (Y,K)=FR(0,I)
DO FRV^DIP1
SET DPP(I,"F")=Y_U_K
if I=1
SET DPP(0,"F")=Y_U_K
+3 FOR I=0:0
SET I=$ORDER(TO(0,I))
if 'I
QUIT
IF TO(0,I)]""
IF $DATA(DPP(I))
SET DPP(I,"T")=TO(0,I)_U_TO(0,I)
+4 FOR I=0:0
SET I=$ORDER(DISPAR(0,I))
if 'I
QUIT
IF DISPAR(0,I)]""
Begin DoDot:1
+5 SET X=""""
SET J=$PIECE(DISPAR(0,I),U)
FOR K="!","#","+","@"
IF J[K
SET X=X_K
+6 IF X'["@"
IF $PIECE(DISPAR(0,I),U,2)'[";"""
SET X=X_"@"
+7 SET $PIECE(DPP(I),U,4)=X
SET $PIECE(DPP(I),U,5)=$PIECE(DISPAR(0,I),U,2)
+8 IF $GET(DISPAR(0,I,"OUT"))]""
SET DPP(I,"OUT")=DISPAR(0,I,"OUT")
+9 QUIT
End DoDot:1
+10 IF $DATA(FR)#2!($DATA(TO)#2)
SET J=""
SET $PIECE(J,",",L(0))=""
if $DATA(FR)#2
SET FR=J_FR
if $DATA(TO)#2
SET TO=J_TO
GOTO ENX
+11 SET J=$ORDER(FR(8),-1)
IF J
FOR J=J:-1:0
IF $DATA(FR(J))#2
SET FR(J+DPP(0))=FR(J)
KILL FR(J)
+12 SET J=$ORDER(TO(8),-1)
IF J
FOR J=J:-1:0
IF $DATA(TO(J))#2
SET TO(J+DPP(0))=TO(J)
KILL TO(J)
ENX SET DJ=L(0)
KILL L(0),FR(0),TO(0),DISPAR(0)
+1 QUIT
+2 ;
ENT(I,J) ;MOVE TEXT OF SEARCH AND GET CODE FROM SEARCH TEMPLATE TO DPP ARRAY
+1 ;I=Entry no.in DPP array, J=record number for search template
+2 if $GET(I)=""
QUIT
if '$GET(J)
QUIT
NEW DIR,%X,%Y
+3 DO BLD^DIALOG(8003,$PIECE($GET(^DIBT(J,0)),U),"","DIR")
if $ORDER(^DIBT(J,"O",0))
Begin DoDot:1
+4 SET %X="^DIBT("_J_",""O"","
SET %Y="DISTXT("
DO %XY^%RCR
+5 SET DIR="("_DIR_")"
QUIT
End DoDot:1
SET DISTXT(99,0)=DIR
+6 if I
SET DPP(I,"GET")="S DISX("_I_")=D0"
+7 QUIT
+8 ;
EX KILL BY(0),L(0)
IF $GET(DIQUIET)
DO CLEAN^DIEFU
QUIT
+1 DO MSG^DIALOG("W")
QUIT
+2 ;
+3 ;DIALOG #201 'The input variable...is missing or invalid.'
+4 ; #1500 'Search template...in BY(0) variable cannot be found...'
+5 ; #8003 'Records from list on...search template.
+6 ; #8004 'Sort using...'
+7 ;
