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/XUMF390.m@ 789

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

initial load of WorldVistAEHR
File size: 2.9 KB
RevLine 
[613]1XUMF390 ;ISS/RAM - Load CLIA & MAMMO ID's;12/15/05
2 ;;8.0;KERNEL;**390**;Jul 10, 1995
3 ;
4 ; $$PARAM^HLCS2 call supported by IA #3552
5 ;
6 Q
7 ;
8MAIN ; -- main
9 ;
10 D LINK,BG
11 ;
12 Q
13 ;
14BG ; -- background job
15 ;
16 N ZTRTN,ZTDESC,ZTDTH
17 ;
18 S ZTRTN="EN^XUMF390"
19 S ZTDESC="XUMF Load CLIA ID's"
20 S ZTDTH=$$NOW^XLFDT
21 S ZTIO=""
22 ;
23 D ^%ZTLOAD
24 ;
25 Q
26 ;
27EN ; -- entry point
28 ;
29 D LOAD^XUMF(4)
30 ;
31 K ^TMP("XUMF ARRAY",$J)
32 ;
33 N PARAM,XUMFLAG,ERROR,TEST
34 ;
35 S (ERROR,XUMFLAG,TEST)=0
36 ;
37 I $P($$PARAM^HLCS2,U,3)="T" S TEST=1
38 ;
39 L +^TMP("XUMF ARRAY",$J):0 D:'$T
40 .S ERROR="1^another process is using the Master File Server"
41 ;
42 I ERROR D EXIT Q
43 ;
44 D MFS0
45 ;
46 I ERROR D EXIT Q
47 ;
48 I '$D(^TMP("XUMF ARRAY",$J)) D
49 .S ERROR="1^Connection to master file server failed!"
50 ;
51 I ERROR D EXIT Q
52 ;
53 D CLIA
54 ;
55 I ERROR D EXIT Q
56 ;
57 ; -- get MAMMO
58 ;
59 K ^TMP("XUMF ARRAY",$J),^TMP("XUMF MFS",$J)
60 ;
61 D MFS1
62 ;
63 I ERROR D EXIT Q
64 ;
65 I '$D(^TMP("XUMF ARRAY",$J)) D
66 .S ERROR="1^Connection to master file server failed!"
67 ;
68 I ERROR D EXIT Q
69 ;
70 D MAMMO
71 ;
72 D EXIT
73 ;
74 Q
75 ;
76MFS0 ; -- get CLIA from Institution Master File
77 ;
78 S PARAM("CDSYS")="CLIA"
79 S PARAM("LLNK")="XUMF MFR^XUMF "_$S('TEST:"FORUM",1:"TEST")
80 S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFQ",0))
81 ;
82 D MAIN^XUMFP(4,"ALL",7,.PARAM,.ERROR) Q:ERROR
83 D MAIN^XUMFI(4,"ALL",7,.PARAM,.ERROR) Q:ERROR
84 D MAIN^XUMFH
85 ;
86 Q
87 ;
88MFS1 ; -- get ACR# from Institution Master File
89 ;
90 S PARAM("CDSYS")="MAMMO-ACR"
91 S PARAM("LLNK")="XUMF MFR^XUMF "_$S('TEST:"FORUM",1:"TEST")
92 S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFQ",0))
93 ;
94 D MAIN^XUMFP(4,"ALL",7,.PARAM,.ERROR) Q:ERROR
95 D MAIN^XUMFI(4,"ALL",7,.PARAM,.ERROR) Q:ERROR
96 D MAIN^XUMFH
97 ;
98 Q
99 ;
100EXIT ; -- cleanup and quit
101 ;
102 K ^TMP("XUMF ARRAY",$J),^TMP("XUMF MFS",$J),^TMP("DIERR",$J)
103 ;
104 L -^TMP("XUMF ARRAY",$J)
105 ;
106 S ZTREQ="@"
107 ;
108 Q
109 ;
110CLIA ; -- add CLIA ID to Institution file
111 ;
112 N ID,NAME,FDA,ERROR,IEN,IENS,X,XUMF,STANUM,OFNME,AGENCY
113 ;
114 S XUMF=1
115 ;
116 S ID=""
117 F S ID=$O(^TMP("XUMF ARRAY",$J,ID)) Q:ID="" D
118 .S X=^TMP("XUMF ARRAY",$J,ID)
119 .S STANUM=$P(X,U,3)
120 .S IEN=$$IEN^XUMF(4,"CLIA",ID)
121 .I 'IEN,$G(STANUM)'="" S IEN=$O(^DIC(4,"D",STANUM,0))
122 .Q:'IEN
123 .S IENS="?+1,"_IEN_","
124 .K FDA
125 .S FDA(4.9999,IENS,.01)="CLIA"
126 .S FDA(4.9999,IENS,.02)=ID
127 .D UPDATE^DIE("E","FDA")
128 ;
129 Q
130 ;
131MAMMO ; -- add MAMMO ID to Institution file
132 ;
133 N ID,NAME,FDA,ERROR,IEN,IENS,X,XUMF,STANUM
134 ;
135 S XUMF=1
136 ;
137 S ID=""
138 F S ID=$O(^TMP("XUMF ARRAY",$J,ID)) Q:ID="" D
139 .S X=^TMP("XUMF ARRAY",$J,ID)
140 .S STANUM=$P(X,U,3)
141 .S IEN=$$IEN^XUMF(4,"MAMMO-ACR",ID)
142 .I 'IEN,$G(STANUM)'="" S IEN=$O(^DIC(4,"D",STANUM,0))
143 .Q:'IEN
144 .S IENS="?+1,"_IEN_","
145 .K FDA
146 .S FDA(4.9999,IENS,.01)="MAMMO-ACR"
147 .S FDA(4.9999,IENS,.02)=ID
148 .D UPDATE^DIE("E","FDA")
149 ;
150 Q
151 ;
152LINK ;
153 ;
154 N IEN,FDA,IENS
155 ;
156 S IEN=$$FIND1^DIC(870,,"BX","XUMF ACK")
157 S IENS=IEN_","
158 ;
159 K FDA
160 S FDA(870,IENS,4.5)=1
161 D UPDATE^DIE(,"FDA")
162 ;
163 S IEN=$$FIND1^DIC(870,,"BX","XUMF FORUM")
164 S IENS=IEN_","
165 ;
166 K FDA
167 S FDA(870,IENS,4.5)=1
168 D UPDATE^DIE(,"FDA")
169 ;
170 Q
171 ;
Note: See TracBrowser for help on using the repository browser.