source: WorldVistAEHR/trunk/r/HEALTH_SUMMARY-GMTS/GMTSLROE.m@ 1006

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

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1GMTSLROE ; SLC/JER,KER - Lab Orders Extract Routine ; 09/21/2001
2 ;;2.7;Health Summary;**9,28,47**;Oct 20, 1995
3 ;
4 ; External References
5 ; DBIA 10035 ^DPT(
6 ; DBIA 525 ^LR(
7 ; DBIA 532 ^LRO(69,
8 ; DBIA 524 ^LAB(61,
9 ; DBIA 67 ^LAB(60
10 ; DBIA 530 ^LAB(62.05,
11 ; DBIA 531 ^LRO(68,
12 ; DBIA 10142 $$VERSION^XPDUTL
13 ;
14XTRCT ; Gets lab orders and loads them into GMTSLRO local array
15 N LRDFN,GMI,CD,ID,SN,TN K ^TMP("LROI",$J)
16 K ^TMP("LRO",$J)
17 Q:'$D(^DPT(DFN,"LR")) S LRDFN=+^DPT(DFN,"LR") Q:'$D(^LR(LRDFN))
18 S CD=GMTSBEG-.1
19 F S CD=$O(^LRO(69,"D",LRDFN,CD)) Q:CD'>0!(CD>GMTSEND) S SN=0 F S SN=$O(^LRO(69,"D",LRDFN,CD,SN)) Q:SN'>0 S TN=0 F S TN=$O(^LRO(69,CD,1,SN,2,TN)) Q:TN'>0 S ^TMP("LROI",$J,9999999-CD,SN,TN)=""
20 S (GMI,ID)=0 F S ID=$O(^TMP("LROI",$J,ID)) Q:ID'>0!(GMI=MAX) S CD=9999999-ID,SN=0 F S SN=$O(^TMP("LROI",$J,ID,SN)) Q:SN'>0!(GMI=MAX) S TN=0 F S TN=$O(^TMP("LROI",$J,ID,SN,TN)) Q:TN'>0!(GMI=MAX) D SET
21 K ^TMP("LROI",$J)
22 Q
23SET ; Sets ^TMP("LRO",$J, w/appropriate data
24 N SPST,CST,OS,CDT,SPST,FST,RDT,SITE,SPEC,TST,IDT,COLL,ODT,MD,CS,URG,ACC
25 N RL,TEST
26 I $D(^LRO(69,CD,1,SN,0)) S SPST=^(0) D ORDER
27 I $D(^LRO(69,CD,1,SN,1)) S CST=^(1) D COLLECT I 1
28 E S OS="ORDERED",X=$P(^LRO(69,CD,1,SN,0),U,8),IDT=9999999-X D REGDTM4^GMTSU S CDT=X K X
29 I $D(^LRO(69,CD,1,SN,3)) S FST=^(3) D RESULT I 1
30 E S RDT="UNKNOWN"
31 S SITE=+$G(^LRO(69,CD,1,SN,4,+$O(^LRO(69,CD,1,SN,4,0)),0)),SPEC=$S(SITE>0:SITE_";"_$P(^LAB(61,SITE,0),U),1:";UNKNOWN")
32 I $D(^LRO(69,CD,1,SN,2,TN,0)) S TST=^(0) S:$P(TST,"^",9)="CA" OS="CANCELED" D TEST
33 I $D(BADTEST) K BADTEST Q
34 I $D(IDT),$D(SN),$D(TN) S ^TMP("LRO",$J,IDT,SN_TN)=CDT_U_TEST_U_SPEC_U_URG_U_OS_U_MD_U_ODT_U_ACC_U_RDT_U_COLL_U_CD,GMI=GMI+1
35 Q
36ORDER ; Get Orders
37 N IFN,FNF,FILE,NM,NSPACE,PKG,X
38 S COLL=$S($L($P(SPST,U,4)):$P(SPST,U,4),1:"UNKNOWN")
39 S:"LW"[COLL COLL=$S(COLL="L":"LAB",1:"WARD")
40 S X=$P(SPST,U,5) D REGDTM4^GMTSU S ODT=X
41 S (MD,IFN)=$P(SPST,U,6),FNF=0,NSPACE="LR"
42 S PKG=$$VERSION^XPDUTL(NSPACE),FILE=$S($G(PKG)<5.2:6,1:200)
43 S NM=$$NAME^GMTSU(MD,0,10) S MD=MD_";"_NM
44 S RL=$P(SPST,U,7) Q
45COLLECT ; Collection Date and Time
46 N X S X=$P(CST,U),IDT=9999999-X D REGDTM4^GMTSU S CDT=X,CS=$P(CST,U,4),OS="COLLECTED"
47 Q
48RESULT ; Result Date and Time
49 N X S X=$P(FST,U,2) D REGDTM4^GMTSU S RDT=X
50 Q
51TEST ; Lab Test Ordered
52 N TPTR,UPTR,ACCD,ACCA,ACCN
53 S TPTR=+TST,UPTR=$P(TST,U,2),ACCD=$P(TST,U,3)
54 I $D(TPTR),(TPTR'>0) S BADTEST=1 Q
55 S ACCA=$P(TST,U,4),ACCN=$P(TST,U,5)
56 S TEST=TPTR_";"_$S($L($P(^LAB(60,TPTR,0),U))<21:$P(^(0),U),1:$P(^(.1),U))
57 S URG=$E($S($D(^LAB(62.05,+UPTR,0)):$P(^(0),U),1:""),1,7)
58 I $S('$D(ACCD):1,'$L(ACCA):1,'$L(ACCD):1,1:0) S ACC="NONE" Q
59 S ACC=$S($D(^LRO(68,+ACCA,1,+ACCD,1,+ACCN,.2)):^(.2),1:"NONE")
60 I $D(^LRO(68,+ACCA,1,+ACCD,1,+ACCN,4,TPTR,0)) S X=$P(^(0),U,5) S OS=$S('$L(X):"PROCESSING",1:"COMPLETED")
61 Q
Note: See TracBrowser for help on using the repository browser.