LRAPRES.m

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

MENU ;

 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 

MENU      ;

 +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))