source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIP10.m@ 1714

Last change on this file since 1714 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1DIP10 ;SFISC/TKW - PROCESS BY(0) INPUT VARIABLES ;12:59 PM 6 Aug 1999
2 ;;22.0;VA FileMan;**2**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN ;
5 N I,J,K,X,Y,DIR K DPP(0),DPP(1) I $G(BY(0))="" D BLD^DIALOG(201,"BY(0)")
6 I $G(BY(0))]"",$E($G(BY))="[" D BLD^DIALOG(201,"BY")
7 I $E(BY(0))'="[" D I Y=-1 D BLD^DIALOG(201,"BY(0)")
8 . N %,X S X=BY(0),Y="" I X'["(" S:X[")"!(X[",") Y=-1 Q:Y=-1 S X=X_"("
9 . S:$E(X)'=U X=U_X
10 . S %=$E(X,$L(X)) S:%=")" $E(X,$L(X))=",",%="," I ",("'[% S X=X_","
11 . S BY(0)=X Q
12 I $E(BY(0))="[" D I Y'<0 S BY(0)="^DIBT("_+Y_",1,",L(0)=1
13 .N DIC,DIBTFILE,DJ,DCC,DI,DNP,L S DIBTFILE=S N S
14 .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))"
15 .D ^DIC
16 .I Y<0 S I(1)=BY(0) D BLD^DIALOG(1500,.I)
17 .Q
18 I '$G(L(0))!($G(L(0))>8) D BLD^DIALOG(201,"L(0)")
19 G:$D(DIERR) EX
20 S DPP(0)=L(0)-1 K DISTXT
21 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
22 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
23DPP 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)
24 S DPP(0,"IX")=$E(U,$E(BY(0))'=U)_BY(0)_DCC_U_$S($D(L(0)):L(0),1:1)
25 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
26 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)
27 F I=0:0 S I=$O(DISPAR(0,I)) Q:'I I DISPAR(0,I)]"" D
28 .S X="""",J=$P(DISPAR(0,I),U) F K="!","#","+","@" I J[K S X=X_K
29 .I X'["@",$P(DISPAR(0,I),U,2)'[";""" S X=X_"@"
30 .S $P(DPP(I),U,4)=X S $P(DPP(I),U,5)=$P(DISPAR(0,I),U,2)
31 .I $G(DISPAR(0,I,"OUT"))]"" S DPP(I,"OUT")=DISPAR(0,I,"OUT")
32 .Q
33 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
34 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)
35 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)
36ENX S DJ=L(0) K L(0),FR(0),TO(0),DISPAR(0)
37 Q
38 ;
39ENT(I,J) ;MOVE TEXT OF SEARCH AND GET CODE FROM SEARCH TEMPLATE TO DPP ARRAY
40 ;I=Entry no.in DPP array, J=record number for search template
41 Q:$G(I)="" Q:'$G(J) N DIR,%X,%Y
42 D BLD^DIALOG(8003,$P($G(^DIBT(J,0)),U),"","DIR") D:$O(^DIBT(J,"O",0)) S DISTXT(99,0)=DIR
43 . S %X="^DIBT("_J_",""O"",",%Y="DISTXT(" D %XY^%RCR
44 . S DIR="("_DIR_")" Q
45 S:I DPP(I,"GET")="S DISX("_I_")=D0"
46 Q
47 ;
48EX K BY(0),L(0) I $G(DIQUIET) D CLEAN^DIEFU Q
49 D MSG^DIALOG("W") Q
50 ;
51 ;DIALOG #201 'The input variable...is missing or invalid.'
52 ; #1500 'Search template...in BY(0) variable cannot be found...'
53 ; #8003 'Records from list on...search template.
54 ; #8004 'Sort using...'
55 ;
Note: See TracBrowser for help on using the repository browser.