LRAPR.m

LRAPR ;DALOI/REG/WTY/KLL/CKA - ANAT RELEASE REPORTS ;10/30/01

 ;;5.2;LAB SERVICE;**1002,1018,1030,1031**;NOV 01, 1997

 ;

 ;;VA LR Patch(s): 72,248,259,317,365

 ;

 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_"S LRELSD=1 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_"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

 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

 W !,LRP,"  ID: ",HRCN       ; IHS/MSC/MKK - LR*5.2*1031

 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)

 I LRSS="AU" D

 .S LRA=^LR(LRDFN,"AU")

 .S LRAC=$$GET1^DIQ(63,LRDFN_",",14,"I")

 .S LRI=$P(LRA,U)

 I LRSS'="AU" D

 .S LRA=^LR(LRDFN,LRSS,LRI,0)

 .S 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

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

 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 OERR^LR7OB63D

 S LRQUIT=1

 Q

END ;

 D V^LRU

 Q

LRAPR     ;DALOI/REG/WTY/KLL/CKA - ANAT RELEASE REPORTS ;10/30/01

 +1       ;;5.2;LAB SERVICE;**1002,1018,1030,1031**;NOV 01, 1997

 +2       ;

 +3       ;;VA LR Patch(s): 72,248,259,317,365

 +4       ;

 +5        NEW LRESSW

 +6        DO SWITCH

 +7        IF +LRESSW

               Begin DoDot:1

 +8                DO ^LRAPRES

 +9                DO END

               End DoDot:1

               QUIT 

 +10       WRITE !!?27,"Release Pathology Reports",!!

 +11       DO A

 +12       IF '$DATA(LRSS)

               DO END

               QUIT 

 +13       IF LRCAPA

               Begin DoDot:1

 +14               SET X=$SELECT(LRSS="CY":"CYTOLOGY REPORTING",LRSS="SP":"SURGICAL PATH REPORTING",1:"")

 +15               IF X]""

                       DO X^LRUWK

               End DoDot:1

               IF '$DATA(X)

                   GOTO END

 +16       IF LRSS="AU"

               DO B

               QUIT 

 +17       SET LRSOP="Z"

 +18       SET DR="S A=^LR(LRDFN,LRSS,LRI,0),LRZ=$P(A,U,3),LRZ(1)=$P(A,U,13),"

 +19       SET DR=DR_"LRZ(2)=$P(A,U,11),LRZ(3)=$P(A,U,2);"

 +20       SET DR=DR_"I 'LRZ W $C(7),!,""No date report completed.   "

 +21       SET DR=DR_"Cannot release."" S Y=0;"

 +22       SET DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;"

 +23       SET DR=DR_"I LRZ(2) D RINFO^LRAPR S Y=0;"

 +24      ;Perform supp edit regardless if date rept released since supp rpt

 +25      ; is added to released report

 +26       SET DR=DR_"D SUPCHK^LRAPR;"

 +27       SET DR=DR_"S DIR(0)=""YA"",DIR(""A"")=""Release report? """

 +28       SET DR=DR_",DIR(""B"")=""NO"" D ^DIR K:Y Y S:$D(Y) Y=0;"

 +29       SET DR=DR_".11////^D NOW^%DTC S X=%;.13////^S X=DUZ;"

 +30       SET DR=DR_"S LRELSD=1 W !!,""Report released..."""

 +31       DO ^LRAPDA

 +32       DO END

 +33       QUIT 

 +34      ;

B         ;Autopsy

 +1        SET LRSOP="Z"

 +2        SET DR="S A=$G(^LR(LRDFN,""AU"")) I A="""" S Y=0;"

 +3        SET DR=DR_"S LRZ=$P(A,U,3),LRZ(1)=$P(A,U,16),LRZ(2)=$P(A,U,15),"

 +4       ;KLL-LRZ(3)=SR PATHOLOGIST,LRZ(4)=PROVISIONAL DATE

 +5        SET DR=DR_"LRZ(3)=$P(A,U,10),LRZ(4)=$P(A,U,17);"

 +6       ;KLL-PROVISIONAL OR DATE REPORT COMPLETED IS REQUIRED

 +7        SET DR=DR_"I 'LRZ(4),'LRZ W $C(7),!,""Provisional date or date report completed required.   "

 +8        SET DR=DR_"Cannot release."" S Y=0;"

 +9        SET DR=DR_"I 'LRZ(2) D NMPATH^LRAPR;"

 +10       SET DR=DR_"I LRZ(2) D RINFO^LRAPR S Y=0;"

 +11      ;Perform supp edit regardless if date rept released since supp rpt

 +12      ; is added to released report

 +13       SET DR=DR_"D SUPCHK^LRAPR;"

 +14       SET DR=DR_"D RELEASE^LRAPR;"

 +15       SET DR=DR_"D NOW^%DTC S LRDTE=%;"

 +16       SET DR=DR_"14.7////^S X=$S(LRZ(2):""@"",1:LRDTE);"

 +17       SET DR=DR_"14.8////^S X=$S(LRZ(2):""@"",1:DUZ);"

 +18       SET DR=DR_"S:'LRZ(2) LRELSD=1 "

 +19       SET DR=DR_"W !!,""Report "" W:LRZ(2) ""un"" W ""released..."";K LRDTE"

 +20       DO ^LRAPDA

 +21       DO END

 +22       QUIT 

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

 +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       WRITE !!,"Data entry for ",LRH(0)," "

 +15       SET %=1

           DO YN^LRU

           IF %<1

               GOTO END

 +16       IF %=2

               Begin DoDot:1

 +17               SET %DT="AE"

                   SET %DT(0)="-N"

                   SET %DT("A")="Enter YEAR: "

                   DO ^%DT

                   KILL %DT

 +18               IF Y<1

                       QUIT 

                   SET LRAD=$EXTRACT(Y,1,3)_"0000"

                   SET LRH(0)=$EXTRACT(Y,1,3)+1700

               End DoDot:1

               IF Y<1

                   GOTO END

 +19       IF '$DATA(^LRO(68,LRAA,1,LRAD,0))

               Begin DoDot:1

 +20               WRITE $CHAR(7),!!,"NO ",LRAA(1)," ACCESIONS IN FILE FOR ",LRH(0),!!

               End DoDot:1

               QUIT 

W          KILL X,Y,LR("CK")

           READ !!,"Select Accession Number/Pt name: ",LRAN:DTIME

 +1        IF LRAN=""!(LRAN[U)

               GOTO END

 +2        IF LRAN'?1N.N

               Begin DoDot:1

 +3                DO PNAME^LRAPDA

 +4                IF LRAN<1

                       QUIT 

 +5                DO DIE

               End DoDot:1

               IF LRAN<1

                   GOTO END

               GOTO W

 +6        DO REST

 +7        GOTO W

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

 +5        IF '$DATA(^LR(LRDFN,0))

               QUIT 

           SET X=^(0)

           DO ^LRUP

 +6       ; W !,LRP,"  ID: ",SSN

 +7       ; IHS/MSC/MKK - LR*5.2*1031

           WRITE !,LRP,"  ID: ",HRCN

 +8        IF LRSS'="AU"

               Begin DoDot:1

 +9                SET LRI=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),"^",5)

 +10               WRITE !,"Specimen(s):"

 +11               SET X=0

                   FOR 

                       SET X=$ORDER(^LR(LRDFN,LRSS,LRI,.1,X))

                       IF 'X

                           QUIT 

                       Begin DoDot:2

 +12                       IF $DATA(^LR(LRDFN,LRSS,LRI,.1,X,0))

                               IF $LENGTH(^(0))

                                   WRITE !,^(0)

                       End DoDot:2

               End DoDot:1

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 '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 

DIE1      ;

 +1        SET (LRQUIT,LRRLM)=0

 +2        FOR 

               Begin DoDot:1

 +3                WRITE !

 +4                IF LRSS="AU"

                       SET (LRLKFL,DIC)="^LR(LRDFN,84,"

 +5                IF LRSS'="AU"

                       SET (LRLKFL,DIC)="^LR(LRDFN,LRSS,LRI,1.2,"

 +6                SET DIC("A")="Select SUPPLEMENTARY REPORT DATE: "

 +7                SET DIC(0)="AEQM"

 +8                DO ^DIC

                   KILL DIC

 +9                IF Y<1

                       SET LRQUIT=1

                       QUIT 

 +10               SET LRDA=+Y

 +11               SET LRIENS=LRDA_","_LRIENS1

 +12               SET LRRLS=+$$GET1^DIQ(LRFILE,LRIENS,.02,"I")

 +13      ;If E-Sign OFF, must check LRRLM.  LRRLM=1 if supp rpt has been

 +14      ;  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 rept has already been released.",!

                           End DoDot:2

                           IF 'LRRLM

                               QUIT 

 +20               WRITE !

 +21               IF LRESSW

                       Begin DoDot:2

 +22                       DO ESIG

                           IF LRQUIT

                               QUIT 

 +23                       DO UPDATE

                       End DoDot:2

                       QUIT 

 +24               SET DIR("A")="Release supplementary report"

                   SET DIR(0)="Y"

                   SET DIR("B")="NO"

 +25               DO ^DIR

                   KILL DIR

 +26               IF 'Y

                       QUIT 

 +27               DO UPDATE

 +28      ;If E-sign switch OFF and orig report released, must verify all

 +29      ;  supp reports released before release main report.

 +30               IF LRCKREL

                       IF 'LRESSW

                           DO CHKSUP^LRAPR1

               End DoDot:1

               IF LRQUIT

                   QUIT 

 +31       QUIT 

 +32      ;

A          DO ^LRAP

           IF '$DATA(Y)

               GOTO END

 +1        QUIT 

C         ;

 +1        SET LRDICS="SPCYEM"

           DO ^LRAP

 +2        IF '$DATA(Y)

               GOTO END

 +3        QUIT 

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 

           SET ^(0)=LRT_"^50^^"_DUZ_"^"_LRK

           SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,0)

           SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRT_"^"_($PIECE(X,"^",4)+1)

 +3        IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0))

               SET ^(0)="^68.14P^^"

 +4        SET C=0

           FOR 

               SET C=$ORDER(LRT(C))

               IF 'C

                   QUIT 

               DO CAP

 +5        SET ^LRO(68,"AA",LRAA_"|"_LRAD_"|"_LRAN_"|"_LRT)=""

 +6        QUIT 

 +7       ;

CAP        SET ^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,C,0)=C_"^1^0^0^^"_LRK_"^"_DUZ_"^"_DUZ(2)_"^"_LRAA_"^"_LRAA_"^"_LRAA

 +1        SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRT,1,0)

           SET ^(0)=$PIECE(X,"^",1,2)_"^"_C_"^"_($PIECE(X,"^",4)+1)

 +2        QUIT 

 +3       ;

SWITCH    ;Check to see if electronic signature is enabled

 +1        DO GETDATA^LRAPESON(.LRESSW)

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

 +6        QUIT 

UPDATE    ;

 +1        SET LRLKFL=LRLKFL_LRDA_",0)"

 +2        LOCK +@(LRLKFL):5

           IF '$TEST

               Begin DoDot:1

 +3                SET LRMSG="This record is locked by another user.  "

 +4                SET LRMSG=LRMSG_"Please wait and try again."

 +5                DO EN^DDIOL(LRMSG,"","!!")

               End DoDot:1

               QUIT 

 +6        SET LRFDA(LRFILE,LRIENS,.02)=1

 +7       ;Set but don't file unless unrel needed

           SET LRFDA2(LRFILE,LRIENS,.02)="@"

 +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       IF LRSS="AU"

               Begin DoDot:1

 +14               SET LRA=^LR(LRDFN,"AU")

 +15               SET LRAC=$$GET1^DIQ(63,LRDFN_",",14,"I")

 +16               SET LRI=$PIECE(LRA,U)

               End DoDot:1

 +17       IF LRSS'="AU"

               Begin DoDot:1

 +18               SET LRA=^LR(LRDFN,LRSS,LRI,0)

 +19               SET LRAC=$$GET1^DIQ(LRSF,LRIENS,.06,"I")

               End DoDot:1

 +20       DO MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)

 +21      ;If all supp reports released, and E-Sign switch is ON, proceed to

 +22      ;  release main report

 +23       SET LRCKREL=0

 +24       IF LRSS'="AU"

               SET LRCKREL=$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",11)

 +25       IF LRSS="AU"

               SET LRCKREL=$PIECE(^LR(LRDFN,LRSS),"^",15)