Routine: LRAPRES

LRAPRES ;DALOI/STAFF,PMK - AP ESIG RELEASE REPORT ;17 Sep 2013 10:52 AM

 ;;5.2;LAB SERVICE;**259,295,317,315,350,427,433**;Sep 27, 1994;Build 4

 ; Reference to NEW^TIUPNAPI supported by IA #1911

 ; Reference to SETPARM^TIULE supported by IA #2863

 ; Reference to File #8925.1 supported by IA #5033

 ; Reference to TGET^TIUSRVR1 supported by IA #2944

 ; Reference to $$DDEFIEN^TIUFLF7 supported by IA #5352

 ; Reference to EXTRACT^TIULQ supported by IA #2693

 ; ZEXCEPT is used to identify variables which are external to a specific TAG

 ;         used in conjunction with Eclipse M-editor.

MAIN ;

 N LRMSG,LRDEM,LREND,LRQUIT,LRNTIME,LRPRCLSS,LRVCDE,LRMTCH

 N LRPCEXP,LRESCPT,LRPCSTR,USRSEL

 S LRESCPT=0

 D TITLE

 I LRQUIT D END Q

 D CPTCHK

 F  D  Q:LRQUIT

 . S LRQUIT=0

 . D MENU

 . Q:LRQUIT

 . S USRSEL=$G(LRSEL)

 . D  ; Protect USRSEL var

 . . N USRSEL

 . . D SECTION

 . Q:LRQUIT

 . S LREND=0

 . I USRSEL="E" S LREND=0 D CLSSCHK^LRAPRES1(DUZ,.LREND)

 . Q:LREND

 . D ACCYR

 . Q:LRQUIT

 . D ACCPN

 D END

ACCPN ; Prompt for accession number or patient name

 N USRSEL1

 S USRSEL1=$G(USRSEL) ;from MAIN

 F  D  Q:LREND

 . S (LRQUIT,LREND)=0

 . D CPTCHK

 . D LOOKUP^LRAPUTL(.LRDATA,LRH(0),LRO(68),LRSS,LRAD,LRAA)

 . Q:'LRDATA

 . I LRDATA=-1 S LREND=1 Q

 . S LRDFN=LRDATA,LRI=LRDATA(1)

 . S LRIENS=LRI_","_LRDFN_","

 . I USRSEL1="E" D  Q:LRQUIT

 . . D RELCHK

 . . Q:LRQUIT

 . . D SETRL^LRVERA(LRDFN,LRSS,$S('LRAU:LRI,1:0),DUZ(2))

 . . D:'LRZ(2) BROWSE

 . . D ESIG

 . . Q:LRQUIT

 . . S LRNTIME=$$NOW^XLFDT

 . . I 'LRZ(2) D TIUPREP,STORE

 . . Q:LRQUIT

 . . D RELEASE

 . . Q:LRQUIT

 . . D:'LRZ(2) MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)

 . . D OERR^LR7OB63D

 . I USRSEL1="C" D

 . . Q:$T(CPT^LRCAPES)=""

 . . S LRPRO=DUZ

 . . D PROVIDR^LRAPUTL

 . . Q:LRQUIT

 . . D CPT^LRCAPES(LRAA,LRAD,LRAN,LRPRO)

 . I USRSEL1="V" D

 . . D DEMARR

 . . D INIT^LRAPSNMD(LRDFN,LRSS,LRI,LRSF,LRAA,LRAN,LRAD,.LRDEM,1)

TITLE ; Title

 S LRQUIT=0

 D CK^LRAP

 I Y=-1 S LRQUIT=1 Q

 W @IOF

 S LRTEXT="Release/Electronically Sign Pathology Reports"

 S LRMSG(1)=$$CJ^XLFSTR(LRTEXT,IOM)

 S LRMSG(1,"F")="!!"

 S LRMSG(2)="",LRMSG(2,"F")="!"

 D EN^DDIOL(.LRMSG) K LRMSG

CPTCHK ; Determine if CPT is activated

 Q:$T(ES^LRCAPES)=""

 S LRESCPT=$$ES^LRCAPES()

DEMARR ;

 I LRAU D

 . S LRPRO=$$GET1^DIQ(63,LRDFN_",",13.5,"I")

 . S LRPRO(1)=$$GET1^DIQ(63,LRDFN_",",13.5)

 I 'LRAU D

 . S LRPRO=$$GET1^DIQ(LRSF,LRI_","_LRDFN_",",.07,"I")

 . S LRPRO(1)=$$GET1^DIQ(LRSF,LRI_","_LRDFN_",",.07)

 S LRDEM("SEX")=SEX,LRDEM("DOB")=DOB

 S LRDEM("AGE")=AGE

 S LRDEM("SEC")=LRAA(1),LRDEM("PNM")=PNM

 S LRDEM("SSN")=SSN,LRDEM("PRO")=LRPRO(1)

 I LRAU D

 . S LRDEM("DTH")=$P(VADM(6),"^",2)

 . S LRDEM("AUDT")=$$GET1^DIQ(63,LRDFN_",",11)

 . S LRDEM("AUTYP")=$$GET1^DIQ(63,LRDFN_",",13.7)

MENU ;

 N DIR,X,Y

 S DIR(0)="SO^"

 S:LRESCPT DIR(0)=DIR(0)_"C:CPT Coding;"

 S DIR(0)=DIR(0)_"E:Electronically Sign Reports;V:View SNOMED Codes"

 S DIR("A")="Selection"

 D ^DIR

 I $D(DIRUT) S LRQUIT=1 Q

 S LRSEL=Y

SECTION ; Choose Anatomic Pathology section (AU,SP,CY,EM)

 N LRMSG

W !

 D ^LRAP

 I '$D(Y)!('$D(LRSS)) S LRQUIT=1 Q

 S:LRO(68)="EM" LRO(68)="ELECTRON MICROSCOPY"

 S LRAU=0            ; LRAU = 0 - Not Autopsy

 S:LRSS="AU" LRAU=1  ;      = 1 - Autopsy

 I LRCAPA D  Q:LRQUIT

 . S X=""

 . S:LRSS="CY" X="CYTOLOGY REPORTING"

 . S:LRSS="SP" X="SURGICAL PATH REPORTING"

 . D:X'="" X^LRUWK

 . S:'$D(X) LRQUIT=1

 S LRSOP="Z"

 S LRMSG(1)=LRO(68)_" ("_LRABV_")",LRMSG(1,"F")="!?20"

 S LRMSG(2)="",LRMSG(2,"F")="!"

 D EN^DDIOL(.LRMSG)

ACCYR ; Determine Accession Year

 D ACCYR^LRAPUTL(.LRAD1,LRH(0),LRAA,LRO(68))

 I LRAD1=-1 S LRQUIT=1 Q

 I LRAD1 S LRAD=$P(LRAD1,U),LRH(0)=$P(LRAD1,U,2)

RELCHK ; Perform series of checks

 N LRPAT,LRSRLST,LRSRREL

 S LRQUIT=0

 I 'LRAU D  Q:LRQUIT

 . S LRPAT=+$$GET1^DIQ(LRSF,LRIENS,.02,"I")

 . S LRZ=$$GET1^DIQ(LRSF,LRIENS,.03,"I")

 . S LRZ(1)=$$GET1^DIQ(LRSF,LRIENS,.13,"I")

 . S LRZ(1.1)=$$GET1^DIQ(LRSF,LRIENS,.13)

 . S LRZ(2)=$$GET1^DIQ(LRSF,LRIENS,.11,"I")

 . I 'LRZ,'LRZ(2) D

 . . W $C(7)

 . . S LRMSG="No date report completed.  Cannot release."

 . . D EN^DDIOL(LRMSG,"","!!") K LRMSG

 . . S LRQUIT=1

 I LRAU D  Q:LRQUIT

 . I $G(^LR(LRDFN,"AU"))="" D  Q

 . . S LRMSG="No information found for this accession in the "

 . . S LRMSG=LRMSG_"LAB DATA file (#63)."

 . . D EN^DDIOL(LRMSG,"","!!") K LRMSG

 . . S LRQUIT=1

 . S LRPAT=+$$GET1^DIQ(63,LRDFN_",",13.6,"I")

 . S LRZ=$$GET1^DIQ(63,LRDFN_",",13,"I")

 . S LRZ(1)=$$GET1^DIQ(63,LRDFN_",",14.8,"I")

 . S LRZ(1.1)=$$GET1^DIQ(63,LRDFN_",",14.8)

 . S LRZ(2)=$$GET1^DIQ(63,LRDFN_",",14.7,"I")

 . ; KLL-CHECK FOR PROVISIONAL DATE OR DATE REPORT COMPLETED

 . S LRZ(3)=$$GET1^DIQ(63,LRDFN_",",14.9,"I")

 . I 'LRZ,'LRZ(3) D

 . . W $C(7)

 . . S LRMSG="Provisional or date report completed required.  Cannot release."

 . . D EN^DDIOL(LRMSG,"","!!") K LRMSG

 . . S LRQUIT=1

 I 'LRPAT,'LRZ(2) D

 . W $C(7)

 . S LRMSG="Pathologist or Cytotechnologist entry missing. Cannot release."

 . D EN^DDIOL(LRMSG,"","!!") K LRMSG

 . S LRQUIT=1

 D:'LRZ(2) SUPCHK^LRAPR1

 Q:LRQUIT

 I LRZ(2) D  Q:LRQUIT

 . W $C(7)

 . S LRMSG="Report " S:LRZ(2)=1 LRMSG=LRMSG_"has already been "

 . S LRMSG=LRMSG_"released "

 . S Y=LRZ(2) D DD^%DT S:LRZ(2)>1 LRMSG=LRMSG_Y

 . S:LRZ(1)'="" LRMSG=LRMSG_" by "_LRZ(1.1)

 . D EN^DDIOL(LRMSG,"","!!") K LRMSG

 . S:'LRAU LRQUIT=1

 ; KLL-DON'T ALLOW UNRELEASE IF REPT COMPLETED DATE EXISTS FOR AU

 I LRZ(2),LRZ S LRQUIT=1

 S LRMSG="" D EN^DDIOL(LRMSG,"","!") K LRMSG

 ; Don't allow unrelease if supp report not released for AU

 I LRZ(2),'LRZ D

 . S LRSRLST=$P($G(^LR(LRDFN,84,0)),"^",4)

 . Q:'LRSRLST

 . S LRSRREL=$P($G(^LR(LRDFN,84,LRSRLST,0)),"^",2)

 . I 'LRSRREL D

 . . N LRMSG

 . . S LRMSG=$C(7)_"Supplementary report has not been released. Cannot use this option."

 . . D EN^DDIOL(LRMSG,"","!!")

 . . S LRQUIT=1

 Q:LRQUIT

 I LRZ(2),'LRZ D

 . S DIR(0)="YA",DIR("B")="NO"

 . S DIR("A")="Unrelease report? "

 . D ^DIR

 . I 'Y S LRQUIT=1

BROWSE ; Display the report in the browser

 N DIR,DIRUT,DTOUT,DUOUT,X,Y

 ; Check if user's terminal supports browser functionality

 I '$$TEST^DDBRT D  Q

 . S DIR("A",1)="This terminal does not support the needed functionality to use the Browser!"

 . S DIR("A",2)="Unable to display report on terminal."

 . S DIR("A")="Press any key to continue."

 . S DIR(0)="EA" D ^DIR

 S DIR(0)="YA",DIR("B")="YES"

 S DIR("A")="View the report before signing? "

 D ^DIR

 I Y<1 Q

 K ^TMP("LRAPBR",$J)

 S LRMSG=$$CJ^XLFSTR("*** Report is being processed.  One moment please. ***",IOM)

 D EN^DDIOL(LRMSG,"","!!")

 D INIT^LRAPBR(LRAA,LRSS,LRI,LRDFN,LRO(68),LRAU,0)

ESIG ; Prompt for electronic signature

 S LRQUIT=0

 D SIG^XUSESIG

 I X1="" D  Q

 . W "  SIGNATURE NOT VERIFIED"

 . S LRQUIT=1

TIUPREP ;

 K ^TMP("TIUP",$J)

 S LRMSG="*** Report is being processed"

 ; Exclude patient files 67, 67.1, 67.2, 67.3, 62.3 from TIU storage

 I LRDPF'=62.3,LRDPF'[67 S LRMSG=LRMSG_" for storage in TIU"

 S LRMSG=LRMSG_".  One moment please. ***"

 S LRMSG=$$CJ^XLFSTR(LRMSG,IOM)

 D EN^DDIOL(LRMSG,"","!!")

 D INIT^LRAPBR(LRAA,LRSS,LRI,LRDFN,LRO(68),LRAU,1,LRNTIME)

RELEASE ; Release the report

 N LRMSG

 ; Store REPORT RELEASE DATE/TIME and RELEASED BY

 I 'LRAU D

 . S LRRC=$$GET1^DIQ(LRSF,LRIENS,.1,"I")

 . I LRCAPA D C^LRAPSWK

 . S DR=".11////^S X=LRNTIME;.13////^S X=DUZ"

 . S DIE="^LR(LRDFN,LRSS,",DA=LRI,DA(1)=LRDFN

 . S LRA=^LR(LRDFN,LRSS,LRI,0) ; Set LRA for xref call to LRWOMEN

 ; Store AUTOPSY RELEASE DATE/TIME and AUTOPSY RELEASED BY

 I LRAU D

 . S DR="14.7////^S X=$S(LRZ(2):""@"",1:LRNTIME);"

 . S DR=DR_"14.8////^S X=$S(LRZ(2):""@"",1:DUZ);"

 . S DIE="^LR(",DA=LRDFN

 D CK^LRU

 Q:$D(LR("CK"))

 D ^DIE

 ; Update accession with completion status

 D ACCCOMP

 ; Update clinical reminders

 D UPDATE^LRPXRM(LRDFN,$G(LRSS,"AU"),$G(LRI))

 D FRE^LRU

 S LRMSG="*** Report "

 I LRZ(2),LRAU S LRMSG=LRMSG_"un"

 S LRMSG=LRMSG_"released. ***"

 D EN^DDIOL($$CJ^XLFSTR(LRMSG,IOM),"","!!")

 ; Record workload

 I "CYSP"[LRSS,LRCAPA D WKLD

 ; Check if supported subscript, released and LEDI accession and send results back to submitting facility.

 I LRSS?1(1"SP",1"CY",1"EM"),$$GET1^DIQ(LRSF,LRI_","_LRDFN_",",.11,"I") D LEDI^LRVR0

 ;I LRCAPA,"SPCYEM"[LRSS,LRD(1)'="","MBA"[LRD(1) D C1^LRAPSWK

STORE ; Store report in TIU

 N LRTITLE,LRIENS,LRFILE,LRFDA,LRTIUPTR,LRMSG

 I LRDPF=62.3!(LRDPF[67) D REFRRL^LRAPUTL Q

 S:LRSS="SP" LRO68="SURGICAL PATHOLOGY"

 S:LRSS="CY" LRO68="CYTOPATHOLOGY"

 S:LRSS="EM" LRO68="ELECTRON MICROSCOPY"

 S:LRSS="AU" LRO68="AUTOPSY"

 D SETPARM^TIULE

 S LRTITLE=$$DDEFIEN^TIUFLF7("LR "_LRO68_" REPORT","TL")

 I 'LRTITLE D

 . W $C(7)

 . S LRMSG="No TIU title for this lab report.  Cannot release."

 . D EN^DDIOL(LRMSG,"","!!") K LRMSG

 . S LRQUIT=1

 Q:LRQUIT

 ; Set parameter to 1 for e-sig verification in TIU; if e-sig fails,

 ;      TIU will abort creation of doc in ^TIU(8925, and return

 ;      an error, tiufn=-1,-1.

 D NEW^TIUPNAPI(.LRTIUPTR,DFN,DUZ,LRNTIME,LRTITLE,,,,DUZ,,1)

 I LRTIUPTR="-1^-1" D  Q

 .S LRMSG(1)="     *** Signature in TIU failed. ***"

 .S LRMSG(2,"F")="!!!"

 .S LRMSG(2)="Possible causes:"

 .S LRMSG(3,"F")="!!"

 .S LRMSG(3)="1. Report contains 3 sequential characters matching those defined"

 .S LRMSG(4)="in the BLANK CHARACTER STRING field (#1.06), TIU PARAMETERS file (#8925.99)"

 .S LRMSG(5)="which are "_$P(TIUPRM1,U,6)_"."

 .S LRMSG(6,"F")="!!"

 .S LRMSG(6)="To correct this situation use a data entry option to remove"

 .S LRMSG(7)="these characters from this report."

 .S LRMSG(8,"F")="!!"

 .S LRMSG(8)="2.  There is some other TIU document setup problem."

 .S LRMSG(9,"F")="!!"

 .S LRMSG(9)="Report this situation to the Laboratory ADP Coordinator."

 .S LRMSG(10)="     *** Report storage in TIU failed. ***"

 .S LRMSG(10,"F")="!!!"

 .D EN^DDIOL(.LRMSG,"","!!")

 .S LRQUIT=1

 I +LRTIUPTR=-1 D  Q

 . S LRMSG="*** Report storage in TIU failed. ***"

 . S LRMSG=$$CJ^XLFSTR(LRMSG,IOM)

 . D EN^DDIOL(LRMSG,"","!!")

 . S LRQUIT=1

 S LRMSG="*** Report storage in TIU is complete. ***"

 S LRMSG=$$CJ^XLFSTR(LRMSG,IOM)

 D EN^DDIOL(LRMSG,"","!!")

 ;CKA-Calculate checksum of TIU report text

 D EXTRACT^TIULQ(+LRTIUPTR,"LRTIU",,,,1,,1)

 S $P(LRTIU(+LRTIUPTR,"TEXT",0),U,5)=$P(LRTIU(+LRTIUPTR,1201,"I"),".")

 S LRCHKSUM=$$CHKSUM^XUSESIG1("LRTIU("_+LRTIUPTR_",""TEXT"")")

 K LRTIU

 ; Store pointer & checksum information in the LAB DATA (#63) file

 S LRIENS="+1,"_$S('LRAU:LRI_",",1:"")_LRDFN_","

 S LRFILE=$S(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")

 S:LRFILE="" LRFILE=$S(LRSS="AU":63.101,1:"")

 S LRFDA(1,LRFILE,LRIENS,.01)=LRNTIME

 S LRFDA(1,LRFILE,LRIENS,1)=+LRTIUPTR

 S LRFDA(1,LRFILE,LRIENS,2)=LRCHKSUM

 D UPDATE^DIE("","LRFDA(1)")

 D RETRACT^LRAPRES1(LRDFN,LRSS,LRI,+LRTIUPTR)

 I $T(REPORT^MAGT7MA)'="" D REPORT^MAGT7MA ; invoke Imaging to associate images to the TIU note - P433

WKLD ; Capture workload

 N ERR,FILE,FILE1,IENS,IENS1,LRIEN,LRFDA,LROUT,RNUM

 S LRK=$P(^LR(LRDFN,LRSS,LRI,0),"^",11) Q:'LRK

 Q:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0))

 S RNUM=1,IENS="+"_RNUM_","_LRAN_","_LRAD_","_LRAA_","

 S FILE=68.04,LRIEN(1)=LRT

 S LRFDA(1,FILE,IENS,.01)=LRT

 S LRFDA(1,FILE,IENS,1)=50

 S LRFDA(1,FILE,IENS,3)=DUZ

 S LRFDA(1,FILE,IENS,4)=LRK

 S C=0,FILE1=68.14

 F  S C=$O(LRT(C)) Q:'C  D

 . S RNUM=RNUM+1,LRIEN(RNUM)=C

 . S IENS1="+"_RNUM_","_IENS

 . S LRFDA(1,FILE1,IENS1,.01)=C

 . S LRFDA(1,FILE1,IENS1,.02)=1

 . S LRFDA(1,FILE1,IENS1,.03)=0

 . S LRFDA(1,FILE1,IENS1,.04)=0

 . S LRFDA(1,FILE1,IENS1,1)=LRK

 . S LRFDA(1,FILE1,IENS1,2)=DUZ

 . S LRFDA(1,FILE1,IENS1,3)=DUZ(2)

 . S LRFDA(1,FILE1,IENS1,4)=LRAA

 . S LRFDA(1,FILE1,IENS1,5)=LRAA

 . S LRFDA(1,FILE1,IENS1,6)=LRAA

 D UPDATE^DIE("","LRFDA(1)","LRIEN","LROUT")

ACCCOMP ; Complete tests on accession

 N LRERR,LRFDA,LRFILE,LRIENS,LRK,LRORDT,LRSN,LRSRDT,LRT,LRX

 ;ZEXCEPT: LRAA,LRAD,LRAN,LRDFN,LRDUZ,LRI,LRSS

 ; Retrieve d/t released

 I LRSS="AU" S LRK=$P(^LR(LRDFN,LRSS),"^",15)

 E  S LRK=$P(^LR(LRDFN,LRSS,LRI,0),"^",11)

 I LRK="" Q

 ; Lab Arrival d/t

 I LRSS="AU" S LRSRDT=$P(^LR(LRDFN,LRSS),"^",1)

 E  S LRSRDT=$P(^LR(LRDFN,LRSS,LRI,0),"^",10)

 ; Don't update workload tests (urgency>49)

 S LRT=0,LRFILE=68.04

 F  S LRT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT)) Q:LRT<.5  D

 . I $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),"^",2)>49 Q

 . K LRIENS,LRFDA,LRERR(1)

 . S LRIENS=LRT_","_LRAN_","_LRAD_","_LRAA_","

 . S LRFDA(1,LRFILE,LRIENS,3)=$S($G(LRDUZ):LRDUZ,$G(DUZ):DUZ,1:"")

 . S LRFDA(1,LRFILE,LRIENS,4)=LRK

 . D UPDATE^DIE("","LRFDA(1)","","LRERR(1)")

 ; Update order with release date/time if available.

 ;  - check for lab arrival time and update if missing

 S LRX=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))

 S LRORDT=$P(LRX,"^",4),LRSN=$P(LRX,"^",5)

 I LRORDT>0,LRSN>0,$D(^LRO(69,LRORDT,1,LRSN,0)) D

 . K LRFILE,LRIENS

 . S LRIENS=LRSN_","_LRORDT_",",LRFILE=69.01

 . I $P($G(^LRO(69,LRORDT,1,LRSN,3)),"^")="",LRSRDT S LRFDA(2,LRFILE,LRIENS,20)=LRSRDT

 . S LRFDA(2,LRFILE,LRIENS,21)=LRK

 . D UPDATE^DIE("","LRFDA(2)","","LRERR(2)")

END ; Clean-up variables and quit

 K LRAD1,LRDATA,LRAU,LRRDTE,LRTEXT,LRSEL,LRFILE,LRIENS,LRIENS1

 K LRFDA,ERR,IENS,LROUT,LRIEN,LRTMP

 K ^TMP("LRAPBR",$J),^TMP("TIUP",$J)

 D:$T(CLEAN^LRCAPES)'="" CLEAN^LRCAPES

 D V^LRU

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPRES   13672     printed  Apr 23, 2025@18:22:08                                                                                                                                                                                                    Page 2

LRAPRES   ;DALOI/STAFF,PMK - AP ESIG RELEASE REPORT ;17 Sep 2013 10:52 AM

 +1       ;;5.2;LAB SERVICE;**259,295,317,315,350,427,433**;Sep 27, 1994;Build 4

 +2       ;

 +3       ;

 +4       ; Reference to NEW^TIUPNAPI supported by IA #1911

 +5       ; Reference to SETPARM^TIULE supported by IA #2863

 +6       ; Reference to File #8925.1 supported by IA #5033

 +7       ; Reference to TGET^TIUSRVR1 supported by IA #2944

 +8       ; Reference to $$DDEFIEN^TIUFLF7 supported by IA #5352

 +9       ; Reference to EXTRACT^TIULQ supported by IA #2693

 +10      ;

 +11      ; ZEXCEPT is used to identify variables which are external to a specific TAG

 +12      ;         used in conjunction with Eclipse M-editor.

 +13      ;

MAIN      ;

 +1        NEW LRMSG,LRDEM,LREND,LRQUIT,LRNTIME,LRPRCLSS,LRVCDE,LRMTCH

 +2        NEW LRPCEXP,LRESCPT,LRPCSTR,USRSEL

 +3        SET LRESCPT=0

 +4        DO TITLE

 +5        IF LRQUIT

               DO END

               QUIT

 +6        DO CPTCHK

 +7        FOR

               Begin DoDot:1

 +8                SET LRQUIT=0

 +9                DO MENU

 +10               if LRQUIT

                       QUIT

 +11               SET USRSEL=$GET(LRSEL)

 +12      ; Protect USRSEL var

                   Begin DoDot:2

 +13                   NEW USRSEL

 +14                   DO SECTION

                   End DoDot:2

 +15               if LRQUIT

                       QUIT

 +16               SET LREND=0

 +17               IF USRSEL="E"

                       SET LREND=0

                       DO CLSSCHK^LRAPRES1(DUZ,.LREND)

 +18               if LREND

                       QUIT

 +19               DO ACCYR

 +20               if LRQUIT

                       QUIT

 +21               DO ACCPN

               End DoDot:1

               if LRQUIT

                   QUIT

 +22       DO END

 +23       QUIT

 +24      ;

 +25      ;

ACCPN     ; Prompt for accession number or patient name

 +1        NEW USRSEL1

 +2       ;from MAIN

           SET USRSEL1=$GET(USRSEL)

 +3        FOR

               Begin DoDot:1

 +4                SET (LRQUIT,LREND)=0

 +5                DO CPTCHK

 +6                DO LOOKUP^LRAPUTL(.LRDATA,LRH(0),LRO(68),LRSS,LRAD,LRAA)

 +7                if 'LRDATA

                       QUIT

 +8                IF LRDATA=-1

                       SET LREND=1

                       QUIT

 +9                SET LRDFN=LRDATA

                   SET LRI=LRDATA(1)

 +10               SET LRIENS=LRI_","_LRDFN_","

 +11               IF USRSEL1="E"

                       Begin DoDot:2

 +12                       DO RELCHK

 +13                       if LRQUIT

                               QUIT

 +14                       DO SETRL^LRVERA(LRDFN,LRSS,$SELECT('LRAU:LRI,1:0),DUZ(2))

 +15                       if 'LRZ(2)

                               DO BROWSE

 +16                       DO ESIG

 +17                       if LRQUIT

                               QUIT

 +18                       SET LRNTIME=$$NOW^XLFDT

 +19                       IF 'LRZ(2)

                               DO TIUPREP

                               DO STORE

 +20                       if LRQUIT

                               QUIT

 +21                       DO RELEASE

 +22                       if LRQUIT

                               QUIT

 +23                       if 'LRZ(2)

                               DO MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)

 +24                       DO OERR^LR7OB63D

                       End DoDot:2

                       if LRQUIT

                           QUIT

 +25               IF USRSEL1="C"

                       Begin DoDot:2

 +26                       if $TEXT(CPT^LRCAPES)=""

                               QUIT

 +27                       SET LRPRO=DUZ

 +28                       DO PROVIDR^LRAPUTL

 +29                       if LRQUIT

                               QUIT

 +30                       DO CPT^LRCAPES(LRAA,LRAD,LRAN,LRPRO)

                       End DoDot:2

 +31               IF USRSEL1="V"

                       Begin DoDot:2

 +32                       DO DEMARR

 +33                       DO INIT^LRAPSNMD(LRDFN,LRSS,LRI,LRSF,LRAA,LRAN,LRAD,.LRDEM,1)

                       End DoDot:2

               End DoDot:1

               if LREND

                   QUIT

 +34       QUIT

 +35      ;

 +36      ;

TITLE     ; Title

 +1        SET LRQUIT=0

 +2        DO CK^LRAP

 +3        IF Y=-1

               SET LRQUIT=1

               QUIT

 +4        WRITE @IOF

 +5        SET LRTEXT="Release/Electronically Sign Pathology Reports"

 +6        SET LRMSG(1)=$$CJ^XLFSTR(LRTEXT,IOM)

 +7        SET LRMSG(1,"F")="!!"

 +8        SET LRMSG(2)=""

           SET LRMSG(2,"F")="!"

 +9        DO EN^DDIOL(.LRMSG)

           KILL LRMSG

 +10       QUIT

 +11      ;

 +12      ;

CPTCHK    ; Determine if CPT is activated

 +1        if $TEXT(ES^LRCAPES)=""

               QUIT

 +2        SET LRESCPT=$$ES^LRCAPES()

 +3        QUIT

 +4       ;

 +5       ;

DEMARR    ;

 +1        IF LRAU

               Begin DoDot:1

 +2                SET LRPRO=$$GET1^DIQ(63,LRDFN_",",13.5,"I")

 +3                SET LRPRO(1)=$$GET1^DIQ(63,LRDFN_",",13.5)

               End DoDot:1

 +4        IF 'LRAU

               Begin DoDot:1

 +5                SET LRPRO=$$GET1^DIQ(LRSF,LRI_","_LRDFN_",",.07,"I")

 +6                SET LRPRO(1)=$$GET1^DIQ(LRSF,LRI_","_LRDFN_",",.07)

               End DoDot:1

 +7        SET LRDEM("SEX")=SEX

           SET LRDEM("DOB")=DOB

 +8        SET LRDEM("AGE")=AGE

 +9        SET LRDEM("SEC")=LRAA(1)

           SET LRDEM("PNM")=PNM

 +10       SET LRDEM("SSN")=SSN

           SET LRDEM("PRO")=LRPRO(1)

 +11       IF LRAU

               Begin DoDot:1

 +12               SET LRDEM("DTH")=$PIECE(VADM(6),"^",2)

 +13               SET LRDEM("AUDT")=$$GET1^DIQ(63,LRDFN_",",11)

 +14               SET LRDEM("AUTYP")=$$GET1^DIQ(63,LRDFN_",",13.7)

               End DoDot:1

 +15       QUIT

 +16      ;

 +17      ;

MENU      ;

 +1        NEW DIR,X,Y

 +2        SET DIR(0)="SO^"

 +3        if LRESCPT

               SET DIR(0)=DIR(0)_"C:CPT Coding;"

 +4        SET DIR(0)=DIR(0)_"E:Electronically Sign Reports;V:View SNOMED Codes"

 +5        SET DIR("A")="Selection"

 +6        DO ^DIR

 +7        IF $DATA(DIRUT)

               SET LRQUIT=1

               QUIT

 +8        SET LRSEL=Y

 +9        QUIT

 +10      ;

 +11      ;

SECTION   ; Choose Anatomic Pathology section (AU,SP,CY,EM)

 +1        NEW LRMSG

 +2        WRITE !

 +3        DO ^LRAP

 +4        IF '$DATA(Y)!('$DATA(LRSS))

               SET LRQUIT=1

               QUIT

 +5        if LRO(68)="EM"

               SET LRO(68)="ELECTRON MICROSCOPY"

 +6       ; LRAU = 0 - Not Autopsy

           SET LRAU=0

 +7       ;      = 1 - Autopsy

           if LRSS="AU"

               SET LRAU=1

 +8        IF LRCAPA

               Begin DoDot:1

 +9                SET X=""

 +10               if LRSS="CY"

                       SET X="CYTOLOGY REPORTING"

 +11               if LRSS="SP"

                       SET X="SURGICAL PATH REPORTING"

 +12               if X'=""

                       DO X^LRUWK

 +13               if '$DATA(X)

                       SET LRQUIT=1

               End DoDot:1

               if LRQUIT

                   QUIT

 +14      ;

 +15       SET LRSOP="Z"

 +16       SET LRMSG(1)=LRO(68)_" ("_LRABV_")"

           SET LRMSG(1,"F")="!?20"

 +17       SET LRMSG(2)=""

           SET LRMSG(2,"F")="!"

 +18       DO EN^DDIOL(.LRMSG)

 +19       QUIT

 +20      ;

 +21      ;

ACCYR     ; Determine Accession Year

 +1        DO ACCYR^LRAPUTL(.LRAD1,LRH(0),LRAA,LRO(68))

 +2        IF LRAD1=-1

               SET LRQUIT=1

               QUIT

 +3        IF LRAD1

               SET LRAD=$PIECE(LRAD1,U)

               SET LRH(0)=$PIECE(LRAD1,U,2)

 +4        QUIT

 +5       ;

 +6       ;

RELCHK    ; Perform series of checks

 +1        NEW LRPAT,LRSRLST,LRSRREL

 +2        SET LRQUIT=0

 +3        IF 'LRAU

               Begin DoDot:1

 +4                SET LRPAT=+$$GET1^DIQ(LRSF,LRIENS,.02,"I")

 +5                SET LRZ=$$GET1^DIQ(LRSF,LRIENS,.03,"I")

 +6                SET LRZ(1)=$$GET1^DIQ(LRSF,LRIENS,.13,"I")

 +7                SET LRZ(1.1)=$$GET1^DIQ(LRSF,LRIENS,.13)

 +8                SET LRZ(2)=$$GET1^DIQ(LRSF,LRIENS,.11,"I")

 +9                IF 'LRZ

                       IF 'LRZ(2)

                           Begin DoDot:2

 +10                           WRITE $CHAR(7)

 +11                           SET LRMSG="No date report completed.  Cannot release."

 +12                           DO EN^DDIOL(LRMSG,"","!!")

                               KILL LRMSG

 +13                           SET LRQUIT=1

                           End DoDot:2

               End DoDot:1

               if LRQUIT

                   QUIT

 +14      ;

 +15       IF LRAU

               Begin DoDot:1

 +16               IF $GET(^LR(LRDFN,"AU"))=""

                       Begin DoDot:2

 +17                       SET LRMSG="No information found for this accession in the "

 +18                       SET LRMSG=LRMSG_"LAB DATA file (#63)."

 +19                       DO EN^DDIOL(LRMSG,"","!!")

                           KILL LRMSG

 +20                       SET LRQUIT=1

                       End DoDot:2

                       QUIT

 +21               SET LRPAT=+$$GET1^DIQ(63,LRDFN_",",13.6,"I")

 +22               SET LRZ=$$GET1^DIQ(63,LRDFN_",",13,"I")

 +23               SET LRZ(1)=$$GET1^DIQ(63,LRDFN_",",14.8,"I")

 +24               SET LRZ(1.1)=$$GET1^DIQ(63,LRDFN_",",14.8)

 +25               SET LRZ(2)=$$GET1^DIQ(63,LRDFN_",",14.7,"I")

 +26      ; KLL-CHECK FOR PROVISIONAL DATE OR DATE REPORT COMPLETED

 +27               SET LRZ(3)=$$GET1^DIQ(63,LRDFN_",",14.9,"I")

 +28               IF 'LRZ

                       IF 'LRZ(3)

                           Begin DoDot:2

 +29                           WRITE $CHAR(7)

 +30                           SET LRMSG="Provisional or date report completed required.  Cannot release."

 +31                           DO EN^DDIOL(LRMSG,"","!!")

                               KILL LRMSG

 +32                           SET LRQUIT=1

                           End DoDot:2

               End DoDot:1

               if LRQUIT

                   QUIT

 +33       IF 'LRPAT

               IF 'LRZ(2)

                   Begin DoDot:1

 +34                   WRITE $CHAR(7)

 +35                   SET LRMSG="Pathologist or Cytotechnologist entry missing. Cannot release."

 +36                   DO EN^DDIOL(LRMSG,"","!!")

                       KILL LRMSG

 +37                   SET LRQUIT=1

                   End DoDot:1

 +38       if 'LRZ(2)

               DO SUPCHK^LRAPR1

 +39       if LRQUIT

               QUIT

 +40       IF LRZ(2)

               Begin DoDot:1

 +41               WRITE $CHAR(7)

 +42               SET LRMSG="Report "

                   if LRZ(2)=1

                       SET LRMSG=LRMSG_"has already been "

 +43               SET LRMSG=LRMSG_"released "

 +44               SET Y=LRZ(2)

                   DO DD^%DT

                   if LRZ(2)>1

                       SET LRMSG=LRMSG_Y

 +45               if LRZ(1)'=""

                       SET LRMSG=LRMSG_" by "_LRZ(1.1)

 +46               DO EN^DDIOL(LRMSG,"","!!")

                   KILL LRMSG

 +47               if 'LRAU

                       SET LRQUIT=1

               End DoDot:1

               if LRQUIT

                   QUIT

 +48      ; KLL-DON'T ALLOW UNRELEASE IF REPT COMPLETED DATE EXISTS FOR AU

 +49       IF LRZ(2)

               IF LRZ

                   SET LRQUIT=1

 +50       SET LRMSG=""

           DO EN^DDIOL(LRMSG,"","!")

           KILL LRMSG

 +51      ; Don't allow unrelease if supp report not released for AU

 +52       IF LRZ(2)

               IF 'LRZ

                   Begin DoDot:1

 +53                   SET LRSRLST=$PIECE($GET(^LR(LRDFN,84,0)),"^",4)

 +54                   if 'LRSRLST

                           QUIT

 +55                   SET LRSRREL=$PIECE($GET(^LR(LRDFN,84,LRSRLST,0)),"^",2)

 +56                   IF 'LRSRREL

                           Begin DoDot:2

 +57                           NEW LRMSG

 +58                           SET LRMSG=$CHAR(7)_"Supplementary report has not been released. Cannot use this option."

 +59                           DO EN^DDIOL(LRMSG,"","!!")

 +60                           SET LRQUIT=1

                           End DoDot:2

                   End DoDot:1

 +61       if LRQUIT

               QUIT

 +62       IF LRZ(2)

               IF 'LRZ

                   Begin DoDot:1

 +63                   SET DIR(0)="YA"

                       SET DIR("B")="NO"

 +64                   SET DIR("A")="Unrelease report? "

 +65                   DO ^DIR

 +66                   IF 'Y

                           SET LRQUIT=1

                   End DoDot:1

 +67       QUIT

 +68      ;

 +69      ;

BROWSE    ; Display the report in the browser

 +1        NEW DIR,DIRUT,DTOUT,DUOUT,X,Y

 +2       ;

 +3       ; Check if user's terminal supports browser functionality

 +4        IF '$$TEST^DDBRT

               Begin DoDot:1

 +5                SET DIR("A",1)="This terminal does not support the needed functionality to use the Browser!"

 +6                SET DIR("A",2)="Unable to display report on terminal."

 +7                SET DIR("A")="Press any key to continue."

 +8                SET DIR(0)="EA"

                   DO ^DIR

               End DoDot:1

               QUIT

 +9       ;

 +10       SET DIR(0)="YA"

           SET DIR("B")="YES"

 +11       SET DIR("A")="View the report before signing? "

 +12       DO ^DIR

 +13       IF Y<1

               QUIT

 +14      ;

 +15       KILL ^TMP("LRAPBR",$JOB)

 +16       SET LRMSG=$$CJ^XLFSTR("*** Report is being processed.  One moment please. ***",IOM)

 +17       DO EN^DDIOL(LRMSG,"","!!")

 +18       DO INIT^LRAPBR(LRAA,LRSS,LRI,LRDFN,LRO(68),LRAU,0)

 +19       QUIT

 +20      ;

 +21      ;

ESIG      ; Prompt for electronic signature

 +1        SET LRQUIT=0

 +2        DO SIG^XUSESIG

 +3        IF X1=""

               Begin DoDot:1

 +4                WRITE "  SIGNATURE NOT VERIFIED"

 +5                SET LRQUIT=1

               End DoDot:1

               QUIT

 +6        QUIT

 +7       ;

 +8       ;

TIUPREP   ;

 +1        KILL ^TMP("TIUP",$JOB)

 +2        SET LRMSG="*** Report is being processed"

 +3       ; Exclude patient files 67, 67.1, 67.2, 67.3, 62.3 from TIU storage

 +4       ;

 +5        IF LRDPF'=62.3

               IF LRDPF'[67

                   SET LRMSG=LRMSG_" for storage in TIU"

 +6        SET LRMSG=LRMSG_".  One moment please. ***"

 +7        SET LRMSG=$$CJ^XLFSTR(LRMSG,IOM)

 +8        DO EN^DDIOL(LRMSG,"","!!")

 +9       ;

 +10       DO INIT^LRAPBR(LRAA,LRSS,LRI,LRDFN,LRO(68),LRAU,1,LRNTIME)

 +11       QUIT

 +12      ;

 +13      ;

RELEASE   ; Release the report

 +1        NEW LRMSG

 +2       ;

 +3       ; Store REPORT RELEASE DATE/TIME and RELEASED BY

 +4        IF 'LRAU

               Begin DoDot:1

 +5                SET LRRC=$$GET1^DIQ(LRSF,LRIENS,.1,"I")

 +6                IF LRCAPA

                       DO C^LRAPSWK

 +7                SET DR=".11////^S X=LRNTIME;.13////^S X=DUZ"

 +8                SET DIE="^LR(LRDFN,LRSS,"

                   SET DA=LRI

                   SET DA(1)=LRDFN

 +9       ; Set LRA for xref call to LRWOMEN

                   SET LRA=^LR(LRDFN,LRSS,LRI,0)

               End DoDot:1

 +10      ;

 +11      ; Store AUTOPSY RELEASE DATE/TIME and AUTOPSY RELEASED BY

 +12       IF LRAU

               Begin DoDot:1

 +13               SET DR="14.7////^S X=$S(LRZ(2):""@"",1:LRNTIME);"

 +14               SET DR=DR_"14.8////^S X=$S(LRZ(2):""@"",1:DUZ);"

 +15               SET DIE="^LR("

                   SET DA=LRDFN

               End DoDot:1

 +16      ;

 +17       DO CK^LRU

 +18       if $DATA(LR("CK"))

               QUIT

 +19       DO ^DIE

 +20      ;

 +21      ; Update accession with completion status

 +22       DO ACCCOMP

 +23      ;

 +24      ; Update clinical reminders

 +25       DO UPDATE^LRPXRM(LRDFN,$GET(LRSS,"AU"),$GET(LRI))

 +26      ;

 +27       DO FRE^LRU

 +28       SET LRMSG="*** Report "

 +29       IF LRZ(2)

               IF LRAU

                   SET LRMSG=LRMSG_"un"

 +30       SET LRMSG=LRMSG_"released. ***"

 +31       DO EN^DDIOL($$CJ^XLFSTR(LRMSG,IOM),"","!!")

 +32      ;

 +33      ; Record workload

 +34       IF "CYSP"[LRSS

               IF LRCAPA

                   DO WKLD

 +35      ;

 +36      ; Check if supported subscript, released and LEDI accession and send results back to submitting facility.

 +37       IF LRSS?1(1"SP",1"CY",1"EM")

               IF $$GET1^DIQ(LRSF,LRI_","_LRDFN_",",.11,"I")

                   DO LEDI^LRVR0

 +38      ;

 +39      ;I LRCAPA,"SPCYEM"[LRSS,LRD(1)'="","MBA"[LRD(1) D C1^LRAPSWK

 +40       QUIT

 +41      ;

 +42      ;

STORE     ; Store report in TIU

 +1        NEW LRTITLE,LRIENS,LRFILE,LRFDA,LRTIUPTR,LRMSG

 +2        IF LRDPF=62.3!(LRDPF[67)

               DO REFRRL^LRAPUTL

               QUIT

 +3        if LRSS="SP"

               SET LRO68="SURGICAL PATHOLOGY"

 +4        if LRSS="CY"

               SET LRO68="CYTOPATHOLOGY"

 +5        if LRSS="EM"

               SET LRO68="ELECTRON MICROSCOPY"

 +6        if LRSS="AU"

               SET LRO68="AUTOPSY"

 +7        DO SETPARM^TIULE

 +8        SET LRTITLE=$$DDEFIEN^TIUFLF7("LR "_LRO68_" REPORT","TL")

 +9        IF 'LRTITLE

               Begin DoDot:1

 +10               WRITE $CHAR(7)

 +11               SET LRMSG="No TIU title for this lab report.  Cannot release."

 +12               DO EN^DDIOL(LRMSG,"","!!")

                   KILL LRMSG

 +13               SET LRQUIT=1

               End DoDot:1

 +14       if LRQUIT

               QUIT

 +15      ; Set parameter to 1 for e-sig verification in TIU; if e-sig fails,

 +16      ;      TIU will abort creation of doc in ^TIU(8925, and return

 +17      ;      an error, tiufn=-1,-1.

 +18       DO NEW^TIUPNAPI(.LRTIUPTR,DFN,DUZ,LRNTIME,LRTITLE,,,,DUZ,,1)

 +19       IF LRTIUPTR="-1^-1"

               Begin DoDot:1

 +20               SET LRMSG(1)="     *** Signature in TIU failed. ***"

 +21               SET LRMSG(2,"F")="!!!"

 +22               SET LRMSG(2)="Possible causes:"

 +23               SET LRMSG(3,"F")="!!"

 +24               SET LRMSG(3)="1. Report contains 3 sequential characters matching those defined"

 +25               SET LRMSG(4)="in the BLANK CHARACTER STRING field (#1.06), TIU PARAMETERS file (#8925.99)"

 +26               SET LRMSG(5)="which are "_$PIECE(TIUPRM1,U,6)_"."

 +27               SET LRMSG(6,"F")="!!"

 +28               SET LRMSG(6)="To correct this situation use a data entry option to remove"

 +29               SET LRMSG(7)="these characters from this report."

 +30               SET LRMSG(8,"F")="!!"

 +31               SET LRMSG(8)="2.  There is some other TIU document setup problem."

 +32               SET LRMSG(9,"F")="!!"

 +33               SET LRMSG(9)="Report this situation to the Laboratory ADP Coordinator."

 +34               SET LRMSG(10)="     *** Report storage in TIU failed. ***"

 +35               SET LRMSG(10,"F")="!!!"

 +36               DO EN^DDIOL(.LRMSG,"","!!")

 +37               SET LRQUIT=1

               End DoDot:1

               QUIT

 +38       IF +LRTIUPTR=-1

               Begin DoDot:1

 +39               SET LRMSG="*** Report storage in TIU failed. ***"

 +40               SET LRMSG=$$CJ^XLFSTR(LRMSG,IOM)

 +41               DO EN^DDIOL(LRMSG,"","!!")

 +42               SET LRQUIT=1

               End DoDot:1

               QUIT

 +43       SET LRMSG="*** Report storage in TIU is complete. ***"

 +44       SET LRMSG=$$CJ^XLFSTR(LRMSG,IOM)

 +45       DO EN^DDIOL(LRMSG,"","!!")

 +46      ;CKA-Calculate checksum of TIU report text

 +47       DO EXTRACT^TIULQ(+LRTIUPTR,"LRTIU",,,,1,,1)

 +48       SET $PIECE(LRTIU(+LRTIUPTR,"TEXT",0),U,5)=$PIECE(LRTIU(+LRTIUPTR,1201,"I"),".")

 +49       SET LRCHKSUM=$$CHKSUM^XUSESIG1("LRTIU("_+LRTIUPTR_",""TEXT"")")

 +50       KILL LRTIU

 +51      ;

 +52      ; Store pointer & checksum information in the LAB DATA (#63) file

 +53       SET LRIENS="+1,"_$SELECT('LRAU:LRI_",",1:"")_LRDFN_","

 +54       SET LRFILE=$SELECT(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")

 +55       if LRFILE=""

               SET LRFILE=$SELECT(LRSS="AU":63.101,1:"")

 +56       SET LRFDA(1,LRFILE,LRIENS,.01)=LRNTIME

 +57       SET LRFDA(1,LRFILE,LRIENS,1)=+LRTIUPTR

 +58       SET LRFDA(1,LRFILE,LRIENS,2)=LRCHKSUM

 +59       DO UPDATE^DIE("","LRFDA(1)")

 +60       DO RETRACT^LRAPRES1(LRDFN,LRSS,LRI,+LRTIUPTR)

 +61      ;

 +62      ; invoke Imaging to associate images to the TIU note - P433

           IF $TEXT(REPORT^MAGT7MA)'=""

               DO REPORT^MAGT7MA

 +63      ;

 +64       QUIT

 +65      ;

 +66      ;

WKLD      ; Capture workload

 +1        NEW ERR,FILE,FILE1,IENS,IENS1,LRIEN,LRFDA,LROUT,RNUM

 +2        SET LRK=$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",11)

           if 'LRK

               QUIT

 +3        if $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0))

               QUIT

 +4        SET RNUM=1

           SET IENS="+"_RNUM_","_LRAN_","_LRAD_","_LRAA_","

 +5        SET FILE=68.04

           SET LRIEN(1)=LRT

 +6        SET LRFDA(1,FILE,IENS,.01)=LRT

 +7        SET LRFDA(1,FILE,IENS,1)=50

 +8        SET LRFDA(1,FILE,IENS,3)=DUZ

 +9        SET LRFDA(1,FILE,IENS,4)=LRK

 +10       SET C=0

           SET FILE1=68.14

 +11       FOR

               SET C=$ORDER(LRT(C))

               if 'C

                   QUIT

               Begin DoDot:1

 +12               SET RNUM=RNUM+1

                   SET LRIEN(RNUM)=C

 +13               SET IENS1="+"_RNUM_","_IENS

 +14               SET LRFDA(1,FILE1,IENS1,.01)=C

 +15               SET LRFDA(1,FILE1,IENS1,.02)=1

 +16               SET LRFDA(1,FILE1,IENS1,.03)=0

 +17               SET LRFDA(1,FILE1,IENS1,.04)=0

 +18               SET LRFDA(1,FILE1,IENS1,1)=LRK

 +19               SET LRFDA(1,FILE1,IENS1,2)=DUZ

 +20               SET LRFDA(1,FILE1,IENS1,3)=DUZ(2)

 +21               SET LRFDA(1,FILE1,IENS1,4)=LRAA

 +22               SET LRFDA(1,FILE1,IENS1,5)=LRAA

 +23               SET LRFDA(1,FILE1,IENS1,6)=LRAA

               End DoDot:1

 +24       DO UPDATE^DIE("","LRFDA(1)","LRIEN","LROUT")

 +25       QUIT

 +26      ;

 +27      ;

ACCCOMP   ; Complete tests on accession

 +1       ;

 +2        NEW LRERR,LRFDA,LRFILE,LRIENS,LRK,LRORDT,LRSN,LRSRDT,LRT,LRX

 +3       ;

 +4       ;ZEXCEPT: LRAA,LRAD,LRAN,LRDFN,LRDUZ,LRI,LRSS

 +5       ;

 +6       ; Retrieve d/t released

 +7        IF LRSS="AU"

               SET LRK=$PIECE(^LR(LRDFN,LRSS),"^",15)

 +8       IF '$TEST

               SET LRK=$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",11)

 +9        IF LRK=""

               QUIT

 +10      ;

 +11      ; Lab Arrival d/t

 +12       IF LRSS="AU"

               SET LRSRDT=$PIECE(^LR(LRDFN,LRSS),"^",1)

 +13      IF '$TEST

               SET LRSRDT=$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",10)

 +14      ;

 +15      ; Don't update workload tests (urgency>49)

 +16       SET LRT=0

           SET LRFILE=68.04

 +17       FOR

               SET LRT=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT))

               if LRT<.5

                   QUIT

               Begin DoDot:1

 +18               IF $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0),"^",2)>49

                       QUIT

 +19               KILL LRIENS,LRFDA,LRERR(1)

 +20               SET LRIENS=LRT_","_LRAN_","_LRAD_","_LRAA_","

 +21               SET LRFDA(1,LRFILE,LRIENS,3)=$SELECT($GET(LRDUZ):LRDUZ,$GET(DUZ):DUZ,1:"")

 +22               SET LRFDA(1,LRFILE,LRIENS,4)=LRK

 +23               DO UPDATE^DIE("","LRFDA(1)","","LRERR(1)")

               End DoDot:1

 +24      ;

 +25      ; Update order with release date/time if available.

 +26      ;  - check for lab arrival time and update if missing

 +27       SET LRX=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))

 +28       SET LRORDT=$PIECE(LRX,"^",4)

           SET LRSN=$PIECE(LRX,"^",5)

 +29       IF LRORDT>0

               IF LRSN>0

                   IF $DATA(^LRO(69,LRORDT,1,LRSN,0))

                       Begin DoDot:1

 +30                       KILL LRFILE,LRIENS

 +31                       SET LRIENS=LRSN_","_LRORDT_","

                           SET LRFILE=69.01

 +32                       IF $PIECE($GET(^LRO(69,LRORDT,1,LRSN,3)),"^")=""

                               IF LRSRDT

                                   SET LRFDA(2,LRFILE,LRIENS,20)=LRSRDT

 +33                       SET LRFDA(2,LRFILE,LRIENS,21)=LRK

 +34                       DO UPDATE^DIE("","LRFDA(2)","","LRERR(2)")

                       End DoDot:1

 +35      ;

 +36       QUIT

 +37      ;

 +38      ;

END       ; Clean-up variables and quit

 +1        KILL LRAD1,LRDATA,LRAU,LRRDTE,LRTEXT,LRSEL,LRFILE,LRIENS,LRIENS1

 +2        KILL LRFDA,ERR,IENS,LROUT,LRIEN,LRTMP

 +3        KILL ^TMP("LRAPBR",$JOB),^TMP("TIUP",$JOB)

 +4        if $TEXT(CLEAN^LRCAPES)'=""

               DO CLEAN^LRCAPES

 +5        DO V^LRU

 +6        QUIT

LRAPRES.m