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

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

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

 +2       ;

 +3       ;                     

 +4       ; External References

 +5       ;   DBIA 10090  ^DIC(4

 +6       ;   DBIA   528  ^LAB(66

 +7       ;   DBIA   525  ^LR(

 +8       ;   DBIA   527  ^LRD(65

 +9       ;   DBIA 10015  EN^DIQ1 (file #65)

 +10      ;                     

XTRCT     ; Extract Blood Availability

 +1        NEW I1,UN,CNT

           SET CNT=0

           KILL ^TMP("LRB",$JOB)

 +2        IF $LENGTH($PIECE(^LR(LRDFN,0),U,5,6))

               SET ^TMP("LRB",$JOB,0)=$PIECE(^(0),U,5)_U_$PIECE(^(0),U,6)

 +3        SET UN=""

           FOR 

               SET UN=$ORDER(^LRD(65,"AP",LRDFN,UN))

               IF UN=""!(CNT'<MAX)

                   QUIT 

               DO BASET

 +4        QUIT 

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

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

 +2        NEW IDT,GMI,ULOC

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

 +4        SET UID=$PIECE(^LRD(65,UN,0),U)

           SET EDT=$PIECE(^(0),U,6)

           SET ABO=$PIECE(^(0),U,7)

           SET RH=$PIECE(^(0),U,8)

           SET VOL=$PIECE(^(0),U,11)

           SET COMP=$PIECE(^LAB(66,$PIECE(^LRD(65,UN,0),U,4),0),U)

 +5        SET ADT=$PIECE(^LRD(65,UN,2,LRDFN,0),U,2)

 +6       ;Gets division unit is located at

           SET UDIV=$PIECE(^LRD(65,UN,0),U,16)

           SET UDIV=$SELECT(UDIV'="":$PIECE(^DIC(4,UDIV,0),U),1:UDIV)

 +7        IF $DATA(^LRD(65,UN,8))

               SET DIC=65

               SET DIQ="DON"

               SET DIQ(0)="E"

               SET DR=8.3

               SET DA=UN

               DO EN^DIQ1

               IF $DATA(DON)

                   SET DTYP=DON(65,UN,8.3,"E")

 +8        SET GMI=$ORDER(^LRD(65,UN,3,0))

           IF +GMI>0

               Begin DoDot:1

 +9                SET ULOC=$PIECE($GET(^LRD(65,UN,3,GMI,0)),U,4)

               End DoDot:1

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

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

 +12       IF EDT>DT

               SET EFLG=$SELECT(EDT-DT<2:"*",EDT-DT<1:"**",1:"")

 +13       SET IDT=9999999-ADT

 +14       IF $SELECT(IDT<GMTS1:1,IDT>GMTS2:1,EDT<DT:1,1:0)

               QUIT 

 +15       SET X=EDT

           DO REGDT4^GMTSU

           SET EDT=X

           KILL X

 +16       FOR 

               IF '$DATA(^TMP("LRB",$JOB,IDT))

                   QUIT 

               SET IDT=IDT+.0001

 +17       SET ^TMP("LRB",$JOB,IDT)=EFLG_U_EDT_U_UID_U_COMP_U_VOL_U_ABO_U_RH_U_DTYP_U_UDIV_U_ULOC

 +18       SET CNT=CNT+1

 +19       QUIT