source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LR7OF4.m@ 1432

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

initial load of WorldVistAEHR
File size: 1.6 KB
RevLine 
[613]1LR7OF4 ;slc/dcm - Process messages from OE/RR ;8/11/97
2 ;;5.2;LAB SERVICE;**121,187**;Sep 27, 1994
3PURG ;Process Purge request for OBR Segment
4 N TST,X,LRODT,LRSN,LRORD,LRORIFN,STARTDT,LRDUZ,PROV,REASON,QUANT,LREND
5 S LREND=0
6 D GET^LR7OF2(.LRXORC,LRXORC) Q:LREND
7 I 'LRVERZ S LRODT=0 F S LRODT=$O(^LRO(69,"C",LRORD,LRODT)) Q:LRODT<1 S LRSN=0 F S LRSN=$O(^LRO(69,"C",LRORD,LRODT,LRSN)) Q:LRSN<1 D Q
8 . S X=$P($P(LRXMSG,"|",5),"^",4) I X S TST=$O(^LRO(69,LRODT,1,LRSN,2,"B",X,0)) I TST D P1(LRODT,LRSN,TST) Q:LREND
9 I LRVERZ,$D(^LRO(69,LRODT,1,LRSN,0)) S X=$P($P(LRXMSG,"|",5),"^",4) I X S TST=$O(^LRO(69,LRODT,1,LRSN,2,"B",X,0)) I TST D P1(LRODT,LRSN,TST) Q:LREND
10 I LREND D ACK^LR7OF0("ZU",LRXORC) Q
11 D ACK^LR7OF0("ZR",LRXORC)
12 Q
13P1(LRODT,LRSN,TST) ;Check to purge
14 N X
15 I '$D(^LRO(69,LRODT,1,LRSN,0)) Q
16 S X=+^LRO(69,LRODT,1,LRSN,0) I $D(^LR(X,0)),$P(X,"^",2)'=2 G P2
17 I '$D(^LRO(69,LRODT,1,LRSN,1)) S LREND=1 Q
18 I $D(^LRO(69,LRODT,1,LRSN,3)),'$L($P(^(3),"^",2)) S LREND=1 Q
19P2 S:$D(^LRO(69,LRODT,1,LRSN,2,TST,0)) $P(^(0),"^",7)="P" ;P=flag for purged
20 Q
21PURG1 ;Process Purge request for ORC Segment
22 N X,I,STOP S X=$P(LRXORC,"|",4),STOP=0
23 S I=LINE F S I=$O(MSG(I)) Q:I<1 I $P(MSG(I),"|")="OBR" S STOP=1 Q
24 Q:STOP
25 I $L(X,"^")>5 D ACK^LR7OF0("ZR",LRXORC) Q ;Old unreleased 2.5 order
26 I +X#1 D ACK^LR7OF0("ZR",LRXORC) Q ;Old ORGY 2.5
27 I +X,$P(X,"^",2),$P(X,"^",3) D ACK^LR7OF0("ZR",LRXORC) Q ;Old unconverted 2.5
28 I +X,$P(X,"^",2)="LRCH" D PURG Q ;3.0 order with no tests (early tuscaloosa days)
29 I 'X D ACK^LR7OF0("ZR",LRXORC) Q ;Order with no lab pointers
30 D ACK^LR7OF0("DE",LRXORC,"Unrecognized ID's :"_$P(LRXORC,"|",4))
31 Q
Note: See TracBrowser for help on using the repository browser.