source: WorldVistAEHR/trunk/r/HEALTH_SUMMARY-GMTS/GMTSLRTE.m

Last change on this file was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.1 KB
Line 
1GMTSLRTE ; SLC/JER,KER - Transfusion Record Extract Routine ; 01/06/2003
2 ;;2.7;Health Summary;**56,58**;Oct 20, 1995
3 ;
4 ; External References
5 ; DBIA 10035 ^DPT(
6 ; DBIA 528 ^LAB(66
7 ; DBIA 525 ^LR(
8 ;
9XTRCT ; Extract Transfusion Records
10 N LRDFN,IDT,CNTR,TR,PN,PRODUCT
11 S:'$D(GMTS1) GMTS1=6666666 S:'$D(GMTS2) GMTS2=9999999
12 K ^TMP("LRT",$J)
13 Q:'$D(^DPT(DFN,"LR")) S LRDFN=+^DPT(DFN,"LR"),IDT=GMTS1-1
14 I '$D(^LR(LRDFN)) Q
15 S IDT=GMTS1-1 F S IDT=$O(^LR(LRDFN,1.6,IDT)) Q:+IDT'>0!(IDT>GMTS2) D
16 . S TR=$G(^LR(LRDFN,1.6,IDT,0)) D SET
17 S IDT=0 F S IDT=$O(CNTR(IDT)) Q:+IDT'>0 D
18 . S ^TMP("LRT",$J,IDT)=9999999-IDT_U
19 . S PN=0 F S PN=$O(CNTR(IDT,PN)) Q:PN'>0 D
20 . . S PRODUCT=$G(^LAB(66,+PN,0)),^TMP("LRT",$J,$P(PRODUCT,U,2))=$P(PRODUCT,U)
21 . . S ^TMP("LRT",$J,IDT)=^TMP("LRT",$J,IDT)_CNTR(IDT,PN)_"\"_$P(PRODUCT,U,2)_";"
22 Q
23SET ; Save Appropriate Data
24 N COMP,UNITS,TDT,ITDT S TDT=9999999-IDT,ITDT=9999999-$P(TDT,".")
25 S UNITS=+$P(TR,U,7) S:UNITS'>0 UNITS=1
26 S CNTR(ITDT,+$P(TR,U,2))=+$G(CNTR(ITDT,+$P(TR,U,2)))+UNITS
27 Q
Note: See TracBrowser for help on using the repository browser.