- 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 Feb 18, 2025@23:40:35 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