- 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 Jan 18, 2025@03:08:50 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