source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBA278P.m

Last change on this file was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 5.7 KB
Line 
1DVBA278P ;ALB/GTS - PATCH DVBA*2.7*8 TO CLEANUP 396.1 DD ; 4/29/96
2 ;;2.7;AMIE;**8**;Apr 10, 1995
3 ;
4TEXT ; write lines for user
5 ;; This routine will loop through all fields in the AMIE SITE PARAMETER
6 ;; file looking for fields not supported with class I software. When
7 ;; such a field is found, the installer will be asked if they want to
8 ;; delete the field. When all fields are checked, a message will be
9 ;; sent to the installer indicating what they selected to delete.
10 ;; This message serves as record of what was selected for a particular
11 ;; install and can be used to check if existing class III fields are
12 ;; needed. The user may abort the install by entering an '^' at
13 ;; the Device selection prompt. If you are unsure that the fields
14 ;; you have selected for deletion are not used by any class III
15 ;; programming at your site, PLEASE '^' AT THE DEVICE SELECTION
16 ;; PROMPT AND REVIEW THE MAIL MESSAGE THAT IS DELIVERED. You may
17 ;; rerun the install at any time after you have reviewed the mail
18 ;; message.
19 ;;
20 ;;QUIT
21 ;
22ENVCHKQ QUIT ;** Quit the environment check. Only called so routine is
23 ; ** available from Pre-Init questions.
24 ;
25QUEST ;** Entry point - Question Class III fields
26 N TXTVAR
27 D KVARS
28 D MES^XPDUTL(" "),MES^XPDUTL(" ")
29 F I=1:1 S TXTVAR=$P($T(TEXT+I),";;",2) Q:TXTVAR="QUIT" DO
30 .S:TXTVAR="" TXTVAR=" "
31 .D MES^XPDUTL(TXTVAR)
32 D START
33 Q
34 ;
35 ;
36START ;** Start processing
37 S (I,NODE,COUNT,QUESDA)=0
38 ;
39 ;** Look for unsupported fields
40 D MES^XPDUTL(" ")
41 D MES^XPDUTL("Inspecting file 396.1 for unsupported fields.")
42 ;
43 ;** Class I fld array
44 F FILE=396.1,396.12,396.13,396.14,396.115 DO
45 .F I=(I+1):1 S FIELDVAR=$P($T(FIELDS+I),";;",2) Q:(FIELDVAR="QUIT") DO
46 ..S CLASSI(FILE,FIELDVAR)=""
47 ;
48 ;** Fields at site
49 F FILE=396.1,396.12,396.13,396.14,396.115 DO
50 .F FLDDA=0:0 S FLDDA=$O(^DD(FILE,FLDDA)) Q:'FLDDA DO
51 ..I $D(^DD(FILE,FLDDA,0)),'$D(CLASSI(FILE,FLDDA)) DO
52 ...S CLASSIII(FILE,FLDDA)=$P(^DD(FILE,FLDDA,0),"^",1)_"^"_$P(^(0),"^",4)
53 ;
54 ;** If no Class III fields
55 I '$D(CLASSIII) DO
56 .D MES^XPDUTL(" ")
57 .D MES^XPDUTL(".....no unsupported fields were found!")
58 ;
59 ;** Nullify all XPDQUES nodes
60 S QUESSUB=""
61 F S QUESSUB=$O(XPDQUES(QUESSUB)) Q:(QUESSUB']"") DO
62 .S XPDQUES(QUESSUB)=""
63 .S XPDQUES(QUESSUB,"A")=""
64 ;
65 ;** Set up XPDQUES nodes
66 S FILE=""
67 F S FILE=$O(CLASSIII(FILE)) Q:('FILE!($D(DVBAOUT))) DO
68 .S FLDDA=""
69 .F S FLDDA=$O(CLASSIII(FILE,FLDDA)) Q:('FLDDA!($D(DVBAOUT))) DO
70 ..W !!!,?1,"Field #",?12,"Field Name",?45,"Node;Piece"
71 ..W !,?3,FLDDA
72 ..W ?12,$P(CLASSIII(FILE,FLDDA),U,1)
73 ..W ?48,$P(CLASSIII(FILE,FLDDA),U,2)
74 ..S DIR(0)="YAO^",DIR("A")="Do you want to delete this field? "
75 ..S DIR("B")="YES" D ^DIR
76 ..I $D(DTOUT)!($D(DUOUT)!($D(DIROUT))) S DVBAOUT=""
77 ..I '$D(DVBAOUT)&(+Y=1) DO
78 ...S QUESDA=QUESDA+1
79 ...S QUESSUB="PRE"_QUESDA
80 ...S XPDQUES(QUESSUB)=$P(CLASSIII(FILE,FLDDA),U,1)_"^"_FLDDA_"^"_FILE
81 ...S XPDQUES(QUESSUB,"A")=$P(CLASSIII(FILE,FLDDA),U,1)_" selected for deletion!"
82 ..K DIR,X,Y
83 I $D(DVBAOUT) K XPDQUES
84 I '$D(DVBAOUT) D MAIL
85KVARS K COUNT,DFN,I,NODE,NODENM,FIELDVAR,FLDDA,FILE,QUESDA
86 K CLASSI,CLASSIII,DVBAOUT
87 K DTOUT,DUOUT,DIROUT
88 Q
89 ;
90MAIL ; mail message of bogus nodes found
91 N DIFROM
92 S XMY(DUZ)="",XMDUZ=.5
93 S XMSUB="AMIE SITE PARAMETER file field cleanup"
94 S XMTEXT="^TMP(""DVBA V2.7 P8 E-MAIL"","_$J_","
95 S I=0,COUNT=0
96 S TEXT="This Mailman message records the Class III fields selected for deletion"
97 D LINE(TEXT)
98 S TEXT=" with patch DVBA*2.7*8. These fields are only deleted if/when the"
99 D LINE(TEXT)
100 S TEXT=" installation was/is completed."
101 D LINE(TEXT)
102 D LINE(" ")
103 S TEXT=" The following fields were selected to delete from the AMIE SITE"
104 D LINE(TEXT)
105 S TEXT=" PARAMETER file (#396.1) (Multiples included):"
106 D LINE(TEXT)
107 D LINE(" ")
108 I '$D(XPDQUES) DO
109 .S TEXT=" No fields selected for deletion!"
110 .D LINE(TEXT)
111 I $D(XPDQUES("PRE1")),(XPDQUES("PRE1")="") DO
112 .S TEXT=" No fields selected for deletion!"
113 .D LINE(TEXT)
114 I $D(XPDQUES("PRE1")),(XPDQUES("PRE1")'="") DO
115 .S TEXT=" FIELD NAME FIELD # FILE #"
116 .D LINE(TEXT)
117 .S TEXT=" ========== ======= ======"
118 .D LINE(TEXT)
119 .S I="PRE0"
120 .F S I=$O(XPDQUES(I)) Q:(I']"") D
121 ..S (BLANK1,BLANK2)=""
122 ..S $P(BLANK1," ",(37-$L($P(XPDQUES(I),"^",1))))=""
123 ..S TEXT=" "_$P(XPDQUES(I),"^",1)_BLANK1_$P(XPDQUES(I),"^",2)
124 ..S $P(BLANK2," ",(53-$L(TEXT)))=""
125 ..S TEXT=TEXT_BLANK2_$P(XPDQUES(I),"^",3)
126 ..D LINE(TEXT)
127 D ^XMD
128 K XMDUZ,XMY,XMTEXT,XMSUB,BLANK1,BLANK2,TEXT,QUESSUB
129 K ^TMP("DVBA V2.7 P8 E-MAIL",$J)
130 Q
131 ;
132 ;
133LINE(TEXT) ; add line to array for e-mail
134 S COUNT=COUNT+1,^TMP("DVBA V2.7 P8 E-MAIL",$J,COUNT)=TEXT
135 Q
136 ;
137FLDCLEAN ;**Delete selected fields
138 I $D(XPDQUES) DO
139 .N I,SITEDA,MULTDA,FLDDA,FILEDA1,NODE,CLEANFLD
140 .S SITEDA=0
141 .S SITEDA=$O(^DVB(396.1,SITEDA))
142 .S I="PRE0"
143 .F S I=$O(XPDQUES(I)) Q:(I']"") Q:(XPDQUES(I)="") D
144 ..S FILEDA1=$P(XPDQUES(I),"^",3)
145 ..S FLDDA=$P(XPDQUES(I),"^",2)
146 ..;
147 ..;** Remove data in fields deleted
148 ..I FILEDA1=396.1 DO
149 ...S DIE="^DVB(396.1,",DA=SITEDA
150 ...S DR=FLDDA_"////@"
151 ...D ^DIE
152 ...K DIE,DA,DR
153 ..I FILEDA1'=396.1 DO
154 ...S (CLEANFLD,MULTDA)=0
155 ...S MULTDA=$O(^DD(396.1,"SB",FILEDA1,0))
156 ...S:MULTDA CLEANFLD=1,NODE=$P($P(^DD(396.1,MULTDA,0),"^",4),";",1)
157 ...I CLEANFLD DO
158 ....S MULTDA=0
159 ....F S MULTDA=$O(^DVB(396.1,SITEDA,NODE,MULTDA)) Q:'MULTDA DO
160 .....S DIE="^DVB(396.1,"_SITEDA_","_NODE_","
161 .....S DA=MULTDA,DA(1)=SITEDA
162 .....S DR=FLDDA_"////@"
163 .....D ^DIE
164 .....K DIE,DA,DR
165 ..;
166 ..;** Remove from DD
167 ..S DA=FLDDA
168 ..S DA(1)=FILEDA1
169 ..S DIK="^DD("_DA(1)_","
170 ..D ^DIK
171 ..K DA,DIK
172 Q
173 ;
174FIELDS ; list of fields in 396.1
175 ;;.01
176 ;;.11
177 ;;2
178 ;;3
179 ;;4
180 ;;6
181 ;;7
182 ;;8
183 ;;9
184 ;;10
185 ;;11
186 ;;12
187 ;;14
188 ;;15
189 ;;16
190 ;;17
191 ;;18
192 ;;50
193 ;;90
194 ;;QUIT
195P12 ;;.01
196 ;;QUIT
197P13 ;;.01
198 ;;1
199 ;;QUIT
200P14 ;;.01
201 ;;1
202 ;;QUIT
203P115 ;;.01
204 ;;QUIT
Note: See TracBrowser for help on using the repository browser.