GMTSLROE ; SLC/JER,KER - Lab Orders Extract Routine ; 09/21/2001
;;2.7;Health Summary;**9,28,47,96,112**;Oct 20, 1995;Build 3
;
; External References
; DBIA 10035 ^DPT(
; DBIA 525 ^LR(
; DBIA 532 ^LRO(69,
; DBIA 524 ^LAB(61,
; DBIA 67 ^LAB(60
; DBIA 530 ^LAB(62.05,
; DBIA 531 ^LRO(68,
; DBIA 5466 ^LRJWLST
; DBIA 10142 $$VERSION^XPDUTL
;
XTRCT ; Gets lab orders and loads them into GMTSLRO local array
N LRDFN,GMI,CD,ID,SN,TN K ^TMP("LROI",$J)
K ^TMP("LRO",$J)
Q:'$D(^DPT(DFN,"LR")) S LRDFN=+^DPT(DFN,"LR") Q:'$D(^LR(LRDFN))
S CD=GMTSBEG-.1
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)=""
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
K ^TMP("LROI",$J)
Q
SET ; Sets ^TMP("LRO",$J, w/appropriate data
N SPST,CST,OS,CDT,SPST,FST,RDT,SITE,SPEC,TST,IDT,COLL,ODT,MD,CS,URG,ACC
N RL,TEST
I $D(^LRO(69,CD,1,SN,0)) S SPST=^(0) D ORDER
I $D(^LRO(69,CD,1,SN,1)) S CST=^(1) D COLLECT I 1
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
I $D(^LRO(69,CD,1,SN,3)) S FST=^(3) D RESULT I 1
E S RDT="UNKNOWN"
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")
I $D(^LRO(69,CD,1,SN,2,TN,0)) S TST=^(0) S:$P(TST,"^",9)="CA" OS="CANCELED" D TEST
I $D(BADTEST) K BADTEST Q
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_U_$P(TST,U,7),GMI=GMI+1
Q
ORDER ; Get Orders
N IFN,FNF,FILE,NM,NSPACE,PKG,X
S COLL=$S($L($P(SPST,U,4)):$P(SPST,U,4),1:"UNKNOWN")
S:"LW"[COLL COLL=$S(COLL="L":"LAB",1:"WARD")
S X=$P(SPST,U,5) D REGDTM4^GMTSU S ODT=X
S (MD,IFN)=$P(SPST,U,6),FNF=0,NSPACE="LR"
S PKG=$$VERSION^XPDUTL(NSPACE),FILE=$S($G(PKG)<5.2:6,1:200)
S NM=$$NAME^GMTSU(MD,0,10) S MD=MD_";"_NM
S RL=$P(SPST,U,7) Q
COLLECT ; Collection Date and Time
N X S X=$P(CST,U),IDT=9999999-X D REGDTM4^GMTSU S CDT=X,CS=$P(CST,U,4),OS="COLLECTED"
S X=CS,OS=$S(X="C":"COLLECTED",X="U":"CANCELED",1:"On Collection List")
Q
RESULT ; Result Date and Time
N X S X=$P(FST,U,2) D REGDTM4^GMTSU S RDT=X
I X S OS="COMPLETED"
Q
TEST ; Lab Test Ordered
N TPTR,UPTR,ACCD,ACCA,ACCN
S TPTR=+TST,UPTR=$P(TST,U,2),ACCD=$P(TST,U,3)
I $D(TPTR),(TPTR'>0) S BADTEST=1 Q
S ACCA=$P(TST,U,4),ACCN=$P(TST,U,5)
S TEST=TPTR_";"_$S($L($P(^LAB(60,TPTR,0),U))<21:$P(^(0),U),1:$P(^(.1),U))
S URG=$E($S($D(^LAB(62.05,+UPTR,0)):$P(^(0),U),1:""),1,7)
I $S('$D(ACCD):1,'$L(ACCA):1,'$L(ACCD):1,1:0) S ACC="NONE" Q
S ACC=$S($D(^LRO(68,+ACCA,1,+ACCD,1,+ACCN,.2)):^(.2),1:"NONE")
I $T(GETACC^LRJWLST)]"" D
. N OACC
. S OACC=$P($G(^LRO(69,CD,1,SN,2,TN,64.91)),"^",3)
. I OACC]"" S ACC=OACC
I $D(^LRO(68,+ACCA,1,+ACCD,1,+ACCN,4,TPTR,0)) S X=$P(^(0),U,5) I $G(OS)'="CANCELED",$G(OS)'="On Collection List" S OS=$S('$L(X):"PROCESSING",1:"COMPLETED")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSLROE 3237 printed Nov 22, 2024@17:08:01 Page 2
GMTSLROE ; SLC/JER,KER - Lab Orders Extract Routine ; 09/21/2001
+1 ;;2.7;Health Summary;**9,28,47,96,112**;Oct 20, 1995;Build 3
+2 ;
+3 ; External References
+4 ; DBIA 10035 ^DPT(
+5 ; DBIA 525 ^LR(
+6 ; DBIA 532 ^LRO(69,
+7 ; DBIA 524 ^LAB(61,
+8 ; DBIA 67 ^LAB(60
+9 ; DBIA 530 ^LAB(62.05,
+10 ; DBIA 531 ^LRO(68,
+11 ; DBIA 5466 ^LRJWLST
+12 ; DBIA 10142 $$VERSION^XPDUTL
+13 ;
XTRCT ; Gets lab orders and loads them into GMTSLRO local array
+1 NEW LRDFN,GMI,CD,ID,SN,TN
KILL ^TMP("LROI",$JOB)
+2 KILL ^TMP("LRO",$JOB)
+3 if '$DATA(^DPT(DFN,"LR"))
QUIT
SET LRDFN=+^DPT(DFN,"LR")
if '$DATA(^LR(LRDFN))
QUIT
+4 SET CD=GMTSBEG-.1
+5 FOR
SET CD=$ORDER(^LRO(69,"D",LRDFN,CD))
if CD'>0!(CD>GMTSEND)
QUIT
SET SN=0
FOR
SET SN=$ORDER(^LRO(69,"D",LRDFN,CD,SN))
if SN'>0
QUIT
SET TN=0
FOR
SET TN=$ORDER(^LRO(69,CD,1,SN,2,TN))
if TN'>0
QUIT
SET ^TMP("LROI",$JOB,9999999-CD,SN,TN)=""
+6 SET (GMI,ID)=0
FOR
SET ID=$ORDER(^TMP("LROI",$JOB,ID))
if ID'>0!(GMI=MAX)
QUIT
SET CD=9999999-ID
SET SN=0
FOR
SET SN=$ORDER(^TMP("LROI",$JOB,ID,SN))
if SN'>0!(GMI=MAX)
QUIT
SET TN=0
FOR
SET TN=$ORDER(^TMP("LROI",$JOB,ID,SN,TN))
if TN'>0!(GMI=MAX)
QUIT
DO SET
+7 KILL ^TMP("LROI",$JOB)
+8 QUIT
SET ; Sets ^TMP("LRO",$J, w/appropriate data
+1 NEW SPST,CST,OS,CDT,SPST,FST,RDT,SITE,SPEC,TST,IDT,COLL,ODT,MD,CS,URG,ACC
+2 NEW RL,TEST
+3 IF $DATA(^LRO(69,CD,1,SN,0))
SET SPST=^(0)
DO ORDER
+4 IF $DATA(^LRO(69,CD,1,SN,1))
SET CST=^(1)
DO COLLECT
IF 1
+5 IF '$TEST
SET OS="ORDERED"
SET X=$PIECE(^LRO(69,CD,1,SN,0),U,8)
SET IDT=9999999-X
DO REGDTM4^GMTSU
SET CDT=X
KILL X
+6 IF $DATA(^LRO(69,CD,1,SN,3))
SET FST=^(3)
DO RESULT
IF 1
+7 IF '$TEST
SET RDT="UNKNOWN"
+8 SET SITE=+$GET(^LRO(69,CD,1,SN,4,+$ORDER(^LRO(69,CD,1,SN,4,0)),0))
SET SPEC=$SELECT(SITE>0:SITE_";"_$PIECE(^LAB(61,SITE,0),U),1:";UNKNOWN")
+9 IF $DATA(^LRO(69,CD,1,SN,2,TN,0))
SET TST=^(0)
if $PIECE(TST,"^",9)="CA"
SET OS="CANCELED"
DO TEST
+10 IF $DATA(BADTEST)
KILL BADTEST
QUIT
+11 IF $DATA(IDT)
IF $DATA(SN)
IF $DATA(TN)
SET ^TMP("LRO",$JOB,IDT,SN_TN)=CDT_U_TEST_U_SPEC_U_URG_U_OS_U_MD_U_ODT_U_ACC_U_RDT_U_COLL_U_CD_U_$PIECE(TST,U,7)
SET GMI=GMI+1
+12 QUIT
ORDER ; Get Orders
+1 NEW IFN,FNF,FILE,NM,NSPACE,PKG,X
+2 SET COLL=$SELECT($LENGTH($PIECE(SPST,U,4)):$PIECE(SPST,U,4),1:"UNKNOWN")
+3 if "LW"[COLL
SET COLL=$SELECT(COLL="L":"LAB",1:"WARD")
+4 SET X=$PIECE(SPST,U,5)
DO REGDTM4^GMTSU
SET ODT=X
+5 SET (MD,IFN)=$PIECE(SPST,U,6)
SET FNF=0
SET NSPACE="LR"
+6 SET PKG=$$VERSION^XPDUTL(NSPACE)
SET FILE=$SELECT($GET(PKG)<5.2:6,1:200)
+7 SET NM=$$NAME^GMTSU(MD,0,10)
SET MD=MD_";"_NM
+8 SET RL=$PIECE(SPST,U,7)
QUIT
COLLECT ; Collection Date and Time
+1 NEW X
SET X=$PIECE(CST,U)
SET IDT=9999999-X
DO REGDTM4^GMTSU
SET CDT=X
SET CS=$PIECE(CST,U,4)
SET OS="COLLECTED"
+2 SET X=CS
SET OS=$SELECT(X="C":"COLLECTED",X="U":"CANCELED",1:"On Collection List")
+3 QUIT
RESULT ; Result Date and Time
+1 NEW X
SET X=$PIECE(FST,U,2)
DO REGDTM4^GMTSU
SET RDT=X
+2 IF X
SET OS="COMPLETED"
+3 QUIT
TEST ; Lab Test Ordered
+1 NEW TPTR,UPTR,ACCD,ACCA,ACCN
+2 SET TPTR=+TST
SET UPTR=$PIECE(TST,U,2)
SET ACCD=$PIECE(TST,U,3)
+3 IF $DATA(TPTR)
IF (TPTR'>0)
SET BADTEST=1
QUIT
+4 SET ACCA=$PIECE(TST,U,4)
SET ACCN=$PIECE(TST,U,5)
+5 SET TEST=TPTR_";"_$SELECT($LENGTH($PIECE(^LAB(60,TPTR,0),U))<21:$PIECE(^(0),U),1:$PIECE(^(.1),U))
+6 SET URG=$EXTRACT($SELECT($DATA(^LAB(62.05,+UPTR,0)):$PIECE(^(0),U),1:""),1,7)
+7 IF $SELECT('$DATA(ACCD):1,'$LENGTH(ACCA):1,'$LENGTH(ACCD):1,1:0)
SET ACC="NONE"
QUIT
+8 SET ACC=$SELECT($DATA(^LRO(68,+ACCA,1,+ACCD,1,+ACCN,.2)):^(.2),1:"NONE")
+9 IF $TEXT(GETACC^LRJWLST)]""
Begin DoDot:1
+10 NEW OACC
+11 SET OACC=$PIECE($GET(^LRO(69,CD,1,SN,2,TN,64.91)),"^",3)
+12 IF OACC]""
SET ACC=OACC
End DoDot:1
+13 IF $DATA(^LRO(68,+ACCA,1,+ACCD,1,+ACCN,4,TPTR,0))
SET X=$PIECE(^(0),U,5)
IF $GET(OS)'="CANCELED"
IF $GET(OS)'="On Collection List"
SET OS=$SELECT('$LENGTH(X):"PROCESSING",1:"COMPLETED")
+14 QUIT
