LRAPR ;DALOI/STAFF - ANAT RELEASE REPORTS ;12/09/11 10:20
;;5.2;LAB SERVICE;**72,248,259,317,365,350,490**;Sep 27, 1994;Build 2
;
N LRESSW,LRX,%,X,Y
D SWITCH
I +LRESSW D Q
. D ^LRAPRES
. D END
W !!?27,"Release Pathology Reports",!!
D A
I '$D(LRSS) D END Q
I LRCAPA D G:'$D(X) END
. S X=$S(LRSS="CY":"CYTOLOGY REPORTING",LRSS="SP":"SURGICAL PATH REPORTING",1:"")
. D:X]"" X^LRUWK
I LRSS="AU" D B Q
;
S LRSOP="Z"
S DR="S LRX=^LR(LRDFN,LRSS,LRI,0),LRZ=$P(LRX,U,3),LRZ(1)=$P(LRX,U,13),"
S DR=DR_"LRZ(2)=$P(LRX,U,11),LRZ(3)=$P(LRX,U,2);"
S DR=DR_"I 'LRZ W $C(7),!,""No date report completed. "
S DR=DR_"Cannot release."" S Y=0;"
S DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;"
S DR=DR_"I LRZ(2) D RINFO^LRAPR S Y=0;"
;
; Perform supp edit regardless if date rept released since supp rpt is added to released report
S DR=DR_"D SUPCHK^LRAPR;"
S DR=DR_"S DIR(0)=""YA"",DIR(""A"")=""Release report? """
S DR=DR_",DIR(""B"")=""NO"" D ^DIR K:Y Y S:$D(Y) Y=0;"
S DR=DR_".11////^S X=$$NOW^XLFDT;.13////^S X=DUZ;"
S DR=DR_"S LRELSD=1 W !!,""Report released..."""
D ^LRAPDA
D END
Q
;
;
B ; Autopsy
S LRSOP="Z"
S DR="S LRX=$G(^LR(LRDFN,""AU"")) I LRX="""" S Y=0;"
S DR=DR_"S LRZ=$P(LRX,U,3),LRZ(1)=$P(LRX,U,16),LRZ(2)=$P(LRX,U,15),"
;
; KLL-LRZ(3)=SR PATHOLOGIST,LRZ(4)=PROVISIONAL DATE
S DR=DR_"LRZ(3)=$P(LRX,U,10),LRZ(4)=$P(LRX,U,17);"
;
; KLL-PROVISIONAL OR DATE REPORT COMPLETED IS REQUIRED
S DR=DR_"I 'LRZ(4),'LRZ W $C(7),!,""Provisional date or date report completed required. "
S DR=DR_"Cannot release."" S Y=0;"
S DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;"
S DR=DR_"I LRZ(2) D RINFO^LRAPR S:LRZ Y=0;"
; Perform supp edit regardless if date rept released since supp rpt is added to released report
S DR=DR_"D SUPCHK^LRAPR;"
S DR=DR_"D RELEASE^LRAPR;"
S DR=DR_"S LRDTE=$$NOW^XLFDT;"
S DR=DR_"14.7////^S X=$S(LRZ(2):""@"",1:LRDTE);"
S DR=DR_"14.8////^S X=$S(LRZ(2):""@"",1:DUZ);"
S DR=DR_"S:'LRZ(2) LRELSD=1 "
S DR=DR_"W !!,""Report "" W:LRZ(2) ""un"" W ""released..."";K LRDTE"
D ^LRAPDA
D END
Q
;
;
EN ; Supplementary Report Entry Point
N LRESSW
D SWITCH
W !!?20,"Release Supplementary Pathology Reports",!
;D A
; Section prompt replaces the line above
S LRQUIT=0,LRDATA=0
D SECTION^LRAPRES
I '$D(LRSS) D END Q
; Verify User ID has access to release supp. reports
S LREND=0
I LRESSW D CLSSCHK^LRAPRES1(DUZ,.LREND)
Q:LREND
;
N DIR,DIRUT,Y
W !!
S DIR(0)="Y",DIR("A")="Data entry for "_LRH(0)_" "
S DIR("B")="Yes"
D ^DIR K DIR
G:$G(DIRUT) END
I Y=0 D G:Y<1 END
. N DIR
. S DIR(0)="D0^:DT:E"
. D ^DIR
. Q:Y<1
. S LRAD=$E(Y,1,3)_"0000",LRH(0)=$E(Y,1,3)+1700
;
I '$D(^LRO(68,LRAA,1,LRAD,0)) D Q
. W $C(7),!!,"NO ",LRAA(1)," ACCESSIONS IN FILE FOR ",LRH(0),!!
;
W K X,Y,LR("CK")
D LOOKUP^LRAPUTL(.LRDATA,LRH(0),LRO(68),LRSS,LRAD,LRAA)
I LRDATA=-1!('$G(LRSEL))!('$D(LRI)) S LREND=1 G END
S LRIDT=LRI
I LRSEL=3 D DIE
D REST
G W
;
;
REST W " for ",LRH(0)
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
. W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)
. W " not in ACCESSION file",!!
S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRLLOC=$P(X,"^",7),LRDFN=+X,LRODT=$P(X,"^",4),LRSN=$P(X,"^",5)
Q:'$D(^LR(LRDFN,0)) S X=^(0) D ^LRUP
;W !,LRP," ID: ",SSN
;I LRSS'="AU" D
;.S LRI=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)
;.W !,"Specimen(s):"
;.S X=0 F S X=$O(^LR(LRDFN,LRSS,LRI,.1,X)) Q:'X D
;..I $D(^LR(LRDFN,LRSS,LRI,.1,X,0)),$L(^(0)) W !,^(0)
;
;
DIE ; Define default supplementary report
N LRFILE,LRIENS,LRIENS1,LRX,LRRLS,LRFDA,LRLKFL,LRDA,LRQUIT,LRNOSP
N LRMSG,LRSRFL,LRFDA2,LRSRMD,LRRLM
S DIC("B")="",LRNOSP=0
I LRSS'="AU" D
. S LRFILE=+$$GET1^DID(LRSF,1.2,"","SPECIFIER")
. S LRIENS1=LRI_","_LRDFN_","
. I '+$P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),"^",4) S LRNOSP=1 Q
. S LRX=0 F S LRX=$O(^LR(LRDFN,LRSS,LRI,1.2,LRX)) Q:'LRX D
. . S LRIENS=LRX_","_LRIENS1
. . S LRSRFL=$$GET1^DIQ(LRFILE,LRIENS,.02,"I")
. . ; LRSRMD-set to 1 if supp rpt modified and requires release
. . S LRSRMD=$$GET1^DIQ(LRFILE,LRIENS,.03,"I")
. . Q:LRSRFL&('LRSRMD)
. . S DIC("B")=$$GET1^DIQ(LRFILE,LRIENS,.01,"I")
I LRSS="AU" D
. S LRFILE=63.324,LRIENS1=LRDFN_","
. I '+$P($G(^LR(LRDFN,84,0)),"^",4) S LRNOSP=1 Q
. S LRX=0 F S LRX=$O(^LR(LRDFN,84,LRX)) Q:'LRX D
. . S LRIENS=LRX_","_LRIENS1
. . S LRSRFL=$$GET1^DIQ(LRFILE,LRIENS,.02,"I")
. . ; LRSRMD-set to 1 if supp rpt modified and requires release
. . S LRSRMD=$$GET1^DIQ(LRFILE,LRIENS,.03,"I")
. . Q:LRSRFL&('LRSRMD)
. . S DIC("B")=$$GET1^DIQ(LRFILE,LRIENS,.01,"I")
I LRNOSP D Q
. K LRMSG
. S LRMSG=$C(7)_"No supplementary reports exist for this accession."
. D EN^DDIOL(LRMSG,"","!!")
I '$G(DIC("B")) D Q
. K LRMSG
. S LRMSG=$C(7)_"All supplementary reports have been released."
. D EN^DDIOL(LRMSG,"","!!")
;
DIE1 ;
S (LRQUIT,LRRLM)=0
F D Q:LRQUIT
. W !
. N DIC,DIR,DIRUT,DIROUT,DTOUT,X,Y
. S:LRSS="AU" (LRLKFL,DIC)="^LR(LRDFN,84,"
. S:LRSS'="AU" (LRLKFL,DIC)="^LR(LRDFN,LRSS,LRI,1.2,"
. S DIC("A")="Select SUPPLEMENTARY REPORT DATE: "
. S DIC(0)="AEQM"
. D ^DIC K DIC
. I Y<1 S LRQUIT=1 Q
. S LRDA=+Y
. S LRIENS=LRDA_","_LRIENS1
. S LRRLS=+$$GET1^DIQ(LRFILE,LRIENS,.02,"I")
. ; If E-Sign OFF, must check LRRLM. LRRLM=1 if supp rpt has been modified and requires release
. S LRRLM=+$$GET1^DIQ(LRFILE,LRIENS,.03,"I")
. I LRESSW,LRRLS D Q
. . W !!,"This supplementary report has already been released.",!
. I 'LRESSW,LRRLS D Q:'LRRLM
. . I 'LRRLM W !!,"This supplementary report has already been released.",!
. W !
. I LRESSW D Q
. . N DIR,DIRUT,DIROUT,DTOUT,X,Y
. . D ESIG Q:LRQUIT
. . D UPDATE
. S DIR("A")="Release supplementary report",DIR(0)="Y",DIR("B")="NO"
. D ^DIR K DIR
. I $D(DIRUT) S LRQUIT=1 Q
. I Y'=1 Q
. D UPDATE
. ; If E-sign switch OFF and orig report released, must verify all supp reports released before release main report.
. I LRCKREL,'LRESSW D CHKSUP^LRAPR1
Q
;
;
A D ^LRAP G:'$D(Y) END
Q
;
;
C ;
S LRDICS="SPCYEM" D ^LRAP
G:'$D(Y) END
Q
;
;
S ; from LRAPDA
S LRK=$P(^LR(LRDFN,LRSS,LRI,0),"^",11) Q:'LRK S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)) ^(0)="^68.04PA^^"
Q:$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0))
S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)=LRT_"^50^^"_DUZ_"^"_LRK
S X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0),^(0)=$P(X,"^",1,2)_"^"_LRT_"^"_($P(X,"^",4)+1)
S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)) ^(0)="^68.14P^^"
S C=0 F S C=$O(LRT(C)) Q:'C D CAP
S ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
Q
;
;
CAP ; Store workload
S ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)=C_"^1^0^0^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA
S X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0),^(0)=$P(X,"^",1,2)_"^"_C_"^"_($P(X,"^",4)+1)
Q
;
;
SWITCH ; Check to see if electronic signature is enabled
D GETDATA^LRAPESON(.LRESSW)
Q
;
;
ESIG ; Prompt for electronic signature
S LRQUIT=0
D SIG^XUSESIG
I X1="" D
. W " SIGNATURE NOT VERIFIED"
. S LRQUIT=1
Q
;
;
UPDATE ;
S LRLKFL=LRLKFL_LRDA_",0)"
L +@(LRLKFL):DILOCKTM I '$T D Q
. S LRMSG="This record is locked by another user. Please wait and try again."
. D EN^DDIOL(LRMSG,"","!!")
S LRFDA(LRFILE,LRIENS,.02)=1
S LRFDA2(LRFILE,LRIENS,.02)="@" ;Set but don't file unless unrel needed
;
; File signer ID and Date/time of released supp report
D CKSIGNR^LRAPR1
D FILE^DIE("","LRFDA")
W "...Released"
L -@(LRLKFL)
;
I LRSS="AU" S LRA=^LR(LRDFN,"AU"),LRAC=$$GET1^DIQ(63,LRDFN_",",14,"I"),LRI=$P(LRA,U)
;
I LRSS'="AU" S LRA=^LR(LRDFN,LRSS,LRI,0),LRAC=$$GET1^DIQ(LRSF,LRIENS,.06,"I")
;
D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
;
; If all supp reports released, and E-Sign switch is ON, proceed to release main report
S LRCKREL=0
S:LRSS'="AU" LRCKREL=$P(^LR(LRDFN,LRSS,LRI,0),"^",11)
S:LRSS="AU" LRCKREL=$P(^LR(LRDFN,LRSS),"^",15)
;
I LRCKREL,LRESSW D RELMN Q
;
; Check and send LEDI report back to submitting (collecting) site.
; If RELMN called above then LEDI checked performed during that call, calls RELEASE^LRAPRES.
I LRSS'="AU" D LEDI^LRVR0
;
Q
;
;
SUPCHK ; Check for unreleased supplementary reports
N LRSR,LRSR1,LRSR2
S LRSR=0,LRSR1=1
I LRSS'="AU" D
. Q:'+$P($G(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4)
. F S LRSR=$O(^LR(LRDFN,LRSS,LRI,1.2,LRSR)) Q:LRSR'>0!('LRSR1) D
. . S LRSR1=+$P(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U,2)
. . I 'LRSR1 D
. . . S Y=+$P(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U)
. . . S LRSR2=$$FMTE^XLFDT(Y,1)
I LRSS="AU" D
. Q:'+$P($G(^LR(LRDFN,84,0)),U,4)
. F S LRSR=$O(^LR(LRDFN,84,LRSR)) Q:LRSR'>0!('LRSR1) D
. . S LRSR1=+$P(^LR(LRDFN,84,LRSR,0),U,2)
. . I 'LRSR1 D
. . . S Y=+$P(^LR(LRDFN,84,LRSR,0),U)
. . . S LRSR2=$$FMTE^XLFDT(Y,1)
I 'LRSR1 D
. W $C(7),!,"Supplementary report "_LRSR2_" has not been released. "
. W "Cannot release."
. S Y=0
Q
;
;
RINFO ; Display release information
W $C(7),!,"Report "
W:LRZ(2)=1 "has already been "
W "released "
W:LRZ(2)>1 $$FMTE^XLFDT(LRZ(2),1)
W:LRZ(1)'="" " by "_$P($G(^VA(200,LRZ(1),0)),U)
Q
;
;
NMPATH ; Check for missing pathologist name
I 'LRZ(3) D
. W $C(7),!,"Pathologist name missing. Cannot release."
. S Y=0
Q
;
;
RELEASE ; Prompt for release/unrelease
N DIR
W ! S DIR(0)="YA",DIR("B")="NO"
S:LRZ(2) DIR("A")="Unrelease report? "
S:'LRZ(2) DIR("A")="Release report? "
D ^DIR
K:Y Y
I $D(Y) S Y=0
Q
;
;
RELMN ; Allow release of main report as long as all supp reports are released, and signer is same person for main and supp report(s)
; Make sure all supp reports signed out
S LRQT=0
D RELCHK^LRAPR1
Q:LRQT
;
; Continue with electronic signature and storage in TIU
S LRAU=$S(LRSS="AU":1,1:0)
I 'LRAU D
. S LRPAT=+$$GET1^DIQ(LRSF,LRIENS1,.02,"I")
. S LRZ=$$GET1^DIQ(LRSF,LRIENS1,.03,"I")
. S LRZ(1)=$$GET1^DIQ(LRSF,LRIENS1,.13,"I")
. S LRZ(1.1)=$$GET1^DIQ(LRSF,LRIENS1,.13)
. S LRZ(2)=$$GET1^DIQ(LRSF,LRIENS1,.11,"I")
I LRAU D
. 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")
. S LRI=""
W !!,?25,"*** Main Report Release ***",!
S LRNTIME=$$NOW^XLFDT
D TIUPREP^LRAPRES
D STORE^LRAPRES
I LRQUIT D FILE^DIE("","LRFDA2") Q
D UNRLSE^LRAPR1
D RELEASE^LRAPRES
I LRQUIT D FILE^DIE("","LRFDA2") Q
D OERR^LR7OB63D
S LRQUIT=1
Q
;
;
END ;
D V^LRU
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPR 10582 printed Sep 23, 2025@19:43:46 Page 2
LRAPR ;DALOI/STAFF - ANAT RELEASE REPORTS ;12/09/11 10:20
+1 ;;5.2;LAB SERVICE;**72,248,259,317,365,350,490**;Sep 27, 1994;Build 2
+2 ;
+3 NEW LRESSW,LRX,%,X,Y
+4 DO SWITCH
+5 IF +LRESSW
Begin DoDot:1
+6 DO ^LRAPRES
+7 DO END
End DoDot:1
QUIT
+8 WRITE !!?27,"Release Pathology Reports",!!
+9 DO A
+10 IF '$DATA(LRSS)
DO END
QUIT
+11 IF LRCAPA
Begin DoDot:1
+12 SET X=$SELECT(LRSS="CY":"CYTOLOGY REPORTING",LRSS="SP":"SURGICAL PATH REPORTING",1:"")
+13 if X]""
DO X^LRUWK
End DoDot:1
if '$DATA(X)
GOTO END
+14 IF LRSS="AU"
DO B
QUIT
+15 ;
+16 SET LRSOP="Z"
+17 SET DR="S LRX=^LR(LRDFN,LRSS,LRI,0),LRZ=$P(LRX,U,3),LRZ(1)=$P(LRX,U,13),"
+18 SET DR=DR_"LRZ(2)=$P(LRX,U,11),LRZ(3)=$P(LRX,U,2);"
+19 SET DR=DR_"I 'LRZ W $C(7),!,""No date report completed. "
+20 SET DR=DR_"Cannot release."" S Y=0;"
+21 SET DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;"
+22 SET DR=DR_"I LRZ(2) D RINFO^LRAPR S Y=0;"
+23 ;
+24 ; Perform supp edit regardless if date rept released since supp rpt is added to released report
+25 SET DR=DR_"D SUPCHK^LRAPR;"
+26 SET DR=DR_"S DIR(0)=""YA"",DIR(""A"")=""Release report? """
+27 SET DR=DR_",DIR(""B"")=""NO"" D ^DIR K:Y Y S:$D(Y) Y=0;"
+28 SET DR=DR_".11////^S X=$$NOW^XLFDT;.13////^S X=DUZ;"
+29 SET DR=DR_"S LRELSD=1 W !!,""Report released..."""
+30 DO ^LRAPDA
+31 DO END
+32 QUIT
+33 ;
+34 ;
B ; Autopsy
+1 SET LRSOP="Z"
+2 SET DR="S LRX=$G(^LR(LRDFN,""AU"")) I LRX="""" S Y=0;"
+3 SET DR=DR_"S LRZ=$P(LRX,U,3),LRZ(1)=$P(LRX,U,16),LRZ(2)=$P(LRX,U,15),"
+4 ;
+5 ; KLL-LRZ(3)=SR PATHOLOGIST,LRZ(4)=PROVISIONAL DATE
+6 SET DR=DR_"LRZ(3)=$P(LRX,U,10),LRZ(4)=$P(LRX,U,17);"
+7 ;
+8 ; KLL-PROVISIONAL OR DATE REPORT COMPLETED IS REQUIRED
+9 SET DR=DR_"I 'LRZ(4),'LRZ W $C(7),!,""Provisional date or date report completed required. "
+10 SET DR=DR_"Cannot release."" S Y=0;"
+11 SET DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;"
+12 SET DR=DR_"I LRZ(2) D RINFO^LRAPR S:LRZ Y=0;"
+13 ; Perform supp edit regardless if date rept released since supp rpt is added to released report
+14 SET DR=DR_"D SUPCHK^LRAPR;"
+15 SET DR=DR_"D RELEASE^LRAPR;"
+16 SET DR=DR_"S LRDTE=$$NOW^XLFDT;"
+17 SET DR=DR_"14.7////^S X=$S(LRZ(2):""@"",1:LRDTE);"
+18 SET DR=DR_"14.8////^S X=$S(LRZ(2):""@"",1:DUZ);"
+19 SET DR=DR_"S:'LRZ(2) LRELSD=1 "
+20 SET DR=DR_"W !!,""Report "" W:LRZ(2) ""un"" W ""released..."";K LRDTE"
+21 DO ^LRAPDA
+22 DO END
+23 QUIT
+24 ;
+25 ;
EN ; Supplementary Report Entry Point
+1 NEW LRESSW
+2 DO SWITCH
+3 WRITE !!?20,"Release Supplementary Pathology Reports",!
+4 ;D A
+5 ; Section prompt replaces the line above
+6 SET LRQUIT=0
SET LRDATA=0
+7 DO SECTION^LRAPRES
+8 IF '$DATA(LRSS)
DO END
QUIT
+9 ; Verify User ID has access to release supp. reports
+10 SET LREND=0
+11 IF LRESSW
DO CLSSCHK^LRAPRES1(DUZ,.LREND)
+12 if LREND
QUIT
+13 ;
+14 NEW DIR,DIRUT,Y
+15 WRITE !!
+16 SET DIR(0)="Y"
SET DIR("A")="Data entry for "_LRH(0)_" "
+17 SET DIR("B")="Yes"
+18 DO ^DIR
KILL DIR
+19 if $GET(DIRUT)
GOTO END
+20 IF Y=0
Begin DoDot:1
+21 NEW DIR
+22 SET DIR(0)="D0^:DT:E"
+23 DO ^DIR
+24 if Y<1
QUIT
+25 SET LRAD=$EXTRACT(Y,1,3)_"0000"
SET LRH(0)=$EXTRACT(Y,1,3)+1700
End DoDot:1
if Y<1
GOTO END
+26 ;
+27 IF '$DATA(^LRO(68,LRAA,1,LRAD,0))
Begin DoDot:1
+28 WRITE $CHAR(7),!!,"NO ",LRAA(1)," ACCESSIONS IN FILE FOR ",LRH(0),!!
End DoDot:1
QUIT
+29 ;
W KILL X,Y,LR("CK")
+1 DO LOOKUP^LRAPUTL(.LRDATA,LRH(0),LRO(68),LRSS,LRAD,LRAA)
+2 IF LRDATA=-1!('$GET(LRSEL))!('$DATA(LRI))
SET LREND=1
GOTO END
+3 SET LRIDT=LRI
+4 IF LRSEL=3
DO DIE
+5 DO REST
+6 GOTO W
+7 ;
+8 ;
REST WRITE " for ",LRH(0)
+1 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
Begin DoDot:1
+2 WRITE $CHAR(7),!!,"Accession # ",LRAN," for ",LRH(0)
+3 WRITE " not in ACCESSION file",!!
End DoDot:1
QUIT
+4 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRLLOC=$PIECE(X,"^",7)
SET LRDFN=+X
SET LRODT=$PIECE(X,"^",4)
SET LRSN=$PIECE(X,"^",5)
+5 if '$DATA(^LR(LRDFN,0))
QUIT
SET X=^(0)
DO ^LRUP
+6 ;W !,LRP," ID: ",SSN
+7 ;I LRSS'="AU" D
+8 ;.S LRI=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)
+9 ;.W !,"Specimen(s):"
+10 ;.S X=0 F S X=$O(^LR(LRDFN,LRSS,LRI,.1,X)) Q:'X D
+11 ;..I $D(^LR(LRDFN,LRSS,LRI,.1,X,0)),$L(^(0)) W !,^(0)
+12 ;
+13 ;
DIE ; Define default supplementary report
+1 NEW LRFILE,LRIENS,LRIENS1,LRX,LRRLS,LRFDA,LRLKFL,LRDA,LRQUIT,LRNOSP
+2 NEW LRMSG,LRSRFL,LRFDA2,LRSRMD,LRRLM
+3 SET DIC("B")=""
SET LRNOSP=0
+4 IF LRSS'="AU"
Begin DoDot:1
+5 SET LRFILE=+$$GET1^DID(LRSF,1.2,"","SPECIFIER")
+6 SET LRIENS1=LRI_","_LRDFN_","
+7 IF '+$PIECE($GET(^LR(LRDFN,LRSS,LRI,1.2,0)),"^",4)
SET LRNOSP=1
QUIT
+8 SET LRX=0
FOR
SET LRX=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRX))
if 'LRX
QUIT
Begin DoDot:2
+9 SET LRIENS=LRX_","_LRIENS1
+10 SET LRSRFL=$$GET1^DIQ(LRFILE,LRIENS,.02,"I")
+11 ; LRSRMD-set to 1 if supp rpt modified and requires release
+12 SET LRSRMD=$$GET1^DIQ(LRFILE,LRIENS,.03,"I")
+13 if LRSRFL&('LRSRMD)
QUIT
+14 SET DIC("B")=$$GET1^DIQ(LRFILE,LRIENS,.01,"I")
End DoDot:2
End DoDot:1
+15 IF LRSS="AU"
Begin DoDot:1
+16 SET LRFILE=63.324
SET LRIENS1=LRDFN_","
+17 IF '+$PIECE($GET(^LR(LRDFN,84,0)),"^",4)
SET LRNOSP=1
QUIT
+18 SET LRX=0
FOR
SET LRX=$ORDER(^LR(LRDFN,84,LRX))
if 'LRX
QUIT
Begin DoDot:2
+19 SET LRIENS=LRX_","_LRIENS1
+20 SET LRSRFL=$$GET1^DIQ(LRFILE,LRIENS,.02,"I")
+21 ; LRSRMD-set to 1 if supp rpt modified and requires release
+22 SET LRSRMD=$$GET1^DIQ(LRFILE,LRIENS,.03,"I")
+23 if LRSRFL&('LRSRMD)
QUIT
+24 SET DIC("B")=$$GET1^DIQ(LRFILE,LRIENS,.01,"I")
End DoDot:2
End DoDot:1
+25 IF LRNOSP
Begin DoDot:1
+26 KILL LRMSG
+27 SET LRMSG=$CHAR(7)_"No supplementary reports exist for this accession."
+28 DO EN^DDIOL(LRMSG,"","!!")
End DoDot:1
QUIT
+29 IF '$GET(DIC("B"))
Begin DoDot:1
+30 KILL LRMSG
+31 SET LRMSG=$CHAR(7)_"All supplementary reports have been released."
+32 DO EN^DDIOL(LRMSG,"","!!")
End DoDot:1
QUIT
+33 ;
DIE1 ;
+1 SET (LRQUIT,LRRLM)=0
+2 FOR
Begin DoDot:1
+3 WRITE !
+4 NEW DIC,DIR,DIRUT,DIROUT,DTOUT,X,Y
+5 if LRSS="AU"
SET (LRLKFL,DIC)="^LR(LRDFN,84,"
+6 if LRSS'="AU"
SET (LRLKFL,DIC)="^LR(LRDFN,LRSS,LRI,1.2,"
+7 SET DIC("A")="Select SUPPLEMENTARY REPORT DATE: "
+8 SET DIC(0)="AEQM"
+9 DO ^DIC
KILL DIC
+10 IF Y<1
SET LRQUIT=1
QUIT
+11 SET LRDA=+Y
+12 SET LRIENS=LRDA_","_LRIENS1
+13 SET LRRLS=+$$GET1^DIQ(LRFILE,LRIENS,.02,"I")
+14 ; If E-Sign OFF, must check LRRLM. LRRLM=1 if supp rpt has been modified and requires release
+15 SET LRRLM=+$$GET1^DIQ(LRFILE,LRIENS,.03,"I")
+16 IF LRESSW
IF LRRLS
Begin DoDot:2
+17 WRITE !!,"This supplementary report has already been released.",!
End DoDot:2
QUIT
+18 IF 'LRESSW
IF LRRLS
Begin DoDot:2
+19 IF 'LRRLM
WRITE !!,"This supplementary report has already been released.",!
End DoDot:2
if 'LRRLM
QUIT
+20 WRITE !
+21 IF LRESSW
Begin DoDot:2
+22 NEW DIR,DIRUT,DIROUT,DTOUT,X,Y
+23 DO ESIG
if LRQUIT
QUIT
+24 DO UPDATE
End DoDot:2
QUIT
+25 SET DIR("A")="Release supplementary report"
SET DIR(0)="Y"
SET DIR("B")="NO"
+26 DO ^DIR
KILL DIR
+27 IF $DATA(DIRUT)
SET LRQUIT=1
QUIT
+28 IF Y'=1
QUIT
+29 DO UPDATE
+30 ; If E-sign switch OFF and orig report released, must verify all supp reports released before release main report.
+31 IF LRCKREL
IF 'LRESSW
DO CHKSUP^LRAPR1
End DoDot:1
if LRQUIT
QUIT
+32 QUIT
+33 ;
+34 ;
A DO ^LRAP
if '$DATA(Y)
GOTO END
+1 QUIT
+2 ;
+3 ;
C ;
+1 SET LRDICS="SPCYEM"
DO ^LRAP
+2 if '$DATA(Y)
GOTO END
+3 QUIT
+4 ;
+5 ;
S ; from LRAPDA
+1 SET LRK=$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",11)
if 'LRK
QUIT
if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
SET ^(0)="^68.04PA^^"
+2 if $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0))
QUIT
+3 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,0)=LRT_"^50^^"_DUZ_"^"_LRK
+4 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRT_"^"_($PIECE(X,"^",4)+1)
+5 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0))
SET ^(0)="^68.14P^^"
+6 SET C=0
FOR
SET C=$ORDER(LRT(C))
if 'C
QUIT
DO CAP
+7 SET ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""
+8 QUIT
+9 ;
+10 ;
CAP ; Store workload
+1 SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)=C_"^1^0^0^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA
+2 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_C_"^"_($PIECE(X,"^",4)+1)
+3 QUIT
+4 ;
+5 ;
SWITCH ; Check to see if electronic signature is enabled
+1 DO GETDATA^LRAPESON(.LRESSW)
+2 QUIT
+3 ;
+4 ;
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
+6 QUIT
+7 ;
+8 ;
UPDATE ;
+1 SET LRLKFL=LRLKFL_LRDA_",0)"
+2 LOCK +@(LRLKFL):DILOCKTM
IF '$TEST
Begin DoDot:1
+3 SET LRMSG="This record is locked by another user. Please wait and try again."
+4 DO EN^DDIOL(LRMSG,"","!!")
End DoDot:1
QUIT
+5 SET LRFDA(LRFILE,LRIENS,.02)=1
+6 ;Set but don't file unless unrel needed
SET LRFDA2(LRFILE,LRIENS,.02)="@"
+7 ;
+8 ; File signer ID and Date/time of released supp report
+9 DO CKSIGNR^LRAPR1
+10 DO FILE^DIE("","LRFDA")
+11 WRITE "...Released"
+12 LOCK -@(LRLKFL)
+13 ;
+14 IF LRSS="AU"
SET LRA=^LR(LRDFN,"AU")
SET LRAC=$$GET1^DIQ(63,LRDFN_",",14,"I")
SET LRI=$PIECE(LRA,U)
+15 ;
+16 IF LRSS'="AU"
SET LRA=^LR(LRDFN,LRSS,LRI,0)
SET LRAC=$$GET1^DIQ(LRSF,LRIENS,.06,"I")
+17 ;
+18 DO MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
+19 ;
+20 ; If all supp reports released, and E-Sign switch is ON, proceed to release main report
+21 SET LRCKREL=0
+22 if LRSS'="AU"
SET LRCKREL=$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",11)
+23 if LRSS="AU"
SET LRCKREL=$PIECE(^LR(LRDFN,LRSS),"^",15)
+24 ;
+25 IF LRCKREL
IF LRESSW
DO RELMN
QUIT
+26 ;
+27 ; Check and send LEDI report back to submitting (collecting) site.
+28 ; If RELMN called above then LEDI checked performed during that call, calls RELEASE^LRAPRES.
+29 IF LRSS'="AU"
DO LEDI^LRVR0
+30 ;
+31 QUIT
+32 ;
+33 ;
SUPCHK ; Check for unreleased supplementary reports
+1 NEW LRSR,LRSR1,LRSR2
+2 SET LRSR=0
SET LRSR1=1
+3 IF LRSS'="AU"
Begin DoDot:1
+4 if '+$PIECE($GET(^LR(LRDFN,LRSS,LRI,1.2,0)),U,4)
QUIT
+5 FOR
SET LRSR=$ORDER(^LR(LRDFN,LRSS,LRI,1.2,LRSR))
if LRSR'>0!('LRSR1)
QUIT
Begin DoDot:2
+6 SET LRSR1=+$PIECE(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U,2)
+7 IF 'LRSR1
Begin DoDot:3
+8 SET Y=+$PIECE(^LR(LRDFN,LRSS,LRI,1.2,LRSR,0),U)
+9 SET LRSR2=$$FMTE^XLFDT(Y,1)
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF LRSS="AU"
Begin DoDot:1
+11 if '+$PIECE($GET(^LR(LRDFN,84,0)),U,4)
QUIT
+12 FOR
SET LRSR=$ORDER(^LR(LRDFN,84,LRSR))
if LRSR'>0!('LRSR1)
QUIT
Begin DoDot:2
+13 SET LRSR1=+$PIECE(^LR(LRDFN,84,LRSR,0),U,2)
+14 IF 'LRSR1
Begin DoDot:3
+15 SET Y=+$PIECE(^LR(LRDFN,84,LRSR,0),U)
+16 SET LRSR2=$$FMTE^XLFDT(Y,1)
End DoDot:3
End DoDot:2
End DoDot:1
+17 IF 'LRSR1
Begin DoDot:1
+18 WRITE $CHAR(7),!,"Supplementary report "_LRSR2_" has not been released. "
+19 WRITE "Cannot release."
+20 SET Y=0
End DoDot:1
+21 QUIT
+22 ;
+23 ;
RINFO ; Display release information
+1 WRITE $CHAR(7),!,"Report "
+2 if LRZ(2)=1
WRITE "has already been "
+3 WRITE "released "
+4 if LRZ(2)>1
WRITE $$FMTE^XLFDT(LRZ(2),1)
+5 if LRZ(1)'=""
WRITE " by "_$PIECE($GET(^VA(200,LRZ(1),0)),U)
+6 QUIT
+7 ;
+8 ;
NMPATH ; Check for missing pathologist name
+1 IF 'LRZ(3)
Begin DoDot:1
+2 WRITE $CHAR(7),!,"Pathologist name missing. Cannot release."
+3 SET Y=0
End DoDot:1
+4 QUIT
+5 ;
+6 ;
RELEASE ; Prompt for release/unrelease
+1 NEW DIR
+2 WRITE !
SET DIR(0)="YA"
SET DIR("B")="NO"
+3 if LRZ(2)
SET DIR("A")="Unrelease report? "
+4 if 'LRZ(2)
SET DIR("A")="Release report? "
+5 DO ^DIR
+6 if Y
KILL Y
+7 IF $DATA(Y)
SET Y=0
+8 QUIT
+9 ;
+10 ;
RELMN ; Allow release of main report as long as all supp reports are released, and signer is same person for main and supp report(s)
+1 ; Make sure all supp reports signed out
+2 SET LRQT=0
+3 DO RELCHK^LRAPR1
+4 if LRQT
QUIT
+5 ;
+6 ; Continue with electronic signature and storage in TIU
+7 SET LRAU=$SELECT(LRSS="AU":1,1:0)
+8 IF 'LRAU
Begin DoDot:1
+9 SET LRPAT=+$$GET1^DIQ(LRSF,LRIENS1,.02,"I")
+10 SET LRZ=$$GET1^DIQ(LRSF,LRIENS1,.03,"I")
+11 SET LRZ(1)=$$GET1^DIQ(LRSF,LRIENS1,.13,"I")
+12 SET LRZ(1.1)=$$GET1^DIQ(LRSF,LRIENS1,.13)
+13 SET LRZ(2)=$$GET1^DIQ(LRSF,LRIENS1,.11,"I")
End DoDot:1
+14 IF LRAU
Begin DoDot:1
+15 SET LRPAT=+$$GET1^DIQ(63,LRDFN_",",13.6,"I")
+16 SET LRZ=$$GET1^DIQ(63,LRDFN_",",13,"I")
+17 SET LRZ(1)=$$GET1^DIQ(63,LRDFN_",",14.8,"I")
+18 SET LRZ(1.1)=$$GET1^DIQ(63,LRDFN_",",14.8)
+19 SET LRZ(2)=$$GET1^DIQ(63,LRDFN_",",14.7,"I")
+20 SET LRI=""
End DoDot:1
+21 WRITE !!,?25,"*** Main Report Release ***",!
+22 SET LRNTIME=$$NOW^XLFDT
+23 DO TIUPREP^LRAPRES
+24 DO STORE^LRAPRES
+25 IF LRQUIT
DO FILE^DIE("","LRFDA2")
QUIT
+26 DO UNRLSE^LRAPR1
+27 DO RELEASE^LRAPRES
+28 IF LRQUIT
DO FILE^DIE("","LRFDA2")
QUIT
+29 DO OERR^LR7OB63D
+30 SET LRQUIT=1
+31 QUIT
+32 ;
+33 ;
END ;
+1 DO V^LRU
+2 QUIT
