GMTSLRTE.m

GMTSLRTE ; SLC/JER,KER - Transfusion Record Extract Routine ; 01/06/2003

 ;;2.7;Health Summary;**56,58**;Oct 20, 1995

 ;                     

 ; External References

 ;   DBIA 10035  ^DPT(

 ;   DBIA   528  ^LAB(66

 ;   DBIA   525  ^LR(

 ;                     

XTRCT ; Extract Transfusion Records

 N LRDFN,IDT,CNTR,TR,PN,PRODUCT

 S:'$D(GMTS1) GMTS1=6666666 S:'$D(GMTS2) GMTS2=9999999

 K ^TMP("LRT",$J)

 Q:'$D(^DPT(DFN,"LR"))  S LRDFN=+^DPT(DFN,"LR"),IDT=GMTS1-1

 I '$D(^LR(LRDFN)) Q

 S IDT=GMTS1-1 F  S IDT=$O(^LR(LRDFN,1.6,IDT)) Q:+IDT'>0!(IDT>GMTS2)  D

 . S TR=$G(^LR(LRDFN,1.6,IDT,0)) D SET

 S IDT=0 F  S IDT=$O(CNTR(IDT)) Q:+IDT'>0  D

 . S ^TMP("LRT",$J,IDT)=9999999-IDT_U

 . S PN=0 F  S PN=$O(CNTR(IDT,PN)) Q:PN'>0  D

 . . S PRODUCT=$G(^LAB(66,+PN,0)),^TMP("LRT",$J,$P(PRODUCT,U,2))=$P(PRODUCT,U)

 . . S ^TMP("LRT",$J,IDT)=^TMP("LRT",$J,IDT)_CNTR(IDT,PN)_"\"_$P(PRODUCT,U,2)_";"

 Q

SET ; Save Appropriate Data

 N COMP,UNITS,TDT,ITDT S TDT=9999999-IDT,ITDT=9999999-$P(TDT,".")

 S UNITS=+$P(TR,U,7) S:UNITS'>0 UNITS=1

 S CNTR(ITDT,+$P(TR,U,2))=+$G(CNTR(ITDT,+$P(TR,U,2)))+UNITS

 Q

GMTSLRTE  ; SLC/JER,KER - Transfusion Record Extract Routine ; 01/06/2003

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

 +2       ;                     

 +3       ; External References

 +4       ;   DBIA 10035  ^DPT(

 +5       ;   DBIA   528  ^LAB(66

 +6       ;   DBIA   525  ^LR(

 +7       ;                     

XTRCT     ; Extract Transfusion Records

 +1        NEW LRDFN,IDT,CNTR,TR,PN,PRODUCT

 +2        IF '$DATA(GMTS1)

               SET GMTS1=6666666

           IF '$DATA(GMTS2)

               SET GMTS2=9999999

 +3        KILL ^TMP("LRT",$JOB)

 +4        IF '$DATA(^DPT(DFN,"LR"))

               QUIT 

           SET LRDFN=+^DPT(DFN,"LR")

           SET IDT=GMTS1-1

 +5        IF '$DATA(^LR(LRDFN))

               QUIT 

 +6        SET IDT=GMTS1-1

           FOR 

               SET IDT=$ORDER(^LR(LRDFN,1.6,IDT))

               IF +IDT'>0!(IDT>GMTS2)

                   QUIT 

               Begin DoDot:1

 +7                SET TR=$GET(^LR(LRDFN,1.6,IDT,0))

                   DO SET

               End DoDot:1

 +8        SET IDT=0

           FOR 

               SET IDT=$ORDER(CNTR(IDT))

               IF +IDT'>0

                   QUIT 

               Begin DoDot:1

 +9                SET ^TMP("LRT",$JOB,IDT)=9999999-IDT_U

 +10               SET PN=0

                   FOR 

                       SET PN=$ORDER(CNTR(IDT,PN))

                       IF PN'>0

                           QUIT 

                       Begin DoDot:2

 +11                       SET PRODUCT=$GET(^LAB(66,+PN,0))

                           SET ^TMP("LRT",$JOB,$PIECE(PRODUCT,U,2))=$PIECE(PRODUCT,U)

 +12                       SET ^TMP("LRT",$JOB,IDT)=^TMP("LRT",$JOB,IDT)_CNTR(IDT,PN)_"\"_$PIECE(PRODUCT,U,2)_";"

                       End DoDot:2

               End DoDot:1

 +13       QUIT 

SET       ; Save Appropriate Data

 +1        NEW COMP,UNITS,TDT,ITDT

           SET TDT=9999999-IDT

           SET ITDT=9999999-$PIECE(TDT,".")

 +2        SET UNITS=+$PIECE(TR,U,7)

           IF UNITS'>0

               SET UNITS=1

 +3        SET CNTR(ITDT,+$PIECE(TR,U,2))=+$GET(CNTR(ITDT,+$PIECE(TR,U,2)))+UNITS

 +4        QUIT