- 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 Mar 13, 2025@21:02:32 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
