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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSLRTE 1109 printed Dec 13, 2024@01:58:01 Page 2
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
