GMTSLRBE.m

GMTSLRBE ; SLC/JER,KER - Blood Availability Extract ; 08/27/2002

 ;;2.7;Health Summary;**17,28,56**;Oct 20, 1995

 ;

 ;                     

 ; External References

 ;   DBIA 10090  ^DIC(4

 ;   DBIA   528  ^LAB(66

 ;   DBIA   525  ^LR(

 ;   DBIA   527  ^LRD(65

 ;   DBIA 10015  EN^DIQ1 (file #65)

 ;                     

XTRCT ; Extract Blood Availability

 N I1,UN,CNT S CNT=0 K ^TMP("LRB",$J)

 I $L($P(^LR(LRDFN,0),U,5,6)) S ^TMP("LRB",$J,0)=$P(^(0),U,5)_U_$P(^(0),U,6)

 S UN="" F  S UN=$O(^LRD(65,"AP",LRDFN,UN)) Q:UN=""!(CNT'<MAX)  D BASET

 Q

BASET ; Sets ^TMP("LRB",$J, with data elements

 N ADT,DA,DIC,DIQ,DON,DR,EFLG,EDT,UID,UDIV,DTYP,COMP,ABO,RH,VOL,XDT,XMR,XMATCH

 N IDT,GMI,ULOC

 S (ADT,EFLG,EDT,UID,DTYP,COMP,ABO,RH,VOL,XMR,ULOC)=""

 S UID=$P(^LRD(65,UN,0),U),EDT=$P(^(0),U,6),ABO=$P(^(0),U,7),RH=$P(^(0),U,8),VOL=$P(^(0),U,11),COMP=$P(^LAB(66,$P(^LRD(65,UN,0),U,4),0),U)

 S ADT=$P(^LRD(65,UN,2,LRDFN,0),U,2)

 S UDIV=$P(^LRD(65,UN,0),U,16),UDIV=$S(UDIV'="":$P(^DIC(4,UDIV,0),U),1:UDIV) ;Gets division unit is located at

 I $D(^LRD(65,UN,8)) S DIC=65,DIQ="DON",DIQ(0)="E",DR=8.3,DA=UN D EN^DIQ1 S:$D(DON) DTYP=DON(65,UN,8.3,"E")

 S GMI=$O(^LRD(65,UN,3,0)) I +GMI>0 D

 . S ULOC=$P($G(^LRD(65,UN,3,GMI,0)),U,4)

 ;   If unit will expire w/in 48 hrs, flag with "*"

 ;                       w/in 24 hrs, flag with "**"

 I EDT>DT S EFLG=$S(EDT-DT<2:"*",EDT-DT<1:"**",1:"")

 S IDT=9999999-ADT

 I $S(IDT<GMTS1:1,IDT>GMTS2:1,EDT<DT:1,1:0) Q

 S X=EDT D REGDT4^GMTSU S EDT=X K X

 F  Q:'$D(^TMP("LRB",$J,IDT))  S IDT=IDT+.0001

 S ^TMP("LRB",$J,IDT)=EFLG_U_EDT_U_UID_U_COMP_U_VOL_U_ABO_U_RH_U_DTYP_U_UDIV_U_ULOC

 S CNT=CNT+1

 Q