LR7OR1 ;VA/slc/dcm - Get Lab results ;JUL 06, 2010 3:14 PM
;;5.2;LAB SERVICE;**121,187,219,230,256,310,340,348,1027**;NOV 01, 1997
RR(DFN,ORD,SDATE,EDATE,SUB,TEST,FLAG,COUNT,SPEC,UNVER) ;Get LAB results for patient
;DFN = Patient DFN, ptr to file 2 (Required)
;ORD = Lab Link from OE/RR (ORPK node) (Optional)
;SDATE = start date to begin search in fileman format (Optional)
;EDATE = end date to end search in fileman format (Optional)
;SUB =set to CH,MI,AP or ALL to specify lab (Optional)
; subsection. A null entry will imply ALL.
;TEST = Test to do lookup on (Optional). A null parameter will get all tests
;FLAG = L for local test ID, N for National test ID (Optional)
; this is specified for both input and output
;COUNT =Count of results to return. Each Date/time counts as 1 (optional)
;SPEC =ptr file 61 to specify specimen (optional).
; If specified, no AP results are returned.
;UNVER =1 to include unverified data
;Output is set in ^TMP("LRRR",$J,dfn,subscript,inverse d/t,seq)=
; testID^result^flag^units^refrange^resultstatus(F or P)^^^natlCode^natlName^system^Verifyby^^Theraputicflag(T or "")^PrintName^Accession^Order#^Specimen
N LRDFN,LRDPF,SEX,AGE,DOB,ORDT,ORSN,II,III,DRAW,TSTY,SS,CT1
Q:'$G(DFN)
S LRDFN=$$LRDFN(DFN),LRDPF="2^DPT("
Q:'LRDFN
S SEX=$P($G(@("^"_$P(LRDPF,"^",2)_+DFN_",0)")),"^",2)
S DOB=$P($G(@("^"_$P(LRDPF,"^",2)_+DFN_",0)")),"^",3),AGE=$S($D(DT)&(DOB?7N):DT-DOB\10000,1:"??")
D DTRNG
S SUB=$S($G(SUB)="ALL":"CHMIAP",$L($G(SUB)):SUB,1:"CHMIAP"),FLAG=$S('$L($G(FLAG)):"L",1:FLAG)
I $G(TEST),FLAG="L",'$D(^LAB(60,TEST)) Q ;No-Match on Local testID
I $G(TEST),FLAG="N" S TEST=$O(^LAB(60,"AC",TEST,0)) Q:'TEST ;No-Match on National testID
I $G(TEST) S SUB=$P(^LAB(60,TEST,0),"^",4) Q:'$L(SUB) ;Test with no subscript
K ^TMP("LRRR",$J),^TMP("LRAPI",$J) S COUNT=$S($G(COUNT):COUNT,1:9999999),CT1=1
I $G(ORD) S ORDT=0 D Q
. I $G(TEST) Q:'$D(^LAB(60,TEST,0)) S X=^(0) I $P(X,"^",4)="CH" D
.. I $L($P(X,"^",5)) S TSTY($P($P(X,"^",5),";",2))=TEST
.. I '$L($P(X,"^",5)) D EN^LR7OU1(TEST)
. I ORD["^" S ORDT=$P(ORD,"^"),ORSN=$P(ORD,"^",2) I ORDT,ORSN D SN Q ;OE/RR 2.5 unconverted orders
. I ORD'[";" F S ORDT=$O(^LRO(69,"C",ORD,ORDT)) Q:ORDT<1 S ORSN=0 F S ORSN=$O(^LRO(69,"C",ORD,ORDT,ORSN)) Q:ORSN<1 D SN ;Early CPRS when only LR# stored
. I ORD[";" S ORDT=$P(ORD,";",2),ORSN=$P(ORD,";",3) I ORDT,ORSN D SN
I SUB["CH" D CH^LR7OR2(SDATE,EDATE,$G(TEST),COUNT,$G(SPEC),$G(UNVER))
I SUB["MI" D MI(SDATE,EDATE,COUNT,$G(SPEC))
;I SUB["BB" D BB(SDATE,EDATE,COUNT,$G(SPEC))
I SUB["AP",'$G(SPEC) D AP(SDATE,EDATE,COUNT)
Q
MI(SDATE,EDATE,COUNT,SPEC) ;Get MI Subscript data
Q:'$D(SDATE) Q:'$D(EDATE) Q:'$D(COUNT) Q:'$D(CT1)
K ^TMP("LRX",$J)
S IVDT=SDATE F S IVDT=$O(^LR(LRDFN,"MI",IVDT)) Q:IVDT<1!(IVDT>EDATE)!(CT1>COUNT) K LRX S CTR=99,CT1=CT1+1 D MI^LR7OB63A(SPEC) M ^TMP("LRRR",$J,DFN,"MI",IVDT)=^TMP("LRX",$J,69,99,63)
K ^TMP("LRX",$J) Q
BB(SDATE,EDATE,COUNT,SPEC) ;Get BB Subscript data
Q
Q:'$D(SDATE) Q:'$D(EDATE) Q:'$D(COUNT) Q:'$D(CT1)
K ^TMP("LRX",$J)
S IVDT=SDATE F S IVDT=$O(^LR(LRDFN,"BB",IVDT)) Q:IVDT<1!(IVDT>EDATE)!(CT1>COUNT) K LRX S CTR=99,CT1=CT1+1 D BB1^LR7OB63(SPEC) M ^TMP("LRRR",$J,DFN,"BB",IVDT)=^TMP("LRX",$J,69,99,63)
K ^TMP("LRX",$J) Q
AP(SDATE,EDATE,COUNT) ;Get AP Subscript data (EM,CY,AU,SP)
N LRSS K ^TMP("LRX",$J)
Q:'$D(SDATE) Q:'$D(EDATE) Q:'$D(COUNT) Q:'$D(CT1)
S CTR=99 D AU^LR7OB63D M ^TMP("LRRR",$J,DFN,"AU")=^TMP("LRX",$J,69,99,63)
F LRSS="EM","CY","SP" S IVDT=SDATE F S IVDT=$O(^LR(LRDFN,LRSS,IVDT)) Q:IVDT<1!(IVDT>EDATE)!(CT1>COUNT) K LRX S CTR=99,CT1=CT1+1 D SS^LR7OB63C(LRSS) M ^TMP("LRRR",$J,DFN,LRSS,IVDT)=^TMP("LRX",$J,69,99,63)
K ^TMP("LRX",$J) Q
TEST ;Test the RR entry point
N X1,X2,X3,X4,X5,DIC,%DT,X,Y
K ^TMP("LRRR",$J),^TMP("LRAPI",$J) S (X1,X2,X3,X4,X5)=""
D ^LRDPA Q:'DFN
O1 W !,"Select Lab Order #: " R X:DTIME Q:'$T!(X["^")
I $L(X),'$D(^LRO(69,"C",X)) W !!,X_" is not a valid order number." G O1
I $L(X),$D(^LRO(69,"C",X)) S X5=X,DIC=60,DIC(0)="AEQM",DIC("A")="Select Test (optional): " D ^DIC S X3=$S(Y>0:+Y,1:"") Q:Y<0&(X["^") G T2
S %DT="AETS",%DT("A")="Select Start Date: " D ^%DT S X1=$S(Y>0:Y,1:"") I Y<0,X["^" Q
S %DT="AETS",%DT("A")="Select End Date: " D ^%DT S X2=$S(Y>0:Y,1:"") I Y<0,X["^" Q
S DIC=60,DIC(0)="AEQM",DIC("A")="Look for specific Test: " D ^DIC S X3=$S(Y>0:+Y,1:"") I Y<0,X["^" Q
I 'X3 D
T1 . W !,"Enter a lab area to search on (ALL,CH,MI,AP): " R X:DTIME Q:'$T!(X["^")
. IF "ALLCHMIAP"'[X W !!,"Bad input, enter ALL, CH, MI, or AP" G T1
. S X4=$S("ALLCHMIAP"[X:X,1:"")
T2 D RR(DFN,X5,X1,X2,X4,X3)
W !!,$S($D(^TMP("LRRR",$J)):"Data found!",1:"NO Data found!")
Q
DTRNG ;Date range setup
I $G(EDATE)<$G(SDATE) S X=EDATE,EDATE=SDATE,SDATE=X
I $G(EDATE) S EDATE=$S($L(EDATE,".")=2:EDATE+.000001,1:EDATE+1)
I $G(SDATE) S SDATE=$S($L(SDATE,".")=2:SDATE-.000001,1:SDATE)
S SDATE=$S($G(SDATE):9999999-SDATE,1:9999999),EDATE=$S($G(EDATE):9999999-EDATE,1:1)
S X=EDATE,EDATE=SDATE,SDATE=X
Q
SN ;Get the subs
D 69^LR7OB69(ORDT,ORSN) Q:'$D(^TMP("LRX",$J,69))
S II=0 F S II=$O(^TMP("LRX",$J,69,II)) Q:II<1 S DRAW=$P($G(^TMP("LRX",$J,69,II,68)),"^",4),SS=$P($G(^LRO(68,+$P(^TMP("LRX",$J,69,II),"^",4),0)),"^",2) D
. S III=0 F S III=$O(^TMP("LRX",$J,69,II,63,III)) Q:III<1 I $S($D(TSTY):$D(TSTY(III)),1:1) D
.. I $P(^TMP("LRX",$J,69,II,63,III),U,6)="" Q
.. S ^TMP("LRRR",$J,DFN,SS,9999999-DRAW,III)=^TMP("LRX",$J,69,II,63,III)
. I $D(^TMP("LRX",$J,69,II,63,"N")),$O(^TMP("LRRR",$J,DFN,SS,9999999-DRAW,0)) M ^TMP("LRRR",$J,DFN,SS,9999999-DRAW,"N")=^TMP("LRX",$J,69,II,63,"N")
Q
LRDFN(IFN,FILEROOT) ;Get LRDFN
;IFN=Internal file number
;FILEROOT=Root of file to get LRDFN (optional) "DPT(" is default
Q:'$G(IFN) ""
I '$L($G(FILEROOT)) S FILEROOT="DPT("
S X=$S($D(@("^"_FILEROOT_+IFN_",""LR"")")):+^("LR"),1:"")
I X,'$D(^LR(X,0)) S X=""
Q X
LR7OR1 ;VA/slc/dcm - Get Lab results ;JUL 06, 2010 3:14 PM
+1 ;;5.2;LAB SERVICE;**121,187,219,230,256,310,340,348,1027**;NOV 01, 1997
RR(DFN,ORD,SDATE,EDATE,SUB,TEST,FLAG,COUNT,SPEC,UNVER) ;Get LAB results for patient
+1 ;DFN = Patient DFN, ptr to file 2 (Required)
+2 ;ORD = Lab Link from OE/RR (ORPK node) (Optional)
+3 ;SDATE = start date to begin search in fileman format (Optional)
+4 ;EDATE = end date to end search in fileman format (Optional)
+5 ;SUB =set to CH,MI,AP or ALL to specify lab (Optional)
+6 ; subsection. A null entry will imply ALL.
+7 ;TEST = Test to do lookup on (Optional). A null parameter will get all tests
+8 ;FLAG = L for local test ID, N for National test ID (Optional)
+9 ; this is specified for both input and output
+10 ;COUNT =Count of results to return. Each Date/time counts as 1 (optional)
+11 ;SPEC =ptr file 61 to specify specimen (optional).
+12 ; If specified, no AP results are returned.
+13 ;UNVER =1 to include unverified data
+14 ;Output is set in ^TMP("LRRR",$J,dfn,subscript,inverse d/t,seq)=
+15 ; testID^result^flag^units^refrange^resultstatus(F or P)^^^natlCode^natlName^system^Verifyby^^Theraputicflag(T or "")^PrintName^Accession^Order#^Specimen
+16 NEW LRDFN,LRDPF,SEX,AGE,DOB,ORDT,ORSN,II,III,DRAW,TSTY,SS,CT1
+17 IF '$GET(DFN)
QUIT
+18 SET LRDFN=$$LRDFN(DFN)
SET LRDPF="2^DPT("
+19 IF 'LRDFN
QUIT
+20 SET SEX=$PIECE($GET(@("^"_$PIECE(LRDPF,"^",2)_+DFN_",0)")),"^",2)
+21 SET DOB=$PIECE($GET(@("^"_$PIECE(LRDPF,"^",2)_+DFN_",0)")),"^",3)
SET AGE=$SELECT($DATA(DT)&(DOB?7N):DT-DOB\10000,1:"??")
+22 DO DTRNG
+23 SET SUB=$SELECT($GET(SUB)="ALL":"CHMIAP",$LENGTH($GET(SUB)):SUB,1:"CHMIAP")
SET FLAG=$SELECT('$LENGTH($GET(FLAG)):"L",1:FLAG)
+24 ;No-Match on Local testID
IF $GET(TEST)
IF FLAG="L"
IF '$DATA(^LAB(60,TEST))
QUIT
+25 ;No-Match on National testID
IF $GET(TEST)
IF FLAG="N"
SET TEST=$ORDER(^LAB(60,"AC",TEST,0))
IF 'TEST
QUIT
+26 ;Test with no subscript
IF $GET(TEST)
SET SUB=$PIECE(^LAB(60,TEST,0),"^",4)
IF '$LENGTH(SUB)
QUIT
+27 KILL ^TMP("LRRR",$JOB),^TMP("LRAPI",$JOB)
SET COUNT=$SELECT($GET(COUNT):COUNT,1:9999999)
SET CT1=1
+28 IF $GET(ORD)
SET ORDT=0
Begin DoDot:1
+29 IF $GET(TEST)
IF '$DATA(^LAB(60,TEST,0))
QUIT
SET X=^(0)
IF $PIECE(X,"^",4)="CH"
Begin DoDot:2
+30 IF $LENGTH($PIECE(X,"^",5))
SET TSTY($PIECE($PIECE(X,"^",5),";",2))=TEST
+31 IF '$LENGTH($PIECE(X,"^",5))
DO EN^LR7OU1(TEST)
End DoDot:2
+32 ;OE/RR 2.5 unconverted orders
IF ORD["^"
SET ORDT=$PIECE(ORD,"^")
SET ORSN=$PIECE(ORD,"^",2)
IF ORDT
IF ORSN
DO SN
QUIT
+33 ;Early CPRS when only LR# stored
IF ORD'[";"
FOR
SET ORDT=$ORDER(^LRO(69,"C",ORD,ORDT))
IF ORDT<1
QUIT
SET ORSN=0
FOR
SET ORSN=$ORDER(^LRO(69,"C",ORD,ORDT,ORSN))
IF ORSN<1
QUIT
DO SN
+34 IF ORD[";"
SET ORDT=$PIECE(ORD,";",2)
SET ORSN=$PIECE(ORD,";",3)
IF ORDT
IF ORSN
DO SN
End DoDot:1
QUIT
+35 IF SUB["CH"
DO CH^LR7OR2(SDATE,EDATE,$GET(TEST),COUNT,$GET(SPEC),$GET(UNVER))
+36 IF SUB["MI"
DO MI(SDATE,EDATE,COUNT,$GET(SPEC))
+37 ;I SUB["BB" D BB(SDATE,EDATE,COUNT,$G(SPEC))
+38 IF SUB["AP"
IF '$GET(SPEC)
DO AP(SDATE,EDATE,COUNT)
+39 QUIT
MI(SDATE,EDATE,COUNT,SPEC) ;Get MI Subscript data
+1 IF '$DATA(SDATE)
QUIT
IF '$DATA(EDATE)
QUIT
IF '$DATA(COUNT)
QUIT
IF '$DATA(CT1)
QUIT
+2 KILL ^TMP("LRX",$JOB)
+3 SET IVDT=SDATE
FOR
SET IVDT=$ORDER(^LR(LRDFN,"MI",IVDT))
IF IVDT<1!(IVDT>EDATE)!(CT1>COUNT)
QUIT
KILL LRX
SET CTR=99
SET CT1=CT1+1
DO MI^LR7OB63A(SPEC)
MERGE ^TMP("LRRR",$JOB,DFN,"MI",IVDT)=^TMP("LRX",$JOB,69,99,63)
+4 KILL ^TMP("LRX",$JOB)
QUIT
BB(SDATE,EDATE,COUNT,SPEC) ;Get BB Subscript data
+1 QUIT
+2 IF '$DATA(SDATE)
QUIT
IF '$DATA(EDATE)
QUIT
IF '$DATA(COUNT)
QUIT
IF '$DATA(CT1)
QUIT
+3 KILL ^TMP("LRX",$JOB)
+4 SET IVDT=SDATE
FOR
SET IVDT=$ORDER(^LR(LRDFN,"BB",IVDT))
IF IVDT<1!(IVDT>EDATE)!(CT1>COUNT)
QUIT
KILL LRX
SET CTR=99
SET CT1=CT1+1
DO BB1^LR7OB63(SPEC)
MERGE ^TMP("LRRR",$JOB,DFN,"BB",IVDT)=^TMP("LRX",$JOB,69,99,63)
+5 KILL ^TMP("LRX",$JOB)
QUIT
AP(SDATE,EDATE,COUNT) ;Get AP Subscript data (EM,CY,AU,SP)
+1 NEW LRSS
KILL ^TMP("LRX",$JOB)
+2 IF '$DATA(SDATE)
QUIT
IF '$DATA(EDATE)
QUIT
IF '$DATA(COUNT)
QUIT
IF '$DATA(CT1)
QUIT
+3 SET CTR=99
DO AU^LR7OB63D
MERGE ^TMP("LRRR",$JOB,DFN,"AU")=^TMP("LRX",$JOB,69,99,63)
+4 FOR LRSS="EM","CY","SP"
SET IVDT=SDATE
FOR
SET IVDT=$ORDER(^LR(LRDFN,LRSS,IVDT))
IF IVDT<1!(IVDT>EDATE)!(CT1>COUNT)
QUIT
KILL LRX
SET CTR=99
SET CT1=CT1+1
DO SS^LR7OB63C(LRSS)
MERGE ^TMP("LRRR",$JOB,DFN,LRSS,IVDT)=^TMP("LRX",$JOB,69,99,63)
+5 KILL ^TMP("LRX",$JOB)
QUIT
TEST ;Test the RR entry point
+1 NEW X1,X2,X3,X4,X5,DIC,%DT,X,Y
+2 KILL ^TMP("LRRR",$JOB),^TMP("LRAPI",$JOB)
SET (X1,X2,X3,X4,X5)=""
+3 DO ^LRDPA
IF 'DFN
QUIT
O1 WRITE !,"Select Lab Order #: "
READ X:DTIME
IF '$TEST!(X["^")
QUIT
+1 IF $LENGTH(X)
IF '$DATA(^LRO(69,"C",X))
WRITE !!,X_" is not a valid order number."
GOTO O1
+2 IF $LENGTH(X)
IF $DATA(^LRO(69,"C",X))
SET X5=X
SET DIC=60
SET DIC(0)="AEQM"
SET DIC("A")="Select Test (optional): "
DO ^DIC
SET X3=$SELECT(Y>0:+Y,1:"")
IF Y<0&(X["^")
QUIT
GOTO T2
+3 SET %DT="AETS"
SET %DT("A")="Select Start Date: "
DO ^%DT
SET X1=$SELECT(Y>0:Y,1:"")
IF Y<0
IF X["^"
QUIT
+4 SET %DT="AETS"
SET %DT("A")="Select End Date: "
DO ^%DT
SET X2=$SELECT(Y>0:Y,1:"")
IF Y<0
IF X["^"
QUIT
+5 SET DIC=60
SET DIC(0)="AEQM"
SET DIC("A")="Look for specific Test: "
DO ^DIC
SET X3=$SELECT(Y>0:+Y,1:"")
IF Y<0
IF X["^"
QUIT
+6 IF 'X3
Begin DoDot:1
T1 WRITE !,"Enter a lab area to search on (ALL,CH,MI,AP): "
READ X:DTIME
IF '$TEST!(X["^")
QUIT
+1 IF "ALLCHMIAP"'[X
WRITE !!,"Bad input, enter ALL, CH, MI, or AP"
GOTO T1
+2 SET X4=$SELECT("ALLCHMIAP"[X:X,1:"")
End DoDot:1
T2 DO RR(DFN,X5,X1,X2,X4,X3)
+1 WRITE !!,$SELECT($DATA(^TMP("LRRR",$JOB)):"Data found!",1:"NO Data found!")
+2 QUIT
DTRNG ;Date range setup
+1 IF $GET(EDATE)<$GET(SDATE)
SET X=EDATE
SET EDATE=SDATE
SET SDATE=X
+2 IF $GET(EDATE)
SET EDATE=$SELECT($LENGTH(EDATE,".")=2:EDATE+.000001,1:EDATE+1)
+3 IF $GET(SDATE)
SET SDATE=$SELECT($LENGTH(SDATE,".")=2:SDATE-.000001,1:SDATE)
+4 SET SDATE=$SELECT($GET(SDATE):9999999-SDATE,1:9999999)
SET EDATE=$SELECT($GET(EDATE):9999999-EDATE,1:1)
+5 SET X=EDATE
SET EDATE=SDATE
SET SDATE=X
+6 QUIT
SN ;Get the subs
+1 DO 69^LR7OB69(ORDT,ORSN)
IF '$DATA(^TMP("LRX",$JOB,69))
QUIT
+2 SET II=0
FOR
SET II=$ORDER(^TMP("LRX",$JOB,69,II))
IF II<1
QUIT
SET DRAW=$PIECE($GET(^TMP("LRX",$JOB,69,II,68)),"^",4)
SET SS=$PIECE($GET(^LRO(68,+$PIECE(^TMP("LRX",$JOB,69,II),"^",4),0)),"^",2)
Begin DoDot:1
+3 SET III=0
FOR
SET III=$ORDER(^TMP("LRX",$JOB,69,II,63,III))
IF III<1
QUIT
IF $SELECT($DATA(TSTY):$DATA(TSTY(III)),1:1)
Begin DoDot:2
+4 IF $PIECE(^TMP("LRX",$JOB,69,II,63,III),U,6)=""
QUIT
+5 SET ^TMP("LRRR",$JOB,DFN,SS,9999999-DRAW,III)=^TMP("LRX",$JOB,69,II,63,III)
End DoDot:2
+6 IF $DATA(^TMP("LRX",$JOB,69,II,63,"N"))
IF $ORDER(^TMP("LRRR",$JOB,DFN,SS,9999999-DRAW,0))
MERGE ^TMP("LRRR",$JOB,DFN,SS,9999999-DRAW,"N")=^TMP("LRX",$JOB,69,II,63,"N")
End DoDot:1
+7 QUIT
LRDFN(IFN,FILEROOT) ;Get LRDFN
+1 ;IFN=Internal file number
+2 ;FILEROOT=Root of file to get LRDFN (optional) "DPT(" is default
+3 IF '$GET(IFN)
QUIT ""
+4 IF '$LENGTH($GET(FILEROOT))
SET FILEROOT="DPT("
+5 SET X=$SELECT($DATA(@("^"_FILEROOT_+IFN_",""LR"")")):+^("LR"),1:"")
+6 IF X
IF '$DATA(^LR(X,0))
SET X=""
+7 QUIT X
