- LR7OR1 ;DALIO/JMC - Get Lab results ; 3/29/19 8:11am
- ;;5.2;LAB SERVICE;**121,187,219,230,256,310,340,348,350,427,459,519,534**;Sep 27, 1994;Build 1
- ;Reference to ^DPT supported by DBIA #10035
- ;Reference to $$FMADD^XLFDT supported by IA #10103
- ;
- 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
- N LRORID,LRORIDX,LRID,LRORIDF,LRD1,LRD2,LRAN,LRUID,LRI
- N LRDTST,LRORU,LRAA,LRSD,LRSA,LRSN,LRORNST
- ;
- 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 SUB["CH",$D(ORID) S LRORID=ORID,LRORIDX=0 D
- . I $G(LRORID)<1,$D(ID) S LRORID=+ID
- . I $D(LRORID) S LRORID=+LRORID
- . I $D(ID) S LRID=+ID
- ;
- 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) F LRI="LRPLS","LRPLS-ADDR" K ^TMP(LRI,$J)
- ;
- S COUNT=$S($G(COUNT):COUNT,1:9999999),CT1=1
- ;
- CV ;Check variables to see if called by OR; build array of tests (LR519)
- I SUB["CH",$D(LRORID) S LRORIDX=0 D
- . S LRD1=9999999-$$FMADD^XLFDT(9999999-SDATE,14),LRD2=9999999-$$FMADD^XLFDT(9999999-EDATE,-14)
- . F S LRD1=$O(^LR(LRDFN,"CH",LRD1)) Q:LRD1<1!(LRD1>LRD2) D
- . . S LRDTST=^LR(LRDFN,"CH",LRD1,0),LRORU=$G(^LR(LRDFN,"CH",LRD1,"ORU")) Q:LRORU=""
- . . S ^TMP("LRORID",$J,+LRDTST)=$P(LRDTST,U,6)_U_$P(LRDTST,U)_U_$P(LRORU,U)
- . S LRD1=0 F S LRD1=$O(^TMP("LRORID",$J,LRD1)) Q:LRD1<1 S LRORIDF=0 D
- . . S LRAN=^TMP("LRORID",$J,LRD1),LRUID=$P(LRAN,U,3)
- . . S LRAA=$O(^LRO(68,"C",LRUID,0))
- . . I LRAA<1 K ^TMP("LRORID",$J,LRD1) Q
- . . S LRAD=$O(^LRO(68,"C",LRUID,LRAA,0))
- . . I LRAD<1 K ^TMP("LRORID",$J,LRD1) Q
- . . S LRSA=$O(^LRO(68,"C",LRUID,LRAA,LRAD,0))
- . . I LRSA<1 K ^TMP("LRORID",$J,LRD1) Q
- . . I $G(^LRO(68,LRAA,1,LRAD,1,LRSA,.2))=$P(LRAN,U) D
- . . . S LRSD=$P(^LRO(68,LRAA,1,LRAD,1,LRSA,0),U,4),LRSN=$P(^(0),U,5)
- . . . ;S LRON=^LRO(68,LRAA,1,LRAD,1,LRSA,.1)
- . . . S LRORNST=$P($G(^LRO(69,LRSD,1,LRSN,2,0)),U,3) Q:LRORNST<1
- . . . F LRI=1:1:LRORNST I $P($G(^LRO(69,LRSD,1,LRSN,2,LRI,0)),U,7)=LRORID S LRORIDF=1 Q
- . . I 'LRORIDF K ^TMP("LRORID",$J,LRD1)
- . S LRD1=0 F S LRD1=$O(^TMP("LRORID",$J,LRD1)) Q:LRD1<1 D
- . . S ^TMP("LRORID",$J,"O",9999999-LRD1)=^TMP("LRORID",$J,LRD1) K ^TMP("LRORID",$J,LRD1)
- . . S ^TMP("LRORID",$J)=$G(^TMP("LRORID",$J))+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 $P(X,"^",5)'="" S TSTY($P($P(X,"^",5),";",2))=TEST
- . . I $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
- AGAIN ;First: get a CH entry; process; then check for another test (LR519)
- I SUB["CH",$D(LRORID) S LRORIDX=$O(^TMP("LRORID",$J,"O",0)) I LRORIDX>0 S (SDATE,EDATE)=LRORIDX K ^TMP("LRORID",$J,"O",LRORIDX)
- 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)
- I $D(^TMP("LRORID",$J)) G AGAIN:$O(^TMP("LRORID",$J,"O",0))>0 K ^TMP("LRORID",$J)
- I SUB["CH" K LRORID,LRORIDX,LRD1,LRD2,LRDTST,LRORIDF,LRAN,LRAA,LRSD,LRSA,LRAD,LRUID,LRI,LRORNST
- 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
- ;
- N I,II,III,LRPLSAVE
- ;
- ; Set flag to not print performing lab in called routines, wait for control returns to this routine.
- S LRPLSAVE=1
- ;
- D 69^LR7OB69(ORDT,ORSN) Q:'$D(^TMP("LRX",$J,69))
- ;
- ; List performing laboratories
- I $G(LRPLSAVE(0)) D
- . N CTR,IVDT
- . S CTR=LRPLSAVE(0),IVDT=0
- . F S IVDT=$O(LRPLSAVE("CH",IVDT)) Q:IVDT<1 D
- . . D PLS^LR7OB63
- ;
- S II=0
- F S II=$O(^TMP("LRX",$J,69,II)) Q:II<1 D
- . 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)
- . 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 I=III
- . . I $D(^TMP("LRRR",$J,DFN,SS,9999999-DRAW,I)) F S I=I+.00000001 I '$D(^TMP("LRRR",$J,DFN,SS,9999999-DRAW,I)) Q
- . . S ^TMP("LRRR",$J,DFN,SS,9999999-DRAW,I)=^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")
- ;
- F I="LRPLS","LRPLS-ADDR" K ^TMP(I,$J)
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OR1 8747 printed Jan 18, 2025@03:06:02 Page 2
- LR7OR1 ;DALIO/JMC - Get Lab results ; 3/29/19 8:11am
- +1 ;;5.2;LAB SERVICE;**121,187,219,230,256,310,340,348,350,427,459,519,534**;Sep 27, 1994;Build 1
- +2 ;Reference to ^DPT supported by DBIA #10035
- +3 ;Reference to $$FMADD^XLFDT supported by IA #10103
- +4 ;
- 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 ;
- +17 NEW LRDFN,LRDPF,SEX,AGE,DOB,ORDT,ORSN,II,III,DRAW,TSTY,SS,CT1
- +18 NEW LRORID,LRORIDX,LRID,LRORIDF,LRD1,LRD2,LRAN,LRUID,LRI
- +19 NEW LRDTST,LRORU,LRAA,LRSD,LRSA,LRSN,LRORNST
- +20 ;
- +21 if '$GET(DFN)
- QUIT
- +22 SET LRDFN=$$LRDFN(DFN)
- SET LRDPF="2^DPT("
- +23 if 'LRDFN
- QUIT
- +24 ;
- +25 SET SEX=$PIECE($GET(@("^"_$PIECE(LRDPF,"^",2)_+DFN_",0)")),"^",2)
- +26 SET DOB=$PIECE($GET(@("^"_$PIECE(LRDPF,"^",2)_+DFN_",0)")),"^",3)
- SET AGE=$SELECT($DATA(DT)&(DOB?7N):DT-DOB\10000,1:"??")
- +27 DO DTRNG
- +28 SET SUB=$SELECT($GET(SUB)="ALL":"CHMIAP",$LENGTH($GET(SUB)):SUB,1:"CHMIAP")
- SET FLAG=$SELECT('$LENGTH($GET(FLAG)):"L",1:FLAG)
- +29 ;
- +30 IF SUB["CH"
- IF $DATA(ORID)
- SET LRORID=ORID
- SET LRORIDX=0
- Begin DoDot:1
- +31 IF $GET(LRORID)<1
- IF $DATA(ID)
- SET LRORID=+ID
- +32 IF $DATA(LRORID)
- SET LRORID=+LRORID
- +33 IF $DATA(ID)
- SET LRID=+ID
- End DoDot:1
- +34 ;
- +35 ;No-Match on Local testID
- IF $GET(TEST)
- IF FLAG="L"
- IF '$DATA(^LAB(60,TEST))
- QUIT
- +36 ;No-Match on National testID
- IF $GET(TEST)
- IF FLAG="N"
- SET TEST=$ORDER(^LAB(60,"AC",TEST,0))
- if 'TEST
- QUIT
- +37 ;Test with no subscript
- IF $GET(TEST)
- SET SUB=$PIECE(^LAB(60,TEST,0),"^",4)
- if '$LENGTH(SUB)
- QUIT
- +38 ;
- +39 KILL ^TMP("LRRR",$JOB),^TMP("LRAPI",$JOB)
- FOR LRI="LRPLS","LRPLS-ADDR"
- KILL ^TMP(LRI,$JOB)
- +40 ;
- +41 SET COUNT=$SELECT($GET(COUNT):COUNT,1:9999999)
- SET CT1=1
- +42 ;
- CV ;Check variables to see if called by OR; build array of tests (LR519)
- +1 IF SUB["CH"
- IF $DATA(LRORID)
- SET LRORIDX=0
- Begin DoDot:1
- +2 SET LRD1=9999999-$$FMADD^XLFDT(9999999-SDATE,14)
- SET LRD2=9999999-$$FMADD^XLFDT(9999999-EDATE,-14)
- +3 FOR
- SET LRD1=$ORDER(^LR(LRDFN,"CH",LRD1))
- if LRD1<1!(LRD1>LRD2)
- QUIT
- Begin DoDot:2
- +4 SET LRDTST=^LR(LRDFN,"CH",LRD1,0)
- SET LRORU=$GET(^LR(LRDFN,"CH",LRD1,"ORU"))
- if LRORU=""
- QUIT
- +5 SET ^TMP("LRORID",$JOB,+LRDTST)=$PIECE(LRDTST,U,6)_U_$PIECE(LRDTST,U)_U_$PIECE(LRORU,U)
- End DoDot:2
- +6 SET LRD1=0
- FOR
- SET LRD1=$ORDER(^TMP("LRORID",$JOB,LRD1))
- if LRD1<1
- QUIT
- SET LRORIDF=0
- Begin DoDot:2
- +7 SET LRAN=^TMP("LRORID",$JOB,LRD1)
- SET LRUID=$PIECE(LRAN,U,3)
- +8 SET LRAA=$ORDER(^LRO(68,"C",LRUID,0))
- +9 IF LRAA<1
- KILL ^TMP("LRORID",$JOB,LRD1)
- QUIT
- +10 SET LRAD=$ORDER(^LRO(68,"C",LRUID,LRAA,0))
- +11 IF LRAD<1
- KILL ^TMP("LRORID",$JOB,LRD1)
- QUIT
- +12 SET LRSA=$ORDER(^LRO(68,"C",LRUID,LRAA,LRAD,0))
- +13 IF LRSA<1
- KILL ^TMP("LRORID",$JOB,LRD1)
- QUIT
- +14 IF $GET(^LRO(68,LRAA,1,LRAD,1,LRSA,.2))=$PIECE(LRAN,U)
- Begin DoDot:3
- +15 SET LRSD=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRSA,0),U,4)
- SET LRSN=$PIECE(^(0),U,5)
- +16 ;S LRON=^LRO(68,LRAA,1,LRAD,1,LRSA,.1)
- +17 SET LRORNST=$PIECE($GET(^LRO(69,LRSD,1,LRSN,2,0)),U,3)
- if LRORNST<1
- QUIT
- +18 FOR LRI=1:1:LRORNST
- IF $PIECE($GET(^LRO(69,LRSD,1,LRSN,2,LRI,0)),U,7)=LRORID
- SET LRORIDF=1
- QUIT
- End DoDot:3
- +19 IF 'LRORIDF
- KILL ^TMP("LRORID",$JOB,LRD1)
- End DoDot:2
- +20 SET LRD1=0
- FOR
- SET LRD1=$ORDER(^TMP("LRORID",$JOB,LRD1))
- if LRD1<1
- QUIT
- Begin DoDot:2
- +21 SET ^TMP("LRORID",$JOB,"O",9999999-LRD1)=^TMP("LRORID",$JOB,LRD1)
- KILL ^TMP("LRORID",$JOB,LRD1)
- +22 SET ^TMP("LRORID",$JOB)=$GET(^TMP("LRORID",$JOB))+1
- End DoDot:2
- End DoDot:1
- +23 IF $GET(ORD)
- SET ORDT=0
- Begin DoDot:1
- +24 IF $GET(TEST)
- if '$DATA(^LAB(60,TEST,0))
- QUIT
- SET X=^(0)
- IF $PIECE(X,"^",4)="CH"
- Begin DoDot:2
- +25 IF $PIECE(X,"^",5)'=""
- SET TSTY($PIECE($PIECE(X,"^",5),";",2))=TEST
- +26 IF $PIECE(X,"^",5)=""
- DO EN^LR7OU1(TEST)
- End DoDot:2
- +27 ;OE/RR 2.5 unconverted orders
- IF ORD["^"
- SET ORDT=$PIECE(ORD,"^")
- SET ORSN=$PIECE(ORD,"^",2)
- IF ORDT
- IF ORSN
- DO SN
- QUIT
- +28 ;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
- +29 IF ORD[";"
- SET ORDT=$PIECE(ORD,";",2)
- SET ORSN=$PIECE(ORD,";",3)
- IF ORDT
- IF ORSN
- DO SN
- End DoDot:1
- QUIT
- AGAIN ;First: get a CH entry; process; then check for another test (LR519)
- +1 IF SUB["CH"
- IF $DATA(LRORID)
- SET LRORIDX=$ORDER(^TMP("LRORID",$JOB,"O",0))
- IF LRORIDX>0
- SET (SDATE,EDATE)=LRORIDX
- KILL ^TMP("LRORID",$JOB,"O",LRORIDX)
- +2 IF SUB["CH"
- DO CH^LR7OR2(SDATE,EDATE,$GET(TEST),COUNT,$GET(SPEC),$GET(UNVER))
- +3 IF SUB["MI"
- DO MI(SDATE,EDATE,COUNT,$GET(SPEC))
- +4 ;I SUB["BB" D BB(SDATE,EDATE,COUNT,$G(SPEC))
- +5 IF SUB["AP"
- IF '$GET(SPEC)
- DO AP(SDATE,EDATE,COUNT)
- +6 IF $DATA(^TMP("LRORID",$JOB))
- if $ORDER(^TMP("LRORID",$JOB,"O",0))>0
- GOTO AGAIN
- KILL ^TMP("LRORID",$JOB)
- +7 IF SUB["CH"
- KILL LRORID,LRORIDX,LRD1,LRD2,LRDTST,LRORIDF,LRAN,LRAA,LRSD,LRSA,LRAD,LRUID,LRI,LRORNST
- +8 QUIT
- +9 ;
- +10 ;
- 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)
- +5 QUIT
- +6 ;
- +7 ;
- 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)
- +6 QUIT
- +7 ;
- +8 ;
- 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)
- +6 QUIT
- +7 ;
- +8 ;
- 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
- +3 ;
- +4 ;
- 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 ;I $G(SDATE) S SDATE=$S($L(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
- +7 ;
- +8 ;
- SN ; Get the subs
- +1 ;
- +2 NEW I,II,III,LRPLSAVE
- +3 ;
- +4 ; Set flag to not print performing lab in called routines, wait for control returns to this routine.
- +5 SET LRPLSAVE=1
- +6 ;
- +7 DO 69^LR7OB69(ORDT,ORSN)
- if '$DATA(^TMP("LRX",$JOB,69))
- QUIT
- +8 ;
- +9 ; List performing laboratories
- +10 IF $GET(LRPLSAVE(0))
- Begin DoDot:1
- +11 NEW CTR,IVDT
- +12 SET CTR=LRPLSAVE(0)
- SET IVDT=0
- +13 FOR
- SET IVDT=$ORDER(LRPLSAVE("CH",IVDT))
- if IVDT<1
- QUIT
- Begin DoDot:2
- +14 DO PLS^LR7OB63
- End DoDot:2
- End DoDot:1
- +15 ;
- +16 SET II=0
- +17 FOR
- SET II=$ORDER(^TMP("LRX",$JOB,69,II))
- if II<1
- QUIT
- Begin DoDot:1
- +18 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)
- +19 SET III=0
- +20 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
- +21 IF $PIECE(^TMP("LRX",$JOB,69,II,63,III),U,6)=""
- QUIT
- +22 SET I=III
- +23 IF $DATA(^TMP("LRRR",$JOB,DFN,SS,9999999-DRAW,I))
- FOR
- SET I=I+.00000001
- IF '$DATA(^TMP("LRRR",$JOB,DFN,SS,9999999-DRAW,I))
- QUIT
- +24 SET ^TMP("LRRR",$JOB,DFN,SS,9999999-DRAW,I)=^TMP("LRX",$JOB,69,II,63,III)
- End DoDot:2
- +25 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
- +26 ;
- +27 FOR I="LRPLS","LRPLS-ADDR"
- KILL ^TMP(I,$JOB)
- +28 QUIT
- +29 ;
- 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