- 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 Feb 19, 2025@00:18:52 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 ;