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

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

initial load of WorldVistAEHR
File size: 4.1 KB
RevLine 
[613]1DDGFBK ;SFISC/MKO-ADD, EDIT, DELETE BLOCK ;2:11 PM 13 Sep 1995
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ADD ;Add a new block
6 N B,C1,C2,C3
7 S DDGFDY=DY,DDGFDX=DX
8 ;
9 ;Invoke form to enter block name
10 K DDGFBNUM,DDGFBNAM
11 D DDS(.404,"[DDGF BLOCK ADD]")
12 G:'$D(DDGFBNUM) ADDQ
13 ;
14 ;Ask whether block should be added or indicate duplicate block
15 K DDGFANS
16 S DDSPAGE=$S($P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2)=DDGFBNUM!$D(^(40,"B",DDGFBNUM)):21,1:11)
17 D DDS(.404,"[DDGF BLOCK ADD]","",DDSPAGE)
18 G:DDSPAGE=21 ADDQ
19 I '$G(DDGFANS) D G ADDQ
20 . I $D(^DIST(.404,DDGFBNUM,0))#2,'$P(^(0),U,2) D
21 .. N DIK,DA
22 .. S DIK="^DIST(.404,",DA=DDGFBNUM
23 .. D ^DIK
24 K DDSPAGE,DDGFANS
25 ;
26 ;Add block to page
27 S DIC="^DIST(.403,+DDGFFM,40,DDGFPG,40,",DIC(0)="L"
28 S DA(2)=+DDGFFM,DA(1)=DDGFPG
29 S DIC("P")=$P(^DD(.4031,40,0),U,2)
30 S (DINUM,X)=DDGFBNUM
31 K DO,DD D FILE^DICN K DINUM,X
32 G:Y=-1 ADDQ
33 ;
34 ;Stuff in values for block order, coordinates, and type
35 S DIE=DIC,DA=+Y
36 S DDGFC=DDGFDY-$P(DDGFLIM,U)+1_","_(DDGFDX-$P(DDGFLIM,U,2)+1)
37 S DR="1////"_($O(^DIST(.403,+DDGFFM,40,DDGFPG,40,"AC",""),-1)+1\1)_";2////"_DDGFC_";3////e"
38 D ^DIE K DA,DIC,DIE,DR,X,Y,DDGFC
39 ;
40 ;If this looks like a brand new block, stuff in DD number
41 I $L(^DIST(.404,DDGFBNUM,0),U)=1,'$O(^(0)) D
42 . S DIE="^DIST(.404,",DA=DDGFBNUM
43 . S DR="1////"_$P(^DIST(.403,+DDGFFM,0),U,8)
44 . D ^DIE K DA,DIE,DR
45 ;
46 D BK^DDGFLOAD(DDGFPG,DDGFBNUM,$P(DDGFLIM,U),$P(DDGFLIM,U,2),DDGFDY,DDGFDX,0,1)
47 ;
48 S DY=DDGFDY,DX=DDGFDX
49 S B=DDGFBNUM,C=$P(@DDGFREF@("F",DDGFPG,B),U,4)
50 S C1=DY,C2=DX,C3=C2+$L(DDGFBNAM)-1
51 S DDGFADD=1
52 K DDGFBNUM,DDGFBNAM
53 S:$G(DDGFBV) DDGFORIG(B)=DY_U_DX
54 G EDIT
55 ;
56ADDQ ;Adding aborted
57 D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
58 K DDGFANS,DDGFBNAM,DDGFBNUM,DDGFDX,DDGFDY,DDSPAGE,DA,DIC,Y
59 Q
60 ;
61EDIT ;Edit block
62 ;In: B,C1,C2,C3,C
63 S DDGFDY=DY,DDGFDX=DX
64 S DDGFBK=B,DDGFC1=C1,DDGFC2=C2,DDGFC3=C3
65 S DDGFBKCO=C1-$P(DDGFLIM,U)+1_","_(C2-$P(DDGFLIM,U,2)+1)
66 S DDGFBKNO=C
67 ;
68 ;Invoke form to edit block
69 S DDSFILE=.403,DDSFILE(1)=.4032
70 S DA(2)=+DDGFFM,DA(1)=DDGFPG,DA=B
71 S DR="[DDGF BLOCK EDIT]",DDSPARM="KTW"
72 D ^DDS K DDSFILE,DA,DR,DDSPARM
73 ;
74 ;If block was deleted, remove data from DDGFREF
75 I $D(^DIST(.403,+DDGFFM,40,DDGFPG,40,DDGFBK,0))[0 D DELETE(DDGFBK) G EDITQ
76 ;
77 S:$D(DDGFBKCN)[0 DDGFBKCN=DDGFBKCO
78 S:$D(DDGFBKNN)[0 DDGFBKNN=DDGFBKNO
79 ;
80 S C=DDGFBKNN
81 S C1=$P(DDGFBKCN,",")-1+$P(DDGFLIM,U)
82 S C2=$P(DDGFBKCN,",",2)-1+$P(DDGFLIM,U,2)
83 S C3=C2+$L(C)-1
84 ;
85 ;Update TMP if coordinates or name changed, or new block
86 I DDGFBKCN'=DDGFBKCO!(DDGFBKNN'=DDGFBKNO)!$G(DDGFADD) D
87 . D WRITE^DDGLIBW(DDGFWIDB,$J("",$L(DDGFBKNO)),DDGFC1-$P(DDGFLIM,U),DDGFC2-$P(DDGFLIM,U,2),"",1)
88 . D WRITE^DDGLIBW(DDGFWIDB,C,C1-$P(DDGFLIM,U),C2-$P(DDGFLIM,U,2),"",1)
89 ;
90EDITQ D REFRESH^DDGF,RC(DDGFDY,DDGFDX)
91 S:'$G(DDGFADD) DDGFE=1
92 K DDGFADD,DDGFBK,DDGFBKCO,DDGFBKNO,DDGFBKCN,DDGFBKNN
93 K DDGFC1,DDGFC2,DDGFC3,DDGFDX,DDGFDY
94 Q
95 ;
96DELETE(B,E) ;Remove block from DDGFREF
97 ;E : means don't set DDGFEBV or DDGFBDEL
98 ; (used by EDIT^DDGFHBK when a different header block is chosen)
99 N F,N
100 ;Remove from TMP
101 S F="" F S F=$O(@DDGFREF@("F",DDGFPG,B,F)) Q:F="" D
102 . S N=@DDGFREF@("F",DDGFPG,B,F)
103 . K:$P(N,U,4)]"" @DDGFREF@("RC",DDGFWID,$P(N,U),$P(N,U,2),$P(N,U,3),B)
104 . K:$P(N,U,8)>0 @DDGFREF@("RC",DDGFWID,$P(N,U,5),$P(N,U,6),$P(N,U,7),B)
105 K @DDGFREF@("F",DDGFPG,B)
106 ;
107 ;If no blocks on page, set DDGFEBV to exit Block Viewer
108 ;DDGFBDEL indicates block name should not be painted
109 I $G(DDGFBV) D:'$G(E)
110 . I '$P(^DIST(.403,+DDGFFM,40,DDGFPG,0),U,2),'$O(^(40,0)) S DDGFEBV=1
111 . S DDGFBDEL=1
112 E D PG^DDGFLOAD(+DDGFFM,+DDGFPG,1,1)
113 ;
114 ;If used on no other forms, ask whether to delete from block file
115 I '$O(^DIST(.403,"AB",B,"")),'$O(^DIST(.403,"AC",B,"")) D
116 . K DDGFANS S DDGFBK=B
117 . D DDS(.404,"[DDGF BLOCK DELETE]")
118 . I $G(DDGFANS) S DIK="^DIST(.404,",DA=DDGFBK D ^DIK K DIK,DA
119 . K DDGFANS,DDGFBK
120 Q
121 ;
122DDS(DDSFILE,DR,DA,DDSPAGE) ;
123 ;Call DDS
124 S DDSPARM="KTW" D ^DDS K DDSPARM
125 Q
126 ;
127RC(DDGFY,DDGFX) ;Update status line, reset DX and DY, move cursor
128 N S
129 I DDGFR D
130 . S DY=IOSL-6,DX=IOM-9,S="R"_(DDGFY+1)_",C"_(DDGFX+1)
131 . X IOXY W S_$J("",7-$L(S))
132 S DY=DDGFY,DX=DDGFX X IOXY
133 Q
Note: See TracBrowser for help on using the repository browser.