source: WorldVistAEHR/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7SMU.m@ 1704

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

initial load of WorldVistAEHR
File size: 7.7 KB
Line 
1LA7SMU ;DALOI/JMC - Shipping Manifest Utility ;5/5/97 14:44;
2 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,64**;Sep 27, 1994
3 Q
4 ;
5CHKSM(X) ; Shipping manifest status check
6 ; Call with X = ien of file #62.9 LAB SHIPPING CONFIGURATION
7 ; Returns -1 = error^reason
8 ; 0 = no active shipping manifest exists
9 ; >0 = ien of active shipping manifest in file #62.8, LAB SHIPPING MANIFEST
10 ;
11 ; No value passed
12 I '$G(X) Q "-1^No configuration passed"
13 ; Bad pointer passed
14 I '$D(^LAHM(62.9,X,0)) Q "-1^Bad configuration pointer"
15 ; Get ien of active shipping manifest.
16 S Y=+$O(^LAHM(62.8,"AC1",X,0))
17 I Y S Y=Y_"^"_$P(^LAHM(62.8,Y,0),"^")
18 Q Y
19 ;
20 ;
21CSM(LA7SCFG) ; Creates a new shipping manifest
22 ; Call with X = ien of file #62.9 LAB SHIPPING CONFIGURATION
23 ; Returns -1 = error^reason
24 ; 0 = no active shipping manifest exists
25 ; >0 = ien of active shipping manifest in file #62.8, LAB SHIPPING MANIFEST
26 ;
27 N DATA,FDA,I,LA7CF,LA7DIE,LA7DT,LA7IEN,LA7SM,X,X4
28 ;
29 ; No value passed
30 I '$G(LA7SCFG) Q "-1^No configuration passed"
31 ;
32 ; Bad pointer passed
33 I '$D(^LAHM(62.9,LA7SCFG,0)) Q "-1^Bad configuration pointer"
34 ;
35 S LA7SCFG(0)=$G(^LAHM(62.9,LA7SCFG,0))
36 ; ien of collecting facility
37 S LA7CF=$P(LA7SCFG(0),"^",2)
38 ; file #4 INSTITUTION information
39 F I=.01,.05,99 S X4(I)=$$GET1^DIQ(4,LA7CF_",",I)
40 ;
41 ; Get station number else use short name
42 S LA7SM=""
43 I $L(X4(99)) S LA7SM=X4(99)
44 E S LA7SM=X4(.05)
45 ; Failsafe value
46 I LA7SM="" S LA7SM="INST:"_LA7CF
47 S DT=$$DT^XLFDT,LA7DT=$E($$FMTHL7^XLFDT(DT),1,8)
48 S LA7SM=LA7SM_"-"_LA7DT_"-"
49 ;
50 L +^LAHM(62.8,0):5 ; Set lock
51 I '$T Q "-1^Unable to obtain lock on file LAB SHIPPING MANIFEST #62.8"
52 S X=0
53 F S X=X+1 Q:'$D(^LAHM(62.8,"B",LA7SM_X))
54 S LA7SM=LA7SM_X
55 ;
56 S FDA(1,62.8,"+1,",.01)=LA7SM
57 S FDA(1,62.8,"+1,",.02)=LA7SCFG
58 S FDA(1,62.8,"+1,",.03)=1
59 I $P(LA7SCFG(0),"^",8) S FDA(1,62.8,"+1,",.04)=$P(LA7SCFG(0),"^",8)
60 S FDA(1,62.8,"+1,",.05)=+$P(LA7SCFG(0),"^",15)
61 S FDA(1,62.8,"+1,",.06)=+$P(LA7SCFG(0),"^",16)
62 D UPDATE^DIE("","FDA(1)","LA7IEN","LA7DIE(1)")
63 D RECALL^DILFD(62.8,LA7IEN(1)_",",DUZ)
64 ;
65 S DATA="SM01^"_$$NOW^XLFDT
66 D SEUP(LA7SM,1,DATA)
67 ;
68 S DATA="SM02^"_$$NOW^XLFDT
69 D SEUP(LA7SM,1,DATA)
70 ;
71 ; Release lock
72 L -^LAHM(62.8,0)
73 Q LA7IEN(1)_"^"_LA7SM
74 ;
75 ;
76SMSUP(LA7SM,LA7ST,LA7EVNC) ; Shipping manifest status update.
77 ; Call with LA7SM = ien of entry in file #62.8 LAB SHIPPING MAINFEST^.01 field
78 ; LA7ST = status to update
79 ; LA7EVNC = event code^event date/time (default=NOW)
80 ;
81 N DATA,FDA,LA7IEN
82 ;
83 S LA7IEN(1)=+LA7SM
84 S FDA(2,62.8,+LA7SM_",",.03)=LA7ST
85 D UPDATE^DIE("","FDA(2)","LA7IEN","LA7DIE(2)")
86 S DATA=$P(LA7EVNC,"^")_"^"_$S($P(LA7EVNC,"^",2):$P(LA7EVNC,"^",2),1:$$NOW^XLFDT)
87 D SEUP($P(LA7SM,"^",2),1,DATA)
88 Q
89 ;
90 ;
91STSUP(LA7SM,LA762801,LA7DATA) ; Shipping test status update
92 ; Call with LA7SM = ien of shipping manifest (#62.8)
93 ; LA762801 = ien of test entry on shipping manifest
94 ; LA7DATA = data to be filed
95 N FDA
96 S LA762801=LA762801_","_+LA7SM_","
97 S FDA(62.8,62.801,LA762801,.08)=LA7DATA
98 D FILE^DIE("","FDA(62.8)","LA7DIE(2)")
99 Q
100 ;
101 ;
102SEUP(LA7ID,LA7EVN,LA7DATA) ; Shipping event update
103 ; Call with LA7ID = shipping identifier (manifest invoice # or UID)
104 ; LA7EVN = event type (1=shipping manifest/2=test)
105 ; LA7DATA = data to be filed
106 N FDA,I,LA7IEN,X
107 L +^LAHM(62.85,0) ; Set lock
108 S FDA(3,62.85,"+1,",.01)=LA7ID
109 S FDA(3,62.85,"+1,",.02)=$S($G(DUZ)>0:DUZ,1:.5)
110 S FDA(3,62.85,"+1,",.03)=$$NOW^XLFDT
111 S FDA(3,62.85,"+1,",.04)=LA7EVN
112 I $L($P(LA7DATA,"^")) D
113 . S X=$$EVNC($P(LA7DATA,"^"))
114 . I X S FDA(3,62.85,"+1,",.05)=+X
115 F I=2:1:4 I $L($P(LA7DATA,"^",I)) S FDA(3,62.85,"+1,",$P("^.07^.08^.09","^",I))=$P(LA7DATA,"^",I)
116 ;
117 ; Add event to lab shipping event.
118 D UPDATE^DIE("","FDA(3)","LA7IEN","LA7DIE(3)")
119 ; Release lock
120 L -^LAHM(62.85,0)
121 ;
122 Q
123 ;
124 ;
125ACCSUP(LA7UID,LA760,LA7DATA) ; Accession status update
126 ; Call with LA7UID = UID of accession to update
127 ; LA7DATA = value to update (pointer to file #62.8, LAB SHIPPING MANIFEST or "@" to delete
128 ;
129 N FDA,LA7AA,LA7AD,LA7AN,LA7CAD,LA768,X
130 S X=$Q(^LRO(68,"C",LA7UID))
131 S LA7AA=$QS(X,4),LA7AD=$QS(X,5),LA7AN=$QS(X,6)
132 S LA7CAD=$$AD^LA7SUTL(LA7AA) ; Get current accession date for this accession area.
133 S LA7AD=LA7AD-.000000001
134 F S LA7AD=$O(^LRO(68,LA7AA,1,LA7AD)) Q:'LA7AD!(LA7AD>LA7CAD) D
135 . I '$D(^LRO(68,LA7AA,1,LA7AD,1,LA7AN)) Q
136 . I $P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.3)),"^")'=LA7UID Q
137 . I '$D(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,LA760)) Q ; Test not on accession.
138 . S LA768=LA760_","_LA7AN_","_LA7AD_","_LA7AA_","
139 . S FDA(68,68.04,LA768,9)=LA7DATA
140 . D FILE^DIE("","FDA(68)","LA7DIE(68)")
141 Q
142 ;
143 ;
144SELSM(LA7SCFG,LA7SCR) ; Select shipping manifest
145 ; Call with LA7SCFG = ien of file #62.9 LAB SHIPPING CONFIGURATION
146 ; LA7SCR = comma delimited list of status screen - only allow selection of manifests with matching status
147 ; Returns LA7Y = pointer to shipping manifest or error
148 N D,DIC,DTOUT,DUOUT,LA7Y,X,Y
149 S DIC="^LAHM(62.8,",DIC(0)="AEQ",DIC("A")="Select Shipping Manifest: "
150 S DIC("S")="I $P(^LAHM(62.8,Y,0),U,2)=LA7SCFG"
151 S DIC("W")="D SMW^LA7SMU1(Y)"
152 I $G(LA7SCR)'="" S DIC("S")=DIC("S")_","""_LA7SCR_"""[$P(^LAHM(62.8,Y,0),U,3)"
153 S D="C"
154 D MIX^DIC1
155 I Y<1 S LA7Y="-1^"
156 E S LA7Y=Y
157 Q LA7Y
158 ;
159 ;
160SMED(LA7SM,LA7EVC) ; Determine shipping manifest's event date
161 ; Call with LA7SM = ien of entry in file #62.8 LAB SHIPPING MANIFEST
162 ; LA7EVC = event type code
163 ; Returns LA7Y = internal event date^external event date
164 N LA7I,LA7X,LA7Y
165 I '$G(LA7SM) Q "-1^No shipping manifest passed"
166 S LA7SM(0)=$G(^LAHM(62.8,+LA7SM,0))
167 S LA7EV=+$$EVNC(LA7EVC)
168 I LA7EVC="SM05",$P(LA7SM(0),"^",3)'>2 Q "0^Shipping manifest has not been shipped"
169 S LA7I=0,LA7Y=""
170 F S LA7I=$O(^LAHM(62.85,"B",$P(LA7SM(0),"^"),LA7I)) Q:'LA7I D Q:$L(LA7Y)
171 . I $P($G(^LAHM(62.85,LA7I,0)),"^",5)'=LA7EV Q
172 . S LA7Y=$P(^LAHM(62.85,LA7I,0),"^",7)_"^"_$$FMTE^XLFDT($P(^LAHM(62.85,LA7I,0),"^",7),"M") ; Event date/time
173 I $G(LA7Y)="" S LA7Y="-2^No event date found"
174 Q LA7Y
175 ;
176 ;
177EVNC(LA7EVC) ; Resolve an event code to it's pointer/text(.01) value
178 ; Call with LA7EVC = Code to lookup, i.e. SM01, SM50
179 ; Returns Y = ien of code in file #64.061, LAB ELECTRONIC CODES.
180 N X,Y
181 S (X,Y)=0
182 F S X=$O(^LAB(64.061,"F",LA7EVC,X)) Q:'X D Q:Y
183 . S X(0)=$G(^LAB(64.061,X,0))
184 . I $P(X(0),"^",7)="E" S Y=X_"^"_$P(X(0),"^")
185 I 'Y S Y="0^Code not on file"
186 Q Y
187 ;
188 ;
189CHKTST(LA7SM,LA762801) ; Check and update if test is still valid.
190 ; Call with LA7SM = ien of shipping manifest in file #62.8
191 ; LA762801 = ien of entry on test multiple in file #62.8
192 ;
193 ; Returns LA7SKIP = 0 (Test still on accession).
194 ; 1 (Test not on accession).
195 ; 2 (Accession deleted/purged).
196 ; 3 (Test not on accession - already shipped)
197 ; 4 (Accession deleted/purged - already shipped)
198 ;
199 N LA7AA,LA7AD,LA7AN,LA7DATA,LA7SKIP,LA7UID,X,Y
200 S LA7SKIP=0
201 S LA7SM(0)=$G(^LAHM(62.8,+LA7SM,0))
202 S LA762801(0)=$G(^LAHM(62.8,+LA7SM,10,+LA762801,0))
203 S LA7UID=$P(LA762801(0),"^",5)
204 S X=$Q(^LRO(68,"C",LA7UID))
205 S LA7AA=+$QS(X,4),LA7AD=+$QS(X,5),LA7AN=+$QS(X,6)
206 ;
207 ; Test found.
208 I $D(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,+$P(LA762801(0),"^",2),0)) Q LA7SKIP
209 ; Accession missing.
210 I '$D(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)) D
211 . ; Already shipped
212 . I $P(LA7SM(0),"^",3)>4 S LA7SKIP=4 Q
213 . S LA7SKIP=2,LA7DATA="SM62"
214 ;
215 ; Test missing.
216 I 'LA7SKIP,'$D(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,4,+$P(LA762801(0),"^",2),0)) D
217 . ; Already shipped
218 . I $P(LA7SM(0),"^",3)>4 S LA7SKIP=3 Q
219 . S LA7SKIP=1,LA7DATA="SM61"
220 ;
221 ; Update manifest/event file if test has not shipped.
222 I LA7SKIP,LA7SKIP<3 D
223 . ; Update test on manifest
224 . D STSUP^LA7SMU(+LA7SM,LA762801,0)
225 . ; Update event file
226 . S LA7DATA=LA7DATA_"^"_$$NOW^XLFDT_"^"_$P(LA762801(0),"^",2)_"^"_$P(LA7SM(0),"^")
227 . D SEUP^LA7SMU(LA7UID,2,LA7DATA)
228 Q LA7SKIP
Note: See TracBrowser for help on using the repository browser.