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

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

initial load of WorldVistAEHR
File size: 4.6 KB
Line 
1DDGFLOAD ;SFISC/MKO-LOAD PAGE/BLOCK ;12:33 PM 29 Mar 1995
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4PG(S,P,V,R) ;
5 ;Load and paint page
6 ;Called when a new form or page is selected
7 ;If Page is not pop-up close all windows first
8 ;Input:
9 ; S = internal form number
10 ; P = internal page number
11 ; V = 1 if buffer should be updated but nothing painted
12 ; (new windows are still given focus)
13 ; R = 1 to reload blocks/fields on page even if loaded before
14 ;Returns:
15 ; DDGFWID = Window number for a given page
16 ; DDGFWIDB = Window number of block displayer for a given page
17 ; DDGFLIM = Boundaries within which cursor can be moved
18 ;
19 I $D(^DIST(.403,+$G(S),40,+$G(P),0))[0 S DDGFWID="P0",DDGFWIDB="B0",DDGFLIM="0^0^"_(IOSL-8)_U_(IOM-2),DDGFPG=0 Q
20 ;
21 S DDGFWID="P"_DDGFPG,DDGFWIDB="B"_DDGFPG
22 I $$EXIST^DDGLIBW(DDGFWID),$G(R) D DESTROY^DDGLIBW(DDGFWID,1)
23 I $$EXIST^DDGLIBW(DDGFWID),'$G(R) D Q
24 . S DDGFLIM=$P(@DDGFREF@("F",P),U,1,4)
25 . I $P(DDGFLIM,U,3,4)?."^" D
26 .. S $P(DDGFLIM,U,3,4)=IOSL-8_U_(IOM-2)
27 .. D CLOSEALL^DDGLIBW($G(V))
28 . D FOCUS^DDGLIBW(DDGFWID,$G(V))
29 ;
30 N P1,P2,P3,P4,B,B1,B2
31 ;
32 ;Get page coordinates
33 I $D(@DDGFREF@("F",+P))#2 D
34 . N N
35 . S N=@DDGFREF@("F",+P)
36 . S P1=$P(N,U),P2=$P(N,U,2),P3=$P(N,U,3),P4=$P(N,U,4)
37 E D
38 . S P2=$P(^DIST(.403,+S,40,+P,0),U,3),P3=$P(^(0),U,7)
39 . S P1=$P(P2,",")-1,P2=$P(P2,",",2)-1
40 . S:P1<0 P1=0 S:P2<0 P2=0
41 . S:P3]"" P4=$P(P3,",",2)-1,P3=$P(P3,",")-1
42 . S @DDGFREF@("F",P)=P1_U_P2_U_$S(P3]"":P3_U_P4,1:U)_U_$P($G(^DIST(.403,+S,40,+P,1)),U)_U_$P(^(0),U)
43 ;
44 I P3]"" D
45 . S DDGFLIM=P1_U_P2_U_P3_U_P4
46 . D CREATE^DDGLIBW(DDGFWID,P1_U_P2_U_(P3-P1+1)_U_(P4-P2+1),1,$G(V))
47 . S @DDGFREF@("RC",DDGFWID,P1,P2,P4,"P","P","PTOP")=""
48 . S @DDGFREF@("RC",DDGFWID,P3,P4,P4,"P","P","PBRC")=""
49 ;
50 E D
51 . S DDGFLIM=P1_U_P2_U_(IOSL-8)_U_(IOM-2)
52 . D CLOSEALL^DDGLIBW($G(V))
53 . D CREATE^DDGLIBW(DDGFWID,P1_U_P2_U_(IOSL-7-P1)_U_(IOM-1-P2),"",$G(V))
54 ;
55 ;Load header block
56 S B=$P(^DIST(.403,+S,40,+P,0),U,2) I B]"" D
57 . S B1=P1,B2=P2
58 . D BK(+P,B,P1,P2,B1,B2,1,$G(V))
59 ;
60 ;Load all other blocks
61 S B=0 F S B=$O(^DIST(.403,+S,40,+P,40,B)) Q:B'=+$P(B,"E") D
62 . Q:$D(^DIST(.403,+S,40,+P,40,B,0))[0
63 . S B2=$P(^DIST(.403,+S,40,+P,40,B,0),U,3)
64 . S B1=$P(B2,",")-1,B2=$P(B2,",",2)-1
65 . S:B1<0 B1=0 S:B2<0 B2=0
66 . S B1=B1+P1,B2=B2+P2
67 . D BK(+P,B,P1,P2,B1,B2,"",$G(V))
68 Q
69 ;
70BK(P,B,P1,P2,B1,B2,H,V) ;Load block image
71 ; P = internal page number
72 ; B = internal block number
73 ; P1 = page $Y
74 ; P2 = page $X
75 ; B1 = block abs $Y
76 ; B2 = block abs $X
77 ; H = 1 if header block, immobile (optional)
78 ; V = 1 if buffer should be updated but nothing painted (optional)
79 N B3,F,F1,C,C1,C2,C3,D1,D2,D3,I,L,N,T
80 Q:$D(^DIST(.404,B,0))[0
81 ;
82 S N=$P(^DIST(.404,B,0),U)
83 S:$G(H) B1=P1,B2=P2
84 S B3=B2+$L(N)-1
85 S @DDGFREF@("F",P,B)=B1_U_B2_U_B3_U_N
86 S @DDGFREF@("BKRC",DDGFWIDB,B1,B2,B3,B)=$S($G(H):"H",1:"")
87 ;
88 S F1=""
89 F S F1=$O(^DIST(.404,B,40,"B",F1)) Q:F1="" S F=$O(^(F1,"")) D:F
90 . Q:$D(^DIST(.404,B,40,F,0))[0
91 . S C=$P(^DIST(.404,B,40,F,0),U,2),C2=$P($G(^(2)),U,3)
92 . I C]"",'$P($G(^DIST(.404,B,40,F,2)),U,4),$P(^(0),U,3)'=1 S C=C_":"
93 . S L=$P($G(^DIST(.404,B,40,F,2)),U,2),D2=$P($G(^(2)),U)
94 . S T=$P(^DIST(.404,B,40,F,0),U,3)
95 . ;
96 . ;Kill nodes that are null or contain only ^s
97 . S I=0
98 . F S I=$O(^DIST(.404,B,40,F,I)) Q:'I I $D(^(I))=1,^(I)?."^" K ^(I)
99 . ;
100 . ;Check that fields with captions have caption coords
101 . I C]"",'C2 S C2="1,1",$P(^DIST(.404,B,40,F,2),U,3)=C2
102 . ;
103 . ;Check for DD fields that should be Caption fields
104 . I T=3,$D(^DIST(.404,B,40,F,1))[0,'$O(^(2)) D
105 .. S T=1,(D2,L)=""
106 .. S C=$P($G(^DIST(.404,B,40,F,0)),U,2)
107 .. S $P(^DIST(.404,B,40,F,0),U,3)=1
108 .. S $P(^DIST(.404,B,40,F,2),U,1,4)="^^"_C2_"^"
109 . ;
110 . ;Check that fields have some coordinate
111 . I 'C2,T=1!'D2 D
112 .. I C="" D
113 ... S C="** Null **",$P(^DIST(.404,B,40,F,0),U,2)=C,$P(^(2),U,4)=""
114 ... S:T'=1 C=C_":"
115 .. S C2="1,1",$P(^DIST(.404,B,40,F,2),U,3)=C2
116 . ;
117 . ;Make sure nonCaption fields have data coordinates and length
118 . I T'=1 D
119 .. S:'D2 D2=+C2_","_($P(C2,",",2)+$L(C)+1),$P(^DIST(.404,B,40,F,2),U)=D2
120 .. S:'L L=1,$P(^DIST(.404,B,40,F,2),U,2)=1
121 .. I C="",C2 S C2="",$P(^DIST(.404,B,40,F,2),U,3)=""
122 . ;
123 . I C]"" D
124 .. S C1=$P(C2,",")-1+B1,C2=$P(C2,",",2)-1+B2,C3=C2+$L(C)-1
125 .. S @DDGFREF@("F",P,B,F)=C1_U_C2_U_C3_U_C
126 .. S @DDGFREF@("RC",DDGFWID,C1,C2,C3,B,F,"C")=""
127 .. D WRITE^DDGLIBW(DDGFWID,C,C1-P1,C2-P2,"",$G(V))
128 . ;
129 . ;NonCaption fields
130 . I T'=1 D
131 .. S D1=$P(D2,",")-1+B1,D2=$P(D2,",",2)-1+B2,D3=D2+L-1
132 .. S $P(@DDGFREF@("F",P,B,F),U,5,8)=D1_U_D2_U_D3_U_L
133 .. S @DDGFREF@("RC",DDGFWID,D1,D2,D3,B,F,"D")=""
134 .. D WRITE^DDGLIBW(DDGFWID,$TR($J("",L)," ","_"),D1-P1,D2-P2,"",$G(V))
135 Q
Note: See TracBrowser for help on using the repository browser.