source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPR.m@ 623

LRAPR ;AVAMC/REG/WTY/KLL- ANAT RELEASE REPORTS ;10/30/01
 ;;5.2;LAB SERVICE;**72,248,259,317**;Sep 27, 1994
 ;
 N LRESSW
 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 A=^LR(LRDFN,LRSS,LRI,0),LRZ=$P(A,U,3),LRZ(1)=$P(A,U,13),"
 S DR=DR_"LRZ(2)=$P(A,U,11),LRZ(3)=$P(A,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////^D NOW^%DTC S X=%;.13////^S X=DUZ;"
 S DR=DR_"W !!,""Report released..."""
 D ^LRAPDA
 D END
 Q
 ;
B ;Autopsy
 S LRSOP="Z"
 S DR="S A=$G(^LR(LRDFN,""AU"")) I A="""" S Y=0;"
 S DR=DR_"S LRZ=$P(A,U,3),LRZ(1)=$P(A,U,16),LRZ(2)=$P(A,U,15),"
 ;KLL-LRZ(3)=SR PATHOLOGIST,LRZ(4)=PROVISIONAL DATE
 S DR=DR_"LRZ(3)=$P(A,U,10),LRZ(4)=$P(A,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 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_"D NOW^%DTC S LRDTE=%;"
 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_"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
 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
 ;
 W !!,"Data entry for ",LRH(0)," "
 S %=1 D YN^LRU G:%<1 END
 I %=2 D  G:Y<1 END
 .S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: " D ^%DT K %DT
 .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)," ACCESIONS IN FILE FOR ",LRH(0),!!
W K X,Y,LR("CK") R !!,"Select Accession Number/Pt name: ",LRAN:DTIME
 G:LRAN=""!(LRAN[U) END
 I LRAN'?1N.N D  G:LRAN<1 END  G W
 .D PNAME^LRAPDA
 .Q:LRAN<1
 .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
 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 '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 !
 .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 rept has already been released.",!
 .W !
 .I LRESSW D  Q
 ..D ESIG Q:LRQUIT
 ..D UPDATE
 .S DIR("A")="Release supplementary report",DIR(0)="Y",DIR("B")="NO"
 .D ^DIR K DIR
 .Q:'Y
 .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 ^(0)=LRT_"^50^^"_DUZ_"^"_LRK,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 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):5 I '$T D  Q
 .S LRMSG="This record is locked by another user.  "
 .S LRMSG=LRMSG_"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)
 ;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
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)
 ...D DD^%DT S LRSR2=Y
 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)
 ...D DD^%DT S LRSR2=Y
 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 "
 S Y=LRZ(2)
 D DD^%DT
 W:LRZ(2)>1 Y
 W:LRZ(1)'="" " by "_$P($G(^VA(200,LRZ(1),0)),U)
 K Y
 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
 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 ***",!
 D NOW^%DTC S LRNTIME=%
 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 MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
 D OERR^LR7OB63D
 S LRQUIT=1
 Q
END ;
 D V^LRU
 Q