LRVR0 ;DALOI/STAFF - LEDI MI/AP Data Verification; Jul 20, 2020@13:53
;;5.2;LAB SERVICE;**350,427,474,480,537,561**;Sep 27, 1994;Build 2
;
; LEDI MI/AP Auto-instrument verification
; Called from LRVR
Q
;
;
EN ;
N EAMODE,LA7X,LRANYAA,LRAO,LRBG0,LRCFL,LRCMNT,LRDINST,LREND,LRFIFO,LRFLAG,LRINTYPE,LRLEDI,LRLLT,LRMIDEF,LRMIOTH
N LRNOP,LRONESPC,LRONETST,LRPG,LRPTP,LRSAME,LRSB,LRSS,LRTM60,LRTX,LRUID,LRVT,LRWRDVEW,LRX,X,Y
;
S LRSS=$P($G(^LRO(68,+$G(LRAA),0)),U,2) Q:LRSS=""
I LRSS'?1(1"MI",1"SP",1"CY",1"EM") Q
;
; If micro accession then set flag to indicate "result entry (RE)".
I LRSS="MI" S LRVT="RE"
;
S LRDINST=+$$KSP^XUPARAM("INST")
S LRLEDI=1,LRCFL="",EAMODE=1,LRWRDVEW=1
S LRX=$S(+$P($G(^LAB(69.9,1,0)),U,7):+$P(^(0),U,7),1:1)
S LRANYAA=+$P($G(^LRO(68.2,LRLL,10,LRPROF,0)),"^",3)
I $G(LRVBY)=1 D ACC
I $G(LRVBY)=2 S LRUID="" D UID
D CLEAN
Q
;
;
UID ;UID driven look-up
N DIR,DIRUT,DTOUT,DUOUT,X,Y
;
F D Q:$G(LREND)
. N LRMULTSQ
. I $G(IOF)'="" W @IOF
. K C5,DIC,DIR,DIRUT,DTOUT,DUOUT,LRAB,LRDEL,LRDL,LRFP,LRLDT,LRNG,LRNM,LRNOP,LRSET,LRTEST,LRVER,T,X,Y,Z
. S X=DUZ D DUZ^LRX S LRTEC=LRUSI
. D WLN^LRVRA I $G(LRNOP) D NEXT^LRVRA Q
. ;
. F Q:$G(LRNOP) D
. . N LRSEQCNT
. . D ISQN
. . I $G(LRSEQCNT)>1 S LRMULTSQ=1
. . I $G(LRNOP) Q
. . D ACCSET
. . I $G(LRNOP) Q
. . I "SPCYEM"[LRSS D ^LRVRAP4
. . I LRSS="MI" D PROC,ACCEPT
. . I $G(LRNOP) Q
. . I $G(LRSEQCNT)<2 S LRNOP=1 Q
. . I $G(IOF)'="" W @IOF
. . W !,PNM,?30,SSN," Age: ",AGE(2)
. . W !,"ORDER #: ",LRCEN," ",LRACC," ["_LRUID,"]"
. . W !
. . S (ISQN,LRISQN)=0
. ;
. D UNLOCK,NEXT^LRVRA
D CLEAN
Q
;
;
ERR1 ;Look-up Error
W !,"No data for "_LRUID_" in file"
Q
;
;
CLEAN ;
;
; Task of background jobs for workload and HL7 message processing
D ^LRCAPV2
;
K ^TMP("LRMI",$J)
K AGE,DFN,I,LRACC,LRCDT,DIRUT
K LRCEN,LRDFN,LRDPF,LRNOP,LRLOCK,LRPUID,LRISQN,LRODT,LROU3,LRPROF
K LRSN,LRSTATUS,LRTEC,LRUSI,LRVBY,PNM,SSN,X,Y
K ZTRTN,ZTIO,ZTDTH,ZTDESC
D ^LRVRKIL
Q
;
;
ACC ; Accession number look-up
D ADATE^LRWU
I LRAD<1 S LRNOP=1 Q
S LRAN=0
F D Q:$G(LRDBUG,$G(LREND))
. N LRMULTSQ
. I $G(IOF)'="" W @IOF
. K DIR,DIC,Y,LRNOP
. S LRAN=$O(^LAH(LRLL,1,"C",LRAN)) I 'LRAN D ACCMSG Q
. S Y=LRAN
. S LRISQN=$O(^LAH(LRLL,1,"C",LRAN,0)) I 'LRISQN D ACCMSG Q
. I '$O(^LAH(LRLL,1,LRISQN,0)) D ACCMSG Q
. S DIR(0)="FO^1:10",DIR("A")="Enter Accession number part",DIR("?")="^D LW^LRVR"
. S DIR("S")="I $O(^LAH(LRLL,1,""C"","_Y_",0)"
. I $G(LRAN) S DIR("B")=LRAN
. D ^DIR
. I $D(DIRUT) D STOP^LRVR S LRNOP=1 Q
. S LRAN=+Y I Y<1 D ACCMSG Q
. ;
. F Q:$G(LRNOP) D
. . N LRSEQCNT
. . D ISQN
. . I $G(LRSEQCNT)>1 S LRMULTSQ=1
. . I $G(LRNOP) Q
. . D ACCSET
. . S LRTM60=$$LRTM60^LRVR(LRCDT)
. . I $G(LRNOP) Q
. . I "SPCYEM"[LRSS D ^LRVRAP4
. . I LRSS="MI" D PROC,ACCEPT
. . I $G(LRNOP) Q
. . I $G(LRSEQCNT)<2 S LRNOP=1 Q
. . I $G(IOF)'="" W @IOF
. . S (ISQN,LRISQN)=0
. D UNLOCK
;
D CLEAN
Q
;
;
ACCMSG ;
W !," No accession available for this Load/Worklist",!
D STOP^LRVR S LRNOP=1
Q
;
;
PROC ;Process the entry from LAH(LRLL
Q:$$LEDIERR^LRVRMI0(LRLL,LRISQN,0,1)
;
; Set MI specific variables
S LRBG0=^LR(LRDFN,"MI",LRIDT,0),LRSSC=$P(LRBG0,U,5)_U_$P(LRBG0,U,11),LRFIFO=1
;
D EN^LRVRMI1
Q
;
;
ACCSET ;Set up accession variables
N DA,DIC,DIR,DIRUT,DTOUT,DUOUT,LRCNT,LRLAHD,LRI,LRNODE
K LRERR
S (LRLOCK,LRNOP)=0,LRLAHD=$G(^LAH(LRLL,1,LRISQN,0))
I LRLAHD="" D Q
. W !,"^LAH("_LRLL_",1,"_LRISQN_",0) Global is corrupt"
. D ZAP S LRNOP=1
;
S LRAA=$P(LRLAHD,U,3)
I $P(^LRO(68,LRAA,0),U,2)'=LRSS W !,"Not a "_LRSS_" Area - Abort",! S LRNOP=1 Q
S LRAN=$P(LRLAHD,U,5),LRAD=$P(LRLAHD,U,4)
;
I LRAA=""!(LRAD="")!(LRAN="") D Q
. W !,"^LAH("_LRLL_",1,"_LRISQN_",0) Global is corrupt"
. D ZAP S LRNOP=1
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
. W !,"Accession does not exist in ACCESSION file (#68)"
. D ZAP S LRNOP=1
;
S LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRCEN=$S($D(^(.1)):^(.1),1:0)
S LRACC=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),LRCDT=$P($G(^(3)),U)
S LRODT=$S($P(^(0),U,4):$P(^(0),U,4),1:$P(^(0),U,3)),LRSN=$P(^(0),U,5)
S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),LRIDT=$P(^(3),U,5)
S LRUID=$P(LRORU3,U),LRTS=""
;
S LRI=0
F S LRI=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI)) Q:LRI<1!$G(LRTS) S LRNODE=^(LRI,0) I $P(LRNODE,U,2)<50 S LRTS=+LRNODE
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
D PT^LRX
;
; Patient info displayed during UID lookup - display here when lookup by accession number
I $G(LRVBY)'=2 D
. W !,PNM,?30,SSN," Age: ",AGE(2)
. W !,"ORDER #: ",LRCEN," ",LRACC," ["_LRUID,"]"
;
I $$GET^XPAR("USR^DIV^PKG","LR MI VERIFY DISPLAY PROVIDER",1,"Q") D PROV^LRMIEDZ2
;
S DIR(0)="E"
D ^DIR
I $D(DIRUT) S LRNOP=1 Q
;
K LRERR
S X=$$GETLOCK^LRUTIL("^LR(LRDFN,LRSS,LRIDT)",10,1)
I 'X S LRERR=1 D NOLOCK Q
S X=$$GETLOCK^LRUTIL("^LRO(68,LRAA,1,LRAD,1,LRAN)",10,1)
I 'X S LRERR=2 D NOLOCK Q
;
S LRLOCK=1
I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",3) D
. N LRAA,LRAD,LRAN
. S LRSTATUS="C" D P15^LROE1
. I LRCDT<1 S LRNOP=1
;
I '$G(LRNOP),$P($G(^LRO(69,LRODT,1,LRSN,1)),U,4)'="C" D
. W !,"You cannot verify an accession which has not been collected.",$C(7)
. S LRNOP=1
;
; Determine if one or more tests on accession.
S (LRI,LRCNT,LRPTP)=0
F S LRI=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI)) Q:'LRI D
. I $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0),"^",2)<50 S LRCNT=LRCNT+1,LRPTP=LRI
;
; If more than one test on accession then select the test to work with (URGENCY<50 - non-workload tests).
I LRCNT>1 D
. K DA,DIC
. S DIC="^LRO(68,LRAA,1,LRAD,1,LRAN,4,",DIC(0)="AEMOQ",DIC("A")="Select TEST/PROCEDURE: ",DIC("S")="I $P(^(0),U,2)<50"
. S DA(2)=LRAA,DA(1)=LRAD,DA=LRAN,LRPTP=0
. D ^DIC
. I Y<1 S LRNOP=1 Q
. S LRPTP=+Y
;
I $G(LRNOP) Q
;
S LRMIDEF=$P(^LAB(69.9,1,1),U,10),LRMIOTH=$P(^(1),U,11)
;
; Set interface type
S LRINTYPE=$P(^LAH(LRLL,1,LRISQN,0),"^",12)
;
Q
;
;
NOLOCK ; Not able to lock message
W !!,$S($G(LRERR)=1:" **Accession** ",$G(LRERR)=2:"**Patient's ^LR( file**",1:"Record")_" is locked by another user. " H 5
S LRNOP=1
Q
;
;
UNLOCK ; Unlock accession and ^LR( global
Q:'$G(LRLOCK)
L -^LRO(68,$G(LRAA),1,$G(LRAD),1,$G(LRAN))
L -^LR($G(LRDFN),$G(LRSS),$G(LRIDT))
Q
;
;
ACCEPT ;Display results and accept data
N LRBATCH,LREDITTYPE,LRMODE,LRNPTP
I $G(LREND) S LREND=0 Q
;
S LRMODE="LDSI",LRBATCH=1,LREDITTYPE=1
D DQ^LRMIPSZ1
;
;
N DIR,DIROUT,DIRUT,DUOUT
I LRINTYPE=1 D
. S DIR(0)="SAO^0:Quit;1:Release;2:Comments/Release;3:Edit (full)"
. S DIR("A")="Select RELEASE action: "
. S DIR("B")=$$GET^XPAR("USR^PKG","LR MI UI RELEASE DEFAULT","`"_+LRLL,"E")
. I DIR("B")="" S DIR("B")="Edit (full)"
. S DIR("?")="Selections 1-3 will allow editing of status and approved date/time."
. S DIR("?",1)="Entering 0 will abort review/release."
. S DIR("?",2)="Entering 1 will allow release 'as is' with no editing."
. S DIR("?",3)="Entering 2 will allow you to enter/edit comments then release."
. S DIR("?",4)="Entering 3 will allow you to enter full edit, similar to 'Results entry' option."
;
E D
. S DIR(0)="Y"
. S DIR("A")="Do you want to APPROVE these results",DIR("B")="NO"
. S DIR("?")="Enter Y if you want to approve these results"
. S DIR("?",1)="Entering Y will store the results in the Lab System"
;
D ^DIR
S LREDITTYPE=+Y
I $D(DIRUT) S LRNOP=1 Q
I Y=0 D PURG Q
I Y<1 S LRNOP=1 Q
;
;LR*5.2*537:
;Set LRM63ORG array to track organisms already on file for this
;accession. Used by routine LRCAPVM downstream to determine "new"
;organisms for workload accumulation. The Isolate ID instead of
;the organism id is used for reference because an organism id
;might be filed more than once on an accession. It's standard
;laboratory practice to not change the isolate id for an organism.
;In the rare instance that this occurs, workload must be adjusted
;manually.
N LRM63ORG,LRM63SQ
I LRINTYPE=1 D
. F LRM63SQ=3,6,9,12,17 D
. . M LRM63ORG(LRM63SQ)=^LR(LRDFN,"MI",LRIDT,LRM63SQ,"C")
;
; If user just accepting or doing comments then ask for tests.
I LREDITTYPE<3 D
. D EC^LRMIEDZ4
. S LRTS=LRTS(LRI)
;
D EN^LRVRMI4
;
; If Lab UI interface then allow editing remarks (#13), status (#11.5) and approved date/time (#11)
I LRINTYPE=1,LREDITTYPE<3 D
. N DA,DIE,DR,LRANOK,LRLEDI,LRCAPO,LRUNDO
. S (LRCAPOK,LRANOK)=1,LRUNDO=0
. S DA=LRIDT,DA(1)=LRDFN,DIE="^LR(LRDFN,""MI"","
. S DR=$S(LREDITTYPE=2:"13;",1:"")_"11.5;11"
. D ^DIE
. D VT^LRMIUT1
;
; If Lab UI interface and user wants to do full editing
I LRINTYPE=1,LREDITTYPE=3 D
. N LRANOK,LRLEDI,LRCAPO,LRUNDO
. S (LRCAPOK,LRANOK)=1,LRUNDO=0
. D AUDRTN^LRMIEDZ2
;
; Store performing lab info
I $D(^TMP("LRPL",$J)) D ROLLUPPL^LRRPLUA(LRDFN,LRSS,LRIDT)
;
; Ask for performing laboratory assignment
W !! D EDIT^LRRPLU(LRDFN,"MI",LRIDT)
;
; Store reporting lab
D SETRL^LRVERA(LRDFN,LRSS,LRIDT,DUZ(2))
;
; Update clinical reminders
D UPDATE^LRPXRM(LRDFN,"MI",LRIDT)
;
; Ask to send CPRS alert
D ASKXQA^LRMIEDZ2
;
; If Lab UI interface then prompt user for accession test complete date/time in EC3^LRMIEDZ2 call.
I LRINTYPE=1 S LRFIFO=0
;
; Update accession and order
D EC3^LRMIEDZ2
;
;LR*5.2*537: If UI (not LEDI) store workload
;Downstream LRCAPVM will check other workload related variables
;which might not be defined at this point in LRVR0
I LRINTYPE=1 D
. D LOOK^LRCAPV1
. ;killing LRM63ORG in case somehow a workflow will cause the array
. ;to be carried over between accessions
. K LRM63ORG
;
; Queue results if LEDI and cleanup
D LEDI,ZAP
K ^TMP("LRMI",$J)
;
Q
;
;
PURG ; Ask if the entry should be purged from ^LAH(
W !
N DIR,DIROUT,DIRUT,DUOUT
S DIR(0)="Y",DIR("A")="Do you want to PURGE these results",DIR("B")="NO"
S DIR("?",1)="Enter NO if you want to process these results at a later time"
S DIR("?")="Enter YES to remove these results from the list"
D ^DIR
I $D(DIRUT) S LRNOP=1 Q
I Y=1 D ZAP
Q
;
;
ZAP ; Remove entry from ^LAH( global
N REC
S REC=$S($G(ISQN):ISQN,1:$G(LRISQN))
I LRLL,REC D ZAPALL^LRVR3(LRLL,REC)
Q
;
;
SETACC ;
N LRFILE,LRIENS,LRFDA,LRERR
S LRFILE=68.04,LRERR=""
S LRIENS=LRTS_","_LRAN_","_LRAD_","_LRAA_","
S LRFDA(1,LRFILE,LRIENS,3)=DUZ
S LRFDA(1,LRFILE,LRIENS,4)=$$NOW^XLFDT
S LRFDA(1,LRFILE,LRIENS,8)=$G(LRCDEF)
D FILE^DIE("KS","LRFDA(1)","LRERR")
Q
;
;
LEDI ; If LEDI put results in queue to return to collecting lab
; Called from above, LRMIEDZ2, LRMISTF1 and LRVRAP4.
N IEN,LRCDEFX,LRERR,LRIDT,LRORDT,LRORU3,LRSS,LRTSDEF
Q:'$D(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),0))
;
S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
Q:'$P(LRORU3,U,3)
;
S LRODT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
S LRSS=$P(^LRO(68,LRAA,0),U,2)
S LRIDT=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)
I '$$OK2SEND^LA7SRR D LEDINO Q
;
I '$G(LRCDEF) N LRCDEF I "SPEMCY"[LRSS S LRCDEF=3241,LRCDEFX=1
I '$G(LRTS) N LRTS D
. S IEN=0
. F S IEN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,IEN)) Q:IEN<1 D Q:$G(LRTS)
. . I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,IEN,0)),U,2)<50 S LRTS=IEN,LRTSDEF=1
;LR*5.2*561: Commenting out line below. It caused an issue when preliminary
; results were verified because the accession will not appear on
; the Incomplete Test Status Report. Also, if the results have a
; final status, the file 68 fields are already populated with a
; complete date/time, etc by upstream routines.
;I $G(LRTS) D SETACC
;
; Comment out the following line after testing is complete
W !!,$$CJ^XLFSTR("Sending report to LEDI collecting site",IOM)
D MIAP^LA7VMSG(LRAA,LRAD,LRAN,+$G(LRTS),LRDFN,LRSS,LRIDT,LRODT)
Q
;
;
LEDINO ; LEDI HL7 message sending error message
W !!,$$CJ^XLFSTR("Unable to sent report to LEDI collecting site - no date report approved",IOM)
Q
;
;
ISQN ; Find the entry associated with this accession area and accession number
N LRI,LRSQ
S (LRI,LRSEQCNT)=0
F S LRI=$O(^LAH(LRLL,1,"C",LRAN,LRI)) Q:LRI<1 D
. N LRX
. S LRX=$G(^LAH(LRLL,1,LRI,0))
. ; Quit if different accession area.
. I $P(LRX,"^",3),$P(LRX,"^",3)'=LRAA Q
. ; Quit if different accession date and not a rollover accession (same original accession date).
. I $P(LRX,"^",4),$P(LRX,"^",4)'=LRAD,$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",3)'=$P($G(^LRO(68,LRAA,1,$P(LRX,"^",4),1,LRAN,0)),"^",3) Q
. I LRSEQCNT W !
. S LRSEQCNT=LRSEQCNT+1,LRSQ=LRI,LRSQ(LRI)=""
. W !,?2,"Seq #: ",LRI,?13," Accession: ",$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^")
. I $P(LRX,"^",10) W ?40," Results received: ",$$FMTE^XLFDT($P(LRX,"^",10),"1M")
. W !,?20,"UID: ",$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),"UNKNOWN"),"^")
. I $P(LRX,"^",11) W ?44," Last updated: ",$$FMTE^XLFDT($P(LRX,"^",11),"1M")
. I $G(^LAH(LRLL,1,LRI,.1,"OBR","ORDNLT"))'="" D
. . N LR64,LRNLT,LRNLTN,LRPIECE
. . W !,?13," Order NLT: "
. . F LRPIECE=1:1 S LRNLT=$P($G(^LAH(LRLL,1,LRI,.1,"OBR","ORDNLT")),"^",LRPIECE) Q:LRNLT="" D
. . . S LR64=+$O(^LAM("E",LRNLT,0))
. . . S LRNLTN=$$GET1^DIQ(64,LR64_",",.01)
. . . W ?25,$S(LRNLTN'="":LRNLTN,1:LRNLT),!
;
I LRSEQCNT=0 W !,"No data for that accession" S LRNOP=1 Q
I LRSEQCNT=1,'$G(LRMULTSQ) S (ISQN,LRISQN)=LRSQ Q
;
; If multiple entries (sequence - overlay data=no) then ask user which one to use.
N DIR,DIRUT,DIROUT,DTOUT,DUOUT
S DIR(0)=""
S I=0 F S I=$O(LRSQ(I)) Q:'I S DIR(0)=DIR(0)_$S(I=1:"",1:";")_I_":Seq #"_I
S DIR(0)="SO^"_DIR(0),DIR("A")="Choose sequence number"
I LRSEQCNT=1,$G(LRMULTSQ) S DIR("B")=LRSQ
D ^DIR
I $D(DIRUT)!(Y<1) S LRNOP=1 Q
S (ISQN,LRISQN)=+Y Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVR0 13923 printed Dec 13, 2024@02:22:37 Page 2
LRVR0 ;DALOI/STAFF - LEDI MI/AP Data Verification; Jul 20, 2020@13:53
+1 ;;5.2;LAB SERVICE;**350,427,474,480,537,561**;Sep 27, 1994;Build 2
+2 ;
+3 ; LEDI MI/AP Auto-instrument verification
+4 ; Called from LRVR
+5 QUIT
+6 ;
+7 ;
EN ;
+1 NEW EAMODE,LA7X,LRANYAA,LRAO,LRBG0,LRCFL,LRCMNT,LRDINST,LREND,LRFIFO,LRFLAG,LRINTYPE,LRLEDI,LRLLT,LRMIDEF,LRMIOTH
+2 NEW LRNOP,LRONESPC,LRONETST,LRPG,LRPTP,LRSAME,LRSB,LRSS,LRTM60,LRTX,LRUID,LRVT,LRWRDVEW,LRX,X,Y
+3 ;
+4 SET LRSS=$PIECE($GET(^LRO(68,+$GET(LRAA),0)),U,2)
if LRSS=""
QUIT
+5 IF LRSS'?1(1"MI",1"SP",1"CY",1"EM")
QUIT
+6 ;
+7 ; If micro accession then set flag to indicate "result entry (RE)".
+8 IF LRSS="MI"
SET LRVT="RE"
+9 ;
+10 SET LRDINST=+$$KSP^XUPARAM("INST")
+11 SET LRLEDI=1
SET LRCFL=""
SET EAMODE=1
SET LRWRDVEW=1
+12 SET LRX=$SELECT(+$PIECE($GET(^LAB(69.9,1,0)),U,7):+$PIECE(^(0),U,7),1:1)
+13 SET LRANYAA=+$PIECE($GET(^LRO(68.2,LRLL,10,LRPROF,0)),"^",3)
+14 IF $GET(LRVBY)=1
DO ACC
+15 IF $GET(LRVBY)=2
SET LRUID=""
DO UID
+16 DO CLEAN
+17 QUIT
+18 ;
+19 ;
UID ;UID driven look-up
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 ;
+3 FOR
Begin DoDot:1
+4 NEW LRMULTSQ
+5 IF $GET(IOF)'=""
WRITE @IOF
+6 KILL C5,DIC,DIR,DIRUT,DTOUT,DUOUT,LRAB,LRDEL,LRDL,LRFP,LRLDT,LRNG,LRNM,LRNOP,LRSET,LRTEST,LRVER,T,X,Y,Z
+7 SET X=DUZ
DO DUZ^LRX
SET LRTEC=LRUSI
+8 DO WLN^LRVRA
IF $GET(LRNOP)
DO NEXT^LRVRA
QUIT
+9 ;
+10 FOR
if $GET(LRNOP)
QUIT
Begin DoDot:2
+11 NEW LRSEQCNT
+12 DO ISQN
+13 IF $GET(LRSEQCNT)>1
SET LRMULTSQ=1
+14 IF $GET(LRNOP)
QUIT
+15 DO ACCSET
+16 IF $GET(LRNOP)
QUIT
+17 IF "SPCYEM"[LRSS
DO ^LRVRAP4
+18 IF LRSS="MI"
DO PROC
DO ACCEPT
+19 IF $GET(LRNOP)
QUIT
+20 IF $GET(LRSEQCNT)<2
SET LRNOP=1
QUIT
+21 IF $GET(IOF)'=""
WRITE @IOF
+22 WRITE !,PNM,?30,SSN," Age: ",AGE(2)
+23 WRITE !,"ORDER #: ",LRCEN," ",LRACC," ["_LRUID,"]"
+24 WRITE !
+25 SET (ISQN,LRISQN)=0
End DoDot:2
+26 ;
+27 DO UNLOCK
DO NEXT^LRVRA
End DoDot:1
if $GET(LREND)
QUIT
+28 DO CLEAN
+29 QUIT
+30 ;
+31 ;
ERR1 ;Look-up Error
+1 WRITE !,"No data for "_LRUID_" in file"
+2 QUIT
+3 ;
+4 ;
CLEAN ;
+1 ;
+2 ; Task of background jobs for workload and HL7 message processing
+3 DO ^LRCAPV2
+4 ;
+5 KILL ^TMP("LRMI",$JOB)
+6 KILL AGE,DFN,I,LRACC,LRCDT,DIRUT
+7 KILL LRCEN,LRDFN,LRDPF,LRNOP,LRLOCK,LRPUID,LRISQN,LRODT,LROU3,LRPROF
+8 KILL LRSN,LRSTATUS,LRTEC,LRUSI,LRVBY,PNM,SSN,X,Y
+9 KILL ZTRTN,ZTIO,ZTDTH,ZTDESC
+10 DO ^LRVRKIL
+11 QUIT
+12 ;
+13 ;
ACC ; Accession number look-up
+1 DO ADATE^LRWU
+2 IF LRAD<1
SET LRNOP=1
QUIT
+3 SET LRAN=0
+4 FOR
Begin DoDot:1
+5 NEW LRMULTSQ
+6 IF $GET(IOF)'=""
WRITE @IOF
+7 KILL DIR,DIC,Y,LRNOP
+8 SET LRAN=$ORDER(^LAH(LRLL,1,"C",LRAN))
IF 'LRAN
DO ACCMSG
QUIT
+9 SET Y=LRAN
+10 SET LRISQN=$ORDER(^LAH(LRLL,1,"C",LRAN,0))
IF 'LRISQN
DO ACCMSG
QUIT
+11 IF '$ORDER(^LAH(LRLL,1,LRISQN,0))
DO ACCMSG
QUIT
+12 SET DIR(0)="FO^1:10"
SET DIR("A")="Enter Accession number part"
SET DIR("?")="^D LW^LRVR"
+13 SET DIR("S")="I $O(^LAH(LRLL,1,""C"","_Y_",0)"
+14 IF $GET(LRAN)
SET DIR("B")=LRAN
+15 DO ^DIR
+16 IF $DATA(DIRUT)
DO STOP^LRVR
SET LRNOP=1
QUIT
+17 SET LRAN=+Y
IF Y<1
DO ACCMSG
QUIT
+18 ;
+19 FOR
if $GET(LRNOP)
QUIT
Begin DoDot:2
+20 NEW LRSEQCNT
+21 DO ISQN
+22 IF $GET(LRSEQCNT)>1
SET LRMULTSQ=1
+23 IF $GET(LRNOP)
QUIT
+24 DO ACCSET
+25 SET LRTM60=$$LRTM60^LRVR(LRCDT)
+26 IF $GET(LRNOP)
QUIT
+27 IF "SPCYEM"[LRSS
DO ^LRVRAP4
+28 IF LRSS="MI"
DO PROC
DO ACCEPT
+29 IF $GET(LRNOP)
QUIT
+30 IF $GET(LRSEQCNT)<2
SET LRNOP=1
QUIT
+31 IF $GET(IOF)'=""
WRITE @IOF
+32 SET (ISQN,LRISQN)=0
End DoDot:2
+33 DO UNLOCK
End DoDot:1
if $GET(LRDBUG,$GET(LREND))
QUIT
+34 ;
+35 DO CLEAN
+36 QUIT
+37 ;
+38 ;
ACCMSG ;
+1 WRITE !," No accession available for this Load/Worklist",!
+2 DO STOP^LRVR
SET LRNOP=1
+3 QUIT
+4 ;
+5 ;
PROC ;Process the entry from LAH(LRLL
+1 if $$LEDIERR^LRVRMI0(LRLL,LRISQN,0,1)
QUIT
+2 ;
+3 ; Set MI specific variables
+4 SET LRBG0=^LR(LRDFN,"MI",LRIDT,0)
SET LRSSC=$PIECE(LRBG0,U,5)_U_$PIECE(LRBG0,U,11)
SET LRFIFO=1
+5 ;
+6 DO EN^LRVRMI1
+7 QUIT
+8 ;
+9 ;
ACCSET ;Set up accession variables
+1 NEW DA,DIC,DIR,DIRUT,DTOUT,DUOUT,LRCNT,LRLAHD,LRI,LRNODE
+2 KILL LRERR
+3 SET (LRLOCK,LRNOP)=0
SET LRLAHD=$GET(^LAH(LRLL,1,LRISQN,0))
+4 IF LRLAHD=""
Begin DoDot:1
+5 WRITE !,"^LAH("_LRLL_",1,"_LRISQN_",0) Global is corrupt"
+6 DO ZAP
SET LRNOP=1
End DoDot:1
QUIT
+7 ;
+8 SET LRAA=$PIECE(LRLAHD,U,3)
+9 IF $PIECE(^LRO(68,LRAA,0),U,2)'=LRSS
WRITE !,"Not a "_LRSS_" Area - Abort",!
SET LRNOP=1
QUIT
+10 SET LRAN=$PIECE(LRLAHD,U,5)
SET LRAD=$PIECE(LRLAHD,U,4)
+11 ;
+12 IF LRAA=""!(LRAD="")!(LRAN="")
Begin DoDot:1
+13 WRITE !,"^LAH("_LRLL_",1,"_LRISQN_",0) Global is corrupt"
+14 DO ZAP
SET LRNOP=1
End DoDot:1
QUIT
+15 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
Begin DoDot:1
+16 WRITE !,"Accession does not exist in ACCESSION file (#68)"
+17 DO ZAP
SET LRNOP=1
End DoDot:1
QUIT
+18 ;
+19 SET LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRCEN=$SELECT($DATA(^(.1)):^(.1),1:0)
+20 SET LRACC=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2))
SET LRCDT=$PIECE($GET(^(3)),U)
+21 SET LRODT=$SELECT($PIECE(^(0),U,4):$PIECE(^(0),U,4),1:$PIECE(^(0),U,3))
SET LRSN=$PIECE(^(0),U,5)
+22 SET LRORU3=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
SET LRIDT=$PIECE(^(3),U,5)
+23 SET LRUID=$PIECE(LRORU3,U)
SET LRTS=""
+24 ;
+25 SET LRI=0
+26 FOR
SET LRI=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI))
if LRI<1!$GET(LRTS)
QUIT
SET LRNODE=^(LRI,0)
IF $PIECE(LRNODE,U,2)<50
SET LRTS=+LRNODE
+27 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+28 DO PT^LRX
+29 ;
+30 ; Patient info displayed during UID lookup - display here when lookup by accession number
+31 IF $GET(LRVBY)'=2
Begin DoDot:1
+32 WRITE !,PNM,?30,SSN," Age: ",AGE(2)
+33 WRITE !,"ORDER #: ",LRCEN," ",LRACC," ["_LRUID,"]"
End DoDot:1
+34 ;
+35 IF $$GET^XPAR("USR^DIV^PKG","LR MI VERIFY DISPLAY PROVIDER",1,"Q")
DO PROV^LRMIEDZ2
+36 ;
+37 SET DIR(0)="E"
+38 DO ^DIR
+39 IF $DATA(DIRUT)
SET LRNOP=1
QUIT
+40 ;
+41 KILL LRERR
+42 SET X=$$GETLOCK^LRUTIL("^LR(LRDFN,LRSS,LRIDT)",10,1)
+43 IF 'X
SET LRERR=1
DO NOLOCK
QUIT
+44 SET X=$$GETLOCK^LRUTIL("^LRO(68,LRAA,1,LRAD,1,LRAN)",10,1)
+45 IF 'X
SET LRERR=2
DO NOLOCK
QUIT
+46 ;
+47 SET LRLOCK=1
+48 IF '$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",3)
Begin DoDot:1
+49 NEW LRAA,LRAD,LRAN
+50 SET LRSTATUS="C"
DO P15^LROE1
+51 IF LRCDT<1
SET LRNOP=1
End DoDot:1
+52 ;
+53 IF '$GET(LRNOP)
IF $PIECE($GET(^LRO(69,LRODT,1,LRSN,1)),U,4)'="C"
Begin DoDot:1
+54 WRITE !,"You cannot verify an accession which has not been collected.",$CHAR(7)
+55 SET LRNOP=1
End DoDot:1
+56 ;
+57 ; Determine if one or more tests on accession.
+58 SET (LRI,LRCNT,LRPTP)=0
+59 FOR
SET LRI=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI))
if 'LRI
QUIT
Begin DoDot:1
+60 IF $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0),"^",2)<50
SET LRCNT=LRCNT+1
SET LRPTP=LRI
End DoDot:1
+61 ;
+62 ; If more than one test on accession then select the test to work with (URGENCY<50 - non-workload tests).
+63 IF LRCNT>1
Begin DoDot:1
+64 KILL DA,DIC
+65 SET DIC="^LRO(68,LRAA,1,LRAD,1,LRAN,4,"
SET DIC(0)="AEMOQ"
SET DIC("A")="Select TEST/PROCEDURE: "
SET DIC("S")="I $P(^(0),U,2)<50"
+66 SET DA(2)=LRAA
SET DA(1)=LRAD
SET DA=LRAN
SET LRPTP=0
+67 DO ^DIC
+68 IF Y<1
SET LRNOP=1
QUIT
+69 SET LRPTP=+Y
End DoDot:1
+70 ;
+71 IF $GET(LRNOP)
QUIT
+72 ;
+73 SET LRMIDEF=$PIECE(^LAB(69.9,1,1),U,10)
SET LRMIOTH=$PIECE(^(1),U,11)
+74 ;
+75 ; Set interface type
+76 SET LRINTYPE=$PIECE(^LAH(LRLL,1,LRISQN,0),"^",12)
+77 ;
+78 QUIT
+79 ;
+80 ;
NOLOCK ; Not able to lock message
+1 WRITE !!,$SELECT($GET(LRERR)=1:" **Accession** ",$GET(LRERR)=2:"**Patient's ^LR( file**",1:"Record")_" is locked by another user. "
HANG 5
+2 SET LRNOP=1
+3 QUIT
+4 ;
+5 ;
UNLOCK ; Unlock accession and ^LR( global
+1 if '$GET(LRLOCK)
QUIT
+2 LOCK -^LRO(68,$GET(LRAA),1,$GET(LRAD),1,$GET(LRAN))
+3 LOCK -^LR($GET(LRDFN),$GET(LRSS),$GET(LRIDT))
+4 QUIT
+5 ;
+6 ;
ACCEPT ;Display results and accept data
+1 NEW LRBATCH,LREDITTYPE,LRMODE,LRNPTP
+2 IF $GET(LREND)
SET LREND=0
QUIT
+3 ;
+4 SET LRMODE="LDSI"
SET LRBATCH=1
SET LREDITTYPE=1
+5 DO DQ^LRMIPSZ1
+6 ;
+7 ;
+8 NEW DIR,DIROUT,DIRUT,DUOUT
+9 IF LRINTYPE=1
Begin DoDot:1
+10 SET DIR(0)="SAO^0:Quit;1:Release;2:Comments/Release;3:Edit (full)"
+11 SET DIR("A")="Select RELEASE action: "
+12 SET DIR("B")=$$GET^XPAR("USR^PKG","LR MI UI RELEASE DEFAULT","`"_+LRLL,"E")
+13 IF DIR("B")=""
SET DIR("B")="Edit (full)"
+14 SET DIR("?")="Selections 1-3 will allow editing of status and approved date/time."
+15 SET DIR("?",1)="Entering 0 will abort review/release."
+16 SET DIR("?",2)="Entering 1 will allow release 'as is' with no editing."
+17 SET DIR("?",3)="Entering 2 will allow you to enter/edit comments then release."
+18 SET DIR("?",4)="Entering 3 will allow you to enter full edit, similar to 'Results entry' option."
End DoDot:1
+19 ;
+20 IF '$TEST
Begin DoDot:1
+21 SET DIR(0)="Y"
+22 SET DIR("A")="Do you want to APPROVE these results"
SET DIR("B")="NO"
+23 SET DIR("?")="Enter Y if you want to approve these results"
+24 SET DIR("?",1)="Entering Y will store the results in the Lab System"
End DoDot:1
+25 ;
+26 DO ^DIR
+27 SET LREDITTYPE=+Y
+28 IF $DATA(DIRUT)
SET LRNOP=1
QUIT
+29 IF Y=0
DO PURG
QUIT
+30 IF Y<1
SET LRNOP=1
QUIT
+31 ;
+32 ;LR*5.2*537:
+33 ;Set LRM63ORG array to track organisms already on file for this
+34 ;accession. Used by routine LRCAPVM downstream to determine "new"
+35 ;organisms for workload accumulation. The Isolate ID instead of
+36 ;the organism id is used for reference because an organism id
+37 ;might be filed more than once on an accession. It's standard
+38 ;laboratory practice to not change the isolate id for an organism.
+39 ;In the rare instance that this occurs, workload must be adjusted
+40 ;manually.
+41 NEW LRM63ORG,LRM63SQ
+42 IF LRINTYPE=1
Begin DoDot:1
+43 FOR LRM63SQ=3,6,9,12,17
Begin DoDot:2
+44 MERGE LRM63ORG(LRM63SQ)=^LR(LRDFN,"MI",LRIDT,LRM63SQ,"C")
End DoDot:2
End DoDot:1
+45 ;
+46 ; If user just accepting or doing comments then ask for tests.
+47 IF LREDITTYPE<3
Begin DoDot:1
+48 DO EC^LRMIEDZ4
+49 SET LRTS=LRTS(LRI)
End DoDot:1
+50 ;
+51 DO EN^LRVRMI4
+52 ;
+53 ; If Lab UI interface then allow editing remarks (#13), status (#11.5) and approved date/time (#11)
+54 IF LRINTYPE=1
IF LREDITTYPE<3
Begin DoDot:1
+55 NEW DA,DIE,DR,LRANOK,LRLEDI,LRCAPO,LRUNDO
+56 SET (LRCAPOK,LRANOK)=1
SET LRUNDO=0
+57 SET DA=LRIDT
SET DA(1)=LRDFN
SET DIE="^LR(LRDFN,""MI"","
+58 SET DR=$SELECT(LREDITTYPE=2:"13;",1:"")_"11.5;11"
+59 DO ^DIE
+60 DO VT^LRMIUT1
End DoDot:1
+61 ;
+62 ; If Lab UI interface and user wants to do full editing
+63 IF LRINTYPE=1
IF LREDITTYPE=3
Begin DoDot:1
+64 NEW LRANOK,LRLEDI,LRCAPO,LRUNDO
+65 SET (LRCAPOK,LRANOK)=1
SET LRUNDO=0
+66 DO AUDRTN^LRMIEDZ2
End DoDot:1
+67 ;
+68 ; Store performing lab info
+69 IF $DATA(^TMP("LRPL",$JOB))
DO ROLLUPPL^LRRPLUA(LRDFN,LRSS,LRIDT)
+70 ;
+71 ; Ask for performing laboratory assignment
+72 WRITE !!
DO EDIT^LRRPLU(LRDFN,"MI",LRIDT)
+73 ;
+74 ; Store reporting lab
+75 DO SETRL^LRVERA(LRDFN,LRSS,LRIDT,DUZ(2))
+76 ;
+77 ; Update clinical reminders
+78 DO UPDATE^LRPXRM(LRDFN,"MI",LRIDT)
+79 ;
+80 ; Ask to send CPRS alert
+81 DO ASKXQA^LRMIEDZ2
+82 ;
+83 ; If Lab UI interface then prompt user for accession test complete date/time in EC3^LRMIEDZ2 call.
+84 IF LRINTYPE=1
SET LRFIFO=0
+85 ;
+86 ; Update accession and order
+87 DO EC3^LRMIEDZ2
+88 ;
+89 ;LR*5.2*537: If UI (not LEDI) store workload
+90 ;Downstream LRCAPVM will check other workload related variables
+91 ;which might not be defined at this point in LRVR0
+92 IF LRINTYPE=1
Begin DoDot:1
+93 DO LOOK^LRCAPV1
+94 ;killing LRM63ORG in case somehow a workflow will cause the array
+95 ;to be carried over between accessions
+96 KILL LRM63ORG
End DoDot:1
+97 ;
+98 ; Queue results if LEDI and cleanup
+99 DO LEDI
DO ZAP
+100 KILL ^TMP("LRMI",$JOB)
+101 ;
+102 QUIT
+103 ;
+104 ;
PURG ; Ask if the entry should be purged from ^LAH(
+1 WRITE !
+2 NEW DIR,DIROUT,DIRUT,DUOUT
+3 SET DIR(0)="Y"
SET DIR("A")="Do you want to PURGE these results"
SET DIR("B")="NO"
+4 SET DIR("?",1)="Enter NO if you want to process these results at a later time"
+5 SET DIR("?")="Enter YES to remove these results from the list"
+6 DO ^DIR
+7 IF $DATA(DIRUT)
SET LRNOP=1
QUIT
+8 IF Y=1
DO ZAP
+9 QUIT
+10 ;
+11 ;
ZAP ; Remove entry from ^LAH( global
+1 NEW REC
+2 SET REC=$SELECT($GET(ISQN):ISQN,1:$GET(LRISQN))
+3 IF LRLL
IF REC
DO ZAPALL^LRVR3(LRLL,REC)
+4 QUIT
+5 ;
+6 ;
SETACC ;
+1 NEW LRFILE,LRIENS,LRFDA,LRERR
+2 SET LRFILE=68.04
SET LRERR=""
+3 SET LRIENS=LRTS_","_LRAN_","_LRAD_","_LRAA_","
+4 SET LRFDA(1,LRFILE,LRIENS,3)=DUZ
+5 SET LRFDA(1,LRFILE,LRIENS,4)=$$NOW^XLFDT
+6 SET LRFDA(1,LRFILE,LRIENS,8)=$GET(LRCDEF)
+7 DO FILE^DIE("KS","LRFDA(1)","LRERR")
+8 QUIT
+9 ;
+10 ;
LEDI ; If LEDI put results in queue to return to collecting lab
+1 ; Called from above, LRMIEDZ2, LRMISTF1 and LRVRAP4.
+2 NEW IEN,LRCDEFX,LRERR,LRIDT,LRORDT,LRORU3,LRSS,LRTSDEF
+3 if '$DATA(^LRO(68,+$GET(LRAA),1,+$GET(LRAD),1,+$GET(LRAN),0))
QUIT
+4 ;
+5 SET LRORU3=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+6 if '$PIECE(LRORU3,U,3)
QUIT
+7 ;
+8 SET LRODT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,4)
+9 SET LRSS=$PIECE(^LRO(68,LRAA,0),U,2)
+10 SET LRIDT=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,5)
+11 IF '$$OK2SEND^LA7SRR
DO LEDINO
QUIT
+12 ;
+13 IF '$GET(LRCDEF)
NEW LRCDEF
IF "SPEMCY"[LRSS
SET LRCDEF=3241
SET LRCDEFX=1
+14 IF '$GET(LRTS)
NEW LRTS
Begin DoDot:1
+15 SET IEN=0
+16 FOR
SET IEN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,IEN))
if IEN<1
QUIT
Begin DoDot:2
+17 IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,IEN,0)),U,2)<50
SET LRTS=IEN
SET LRTSDEF=1
End DoDot:2
if $GET(LRTS)
QUIT
End DoDot:1
+18 ;LR*5.2*561: Commenting out line below. It caused an issue when preliminary
+19 ; results were verified because the accession will not appear on
+20 ; the Incomplete Test Status Report. Also, if the results have a
+21 ; final status, the file 68 fields are already populated with a
+22 ; complete date/time, etc by upstream routines.
+23 ;I $G(LRTS) D SETACC
+24 ;
+25 ; Comment out the following line after testing is complete
+26 WRITE !!,$$CJ^XLFSTR("Sending report to LEDI collecting site",IOM)
+27 DO MIAP^LA7VMSG(LRAA,LRAD,LRAN,+$GET(LRTS),LRDFN,LRSS,LRIDT,LRODT)
+28 QUIT
+29 ;
+30 ;
LEDINO ; LEDI HL7 message sending error message
+1 WRITE !!,$$CJ^XLFSTR("Unable to sent report to LEDI collecting site - no date report approved",IOM)
+2 QUIT
+3 ;
+4 ;
ISQN ; Find the entry associated with this accession area and accession number
+1 NEW LRI,LRSQ
+2 SET (LRI,LRSEQCNT)=0
+3 FOR
SET LRI=$ORDER(^LAH(LRLL,1,"C",LRAN,LRI))
if LRI<1
QUIT
Begin DoDot:1
+4 NEW LRX
+5 SET LRX=$GET(^LAH(LRLL,1,LRI,0))
+6 ; Quit if different accession area.
+7 IF $PIECE(LRX,"^",3)
IF $PIECE(LRX,"^",3)'=LRAA
QUIT
+8 ; Quit if different accession date and not a rollover accession (same original accession date).
+9 IF $PIECE(LRX,"^",4)
IF $PIECE(LRX,"^",4)'=LRAD
IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),"^",3)'=$PIECE($GET(^LRO(68,LRAA,1,$PIECE(LRX,"^",4),1,LRAN,0)),"^",3)
QUIT
+10 IF LRSEQCNT
WRITE !
+11 SET LRSEQCNT=LRSEQCNT+1
SET LRSQ=LRI
SET LRSQ(LRI)=""
+12 WRITE !,?2,"Seq #: ",LRI,?13," Accession: ",$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^")
+13 IF $PIECE(LRX,"^",10)
WRITE ?40," Results received: ",$$FMTE^XLFDT($PIECE(LRX,"^",10),"1M")
+14 WRITE !,?20,"UID: ",$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),"UNKNOWN"),"^")
+15 IF $PIECE(LRX,"^",11)
WRITE ?44," Last updated: ",$$FMTE^XLFDT($PIECE(LRX,"^",11),"1M")
+16 IF $GET(^LAH(LRLL,1,LRI,.1,"OBR","ORDNLT"))'=""
Begin DoDot:2
+17 NEW LR64,LRNLT,LRNLTN,LRPIECE
+18 WRITE !,?13," Order NLT: "
+19 FOR LRPIECE=1:1
SET LRNLT=$PIECE($GET(^LAH(LRLL,1,LRI,.1,"OBR","ORDNLT")),"^",LRPIECE)
if LRNLT=""
QUIT
Begin DoDot:3
+20 SET LR64=+$ORDER(^LAM("E",LRNLT,0))
+21 SET LRNLTN=$$GET1^DIQ(64,LR64_",",.01)
+22 WRITE ?25,$SELECT(LRNLTN'="":LRNLTN,1:LRNLT),!
End DoDot:3
End DoDot:2
End DoDot:1
+23 ;
+24 IF LRSEQCNT=0
WRITE !,"No data for that accession"
SET LRNOP=1
QUIT
+25 IF LRSEQCNT=1
IF '$GET(LRMULTSQ)
SET (ISQN,LRISQN)=LRSQ
QUIT
+26 ;
+27 ; If multiple entries (sequence - overlay data=no) then ask user which one to use.
+28 NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT
+29 SET DIR(0)=""
+30 SET I=0
FOR
SET I=$ORDER(LRSQ(I))
if 'I
QUIT
SET DIR(0)=DIR(0)_$SELECT(I=1:"",1:";")_I_":Seq #"_I
+31 SET DIR(0)="SO^"_DIR(0)
SET DIR("A")="Choose sequence number"
+32 IF LRSEQCNT=1
IF $GET(LRMULTSQ)
SET DIR("B")=LRSQ
+33 DO ^DIR
+34 IF $DATA(DIRUT)!(Y<1)
SET LRNOP=1
QUIT
+35 SET (ISQN,LRISQN)=+Y
QUIT
+36 QUIT
