LRVR0.m

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 ---LRVR0   13923     printed  Feb 18, 2025@23:48:29                                                                                                                                                                                                      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)