source: FOIAVistA/trunk/r/VBECS-VBEC/VBECA4.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1VBECA4 ;HINES OI/REL-APIs for Health Summary ;10/12/00 14:02
2 ;;0.5;VBECS;**288**;APR 26, 2002
3 ; This routine retrieves data maintained by a regulated medical
4 ; device. The routine must not be modified by anyone other than the
5 ; device manufacturer.
6 Q
7TRAN(DFN,TMPLOC,GMTS1,GMTS2) ; Get Transfusion Data for Health Summary
8 ; Input variables:
9 ; DFN = Internal number of patient
10 ; TMPLOC = Node in ^TMP to be used for output data array
11 ; GMTS1 = Inverse end date of search
12 ; GMTS2 = Inverse start date of search
13 ;
14 ; Output is data array:
15 ; ^TMP(TMPLOC,$J,n)
16 N LRDFN,IDT,CNTR,TR,PN,PRODUCT,UNITS,TDT,ITDT
17 Q:$G(TMPLOC)=""
18 K ^TMP(TMPLOC,$J)
19 Q:'$G(DFN)
20 S:'$G(GMTS1) GMTS1=5555555 S:'$G(GMTS2) GMTS2=9999999
21 S LRDFN=$$LRDFN^LR7OR1(DFN) Q:'LRDFN
22 S IDT=GMTS1-1 F S IDT=$O(^LR(LRDFN,1.6,IDT)) Q:+IDT'>0!(IDT>GMTS2) D
23 . S TR=$G(^LR(LRDFN,1.6,IDT,0)) D SET
24 S IDT=0 F S IDT=$O(CNTR(IDT)) Q:+IDT'>0 D
25 . S ^TMP(TMPLOC,$J,IDT)=9999999-IDT_U
26 . S PN=0 F S PN=$O(CNTR(IDT,PN)) Q:PN'>0 D
27 . . S PRODUCT=$G(^LAB(66,+PN,0)),^TMP(TMPLOC,$J,$P(PRODUCT,U,2))=$P(PRODUCT,U)
28 . . S ^TMP(TMPLOC,$J,IDT)=^TMP(TMPLOC,$J,IDT)_CNTR(IDT,PN)_"\"_$P(PRODUCT,U,2)_";"
29 Q
30AVUNIT(DFN,TMPLOC,GMTS1,GMTS2,GMTSNDM) ; Get Available Units for Health Summary
31 ; Input variables:
32 ; DFN = Internal number of patient
33 ; TMPLOC = Node in ^TMP to be used for output data array
34 ; GMTS1 = Inverse end date of search
35 ; GMTS2 = Inverse start date of search
36 ; GMTSNDM = Maximum number to be extracted
37 ;
38 ; Output is data array:
39 ; ^TMP(TMPLOC,$J,n)
40 N LRDFN,IDT,UN,CNT,ABO,ADT,COMP,DTYP,EDT,EFLG,GMI,RH,UDIV,UID,ULOC,VOL
41 Q:$G(TMPLOC)=""
42 K ^TMP(TMPLOC,$J)
43 Q:'$G(DFN)
44 S:'$G(GMTS1) GMTS1=5555555 S:'$G(GMTS2) GMTS2=9999999 S:'$G(GMTSNDM) GMTSNDM=999
45 S LRDFN=$$LRDFN^LR7OR1(DFN) Q:'LRDFN
46 I $L($P(^LR(LRDFN,0),U,5,6)) S ^TMP(TMPLOC,$J,0)=$P(^(0),U,5)_U_$P(^(0),U,6)
47 S UN="",CNT=0 F S UN=$O(^LRD(65,"AP",LRDFN,UN)) Q:UN=""!(CNT'<GMTSNDM) D BASET
48 ;K:'CNT ^TMP(TMPLOC,$J)
49 Q
50BASET ; Sets ^TMP with data elements
51 S (EFLG,DTYP,ULOC)=""
52 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)
53 S ADT=$P(^LRD(65,UN,2,LRDFN,0),U,2)
54 S UDIV=$P(^LRD(65,UN,0),U,16),UDIV=$$NS^XUAF4(UDIV),UDIV=$P(UDIV,"^",1) ;Gets division unit is located at
55 I $D(^LRD(65,UN,8)) D
56 . S DIC=65,DIQ="DON",DIQ(0)="E",DR=8.3,DA=UN D EN^DIQ1
57 . S:$D(DON) DTYP=DON(65,UN,8.3,"E") K DA,DIC,DIQ,DON,DR Q
58 S GMI=$O(^LRD(65,UN,3,0)) I +GMI>0 D
59 . S ULOC=$P($G(^LRD(65,UN,3,GMI,0)),U,4)
60 ; If unit will expire w/in 48 hrs, flag with "*"; w/in 24 hrs, flag with "**"
61 I EDT>DT S EFLG=$S(EDT-DT<2:"*",EDT-DT<1:"**",1:"")
62 S IDT=9999999-ADT
63 I $S(IDT<GMTS1:1,IDT>GMTS2:1,EDT<DT:1,1:0) Q
64 S EDT=$TR($$FMTE^XLFDT(EDT,"5DZ"),"@"," ")
65 F Q:'$D(^TMP(TMPLOC,$J,IDT)) S IDT=IDT+.0001
66 S ^TMP(TMPLOC,$J,IDT)=EFLG_U_EDT_U_UID_U_COMP_U_VOL_U_ABO_U_RH_U_DTYP_U_UDIV_U_ULOC
67 S CNT=CNT+1
68 Q
69SET ; Sets CNTR w/appropriate data
70 S TDT=9999999-IDT,ITDT=9999999-$P(TDT,".")
71 S UNITS=+$P(TR,U,7) S:UNITS'>0 UNITS=1
72 S CNTR(ITDT,+$P(TR,U,2))=+$G(CNTR(ITDT,+$P(TR,U,2)))+UNITS
73 Q
Note: See TracBrowser for help on using the repository browser.