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

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

initial load of WorldVistAEHR
File size: 5.1 KB
Line 
1DIC ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 ;10:06 AM 19 Mar 2001
2 ;;22.0;VA FileMan;**4,17,20,78**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 N %,D,DF,DIFILEI,DIENS,DINDEX,DS,DIASKOK K DO S U="^",DIC(0)=$G(DIC(0))
5 D GETFILE^DIC0(.DIC,.DIFILEI,.DIENS) I DIFILEI="" S Y=-1 Q
6 S %=$P("K^",U,DIC(0)["K"),(D,DINDEX,DINDEX("START"))=$$DINDEX^DICL(DIFILEI,%)
7 K %
8EN I $G(DIFILEI)=""!('$D(DINDEX)#2) N DIFILEI,DIENS,DINDEX,DIASKOK,%
9 K DO,DICR,DIROUT,DTOUT,DUOUT S U="^"
10 D INIT^DIC0 I DIFILEI="" S Y=-1 D Q^DIC2 Q
11 S DIC(0)=$G(DIC(0)) D
12 . I DIC(0)["T" K ^TMP($J,"DICSEEN") S ^TMP($J,"DICSEEN",DIFILEI)=""
13 . I $D(ZTQUEUED),$E($G(IOST),1,2)'="C-" S DIC(0)=$TR(DIC(0),"AEQ")
14 . I DIC(0)["X",DIC(0)["O" S DIC(0)=$TR(DIC(0),"O")
15 . S:DINDEX("#")>1 DIC(0)=$TR(DIC(0),"M") Q
16 N DIPGM S DIPGM=$$PGM^DIC2(.DIC,$G(DF),DIFILEI)
17 I DIPGM]"" D KILL1^DIC0 K DIC("W") S DIPGM(0)=1 G @DIPGM
18ASK I $G(DIFILEI)=""!('$D(DINDEX)#2) N DIFILEI,DIENS,DINDEX,DIASKOK,% D INIT^DIC0 I DIFILEI="" S Y=-1 D Q^DIC2 Q
19 I '$D(DIVAL) N DIVAL,DIALLVAL
20 K DIVAL,DIALLVAL S DIVAL(0)=0,Y=-1,DIALLVAL=1
21 I DIC(0)["A" K X W ! D ^DIC1 I $G(DTOUT) D Q^DIC2 Q
22 I DIC(0)'["A" D CHKVAL^DIC0,CHKVAL2^DIC0(DINDEX("#"),.DIVAL,DIC(0),.DDS)
23A1 I DIVAL(0) D
24 . D CHKVAL1^DIC0(DINDEX("#"),.DIVAL,DIC(0),DIC(0),.DIALLVAL) Q:'DIVAL(0)
25 . I $D(DIADD),X]"",X'["""" S (X,DIVAL(1))=""""_X_"""" S:DINDEX("#")>1 X(1)=X
26 . N DUOUT K DINDEX S (DINDEX,DINDEX("START"))=D,DINDEX("WAY")=1
27 . D INDEX^DICUIX(.DIFILEI,"4l",.DINDEX,"",.DIVAL) Q
28X ;
29 I $G(DIFILEI)=""!('$D(DINDEX)#2) K DUOUT,DTOUT N DIFILEI,DIENS,DINDEX,DIASKOK,% N:'$D(DIVAL(0)) DIVAL,DIALLVAL D I DIFILEI="" S Y=-1 D Q^DIC2 Q
30 . D INIT^DIC0 Q:$D(DIVAL(0))!(DIFILEI="")
31 . D SETVAL^DIC0 Q
32 I DIVAL(0),$D(^DD(DIFILEI,.01,7.5)) X ^(7.5) D NODE75^DIC5 I $G(X)="" G:DIC(0)["A" ASK D Q^DIC2 Q
33 N DIPGM S DIPGM=$S(DIVAL(0)'>1:$$PGM^DIC2(.DIC,$G(DF),DIFILEI),1:"")
34 I DIPGM]"" D KILL2^DIC0 S DIPGM(0)=2 G @DIPGM
35RTN I $G(DIFILEI)=""!('$D(DINDEX)#2) N DIFILEI,DIENS,DINDEX,DIASKOK,% N:'$D(DIVAL(0)) DIVAL,DIALLVAL D I DIFILEI="" S Y=-1 D Q^DIC2 Q
36 . D INIT^DIC0 Q:$D(DIVAL(0))!(DIFILEI="")
37 . D SETVAL^DIC0 Q
38 I X?1."?" D Q:$G(DTOUT) G:DIC(0)["A" ASK Q
39 . D DSPHLP^DICQ(.DIC,.DIFILEI,.DINDEX,X)
40 . S Y=-1 Q
41 I DIVAL(0)=0!($G(DUOUT)) S Y=-1 D Q^DIC2 Q
42 D:'$D(DO) GETFA^DIC1(.DIC,.DO)
43 I X?1"`".NP S Y=-1 D BYIEN1^DIC5 Q:Y>0 I '$$TRYADD^DIC11(.DIC,DIFILEI) D DING G:DIC(0)["A" ASK D Q^DIC2 Q
44 I DIVAL(0)=1,+$P(X,"E")=X,X>0 S Y=-1 N DISKIPIX D BYIEN2^DIC5 Q:Y>0
45 I X=" ",$L(DIC)<29,$D(^DISV(DUZ,DIC))#2 S Y=+^(DIC) D SPACEBAR^DIC5 Q:Y>0 D DING G:DIC(0)["A" ASK D Q^DIC2 Q
46F ; Start regular lookup
47 N DD,DS,DIX,DIY,DIYX,DIDONE,DISAVDS,%Y,%H,DISYS
48 I $G(DIFILEI)=""!('$D(DINDEX)#2) N DIFILEI,DIENS,DINDEX,DIASKOK,% N:'$D(DIVAL(0)) DIVAL,DIALLVAL D
49 . D INIT^DIC0 Q:$D(DIVAL(0))
50 . D SETVAL^DIC0 Q
51F1 S (DD,DS,DS(0),DS("DD"))=0
52 D SEARCH^DIC3
53 I $G(DTOUT)!(Y'<0) D Q^DIC2 Q
54 I $P(DS(0),U,2)="?",(DIC(0)_$G(DICR(1,0)))'["A" D K G F1
55 I +DS(0)=2 S X=$P(DS(0),U,2) D K D G A1
56 . K DIVAL,DIALLVAL S DIVAL(0)=0,Y=-1,DIALLVAL=1
57 . D CHKVAL^DIC0,CHKVAL2^DIC0(DINDEX("#"),.DIVAL,DIC(0),.DDS)
58 . Q
59 D D K I Y<0,DIC(0)["A" D D^DIC0 W:DIC(0)["E" ! K:$D(DIROUT) DIROUT G ASK
60 . Q:$G(DIROUT)
61 . I DS(0),$P(DS(0),U,2)="" S:DIC(0)["Y"&($O(Y(0))) Y=0 D DING Q
62 . Q:'($D(DS)#2)
63 . I (DS(0)=0!($P(DS(0),U,2)="U")),DS("DD")=DS,(DO(2)["O"!($G(DIASKOK))!(DIC(0)["T")),DO(2)'["A",DIC(0)["L" D L^DICM
64 . Q
65 D Q^DIC2 Q
66 ;
67K K DD,DS,DIX,DIY,DIYX,DIDONE,DISAVDS
68 I '$G(DICR),DIC(0)["T" K ^TMP($J,"DICSEEN") S ^TMP($J,"DICSEEN",DIFILEI)=""
69 Q
70 ;
71DING Q:DIC(0)'["Q"!(DIC(0)'["E")
72 W:'$D(DUOUT) $C(7)_$S('$D(DDS):" ??",1:"") Q
73 ;
74 ;
75IX N DINDEX,DF
76 S (DF,DINDEX,DINDEX("START"))=D
77 G EN
78 ;
79A K DIY,DIYX,DS I DIC(0)["A" D D^DIC0 Q
80NO S Y=-1 D Q^DIC2 Q
81 ;
82 ; DBS Entry points
83LIST(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DINUMBER,DIFROM,DIPART,DINDEX,DISCREEN,DIWRITE,DILIST,DIMSGA) ;
84 ;ENTRY POINT--return a list of entries from a file (SEA/TOAD)
85 G IN^DICL
86 ;
87FIND1(DIFILE,DIFIEN,DIFLAGS,DIVALUE,DIFORCE,DISCREEN,DIMSGA) ;SEA/TOAD
88 ;ENTRY POINT--find a single entry in the file
89 I '$D(DIQUIET) N DIQUIET S DIQUIET=1
90 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
91 N DICLERR S DICLERR=$G(DIERR) K DIERR
92 N DIERN,DIFIND,DIPE,DITARGET
93 N DIVALS M DIVALS=DIVALUE I $G(DIVALS)="" S DIVALS=$G(DIVALUE(1))
94 D FIND^DICF($G(DIFILE),$G(DIFIEN),"",$G(DIFLAGS)_"f",.DIVALUE,1,$G(DIFORCE),.DISCREEN,"","DITARGET")
95 I $D(DIERR) S DIFIND=""
96 E I $P($G(DITARGET(0)),U,3) K DITARGET S DIFIND="" D
97 . I $O(DIVALS(1)) N I F I=1:0 S I=$O(DIVALS(I)) Q:'I D:DIVALS(I)]"" Q:'I
98 . . I ($L(DIVALS)+$L(DIVALS(I)))>100 S DIVALS=DIVALS_"...",I="" Q
99 . . S DIVALS=DIVALS_$P(", ^",U,DIVALS]"")_DIVALS(I) Q
100 . D ERR^DICF4(299,$G(DIFILE),$G(DIFIEN),"",DIVALS)
101 . Q
102 E S DIFIND=+$G(DITARGET(1))
103 I DICLERR'=""!$G(DIERR) D
104 . S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
105 I $G(DIMSGA)'="" D CALLOUT^DIEFU(DIMSGA)
106 Q DIFIND
107 ;
108FIND(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DIVALUE,DINUMBER,DIFORCE,DISCREEN,DIWRITE,DILIST,DIMSGA) ;SEA/TOAD
109 ;ENTRY POINT--in a file find entries that match a value
110 G FINDX^DICF
111 ;
112 ; Error messages:
113 ; 299 More than one entry matches the value(s) '|1|'
114 ; 120 The previous error occurred when performing
115 ; 8090 Pre-lookup transform (7.5 node)
116 ;
Note: See TracBrowser for help on using the repository browser.