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
Q
;
;
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)
Q
;
;
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
Q
;
;
CPTCHK ; Determine if CPT is activated
Q:$T(ES^LRCAPES)=""
S LRESCPT=$$ES^LRCAPES()
Q
;
;
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)
Q
;
;
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
Q
;
;
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)
Q
;
;
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)
Q
;
;
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
Q
;
;
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)
Q
;
;
ESIG ; Prompt for electronic signature
S LRQUIT=0
D SIG^XUSESIG
I X1="" D Q
. W " SIGNATURE NOT VERIFIED"
. S LRQUIT=1
Q
;
;
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)
Q
;
;
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
Q
;
;
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
;
Q
;
;
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")
Q
;
;
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)")
;
Q
;
;
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPRES 13672 printed Sep 23, 2025@19:43:49 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 ;
+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
