source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUMF4L0.m@ 1801

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

initial load of WorldVistAEHR
File size: 3.9 KB
Line 
1XUMF4L0 ;OIFO-OAK/RAM - Load IMF ;02/21/02
2 ;;8.0;KERNEL;**217**;Jul 10, 1995
3 ;
4 ; $$PARAM^HLCS2 call supported by IA #3552
5 ;
6MAIN ; -- main
7 ;
8 Q:$$SERVER^XUMFI()
9 ;
10 D V23
11 ;
12 I $$CNT<1000 D NEVER Q
13 ;
14 D BG
15 ;
16 Q
17 ;
18BG ; -- background job
19 ;
20 N ZTRTN,ZTDESC,ZTDTH,ZTIO
21 ;
22 S ZTRTN="EN^XUMF4L0"
23 S ZTDESC="XUMF Institution file background cleanup"
24 S ZTDTH=$$NOW^XLFDT
25 S ZTIO=""
26 ;
27 D ^%ZTLOAD
28 ;
29 Q
30 ;
31EN ; -- entry point
32 ;
33 D UPDATE,LOCAL^XUMF4L2,NVS^XUMF4L2,EXIT Q
34 ;
35 Q
36 ;
37UPDATE ; -- get FACILITY TYPE, update, get INSTITUTION, update
38 ;
39 ; -- get FACILITY TYPE
40 K ^TMP("XUMF ARRAY",$J)
41 ;
42 N PARAM,XUMFLAG,ERROR,TEST
43 ;
44 S (ERROR,XUMFLAG,TEST)=0
45 ;
46 I $P($$PARAM^HLCS2,U,3)="T" S TEST=1
47 ;
48 L +^TMP("XUMF ARRAY",$J):0 D:'$T
49 .S ERROR="1^another process is using the Master File Server"
50 ;
51 I ERROR D EXIT Q
52 ;
53 D MFS0
54 ;
55 I ERROR D EXIT Q
56 ;
57 I '$D(^TMP("XUMF ARRAY",$J)) D D EXIT Q
58 .S ERROR="1^Connection to master file server failed!"
59 ;
60 ; -- update
61 D FTCLEAN^XUMF4A I ERROR D EXIT Q
62 ;
63 ; -- get INSTITUTION
64 K ^TMP("XUMF ARRAY",$J),^TMP("XUMF MFS",$J)
65 ;
66 D MFS1
67 ;
68 I ERROR D EXIT Q
69 ;
70 I '$D(^TMP("XUMF ARRAY",$J)) D Q
71 .S ERROR="1^Connection to master file server failed!"
72 .D EXIT
73 ;
74 ; -- update
75 D EN^XUMF4L1
76 ;
77 D EXIT
78 ;
79 Q
80 ;
81MFS0 ; -- get national facility type file from Master File Server
82 ;
83 S PARAM("LLNK")="XUMF MFR^XUMF "_$S('TEST:"FORUM",1:"TEST")
84 S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFQ",0))
85 ;
86 D MAIN^XUMFP(4.1,"ALL",7,.PARAM,.ERROR) Q:ERROR
87 D MAIN^XUMFI(4.1,"ALL",7,.PARAM,.ERROR) Q:ERROR
88 D MAIN^XUMFH
89 ;
90 Q
91 ;
92MFS1 ; -- get national facility type file from Master File Server
93 ;
94 S PARAM("LLNK")="XUMF MFR^XUMF "_$S('TEST:"FORUM",1:"TEST")
95 S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFQ",0))
96 ;
97 D MAIN^XUMFP(4,"ALL",7,.PARAM,.ERROR) Q:ERROR
98 D MAIN^XUMFI(4,"ALL",7,.PARAM,.ERROR) Q:ERROR
99 D MAIN^XUMFH
100 ;
101 Q
102 ;
103 ;
104CNT() ; -- count station numbers in Institution file
105 ;
106 N STA,CNT
107 ;
108 S STA="" F S STA=$O(^DIC(4,"D",STA)) Q:STA="" S CNT=$G(CNT)+1
109 ;
110 Q CNT
111 ;
112EXIT ; -- cleanup and quit
113 ;
114 K ^TMP("XUMF ADD",$J),^TMP("XUMF MOD",$J),^TMP("XUMF DEL",$J)
115 K ^TMP("XUMF ARRAY",$J),^TMP("XUMF MFS",$J),^TMP("DIERR",$J)
116 ;
117 L -^TMP("XUMF ARRAY",$J)
118 ;
119 S ZTREQ="@"
120 ;
121 Q
122 ;
123V23 ; -- stuff VISN 23
124 ;
125 N XUMF,IENS,IEN
126 ;
127 S XUMF=1
128 ;
129 S IEN=$O(^DIC(4.1,"B","VISN",0))
130 S IENS=$S(IEN:IEN_",",1:"+1,")
131 ;
132 K FDA
133 S FDA(4.1,IENS,.01)="VISN"
134 S FDA(4.1,IENS,1)="VETERANS INTEGRATED SERVICE NETWORK"
135 S FDA(4.1,IENS,3)="NATIONAL"
136 D UPDATE^DIE("E","FDA")
137 ;
138 S IEN=$O(^DIC(4,"B","VISN 23",0))
139 S IENS=$S(IEN:IEN_",",1:"+1,")
140 ;
141 K FDA
142 S FDA(4,IENS,.01)="VISN 23"
143 S FDA(4,IENS,11)="LOCAL"
144 S FDA(4,IENS,13)="VISN"
145 D UPDATE^DIE("E","FDA")
146 ;
147 Q
148 ;
149NEVER ; -- cleanup never performed - notify site and NVS
150 ;
151 N XMSUB,TEXT,XMY,XMDUZ,XMTEXT
152 ;
153 S TEXT(1)="A check of the INSTITUTION file (#4) indicates the IFR"
154 S TEXT(2)="cleanup has NOT been performed."
155 S TEXT(3)=""
156 S TEXT(4)="The IFR cleanup is a required action. Future initiatives"
157 S TEXT(5)="are dependant on consistent and reliable Institution data"
158 S TEXT(6)="at each site. A copy of this message is being sent to NVS"
159 S TEXT(7)="for tracking purposes."
160 S TEXT(8)=""
161 S TEXT(9)="If you require assistance performing the IFR cleanup,"
162 S TEXT(10)="you may contact NVS and someone will contact you and"
163 S TEXT(11)="help you with the IFR cleanup process. To request"
164 S TEXT(12)="assistance you may send a MailMan message to the"
165 S TEXT(13)="G.XUMF INSTITUTION mail group on FORUM or log a NOIS."
166 S TEXT(14)=""
167 S TEXT(15)="Note: Running the IFR cleanup on LEGACY systems is"
168 S TEXT(16)="OPTIONAL. If this message refers to a legacy system"
169 S TEXT(17)="please disregard this message."
170 ;
171 S XMSUB="IFR/cleanup/REQUIRED at "_$$SITE
172 S XMDUZ=$S(DUZ:DUZ,1:.5),XMY(DUZ)=""
173 S XMTEXT="TEXT("
174 S XMY("G.XUMF INSTITUTION")=""
175 S:$P($$PARAM^HLCS2,U,3)'="T" XMY("G.XUMF INSTITUTION@FORUM")=""
176 D ^XMD
177 ;
178 Q
179 ;
180SITE() ; -- facility name and sta # string
181 ;
182 Q $P($G(^DIC(4,+DUZ(2),0)),U)_" Sta#: "_$P($G(^DIC(4,+DUZ(2),99)),U)
183 ;
Note: See TracBrowser for help on using the repository browser.