LRAPRES ;VA/DALOI/CKA - AP ESIG RELEASE REPORT; 17-Oct-2014 09:22 ; MKK
;;5.2;LAB SERVICE;**1030,1031,1033,1034**;NOV 1, 1997;Build 188
;
;;VA LR Patche(s): 259,295,317,315
;
;Reference to NEW^TIUPNAPI supported by IA #1911
;Reference to SETPARM^TIULE supported by IA #2863
;Reference to 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
MAIN ;
N LRMSG,LRDEM,LREND,LRQUIT,LRNTIME,LRPRCLSS,LRVCDE,LRMTCH
N LRPCEXP,LRESCPT,LRPCSTR
S LRESCPT=0
D TITLE
I LRQUIT D END^LRAPRES2 Q
D CPTCHK
F D Q:LRQUIT
.S LRQUIT=0
.D MENU
.Q:LRQUIT
.D SECTION
.Q:LRQUIT
.S LREND=0
.I LRSEL="E" S LREND=0 D CLSSCHK^LRAPRES1(DUZ,.LREND)
.Q:LREND
.D ACCYR
.Q:LRQUIT
.D ACCPN
D END^LRAPRES2
Q
ACCPN ;Prompt for accesion number or patient name
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 LRSEL="E" D Q:LRQUIT
..D RELCHK
..Q:LRQUIT
..D:'LRZ(2) BROWSE
..D ESIG
..Q:LRQUIT
..D NOW^%DTC S LRNTIME=%
..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 LRSEL="C" D
.. Q:$T(CPT^LRCAPES)=""
.. ; Q:'$$PATCH^BLRUTIL4("PX*1.0*119") ; IHS/MSC/MKK - LR*5.2*1031
.. Q:'$$PATCH^BLRUTIL4("PX*1.0*197") ; IHS/MSC/MKK - LR*5.2*1033
..S LRPRO=DUZ
..D PROVIDR^LRAPUTL
..Q:LRQUIT
..D CPT^LRCAPES(LRAA,LRAD,LRAN,LRPRO)
.I LRSEL="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)=""
; I $$PATCH^BLRUTIL4("PX*1.0*119") S LRESCPT=$$ES^LRCAPES() ; IHS/MSC/MKK - LR*5.2*1031
I $$PATCH^BLRUTIL4("PX*1.0*197") S LRESCPT=$$ES^LRCAPES() ; IHS/MSC/MKK - LR*5.2*1033
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)="S^"
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(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) S LRQUIT=1 Q
S LRSEL=Y
Q
SECTION ;Choose Anatomic Pathology section (AU,SP,CY,EM)
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 - Autosy
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) K 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
..S LRMSG=$C(7)_"Supplementary report has not been released. "
..S LRMSG=LRMSG_"Cannot use this option."
..D EN^DDIOL(LRMSG,"","!!") K 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
S DIR(0)="YA",DIR("B")="YES"
S DIR("A")="View the report before signing? "
D ^DIR Q:'Y
K ^TMP("LRAPBR",$J)
S LRMSG="*** Report is being processed. One moment please. ***"
S LRMSG=$$CJ^XLFSTR(LRMSG,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 ;
I 'LRAU D
.S LRRC=$$GET1^DIQ(LRSF,LRIENS,.1,"I")
.I LRCAPA,'LRAU D C^LRAPSWK
.;Store REPORT RELEASE DATE/TIME and RELEASED BY
.S DR=".11////^S X=LRNTIME;.13////^S X=DUZ"
.S DIE="^LR(LRDFN,LRSS,",DA=LRI,DA(1)=LRDFN
.;KLL-Set LRA for xref call to LRWOMEN
.S LRA=^LR(LRDFN,LRSS,LRI,0)
I LRAU D
.;Store AUTOPSY RELEASE DATE/TIME and AUTOPSY RELEASED BY
.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
; D UPDATE^LRPXRM(LRDFN,$G(LRSS,"AU"),$G(LRI)) ; IHS/OIT/MKK - LR*5.2*1030 - RPMS Does NOT use Clinical Reminders
I $$PATCH^BLRUTIL4("PXRM*1.5*12") D UPDATE^LRPXRM(LRDFN,$G(LRSS,"AU"),$G(LRI)) ; IHS/MSC/MKK - LR*5.2*1031
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),"","!!") K MSG
I "CYSP"[LRSS,LRCAPA D WKLD^LRAPRES2 Q
;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)
Q
LRAPRES ;VA/DALOI/CKA - AP ESIG RELEASE REPORT; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**1030,1031,1033,1034**;NOV 1, 1997;Build 188
+2 ;
+3 ;;VA LR Patche(s): 259,295,317,315
+4 ;
+5 ;Reference to NEW^TIUPNAPI supported by IA #1911
+6 ;Reference to SETPARM^TIULE supported by IA #2863
+7 ;Reference to 8925.1 supported by IA #5033
+8 ;Reference to TGET^TIUSRVR1 supported by IA #2944
+9 ;Reference to $$DDEFIEN^TIUFLF7 supported by IA #5352
+10 ;Reference to EXTRACT^TIULQ supported by IA #2693
MAIN ;
+1 NEW LRMSG,LRDEM,LREND,LRQUIT,LRNTIME,LRPRCLSS,LRVCDE,LRMTCH
+2 NEW LRPCEXP,LRESCPT,LRPCSTR
+3 SET LRESCPT=0
+4 DO TITLE
+5 IF LRQUIT
DO END^LRAPRES2
QUIT
+6 DO CPTCHK
+7 FOR
Begin DoDot:1
+8 SET LRQUIT=0
+9 DO MENU
+10 IF LRQUIT
QUIT
+11 DO SECTION
+12 IF LRQUIT
QUIT
+13 SET LREND=0
+14 IF LRSEL="E"
SET LREND=0
DO CLSSCHK^LRAPRES1(DUZ,.LREND)
+15 IF LREND
QUIT
+16 DO ACCYR
+17 IF LRQUIT
QUIT
+18 DO ACCPN
End DoDot:1
IF LRQUIT
QUIT
+19 DO END^LRAPRES2
+20 QUIT
ACCPN ;Prompt for accesion number or patient name
+1 FOR
Begin DoDot:1
+2 SET (LRQUIT,LREND)=0
+3 DO CPTCHK
+4 DO LOOKUP^LRAPUTL(.LRDATA,LRH(0),LRO(68),LRSS,LRAD,LRAA)
+5 IF 'LRDATA
QUIT
+6 IF LRDATA=-1
SET LREND=1
QUIT
+7 SET LRDFN=LRDATA
SET LRI=LRDATA(1)
+8 SET LRIENS=LRI_","_LRDFN_","
+9 IF LRSEL="E"
Begin DoDot:2
+10 DO RELCHK
+11 IF LRQUIT
QUIT
+12 IF 'LRZ(2)
DO BROWSE
+13 DO ESIG
+14 IF LRQUIT
QUIT
+15 DO NOW^%DTC
SET LRNTIME=%
+16 IF 'LRZ(2)
DO TIUPREP
DO STORE
+17 IF LRQUIT
QUIT
+18 DO RELEASE
+19 IF LRQUIT
QUIT
+20 IF 'LRZ(2)
DO MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
+21 DO OERR^LR7OB63D
End DoDot:2
IF LRQUIT
QUIT
+22 IF LRSEL="C"
Begin DoDot:2
+23 IF $TEXT(CPT^LRCAPES)=""
QUIT
+24 ; Q:'$$PATCH^BLRUTIL4("PX*1.0*119") ; IHS/MSC/MKK - LR*5.2*1031
+25 ; IHS/MSC/MKK - LR*5.2*1033
IF '$$PATCH^BLRUTIL4("PX*1.0*197")
QUIT
+26 SET LRPRO=DUZ
+27 DO PROVIDR^LRAPUTL
+28 IF LRQUIT
QUIT
+29 DO CPT^LRCAPES(LRAA,LRAD,LRAN,LRPRO)
End DoDot:2
+30 IF LRSEL="V"
Begin DoDot:2
+31 DO DEMARR
+32 DO INIT^LRAPSNMD(LRDFN,LRSS,LRI,LRSF,LRAA,LRAN,LRAD,.LRDEM,1)
End DoDot:2
End DoDot:1
IF LREND
QUIT
+33 QUIT
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
CPTCHK ;Determine if CPT is activated
+1 IF $TEXT(ES^LRCAPES)=""
QUIT
+2 ; I $$PATCH^BLRUTIL4("PX*1.0*119") S LRESCPT=$$ES^LRCAPES() ; IHS/MSC/MKK - LR*5.2*1031
+3 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")
SET LRESCPT=$$ES^LRCAPES()
+4 QUIT
+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
+1 NEW DIR,X,Y
+2 SET DIR(0)="S^"
+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(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
SET LRQUIT=1
QUIT
+8 SET LRSEL=Y
+9 QUIT
SECTION ;Choose Anatomic Pathology section (AU,SP,CY,EM)
+1 WRITE !
+2 DO ^LRAP
+3 IF '$DATA(Y)!('$DATA(LRSS))
SET LRQUIT=1
QUIT
+4 IF LRO(68)="EM"
SET LRO(68)="ELECTRON MICROSCOPY"
+5 ; LRAU = 0 - Not Autopsy
SET LRAU=0
+6 ; = 1 - Autosy
IF LRSS="AU"
SET LRAU=1
+7 IF LRCAPA
Begin DoDot:1
+8 SET X=""
+9 IF LRSS="CY"
SET X="CYTOLOGY REPORTING"
+10 IF LRSS="SP"
SET X="SURGICAL PATH REPORTING"
+11 IF X'=""
DO X^LRUWK
+12 IF '$DATA(X)
SET LRQUIT=1
End DoDot:1
IF LRQUIT
QUIT
+13 ;
+14 SET LRSOP="Z"
+15 SET LRMSG(1)=LRO(68)_" ("_LRABV_")"
SET LRMSG(1,"F")="!?20"
+16 SET LRMSG(2)=""
SET LRMSG(2,"F")="!"
+17 DO EN^DDIOL(.LRMSG)
KILL LRMSG
+18 QUIT
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
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 IF LRAU
Begin DoDot:1
+15 IF $GET(^LR(LRDFN,"AU"))=""
Begin DoDot:2
+16 SET LRMSG="No information found for this accession in the "
+17 SET LRMSG=LRMSG_"LAB DATA file (#63)."
+18 DO EN^DDIOL(LRMSG,"","!!")
KILL LRMSG
+19 SET LRQUIT=1
End DoDot:2
QUIT
+20 SET LRPAT=+$$GET1^DIQ(63,LRDFN_",",13.6,"I")
+21 SET LRZ=$$GET1^DIQ(63,LRDFN_",",13,"I")
+22 SET LRZ(1)=$$GET1^DIQ(63,LRDFN_",",14.8,"I")
+23 SET LRZ(1.1)=$$GET1^DIQ(63,LRDFN_",",14.8)
+24 SET LRZ(2)=$$GET1^DIQ(63,LRDFN_",",14.7,"I")
+25 ;KLL-CHECK FOR PROVISIONAL DATE OR DATE REPORT COMPLETED
+26 SET LRZ(3)=$$GET1^DIQ(63,LRDFN_",",14.9,"I")
+27 IF 'LRZ
IF 'LRZ(3)
Begin DoDot:2
+28 WRITE $CHAR(7)
+29 SET LRMSG="Provisional or date report completed required. Cannot release."
+30 DO EN^DDIOL(LRMSG,"","!!")
KILL LRMSG
+31 SET LRQUIT=1
End DoDot:2
End DoDot:1
IF LRQUIT
QUIT
+32 IF 'LRPAT
IF 'LRZ(2)
Begin DoDot:1
+33 WRITE $CHAR(7)
+34 SET LRMSG="Pathologist or Cytotechnologist entry missing. Cannot release."
+35 DO EN^DDIOL(LRMSG,"","!!")
KILL LRMSG
+36 SET LRQUIT=1
End DoDot:1
+37 IF 'LRZ(2)
DO SUPCHK^LRAPR1
+38 IF LRQUIT
QUIT
+39 IF LRZ(2)
Begin DoDot:1
+40 WRITE $CHAR(7)
+41 SET LRMSG="Report "
IF LRZ(2)=1
SET LRMSG=LRMSG_"has already been "
+42 SET LRMSG=LRMSG_"released "
+43 SET Y=LRZ(2)
DO DD^%DT
IF LRZ(2)>1
SET LRMSG=LRMSG_Y
+44 IF LRZ(1)'=""
SET LRMSG=LRMSG_" by "_LRZ(1.1)
+45 DO EN^DDIOL(LRMSG,"","!!")
KILL LRMSG
+46 IF 'LRAU
SET LRQUIT=1
End DoDot:1
IF LRQUIT
QUIT
+47 ;KLL-DON'T ALLOW UNRELEASE IF REPT COMPLETED DATE EXISTS FOR AU
+48 IF LRZ(2)
IF LRZ
SET LRQUIT=1
+49 SET LRMSG=""
DO EN^DDIOL(LRMSG,"","!")
KILL LRMSG
+50 ;Don't allow unrelease if supp report not released for AU
+51 IF LRZ(2)
IF 'LRZ
Begin DoDot:1
+52 SET LRSRLST=$PIECE($GET(^LR(LRDFN,84,0)),"^",4)
+53 IF 'LRSRLST
QUIT
+54 SET LRSRREL=$PIECE($GET(^LR(LRDFN,84,LRSRLST,0)),"^",2)
+55 IF 'LRSRREL
Begin DoDot:2
+56 SET LRMSG=$CHAR(7)_"Supplementary report has not been released. "
+57 SET LRMSG=LRMSG_"Cannot use this option."
+58 DO EN^DDIOL(LRMSG,"","!!")
KILL LRMSG
+59 SET LRQUIT=1
End DoDot:2
End DoDot:1
+60 IF LRQUIT
QUIT
+61 IF LRZ(2)
IF 'LRZ
Begin DoDot:1
+62 SET DIR(0)="YA"
SET DIR("B")="NO"
+63 SET DIR("A")="Unrelease report? "
+64 DO ^DIR
+65 IF 'Y
SET LRQUIT=1
End DoDot:1
+66 QUIT
BROWSE ;Display the report in the browser
+1 SET DIR(0)="YA"
SET DIR("B")="YES"
+2 SET DIR("A")="View the report before signing? "
+3 DO ^DIR
IF 'Y
QUIT
+4 KILL ^TMP("LRAPBR",$JOB)
+5 SET LRMSG="*** Report is being processed. One moment please. ***"
+6 SET LRMSG=$$CJ^XLFSTR(LRMSG,IOM)
+7 DO EN^DDIOL(LRMSG,"","!!")
+8 DO INIT^LRAPBR(LRAA,LRSS,LRI,LRDFN,LRO(68),LRAU,0)
+9 QUIT
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
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 IF LRDPF'=62.3
IF LRDPF'[67
SET LRMSG=LRMSG_" for storage in TIU"
+5 SET LRMSG=LRMSG_". One moment please. ***"
+6 SET LRMSG=$$CJ^XLFSTR(LRMSG,IOM)
+7 DO EN^DDIOL(LRMSG,"","!!")
+8 DO INIT^LRAPBR(LRAA,LRSS,LRI,LRDFN,LRO(68),LRAU,1,LRNTIME)
+9 QUIT
RELEASE ;
+1 IF 'LRAU
Begin DoDot:1
+2 SET LRRC=$$GET1^DIQ(LRSF,LRIENS,.1,"I")
+3 IF LRCAPA
IF 'LRAU
DO C^LRAPSWK
+4 ;Store REPORT RELEASE DATE/TIME and RELEASED BY
+5 SET DR=".11////^S X=LRNTIME;.13////^S X=DUZ"
+6 SET DIE="^LR(LRDFN,LRSS,"
SET DA=LRI
SET DA(1)=LRDFN
+7 ;KLL-Set LRA for xref call to LRWOMEN
+8 SET LRA=^LR(LRDFN,LRSS,LRI,0)
End DoDot:1
+9 IF LRAU
Begin DoDot:1
+10 ;Store AUTOPSY RELEASE DATE/TIME and AUTOPSY RELEASED BY
+11 SET DR="14.7////^S X=$S(LRZ(2):""@"",1:LRNTIME);"
+12 SET DR=DR_"14.8////^S X=$S(LRZ(2):""@"",1:DUZ);"
+13 SET DIE="^LR("
SET DA=LRDFN
End DoDot:1
+14 DO CK^LRU
+15 IF $DATA(LR("CK"))
QUIT
+16 DO ^DIE
+17 ; D UPDATE^LRPXRM(LRDFN,$G(LRSS,"AU"),$G(LRI)) ; IHS/OIT/MKK - LR*5.2*1030 - RPMS Does NOT use Clinical Reminders
+18 ; IHS/MSC/MKK - LR*5.2*1031
IF $$PATCH^BLRUTIL4("PXRM*1.5*12")
DO UPDATE^LRPXRM(LRDFN,$GET(LRSS,"AU"),$GET(LRI))
+19 DO FRE^LRU
+20 SET LRMSG="*** Report "
+21 IF LRZ(2)
IF LRAU
SET LRMSG=LRMSG_"un"
+22 SET LRMSG=LRMSG_"released. ***"
+23 DO EN^DDIOL($$CJ^XLFSTR(LRMSG,IOM),"","!!")
KILL MSG
+24 IF "CYSP"[LRSS
IF LRCAPA
DO WKLD^LRAPRES2
QUIT
+25 ;I LRCAPA,"SPCYEM"[LRSS,LRD(1)'="","MBA"[LRD(1) D C1^LRAPSWK
+26 QUIT
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 ;Store pointer & checksum information in the LAB DATA (#63) file
+52 SET LRIENS="+1,"_$SELECT('LRAU:LRI_",",1:"")_LRDFN_","
+53 SET LRFILE=$SELECT(LRSS="SP":63.19,LRSS="CY":63.47,LRSS="EM":63.49,1:"")
+54 IF LRFILE=""
SET LRFILE=$SELECT(LRSS="AU":63.101,1:"")
+55 SET LRFDA(1,LRFILE,LRIENS,.01)=LRNTIME
+56 SET LRFDA(1,LRFILE,LRIENS,1)=+LRTIUPTR
+57 SET LRFDA(1,LRFILE,LRIENS,2)=LRCHKSUM
+58 DO UPDATE^DIE("","LRFDA(1)")
+59 DO RETRACT^LRAPRES1(LRDFN,LRSS,LRI,+LRTIUPTR)
+60 QUIT
