LREVENT ;DALIO/JMC - Shipping Event X-ref Utility ; [ 05/21/97 2:26 PM ]
;;5.2;LAB SERVICE;**153,286**;Sep 27, 1994
Q
;
ADT ; set logic for ADT x-ref in file 62.85
N LRMAN S LRMAN=$P(^LAHM(62.85,DA,0),"^") Q:'$O(^LAHM(62.8,"B",LRMAN,0))
S ^LAHM(62.85,"ADT",LRMAN,9999999-X,DA)=""
Q
;
;
KADT ; kill logic for ADT x-ref in file 62.85
K ^LAHM(62.85,"ADT",$P(^LAHM(62.85,DA,0),"^"),9999999-X,DA)
Q
;
;
ATST ; set logic for ATST x-ref in file 62.85
N LREVDT,LRUID S LREVDT=$P($G(^LAHM(62.85,DA,0)),"^",7) Q:'LREVDT
S LRUID=$P(^LAHM(62.85,DA,0),"^") I $D(^LAHM(62.8,LRUID,0)) Q
I X S ^LAHM(62.85,"ATST",LRUID,X,9999999-LREVDT,DA)=""
Q
;
;
KATST ; kill logic for ATST x-ref in file 62.85
N LREVDT S LREVDT=$P($G(^LAHM(62.85,DA,0)),"^",7) Q:'LREVDT
I X K ^LAHM(62.85,"ATST",$P(^LAHM(62.85,DA,0),"^"),X,9999999-LREVDT,DA)
Q
;
;
ATST1 ; set logic for ATST1 x-ref in file 62.85
N LRTST,LRUID S LRTST=$P($G(^LAHM(62.85,DA,0)),"^",8) Q:'LRTST
S LRUID=$P(^LAHM(62.85,DA,0),"^") I $D(^LAHM(62.8,LRUID,0)) Q
S ^LAHM(62.85,"ATST",LRUID,LRTST,9999999-X,DA)=""
Q
;
;
KATST1 ; kill logic for ATST1 x-ref in file 62.85
N LRTST S LRTST=$P($G(^LAHM(62.85,DA,0)),"^",8) Q:'LRTST
K ^LAHM(62.85,"ATST",$P(^LAHM(62.85,DA,0),"^"),LRTST,9999999-X,DA)
Q
;
;
STATUS(LRUID,LRTSTN,LRMAN) ; return status of referral test
; Call with LRUID = accession's unique identifier (UID)
; LRTSTN = file #60 test ien
; LRMAN = manifest shipping #
;
; Returns LREVNT = status of referral testing.
;
N LRAA,LRAD,LRAN,LRDA,LREVNT,LRIEN,LRINVDT,X
;
S LREVNT=""
I LRUID="" Q ""
I LRMAN="" D
. S X=$Q(^LRO(68,"C",LRUID)) Q:X=""
. I $QS(X,3)'=LRUID Q
. S LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
. S LRDA=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRTSTN,0)) Q:'LRDA
. S X=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRDA,0),"^",10) Q:'X
. S LRMAN=$P($G(^LAHM(62.8,X,0),"Manifest missing in file #62.8 with ien "_X),"^")
;
S LRINVDT=$O(^LAHM(62.85,"ATST",LRUID,LRTSTN,0))
I LRINVDT D
. S LRIEN=$O(^LAHM(62.85,"ATST",LRUID,LRTSTN,LRINVDT,0))
. I 'LRIEN Q
. I LRMAN="" S LRMAN=$P(^LAHM(62.85,LRIEN,0),"^",9)
. D EVENT
;
I 'LRINVDT,LRMAN'="" D
. S LRINVDT=$O(^LAHM(62.85,"ADT",LRMAN,0))
. I 'LRINVDT Q
. S LRIEN=$O(^LAHM(62.85,"ADT",LRMAN,LRINVDT,0))
. I LRIEN D EVENT
;
Q LREVNT
;
;
EVENT ;
N LRX
S LRX=$P(^LAHM(62.85,LRIEN,0),"^",5)
I LRX S $P(LREVNT,"^")=$$GET1^DIQ(62.85,LRIEN_",",.05)
S LRX=$P(^LAHM(62.85,LRIEN,0),"^",7)
I LRX S $P(LREVNT,"^",2)=$$FMTE^XLFDT(LRX,"MZ")
S $P(LREVNT,"^",3)=LRMAN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLREVENT 2609 printed Dec 13, 2024@02:14:42 Page 2
LREVENT ;DALIO/JMC - Shipping Event X-ref Utility ; [ 05/21/97 2:26 PM ]
+1 ;;5.2;LAB SERVICE;**153,286**;Sep 27, 1994
+2 QUIT
+3 ;
ADT ; set logic for ADT x-ref in file 62.85
+1 NEW LRMAN
SET LRMAN=$PIECE(^LAHM(62.85,DA,0),"^")
if '$ORDER(^LAHM(62.8,"B",LRMAN,0))
QUIT
+2 SET ^LAHM(62.85,"ADT",LRMAN,9999999-X,DA)=""
+3 QUIT
+4 ;
+5 ;
KADT ; kill logic for ADT x-ref in file 62.85
+1 KILL ^LAHM(62.85,"ADT",$PIECE(^LAHM(62.85,DA,0),"^"),9999999-X,DA)
+2 QUIT
+3 ;
+4 ;
ATST ; set logic for ATST x-ref in file 62.85
+1 NEW LREVDT,LRUID
SET LREVDT=$PIECE($GET(^LAHM(62.85,DA,0)),"^",7)
if 'LREVDT
QUIT
+2 SET LRUID=$PIECE(^LAHM(62.85,DA,0),"^")
IF $DATA(^LAHM(62.8,LRUID,0))
QUIT
+3 IF X
SET ^LAHM(62.85,"ATST",LRUID,X,9999999-LREVDT,DA)=""
+4 QUIT
+5 ;
+6 ;
KATST ; kill logic for ATST x-ref in file 62.85
+1 NEW LREVDT
SET LREVDT=$PIECE($GET(^LAHM(62.85,DA,0)),"^",7)
if 'LREVDT
QUIT
+2 IF X
KILL ^LAHM(62.85,"ATST",$PIECE(^LAHM(62.85,DA,0),"^"),X,9999999-LREVDT,DA)
+3 QUIT
+4 ;
+5 ;
ATST1 ; set logic for ATST1 x-ref in file 62.85
+1 NEW LRTST,LRUID
SET LRTST=$PIECE($GET(^LAHM(62.85,DA,0)),"^",8)
if 'LRTST
QUIT
+2 SET LRUID=$PIECE(^LAHM(62.85,DA,0),"^")
IF $DATA(^LAHM(62.8,LRUID,0))
QUIT
+3 SET ^LAHM(62.85,"ATST",LRUID,LRTST,9999999-X,DA)=""
+4 QUIT
+5 ;
+6 ;
KATST1 ; kill logic for ATST1 x-ref in file 62.85
+1 NEW LRTST
SET LRTST=$PIECE($GET(^LAHM(62.85,DA,0)),"^",8)
if 'LRTST
QUIT
+2 KILL ^LAHM(62.85,"ATST",$PIECE(^LAHM(62.85,DA,0),"^"),LRTST,9999999-X,DA)
+3 QUIT
+4 ;
+5 ;
STATUS(LRUID,LRTSTN,LRMAN) ; return status of referral test
+1 ; Call with LRUID = accession's unique identifier (UID)
+2 ; LRTSTN = file #60 test ien
+3 ; LRMAN = manifest shipping #
+4 ;
+5 ; Returns LREVNT = status of referral testing.
+6 ;
+7 NEW LRAA,LRAD,LRAN,LRDA,LREVNT,LRIEN,LRINVDT,X
+8 ;
+9 SET LREVNT=""
+10 IF LRUID=""
QUIT ""
+11 IF LRMAN=""
Begin DoDot:1
+12 SET X=$QUERY(^LRO(68,"C",LRUID))
if X=""
QUIT
+13 IF $QSUBSCRIPT(X,3)'=LRUID
QUIT
+14 SET LRAA=$QSUBSCRIPT(X,4)
SET LRAD=$QSUBSCRIPT(X,5)
SET LRAN=$QSUBSCRIPT(X,6)
+15 SET LRDA=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,"B",LRTSTN,0))
if 'LRDA
QUIT
+16 SET X=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRDA,0),"^",10)
if 'X
QUIT
+17 SET LRMAN=$PIECE($GET(^LAHM(62.8,X,0),"Manifest missing in file #62.8 with ien "_X),"^")
End DoDot:1
+18 ;
+19 SET LRINVDT=$ORDER(^LAHM(62.85,"ATST",LRUID,LRTSTN,0))
+20 IF LRINVDT
Begin DoDot:1
+21 SET LRIEN=$ORDER(^LAHM(62.85,"ATST",LRUID,LRTSTN,LRINVDT,0))
+22 IF 'LRIEN
QUIT
+23 IF LRMAN=""
SET LRMAN=$PIECE(^LAHM(62.85,LRIEN,0),"^",9)
+24 DO EVENT
End DoDot:1
+25 ;
+26 IF 'LRINVDT
IF LRMAN'=""
Begin DoDot:1
+27 SET LRINVDT=$ORDER(^LAHM(62.85,"ADT",LRMAN,0))
+28 IF 'LRINVDT
QUIT
+29 SET LRIEN=$ORDER(^LAHM(62.85,"ADT",LRMAN,LRINVDT,0))
+30 IF LRIEN
DO EVENT
End DoDot:1
+31 ;
+32 QUIT LREVNT
+33 ;
+34 ;
EVENT ;
+1 NEW LRX
+2 SET LRX=$PIECE(^LAHM(62.85,LRIEN,0),"^",5)
+3 IF LRX
SET $PIECE(LREVNT,"^")=$$GET1^DIQ(62.85,LRIEN_",",.05)
+4 SET LRX=$PIECE(^LAHM(62.85,LRIEN,0),"^",7)
+5 IF LRX
SET $PIECE(LREVNT,"^",2)=$$FMTE^XLFDT(LRX,"MZ")
+6 SET $PIECE(LREVNT,"^",3)=LRMAN
+7 QUIT
