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

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

initial load of WorldVistAEHR
File size: 4.7 KB
RevLine 
[613]1DDS2 ;SFISC/MLH-UP ARROW JUMP, BRANCH ;10:46 AM 17 Jun 1997
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4UPA ;Up-arrow jump
5 Q:$E(X)'=U
6 I X?1"^"1.E,X'="^^",$G(DDSDN) D MSG^DDSMSG("No jumping allowed.",1) Q
7 I X?1"^"1.E,X'="^^" D JMP Q
8 ;
9 ;Up-arrow only
10 I 'DDO D E^DDS3 Q
11 I $D(DDSREP),DA D POSTACT D:$D(DDSBR)[0 END^DDSM Q
12 I $G(DDSDN)=1 D MSG^DDSMSG("No exit allowed, since navigation for the block is disabled.",1) Q
13 D POSTACT S:$D(DDSBR)[0 DDSOSV=DDO,DDO=0 Q
14 Q
15 ;
16POSTACT ;Execute post action
17 Q:$G(DDSO(12))?." "
18 N X
19 S X=$G(DDSOLD) X DDSO(12)
20 D:$D(DDSBR)#2 BR
21 Q
22 ;
23JMP ;Up-arrow jump
24 S DDS2X=X,X=$P(X,U,2) I X="" W $C(7) G KILL
25 K DDH,DDQ S DDH=0
26 S (X,DDSX)=$$UPCASE($E(X,1,63))
27 ;
28 ;Find exact matches
29 D:$D(@DDSREFS@("CAP",X)) CAP
30 D:$D(@DDSREFT@("XCAP",DDSPG,X)) XCAP
31 ;
32 ;Find partial matches
33 S:X="?" (X,DDSX)=""
34 F S DDSX=$O(@DDSREFS@("CAP",DDSX)) Q:DDSX=""!($P(DDSX,X)]"") D CAP
35 S DDSX=X F S DDSX=$O(@DDSREFT@("XCAP",DDSPG,DDSX)) Q:DDSX=""!($P(DDSX,X)]"") D XCAP
36 ;
37 I 'DDH D MSG^DDSMSG($P(DDS2X,U,2)_" not found.",1) G KILL
38 S DDS2O=DDO
39 I DDH=1 S DDO=$O(DDH(DDH,""))
40 E S DDD="J" D SC^DDSU
41 ;
42 S DDS2B=$P(DDO,",",2),DDS2P=$P(DDO,",",3),DDO=+DDO
43 G:'DDS2B KILL
44 ;
45 S DDS2DA=DDSDA
46 I DDS2P'=DDSPG D
47 . D:'$D(@DDSREFT@(DDS2P,DDS2B)) ^DDS1(DDS2P)
48 . S DDS2DA=@DDSREFT@(DDS2P,DDS2B)
49 . I DDS2DA="" D
50 .. D MSG^DDSMSG($C(7)_$P($T(ERR),";;",2))
51 .. S DDO=DDS2O
52 . E D CKUNED D:'$G(DDS2UNED)
53 .. D POSTACT
54 .. S:$D(DDSBR)[0 DDACT="NP",DDSPG=DDS2P,DDSBK=DDS2B,DDSBR=""
55 ;
56 E I DDS2B'=DDSBK D
57 . S DDS2DA=@DDSREFT@(DDS2P,DDS2B)
58 . I DDS2DA="" D
59 .. D MSG^DDSMSG($C(7)_$P($T(ERR),";;",2))
60 .. S DDO=DDS2O
61 . E I $P($G(@DDSREFS@(DDS2P,DDS2B)),U,4) D
62 .. D MSG^DDSMSG($C(7)_$P($T(ERR1),";;",2))
63 .. S DDO=DDS2O
64 . E D CKUNED D:'$G(DDS2UNED)
65 .. D POSTACT
66 .. S:$D(DDSBR)[0 DDACT="NB",DDSBK=DDS2B,DDSBR=""
67 ;
68 E D CKUNED D:'$G(DDS2UNED)
69 . D POSTACT
70 . S:$D(DDSBR)[0 DDACT="N"
71 ;
72KILL S X=DDS2X
73 K DDH,DDSI,DDSPGRP,DDSX
74 K DDS2ATT,DDS2B,DDS2DA,DDS2F,DDS2O,DDS2P,DDS2UNED,DDS2X
75 Q
76 ;
77CKUNED ;Check uneditable status
78 N DDP,DDSFLD
79 ;
80 I $P($G(^DIST(.404,DDS2B,40,+DDO,0)),U,3)=2 D
81 . S DDP=0
82 . S DDSFLD=+DDO_","_DDS2B
83 E D
84 . S DDP=$P($G(@DDSREFS@(DDS2P,DDS2B)),U,3)
85 . S DDSFLD=$P($G(^DIST(.404,DDS2B,40,+DDO,1)),U)
86 ;
87 S DDS2ATT=$P($G(@DDSREFT@("F"_DDP,DDS2DA,DDSFLD,"A")),U,4)
88 ;
89 I DDO,$S(DDS2ATT="":$P($G(^DIST(.404,DDS2B,40,+DDO,4)),U,4)=1,1:DDS2ATT=1),'$P(@DDSREFS@(DDS2P,DDS2B,+DDO,"N"),U,11) D
90 . D MSG^DDSMSG($P(^DIST(.404,DDS2B,40,+DDO,0),U,2)_" is uneditable.",1)
91 . S DDS2UNED=1,DDO=DDS2O
92 Q
93 ;
94CAP ;Find all captions that match DDSX
95 S DDSPGRP="" F S DDSPGRP=$O(@DDSREFS@("CAP",DDSX,DDSPGRP)) Q:DDSPGRP="" D
96 . Q:U_DDSPGRP_U'[(U_DDSPG_U)
97 . S DDS2P="" F S DDS2P=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P)) Q:'DDS2P D
98 .. S DDS2B="" F S DDS2B=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P,DDS2B)) Q:'DDS2B D
99 ... S DDS2F="" F S DDS2F=$O(@DDSREFS@("CAP",DDSX,DDSPGRP,DDS2P,DDS2B,DDS2F)) Q:'DDS2F D FILL
100 Q
101 ;
102XCAP ;Find all xecutable captions that match DDSX
103 S DDS2P=DDSPG
104 S DDS2B=0 F S DDS2B=$O(@DDSREFT@("XCAP",DDSPG,DDSX,DDS2B)) Q:'DDS2B D
105 . S DDS2F=0 F S DDS2F=+$O(@DDSREFT@("XCAP",DDSPG,DDSX,DDS2B,DDS2F)) Q:'DDS2F D
106 .. I $D(^DIST(.404,DDS2B,40,DDS2F,0))#2,$P(^(0),U,3)'=1 D FILL
107 Q
108 ;
109FILL ;Fill DDH array with possible choices
110 S DDS2V=DDSX_$S($P(^DIST(.404,DDS2B,40,DDS2F,0),U,4)]"":" ("_$P(^(0),U,4)_")",1:"")
111 S:DDS2P'=DDSPG DDS2V=DDS2V_" ("_$S($P($G(^DIST(.403,+DDS,40,DDS2P,1)),U)]"":$P(^(1),U),1:"Page "_$P(^(0),U))_")"
112 S DDH=DDH+1,DDH(DDH,DDS2F_","_DDS2B_","_DDS2P)=DDS2V
113 K DDS2V
114 Q
115 ;
116BR ;Evaluate DDSBR
117 N B,B1,F,F1,P,P1,E,X Q:$D(DDSBR)[0
118 S P=$P($G(DDSOPB),U),B=$P($G(DDSOPB),U,2),F=$G(DDO),E=1
119 S:'B B=+$P(@DDSREFS@(+P,"FIRST"),",",2)
120 S P1=$P(DDSBR,U,3),B1=$P(DDSBR,U,2),F1=$P(DDSBR,U)
121 ;
122 D @$S(P1]"":"PG",B1]"":"BK",1:"FD")
123 S:'E DDACT=$S(P'=+DDSOPB:"NP",B'=$P(DDSOPB,U,2):"NB",1:"N"),DDSPG=P,DDSBK=B,DDO=F
124 K:E DDSBR
125 Q
126PG ;
127 I P1=+$P(P1,"E") S P=$O(^DIST(.403,+DDS,40,"B",P1,""))
128 E S P=$O(^DIST(.403,+DDS,40,"C",$$UPCASE(P1),""))
129 Q:'P
130 S:B1="" B1=$O(^DIST(.403,+DDS,40,P,40,"AC","")) Q:B1=""
131BK ;
132 I B1=+$P(B1,"E") D
133 . S B=$O(^DIST(.403,+DDS,40,P,40,"AC",B1,""))
134 E D
135 . S B=$O(^DIST(.404,"B",B1,"")) Q:B=""
136 . S B=$O(^DIST(.403,+DDS,40,P,40,"B",B,""))
137 Q:'B
138 S:F1="" F1=$O(^DIST(.404,B,40,"B",""))
139FD ;
140 Q:F1=""
141 I F1="COM" S (E,F)=0 Q
142 I F1=+$P(F1,"E") S X="B"
143 E S F1=$$UPCASE(F1),X=$S($D(^DIST(.404,B,40,"D",F1)):"D",1:"C")
144 S F=$O(^DIST(.404,B,40,X,F1,""))
145 S:F E=0
146 Q
147 ;
148UPCASE(X) ;
149 ;Return X in uppercase
150 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
151 ;
152ERR ;;Unable to jump to that field. The block on which that field is located has no record associated with it.
153 ;
154ERR1 ;;Unable to jump to that field. The block on which that field is located has navigation disabled.
Note: See TracBrowser for help on using the repository browser.