ORDV02D ;SLC/DCM - OE/RR REPORT EXTRACTS ;JAN 16, 2024@11:20
;;3.0;ORDER ENTRY/RESULTS REPORTING;**423,377,603**;Dec 17, 1997;Build 14
;
OV ;Overview
D EXT("OV")
Q
PEND ;Pending
D EXT("PEND")
Q
ALL ;ALL
D EXT("ALL")
Q
EXT(ORPRT) ;New Lab Reports Extract
N S,DP,ORLIST,STARTDT,STAT,IFN,OS,CST,TEST,COLL,ODT,NM,RL,MD,GMI,SORT,D,SN,STATUS,X4,LRODT,LRSN,ORMERG,ORX0,ORIFN,X1,X2,X3,FLAG,IVEDT,IVSDT
K ^TMP("OR",$J),^TMP("OROR",$J),^TMP("ORSORT",$J),^TMP("ORR",$J)
S X=$O(^ORD(100.98,"B","LAB",0)) Q:'X S DP=X ; Display group = LAB
S FLAG=1,X3=1,OS="",TEST="",GMI=0
S X1=0,X2=9999999 ;Get everything to ensure all orders are included, then sort later by date ranges
I ORPRT="OV" S SORT="On Collection List:2^COLLECTED:3^PROCESSING:4^COMPLETED:6"
I ORPRT="PEND" S SORT="ORDERED:1^On Collection List:2^COLLECTED:3^PROCESSING:4"
I ORPRT="ALL" S SORT="ORDERED:1^On Collection List:2^COLLECTED:3^PROCESSING:4^CANCELED:5^COMPLETED:6"
D EN^ORQ1(DFN_";DPT(",DP,FLAG,"",X1,X2,X3)
S IFN=0
F S IFN=$O(^TMP("ORR",$J,ORLIST,IFN)) Q:IFN<1 S X=^(IFN) D
. S ORIFN=+$P(X,"^"),STARTDT=$P(X,"^",4),STAT=$P(X,"^",6)
. Q:'$D(^OR(100,ORIFN,0)) S ORX0=^(0),X4=$G(^(4))
. I 'STARTDT S STARTDT=$S($L($P(X4,";",5)):9999999-$P(X4,";",5),1:$P(X,"^",3)) ;If no StartDate use lab CollectionDate or OrderDate
. S LRODT=$P(X4,";",2),LRSN=$P(X4,";",3),ORMERG=0
. I ORPRT="OV" D GET ;Set date for Inverse Start Date, sort by Date then Status, exclude ORDERED, CANCELED
. I ORPRT="PEND" D GET ;Set date for Forward Start Date, sort by Date then Status, exclude COMPLETED, CANCELED
. I ORPRT="ALL" D GET ;Set date for Inverse Start Date, sort by Status then Date
S D=0
S IVEDT=ORDBEG,IVSDT=ORDEND,D=IVEDT
F S D=$O(^TMP("OROR",$J,D)) Q:'D!(D>IVSDT) D
. S SN=0
. F S SN=$O(^TMP("OROR",$J,D,SN)) Q:'SN S ORX0=^(SN) I $L(ORX0) S STATUS=$P(ORX0,"^",5) I $L($P(ORX0,"^")) D
.. S S=$E(SORT,$F(SORT,STATUS)+1)
.. I ORPRT="OV",STATUS'="ORDERED",STATUS'="CANCELED" S ^TMP("ORSORT",$J,9999999-D,S,SN)=ORX0 ;Reverse sort order DM-603
.. I ORPRT="PEND",STATUS'="CANCELED",STATUS'="COMPLETED" S ^TMP("ORSORT",$J,9999999-D,S,SN)=ORX0
.. I ORPRT="ALL" S ^TMP("ORSORT",$J,S,D,SN)=ORX0
K ^TMP("OROR",$J),^TMP("ORR",$J)
Q
GET ;
N ORI,ORX,GOTLR
S ORI=0
F S ORI=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",ORI)) Q:ORI<1 I $D(^OR(100,ORIFN,4.5,ORI,1)) S ORX=^(1) D
. S GOTLR=0
. I $D(^ORD(101.43,+ORX,0)) S (TEST,ORX)=+$P(^(0),"^",2)
. I ORX,LRODT,LRSN,$D(^LRO(69,LRODT,1,LRSN,2,"B",ORX)) S ORX=$O(^(ORX,0)) D
.. Q:'$L($G(^LRO(69,LRODT,1,LRSN,0)))
.. I $G(^LRO(69,LRODT,1,LRSN,2,ORX,0)) S ORX=^(0),GOTLR=1 D GET69
. I 'ORMERG,'GOTLR D GET63 ;Get data from file 63 and OE/RR
Q
GET63 ; Get data from file 63 and OE/RR files
N SUB,CDT,LRIDT,X0,SPEC,OS,MD,IFN,PKG,FILE,NM,MD,ACC,ODT,URG,COLL,CD,RDT,LRDFN,FNF,NSPACE
Q:'$L($P(X4,";",4)) Q:'$L($P(X4,";",5))
S SUB=$P(X4,";",4),LRIDT=$P(X4,";",5)
I '$D(DFN) S DFN=$S($D(ORVP):+ORVP,1:0) Q:'DFN
Q:'$D(^DPT(DFN,"LR")) S LRDFN=+^DPT(DFN,"LR") Q:'$D(^LR(LRDFN))
Q:'$D(^LR(LRDFN,SUB,LRIDT,0)) S X0=^(0)
S X=STARTDT D REGDTM4 S CDT=X
S TEST=TEST_";"_$P($G(^LAB(60,+TEST,0)),"^"),SPEC=+$P(X0,"^",5)_";"_$P($G(^LAB(61,+$P(X0,"^",5),0)),"^"),OS=$S($P(X0,"^",3):"COMPLETED",1:"PROCESSING")
S (MD,IFN)=$P(X0,"^",10),FNF=0,NSPACE="LR"
I SUB="MI" S (MD,IFN)=$P(X0,"^",7)
S PKG=$$VERSION^XPDUTL(NSPACE),FILE=$S($G(PKG)<5.2:6,1:200)
S NM=$S($L($P($G(^VA(200,+MD,0)),"^")):$P(^(0),"^"),1:"UNKOWN"),MD=+MD_";"_NM,ACC=$P(X0,"^",6)
S X=$P(ORX0,"^",7) D REGDTM4 S ODT=X
S X=$P(X0,"^",3) D REGDTM4 S RDT=X
S URG="UNKNOWN",COLL="UNKNOWN",CD=$P($P(ORX0,"^",7),".") ;COLL=Collection Type
S GMI=GMI+1,^TMP("OROR",$J,STARTDT,GMI)=CDT_U_TEST_U_SPEC_U_URG_U_OS_U_MD_U_ODT_U_ACC_U_RDT_U_COLL_U_CD_U_ORIFN
Q
GET69 ; Get data from Lab Order/accession (69, 68) files
N X,IDT,SPEC,SITE,BADTEST,FST,SPST
I $L($P($G(^LRO(69,LRODT,1,LRSN,1)),"^",7)) S ORMERG=1 Q ;exclude merged orders from extract
I $D(^LRO(69,LRODT,1,LRSN,0)) S SPST=^(0) D ORDER
I $D(^LRO(69,LRODT,1,LRSN,1)) S CST=^(1) D COLLECT I 1
E S OS="ORDERED",X=$P(^LRO(69,LRODT,1,LRSN,0),U,8),IDT=9999999-X D REGDTM4 S CDT=X
I $D(^LRO(69,LRODT,1,LRSN,3)) S FST=^(3) D RESULT I 1
E S RDT=""
S SITE=+$G(^LRO(69,LRODT,1,LRSN,4,+$O(^LRO(69,LRODT,1,LRSN,4,0)),0)),SPEC=$S(SITE>0:SITE_";"_$P(^LAB(61,SITE,0),U),1:";UNKNOWN")
S:$P(ORX,"^",9)="CA" OS="CANCELED"
D TEST69
I $D(BADTEST) K BADTEST Q
S GMI=GMI+1,^TMP("OROR",$J,STARTDT,GMI)=CDT_U_TEST_U_SPEC_U_URG_U_OS_U_MD_U_ODT_U_ACC_U_RDT_U_COLL_U_LRODT_U_$P(ORX,U,7)
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 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=$S($L($P($G(^VA(200,+MD,0)),"^")):$P(^(0),"^"),1:"UNKOWN"),MD=+MD_";"_NM
S RL=$P(SPST,U,7)
Q
COLLECT ;Get Collection status from 69
N X,CS
S X=STARTDT D REGDTM4 S CDT=X
S CS=$P(CST,U,4),OS="COLLECTED"
S OS=$S(CS="C":"COLLECTED",X="U":"CANCELED",1:"On Collection List")
Q
RESULT ;Get Result status
N X S X=$P(FST,U,2) D REGDTM4 S RDT=X
I X S OS="COMPLETED"
Q
TEST69 ;Get Collection status from file 68 (overrides 69)
N TPTR,UPTR,ACCD,ACCA,ACCN,X
S TPTR=+ORX,UPTR=$P(ORX,U,2)
I '$D(^LAB(60,+TPTR,0)) S BADTEST=1 Q
S ACCD=$P(ORX,U,3),ACCA=$P(ORX,U,4),ACCN=$P(ORX,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 $D(^LRO(68,+ACCA,1,+ACCD,1,+ACCN,4,TPTR,0)) S X=$P(^(0),U,5) D
. I $G(OS)'="CANCELED",$G(OS)'="On Collection List" S OS=$S('$L(X):"PROCESSING",1:"COMPLETED")
Q
REGDTM4 ;Receives X FM date and returns X in MM/DD/YYYY TT:TT
S X=$TR($$FMTE^XLFDT(X,"5ZM"),"@"," ")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORDV02D 6031 printed Dec 13, 2024@02:30:07 Page 2
ORDV02D ;SLC/DCM - OE/RR REPORT EXTRACTS ;JAN 16, 2024@11:20
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**423,377,603**;Dec 17, 1997;Build 14
+2 ;
OV ;Overview
+1 DO EXT("OV")
+2 QUIT
PEND ;Pending
+1 DO EXT("PEND")
+2 QUIT
ALL ;ALL
+1 DO EXT("ALL")
+2 QUIT
EXT(ORPRT) ;New Lab Reports Extract
+1 NEW S,DP,ORLIST,STARTDT,STAT,IFN,OS,CST,TEST,COLL,ODT,NM,RL,MD,GMI,SORT,D,SN,STATUS,X4,LRODT,LRSN,ORMERG,ORX0,ORIFN,X1,X2,X3,FLAG,IVEDT,IVSDT
+2 KILL ^TMP("OR",$JOB),^TMP("OROR",$JOB),^TMP("ORSORT",$JOB),^TMP("ORR",$JOB)
+3 ; Display group = LAB
SET X=$ORDER(^ORD(100.98,"B","LAB",0))
if 'X
QUIT
SET DP=X
+4 SET FLAG=1
SET X3=1
SET OS=""
SET TEST=""
SET GMI=0
+5 ;Get everything to ensure all orders are included, then sort later by date ranges
SET X1=0
SET X2=9999999
+6 IF ORPRT="OV"
SET SORT="On Collection List:2^COLLECTED:3^PROCESSING:4^COMPLETED:6"
+7 IF ORPRT="PEND"
SET SORT="ORDERED:1^On Collection List:2^COLLECTED:3^PROCESSING:4"
+8 IF ORPRT="ALL"
SET SORT="ORDERED:1^On Collection List:2^COLLECTED:3^PROCESSING:4^CANCELED:5^COMPLETED:6"
+9 DO EN^ORQ1(DFN_";DPT(",DP,FLAG,"",X1,X2,X3)
+10 SET IFN=0
+11 FOR
SET IFN=$ORDER(^TMP("ORR",$JOB,ORLIST,IFN))
if IFN<1
QUIT
SET X=^(IFN)
Begin DoDot:1
+12 SET ORIFN=+$PIECE(X,"^")
SET STARTDT=$PIECE(X,"^",4)
SET STAT=$PIECE(X,"^",6)
+13 if '$DATA(^OR(100,ORIFN,0))
QUIT
SET ORX0=^(0)
SET X4=$GET(^(4))
+14 ;If no StartDate use lab CollectionDate or OrderDate
IF 'STARTDT
SET STARTDT=$SELECT($LENGTH($PIECE(X4,";",5)):9999999-$PIECE(X4,";",5),1:$PIECE(X,"^",3))
+15 SET LRODT=$PIECE(X4,";",2)
SET LRSN=$PIECE(X4,";",3)
SET ORMERG=0
+16 ;Set date for Inverse Start Date, sort by Date then Status, exclude ORDERED, CANCELED
IF ORPRT="OV"
DO GET
+17 ;Set date for Forward Start Date, sort by Date then Status, exclude COMPLETED, CANCELED
IF ORPRT="PEND"
DO GET
+18 ;Set date for Inverse Start Date, sort by Status then Date
IF ORPRT="ALL"
DO GET
End DoDot:1
+19 SET D=0
+20 SET IVEDT=ORDBEG
SET IVSDT=ORDEND
SET D=IVEDT
+21 FOR
SET D=$ORDER(^TMP("OROR",$JOB,D))
if 'D!(D>IVSDT)
QUIT
Begin DoDot:1
+22 SET SN=0
+23 FOR
SET SN=$ORDER(^TMP("OROR",$JOB,D,SN))
if 'SN
QUIT
SET ORX0=^(SN)
IF $LENGTH(ORX0)
SET STATUS=$PIECE(ORX0,"^",5)
IF $LENGTH($PIECE(ORX0,"^"))
Begin DoDot:2
+24 SET S=$EXTRACT(SORT,$FIND(SORT,STATUS)+1)
+25 ;Reverse sort order DM-603
IF ORPRT="OV"
IF STATUS'="ORDERED"
IF STATUS'="CANCELED"
SET ^TMP("ORSORT",$JOB,9999999-D,S,SN)=ORX0
+26 IF ORPRT="PEND"
IF STATUS'="CANCELED"
IF STATUS'="COMPLETED"
SET ^TMP("ORSORT",$JOB,9999999-D,S,SN)=ORX0
+27 IF ORPRT="ALL"
SET ^TMP("ORSORT",$JOB,S,D,SN)=ORX0
End DoDot:2
End DoDot:1
+28 KILL ^TMP("OROR",$JOB),^TMP("ORR",$JOB)
+29 QUIT
GET ;
+1 NEW ORI,ORX,GOTLR
+2 SET ORI=0
+3 FOR
SET ORI=$ORDER(^OR(100,ORIFN,4.5,"ID","ORDERABLE",ORI))
if ORI<1
QUIT
IF $DATA(^OR(100,ORIFN,4.5,ORI,1))
SET ORX=^(1)
Begin DoDot:1
+4 SET GOTLR=0
+5 IF $DATA(^ORD(101.43,+ORX,0))
SET (TEST,ORX)=+$PIECE(^(0),"^",2)
+6 IF ORX
IF LRODT
IF LRSN
IF $DATA(^LRO(69,LRODT,1,LRSN,2,"B",ORX))
SET ORX=$ORDER(^(ORX,0))
Begin DoDot:2
+7 if '$LENGTH($GET(^LRO(69,LRODT,1,LRSN,0)))
QUIT
+8 IF $GET(^LRO(69,LRODT,1,LRSN,2,ORX,0))
SET ORX=^(0)
SET GOTLR=1
DO GET69
End DoDot:2
+9 ;Get data from file 63 and OE/RR
IF 'ORMERG
IF 'GOTLR
DO GET63
End DoDot:1
+10 QUIT
GET63 ; Get data from file 63 and OE/RR files
+1 NEW SUB,CDT,LRIDT,X0,SPEC,OS,MD,IFN,PKG,FILE,NM,MD,ACC,ODT,URG,COLL,CD,RDT,LRDFN,FNF,NSPACE
+2 if '$LENGTH($PIECE(X4,";",4))
QUIT
if '$LENGTH($PIECE(X4,";",5))
QUIT
+3 SET SUB=$PIECE(X4,";",4)
SET LRIDT=$PIECE(X4,";",5)
+4 IF '$DATA(DFN)
SET DFN=$SELECT($DATA(ORVP):+ORVP,1:0)
if 'DFN
QUIT
+5 if '$DATA(^DPT(DFN,"LR"))
QUIT
SET LRDFN=+^DPT(DFN,"LR")
if '$DATA(^LR(LRDFN))
QUIT
+6 if '$DATA(^LR(LRDFN,SUB,LRIDT,0))
QUIT
SET X0=^(0)
+7 SET X=STARTDT
DO REGDTM4
SET CDT=X
+8 SET TEST=TEST_";"_$PIECE($GET(^LAB(60,+TEST,0)),"^")
SET SPEC=+$PIECE(X0,"^",5)_";"_$PIECE($GET(^LAB(61,+$PIECE(X0,"^",5),0)),"^")
SET OS=$SELECT($PIECE(X0,"^",3):"COMPLETED",1:"PROCESSING")
+9 SET (MD,IFN)=$PIECE(X0,"^",10)
SET FNF=0
SET NSPACE="LR"
+10 IF SUB="MI"
SET (MD,IFN)=$PIECE(X0,"^",7)
+11 SET PKG=$$VERSION^XPDUTL(NSPACE)
SET FILE=$SELECT($GET(PKG)<5.2:6,1:200)
+12 SET NM=$SELECT($LENGTH($PIECE($GET(^VA(200,+MD,0)),"^")):$PIECE(^(0),"^"),1:"UNKOWN")
SET MD=+MD_";"_NM
SET ACC=$PIECE(X0,"^",6)
+13 SET X=$PIECE(ORX0,"^",7)
DO REGDTM4
SET ODT=X
+14 SET X=$PIECE(X0,"^",3)
DO REGDTM4
SET RDT=X
+15 ;COLL=Collection Type
SET URG="UNKNOWN"
SET COLL="UNKNOWN"
SET CD=$PIECE($PIECE(ORX0,"^",7),".")
+16 SET GMI=GMI+1
SET ^TMP("OROR",$JOB,STARTDT,GMI)=CDT_U_TEST_U_SPEC_U_URG_U_OS_U_MD_U_ODT_U_ACC_U_RDT_U_COLL_U_CD_U_ORIFN
+17 QUIT
GET69 ; Get data from Lab Order/accession (69, 68) files
+1 NEW X,IDT,SPEC,SITE,BADTEST,FST,SPST
+2 ;exclude merged orders from extract
IF $LENGTH($PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),"^",7))
SET ORMERG=1
QUIT
+3 IF $DATA(^LRO(69,LRODT,1,LRSN,0))
SET SPST=^(0)
DO ORDER
+4 IF $DATA(^LRO(69,LRODT,1,LRSN,1))
SET CST=^(1)
DO COLLECT
IF 1
+5 IF '$TEST
SET OS="ORDERED"
SET X=$PIECE(^LRO(69,LRODT,1,LRSN,0),U,8)
SET IDT=9999999-X
DO REGDTM4
SET CDT=X
+6 IF $DATA(^LRO(69,LRODT,1,LRSN,3))
SET FST=^(3)
DO RESULT
IF 1
+7 IF '$TEST
SET RDT=""
+8 SET SITE=+$GET(^LRO(69,LRODT,1,LRSN,4,+$ORDER(^LRO(69,LRODT,1,LRSN,4,0)),0))
SET SPEC=$SELECT(SITE>0:SITE_";"_$PIECE(^LAB(61,SITE,0),U),1:";UNKNOWN")
+9 if $PIECE(ORX,"^",9)="CA"
SET OS="CANCELED"
+10 DO TEST69
+11 IF $DATA(BADTEST)
KILL BADTEST
QUIT
+12 SET GMI=GMI+1
SET ^TMP("OROR",$JOB,STARTDT,GMI)=CDT_U_TEST_U_SPEC_U_URG_U_OS_U_MD_U_ODT_U_ACC_U_RDT_U_COLL_U_LRODT_U_$PIECE(ORX,U,7)
+13 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
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=$SELECT($LENGTH($PIECE($GET(^VA(200,+MD,0)),"^")):$PIECE(^(0),"^"),1:"UNKOWN")
SET MD=+MD_";"_NM
+8 SET RL=$PIECE(SPST,U,7)
+9 QUIT
COLLECT ;Get Collection status from 69
+1 NEW X,CS
+2 SET X=STARTDT
DO REGDTM4
SET CDT=X
+3 SET CS=$PIECE(CST,U,4)
SET OS="COLLECTED"
+4 SET OS=$SELECT(CS="C":"COLLECTED",X="U":"CANCELED",1:"On Collection List")
+5 QUIT
RESULT ;Get Result status
+1 NEW X
SET X=$PIECE(FST,U,2)
DO REGDTM4
SET RDT=X
+2 IF X
SET OS="COMPLETED"
+3 QUIT
TEST69 ;Get Collection status from file 68 (overrides 69)
+1 NEW TPTR,UPTR,ACCD,ACCA,ACCN,X
+2 SET TPTR=+ORX
SET UPTR=$PIECE(ORX,U,2)
+3 IF '$DATA(^LAB(60,+TPTR,0))
SET BADTEST=1
QUIT
+4 SET ACCD=$PIECE(ORX,U,3)
SET ACCA=$PIECE(ORX,U,4)
SET ACCN=$PIECE(ORX,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 $DATA(^LRO(68,+ACCA,1,+ACCD,1,+ACCN,4,TPTR,0))
SET X=$PIECE(^(0),U,5)
Begin DoDot:1
+10 IF $GET(OS)'="CANCELED"
IF $GET(OS)'="On Collection List"
SET OS=$SELECT('$LENGTH(X):"PROCESSING",1:"COMPLETED")
End DoDot:1
+11 QUIT
REGDTM4 ;Receives X FM date and returns X in MM/DD/YYYY TT:TT
+1 SET X=$TRANSLATE($$FMTE^XLFDT(X,"5ZM"),"@"," ")
+2 QUIT
