LRAPDA ;DALOI/STAFF - ANATOMIC PATH DATA ENTRY ;08/10/16 13:22
;;5.2;LAB SERVICE;**72,73,91,121,248,259,295,317,365,350,422,462**;Sep 27, 1994;Build 44
;
; Reference to ^VA(200 supported by IA #10060
;
S LRDATA=0,LRAU=$S(LRSS'="AU":0,1:1)
W !?20,LRO(68)," (",LRABV,")",!
S:'$D(LRSOP) LRSOP=1 S:'$D(LRD(1)) LRD(1)="0"
S:'$D(^LRO(69.2,LRAA,2,0)) ^(0)="^69.23A^0^0"
;
SEL K LR(1)
I $D(LR(2)) D G:%<1 END S:%=1 LR(1)=1
. W !!,"Enter Etiology, Function, Procedure & Disease "
. S %=2 D YN^LRU
;
;
AK ; from LRAPD1
N CORRECT
S:'$D(LRSFLG) LRSFLG=""
W !!,"Data entry for ",LRH(0)," "
S %=1 D YN^LRU G:%<1 END
I %=2 D G:Y<1 END S LRAD=$E(Y,1,3)_"0000",LRH(0)=$E(Y,1,3)+1700
.S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: " D ^%DT K %DT
I '$O(^LRO(68,LRAA,1,LRAD,1,0)) D Q
. W $C(7),!!,"NO ",LRO(68)," ACCESSIONS IN FILE FOR ",LRH(0),!!
W ;
D LOOKUP^LRAPUTL(.LRDATA,LRH(0),LRO(68),LRSS,LRAD,LRAA)
I LRDATA=-1!('$G(LRSEL))!('$D(LRI)) S LREND=1 Q
S LRIDT=LRI
I LRSEL=2 G:LRUID="" W D REST,OERR^LR7OB63D G W
I LRSEL=3 D REST,OERR^LR7OB63D G W
I LRSEL=1 D REST S:$D(DR(1))#2 DR=DR(1) D OERR^LR7OB63D G W
;
;
REST ;
N LRXSTOP,LRX,LRX1
;W " for ",LRH(0)
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
. W $C(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in ",LRO(68),!!
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
S (LRIDT,LRI)=+$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
I LRSS'="AU",'$D(^LR(LRDFN,LRSS,LRI,0)) D Q
. W $C(7),!,"Inverse date missing or incorrect in Accession Area file "
. W "for",!,LRO(68)," Year: ",$E(LRAD,2,3)," Accession: ",LRAN
;I "SPCYEM"[LRSS,$O(^LR(LRDFN,LRSS,LRI,.1,0)) D
;.W !,"Specimen(s):"
;.S X=0 F S X=$O(^LR(LRDFN,LRSS,LRI,.1,X)) Q:'X D
;..W !,$P($G(^LR(LRDFN,LRSS,LRI,.1,X,0)),"^")
;
; Don't allow supp. report to be added to a released report if modifications are being added via MM option
S LRXSTOP=0,(LRX,LRX1)=""
I LRSS'="AU",LRD(1)="S" D
. S LRX=$P($G(^LR(LRDFN,LRSS,LRI,0)),"^",11) ;release date/time
. S LRX1=$P($G(^LR(LRDFN,LRSS,LRI,0)),"^",15) ;orig rel date/time
I LRSS="AU",LRSOP="R" D
. S LRX=$P($G(^LR(LRDFN,"AU")),"^",15) ;release date/time
. S LRX1=$P($G(^LR(LRDFN,"AU")),"^",3) ;date report completed
I 'LRX,LRX1 D
. W $C(7),!!,"This "_$G(LRAA(1))_" report is currently being"
. W !,"modified; it must first be released before Supplementary"
. W !,"report can be added.",!
. S LRXSTOP=1
Q:LRXSTOP
;
;
DIE ;Edit
I LRSS="AU" D D AUE Q
. S LRICDT=$P($G(^LR(LRDFN,"AU")),U,1),ICDFMT=1
. S LRCDSYS=$S(LRICDT'<$$IMPDATE^LEXU("10D"):30,1:1),ICDSYS=LRCDSYS,LRDXV=LRDFN_";"_LRSS
N LRRDT1,LRRDT2,LRIENS,LREL,LRQUIT,LRSNO,LRCPT,LRESCPT
S (LREL,LRESCPT,LRQUIT,LRSNO,LRCPT)=0,LRIENS=LRI_","_LRDFN_","
S LRRDT1=$$GET1^DIQ(LRSF,LRIENS,.11,"I")
S LRRDT2=$$GET1^DIQ(LRSF,LRIENS,.15,"I")
S LRICDT=$$GET1^DIQ(LRSF,LRIENS,.1,"I"),ICDFMT=1
S LRCDSYS=$S(LRICDT'<$$IMPDATE^LEXU("10D"):30,1:1),ICDSYS=LRCDSYS,LRDXV=LRDFN_";"_LRSS_";"_LRI
S:LRRDT1!LRRDT2 LREL=1
; Determine if CPT activated
I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES()
I LRSOP="G",LREL D Q
. W $C(7),!!,"Report verified. Cannot edit with this option."
I LRSOP'="","ABM"[LRSOP,LREL D Q:LRQUIT
. ;Allow SNOMED and CPT coding even after release.
. W $C(7),!!,"Report has been verified. "
. I 'LRESCPT,LRSOP'="B" D Q
. . W "Cannot edit with this option."
. . S LRQUIT=1
. W "Only "
. I LRESCPT W "CPT " W:LRSOP="B" "and "
. W:LRSOP="B" "SNOMED "
. W "coding permitted.",!
. I LRSOP="B" D
. . K DIR S DIR(0)="Y",DIR("A")="Enter SNOMED coding",DIR("B")="NO"
. . D ^DIR W !
. . S LRSNO=+Y
. Q:'LRESCPT
. K DIR S DIR(0)="Y",DIR("A")="Enter CPT coding",DIR("B")="NO"
. D ^DIR W !
. S LRCPT=+Y
. I "AM"[LRSOP,'LRCPT S LRQUIT=1 Q
. I LRSOP="B",'LRCPT,'LRSNO S LRQUIT=1
;
;
RESET ; Reset DR string if altered by prior accession/patient
; Reset DR to orig value in LRAPD1
I LRSOP'="","AMBS"[LRSOP,$G(LRD)'="" D @LRD
I LRSFLG="S",$G(LRD)'="" D @LRD ;For CY,EM Supp entry
S:LRSNO DR=10 ;Modify DR string if only SNOMED coding permitted
I 'LRSNO,LRCPT S DR="" ;Set DR string to null in only CPT coding
; If adding supp rpt to released rpt, remove date rpt completed from DR
I LRRDT1,LRSOP="S"!(LRSFLG="S") S DR=".09///^S X=LRWHO;10"
;
EDIT ; Call to ^DIE
W !
S LRA=^LR(LRDFN,LRSS,LRI,0),LRRC=$P(LRA,"^",10)
I LRCAPA,"SPCYEM"[LRSS D C^LRAPSWK
S DIE="^LR(LRDFN,LRSS,",DA=LRI,DA(1)=LRDFN
D CK^LRU Q:$D(LR("CK"))
I LRSS="SP",LRSOP="B",$O(^LR(LRDFN,LRSS,LRI,1.3,0)) D
. W $C(7),!!,"This accession has a FROZEN SECTION report."
. W !,"Be sure 'FROZEN SECTION' is entered as a SNOMED code in the PROCEDURE field"
. W !,"for the appropriate organ or tissue.",!!
; Code S LRELSD is in DR string setup in LRAPR
N LRELSD S LRELSD=0
D ^DIE
;
; Ask for performing laboratory assignment
I LRSFLG'="S" D EDIT^LRRPLU(LRDFN,LRSS,LRI)
;
; Update accession and order file, releasing facility and send CPRS alerts
I LRELSD D
. D ACCCOMP^LRAPRES
. I LRSS'="AU" D
. . D SETRL^LRVERA(LRDFN,LRSS,LRI,DUZ(2))
. . D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,$P(LRA,"^",6))
. . ;;*Make call to update CPRS order on release *462
. . N LRTEST S LRTEST(+$G(LRT))="" D NEW^LR7OB1(LRODT,LRSN,"RE",,.LRTEST)
;
; Update clinical reminders
D UPDATE^LRPXRM(LRDFN,LRSS,LRI)
;
D:LRSFLG="S"&('$D(Y)) ^LRAPDSR
D FRE^LRU
I LRSOP'="","ABM"[LRSOP D CPTCOD
;
WKLD ; Capture Workload
I LRSOP="Z","CYSP"[LRSS,LRCAPA D S^LRAPR Q
I LRCAPA,"SPCYEM"[LRSS,LRD(1)'="","MBA"[LRD(1) D C1^LRAPSWK
I LRCAPA,"SPCYEM"[LRSS,LRSOP="G" D C1^LRAPSWK
;
QUEUES ; Update Queues
S X=$P(^LR(LRDFN,LRSS,LRI,0),"^",4)
I X,$D(^VA(200,X,0)) S LR("TR")=$P(^(0),"^")
I "CYEMSP"[LRSS,$D(LR(6)),LRSOP="G" Q:$D(^LRO(69.2,LRAA,1,LRAN,0)) D Q
. L +^LRO(69.2,LRAA,1):DILOCKTM I '$T D Q
. . N MSG
. . S MSG(1)="The preliminary reports queue is in use by another person.",MSG(1,"F")="!!"
. . S MSG(2)=" You will need to add this accession to the queue later."
. . D EN^DDIOL(.MSG)
. S ^LRO(69.2,LRAA,1,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
. S X=^LRO(69.2,LRAA,1,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
. L -^LRO(69.2,LRAA,1)
I "CYEMSP"[LRSS,$D(LR(7)),'$D(^LRO(69.2,LRAA,2,LRAN,0)),LRD(1)'="S" D
. L +^LRO(69.2,LRAA,2):DILOCKTM I '$T D Q
. . N MSG
. . S MSG(1)="The final reports queue is in use by another person. ",MSG(1,"F")="!!"
. . S MSG(2)="You will need to add this accession to the queue later."
. . D EN^DDIOL(.MSG)
. S ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
. S X=^LRO(69.2,LRAA,2,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
. L -^LRO(69.2,LRAA,2)
D:LRSOP="M"!(LRSOP="B") EN^LRSPGD
Q
;
;
NM ;
I X'["@"!(X["@"&(Y(Z)="")) D Q
.W $C(7),!?4,"ENTER WHOLE NUMBERS ONLY",! K X
I Y(Z)'="" W $C(7),?40,"OK TO DELETE" S %=2 D YN^LRU I %'=1 K X Q
S Y(Z)="" Q
;
;
AUE ; Autopsy Data Entry
W !
N LREL,LRQUIT,LRSNO,LRESCPT,LRCPT
S (LREL,LRQUIT,LRSNO,LRCPT)=0
S LREL=+$$GET1^DIQ(63,LRDFN_",",14.7,"I")
; Determine if CPT activated
I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES()
; Allow supp report to be added on verified AU
I LRSOP'="","AFIP"[LRSOP,LREL D Q:LRQUIT
. Q:LRESCPT&("AP"[LRSOP)
. W $C(7),!!,"Report verified. Cannot edit with this option!"
. S LRQUIT=1
I LRSOP'="","ABP"[LRSOP,LREL D Q:LRQUIT
. W $C(7),!!,"Report has been verified. "
. W "Only "
. I LRESCPT W "CPT " W:LRSOP="B" "and "
. W:LRSOP="B" "SNOMED "
. W "coding permitted.",!
. I LRSOP="B" D
. . K DIR S DIR(0)="Y",DIR("A")="Enter SNOMED coding",DIR("B")="NO"
. . D ^DIR W !
. . S LRSNO=+Y
. Q:'LRESCPT
. K DIR S DIR(0)="Y",DIR("A")="Enter CPT coding",DIR("B")="NO"
. D ^DIR W !
. S LRCPT=+Y
. I "AP"[LRSOP,'LRCPT S LRQUIT=1 Q
. I LRSOP="B",'LRCPT,'LRSNO S LRQUIT=1
;
AURESET ; Reset DR to orig value in LRAUDA
I LRSOP'="","AP"[LRSOP D @(LRSOP_"DR^LRAUDA")
I LRSOP="B" D BDR^LRAUDA
S:LRSNO DR=32 ;Modify DR string if only SNOMED coding permitted
I 'LRSNO,LRCPT S DR="" ;Set DR string to null inf only CPT coding
; ;
; Not all of the autopsy fields are within the AU subscript.
; Therefore, we must lock the entire LRDFN.
L +^LR(LRDFN):DILOCKTM I '$T D Q
. S MSG="This record is locked by another user. "
. S MSG=MSG_"Please wait and try again."
. D EN^DDIOL(MSG,"","!!") K MSG
I LRSFLG'="S" D
. N LRELSD S LRELSD=0
. S DIE="^LR(",DA=LRDFN
. D ^DIE
. S LRA=^LR(LRDFN,"AU"),LRI=$P(LRA,U),LRAC=$P(LRA,U,6)
. I LRELSD D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
;
D:LRSFLG="S" ^LRAPDSR
;
; Ask for performing laboratory assignment
W !! D EDIT^LRRPLU(LRDFN,LRSS,LRI)
;
D UPDATE^LRPXRM(LRDFN,"AU")
L -^LR(LRDFN)
D:"BAP"[LRSOP AU
D:LRSOP="R" R
I LRSOP'="","ABP"[LRSOP D CPTCOD
Q
;
;
AU I '$D(^LRO(69.2,LRAA,2,LRAN,0)) D
.L +^LRO(69.2,LRAA,2):DILOCKTM I '$T D Q
..S MSG(1)="The final reports queue is in use by another person. "
..S MSG(1,"F")="!!"
..S MSG(2)="You will need to add this accession to the queue later."
..D EN^DDIOL(.MSG) K MSG
.S ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN
.S X=^LRO(69.2,LRAA,2,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
.L -^LRO(69.2,LRAA,2)
D AU^LRSPGD
Q
;
;
R I '$D(^LRO(69.2,LRAA,3,LRAN,0)) D
. L +^LRO(69.2,LRAA,3):DILOCKTM I '$T D Q
. . S MSG(1)="The interim reports queue is in use by another person. "
. . S MSG(1,"F")="!!"
. . S MSG(2)="You will need to add this accession to the queue later."
. . D EN^DDIOL(.MSG) K MSG
. S ^LRO(69.2,LRAA,3,LRAN,0)=LRDFN
. S X=^LRO(69.2,LRAA,3,0),^(0)=$P(X,"^",1,2)_"^"_LRAN_"^"_($P(X,"^",4)+1)
. L -^LRO(69.2,LRAA,3)
Q
;
;
PNAME ; Patient Name Lookup
; LRPFLG tells LRUPS to limit accessions to the chosen year.
N LRPFLG
S X=LRPNM,LRPFLG=1
K LRPNM,DIC,VADM,VAIN,VA
S DFN=-1,DIC(0)="EQM",(LRX,LRDPF)=""
D:'$D(LRLABKY) LABKEY^LRPARAM
D DPA1^LRDPA
I DFN=-1 S LRAN=-1 Q
D I^LRUPS
Q
;
;
CPTCOD ; CPT Coding
N LRPRO
Q:$T(CPT^LRCAPES)=""
Q:LREL&('LRCPT)
I 'LREL D
. K DIR S DIR(0)="Y",DIR("A")="Enter CPT coding",DIR("B")="NO"
. D ^DIR W !
. S LRCPT=+Y
Q:'LRCPT
; SET PROVIDER TO CURRENT USER, ALLOW UPDATES
S LRPRO=DUZ
D PROVIDR^LRAPUTL
Q:LRQUIT
D CPT^LRCAPES(LRAA,LRAD,LRAN,LRPRO)
Q
;
;
END K LRSFLG,LRICDT,LRCDSYS,ICDSYS,ICDFMT,LRDXV
D:$T(CLEAN^LRCAPES)'="" CLEAN^LRCAPES
D V^LRU
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPDA 10593 printed Dec 13, 2024@02:07:14 Page 2
LRAPDA ;DALOI/STAFF - ANATOMIC PATH DATA ENTRY ;08/10/16 13:22
+1 ;;5.2;LAB SERVICE;**72,73,91,121,248,259,295,317,365,350,422,462**;Sep 27, 1994;Build 44
+2 ;
+3 ; Reference to ^VA(200 supported by IA #10060
+4 ;
+5 SET LRDATA=0
SET LRAU=$SELECT(LRSS'="AU":0,1:1)
+6 WRITE !?20,LRO(68)," (",LRABV,")",!
+7 if '$DATA(LRSOP)
SET LRSOP=1
if '$DATA(LRD(1))
SET LRD(1)="0"
+8 if '$DATA(^LRO(69.2,LRAA,2,0))
SET ^(0)="^69.23A^0^0"
+9 ;
SEL KILL LR(1)
+1 IF $DATA(LR(2))
Begin DoDot:1
+2 WRITE !!,"Enter Etiology, Function, Procedure & Disease "
+3 SET %=2
DO YN^LRU
End DoDot:1
if %<1
GOTO END
if %=1
SET LR(1)=1
+4 ;
+5 ;
AK ; from LRAPD1
+1 NEW CORRECT
+2 if '$DATA(LRSFLG)
SET LRSFLG=""
+3 WRITE !!,"Data entry for ",LRH(0)," "
+4 SET %=1
DO YN^LRU
if %<1
GOTO END
+5 IF %=2
Begin DoDot:1
+6 SET %DT="AE"
SET %DT(0)="-N"
SET %DT("A")="Enter YEAR: "
DO ^%DT
KILL %DT
End DoDot:1
if Y<1
GOTO END
SET LRAD=$EXTRACT(Y,1,3)_"0000"
SET LRH(0)=$EXTRACT(Y,1,3)+1700
+7 IF '$ORDER(^LRO(68,LRAA,1,LRAD,1,0))
Begin DoDot:1
+8 WRITE $CHAR(7),!!,"NO ",LRO(68)," ACCESSIONS IN FILE FOR ",LRH(0),!!
End DoDot:1
QUIT
W ;
+1 DO LOOKUP^LRAPUTL(.LRDATA,LRH(0),LRO(68),LRSS,LRAD,LRAA)
+2 IF LRDATA=-1!('$GET(LRSEL))!('$DATA(LRI))
SET LREND=1
QUIT
+3 SET LRIDT=LRI
+4 IF LRSEL=2
if LRUID=""
GOTO W
DO REST
DO OERR^LR7OB63D
GOTO W
+5 IF LRSEL=3
DO REST
DO OERR^LR7OB63D
GOTO W
+6 IF LRSEL=1
DO REST
if $DATA(DR(1))#2
SET DR=DR(1)
DO OERR^LR7OB63D
GOTO W
+7 ;
+8 ;
REST ;
+1 NEW LRXSTOP,LRX,LRX1
+2 ;W " for ",LRH(0)
+3 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
Begin DoDot:1
+4 WRITE $CHAR(7),!!,"Accession # ",LRAN," for ",LRH(0)," not in ",LRO(68),!!
End DoDot:1
QUIT
+5 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)
+6 if '$DATA(^LR(LRDFN,0))
QUIT
SET X=^(0)
DO ^LRUP
+7 ;W !,LRP," ID: ",SSN
+8 SET (LRIDT,LRI)=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
+9 IF LRSS'="AU"
IF '$DATA(^LR(LRDFN,LRSS,LRI,0))
Begin DoDot:1
+10 WRITE $CHAR(7),!,"Inverse date missing or incorrect in Accession Area file "
+11 WRITE "for",!,LRO(68)," Year: ",$EXTRACT(LRAD,2,3)," Accession: ",LRAN
End DoDot:1
QUIT
+12 ;I "SPCYEM"[LRSS,$O(^LR(LRDFN,LRSS,LRI,.1,0)) D
+13 ;.W !,"Specimen(s):"
+14 ;.S X=0 F S X=$O(^LR(LRDFN,LRSS,LRI,.1,X)) Q:'X D
+15 ;..W !,$P($G(^LR(LRDFN,LRSS,LRI,.1,X,0)),"^")
+16 ;
+17 ; Don't allow supp. report to be added to a released report if modifications are being added via MM option
+18 SET LRXSTOP=0
SET (LRX,LRX1)=""
+19 IF LRSS'="AU"
IF LRD(1)="S"
Begin DoDot:1
+20 ;release date/time
SET LRX=$PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),"^",11)
+21 ;orig rel date/time
SET LRX1=$PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),"^",15)
End DoDot:1
+22 IF LRSS="AU"
IF LRSOP="R"
Begin DoDot:1
+23 ;release date/time
SET LRX=$PIECE($GET(^LR(LRDFN,"AU")),"^",15)
+24 ;date report completed
SET LRX1=$PIECE($GET(^LR(LRDFN,"AU")),"^",3)
End DoDot:1
+25 IF 'LRX
IF LRX1
Begin DoDot:1
+26 WRITE $CHAR(7),!!,"This "_$GET(LRAA(1))_" report is currently being"
+27 WRITE !,"modified; it must first be released before Supplementary"
+28 WRITE !,"report can be added.",!
+29 SET LRXSTOP=1
End DoDot:1
+30 if LRXSTOP
QUIT
+31 ;
+32 ;
DIE ;Edit
+1 IF LRSS="AU"
Begin DoDot:1
+2 SET LRICDT=$PIECE($GET(^LR(LRDFN,"AU")),U,1)
SET ICDFMT=1
+3 SET LRCDSYS=$SELECT(LRICDT'<$$IMPDATE^LEXU("10D"):30,1:1)
SET ICDSYS=LRCDSYS
SET LRDXV=LRDFN_";"_LRSS
End DoDot:1
DO AUE
QUIT
+4 NEW LRRDT1,LRRDT2,LRIENS,LREL,LRQUIT,LRSNO,LRCPT,LRESCPT
+5 SET (LREL,LRESCPT,LRQUIT,LRSNO,LRCPT)=0
SET LRIENS=LRI_","_LRDFN_","
+6 SET LRRDT1=$$GET1^DIQ(LRSF,LRIENS,.11,"I")
+7 SET LRRDT2=$$GET1^DIQ(LRSF,LRIENS,.15,"I")
+8 SET LRICDT=$$GET1^DIQ(LRSF,LRIENS,.1,"I")
SET ICDFMT=1
+9 SET LRCDSYS=$SELECT(LRICDT'<$$IMPDATE^LEXU("10D"):30,1:1)
SET ICDSYS=LRCDSYS
SET LRDXV=LRDFN_";"_LRSS_";"_LRI
+10 if LRRDT1!LRRDT2
SET LREL=1
+11 ; Determine if CPT activated
+12 IF $TEXT(ES^LRCAPES)'=""
SET LRESCPT=$$ES^LRCAPES()
+13 IF LRSOP="G"
IF LREL
Begin DoDot:1
+14 WRITE $CHAR(7),!!,"Report verified. Cannot edit with this option."
End DoDot:1
QUIT
+15 IF LRSOP'=""
IF "ABM"[LRSOP
IF LREL
Begin DoDot:1
+16 ;Allow SNOMED and CPT coding even after release.
+17 WRITE $CHAR(7),!!,"Report has been verified. "
+18 IF 'LRESCPT
IF LRSOP'="B"
Begin DoDot:2
+19 WRITE "Cannot edit with this option."
+20 SET LRQUIT=1
End DoDot:2
QUIT
+21 WRITE "Only "
+22 IF LRESCPT
WRITE "CPT "
if LRSOP="B"
WRITE "and "
+23 if LRSOP="B"
WRITE "SNOMED "
+24 WRITE "coding permitted.",!
+25 IF LRSOP="B"
Begin DoDot:2
+26 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Enter SNOMED coding"
SET DIR("B")="NO"
+27 DO ^DIR
WRITE !
+28 SET LRSNO=+Y
End DoDot:2
+29 if 'LRESCPT
QUIT
+30 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Enter CPT coding"
SET DIR("B")="NO"
+31 DO ^DIR
WRITE !
+32 SET LRCPT=+Y
+33 IF "AM"[LRSOP
IF 'LRCPT
SET LRQUIT=1
QUIT
+34 IF LRSOP="B"
IF 'LRCPT
IF 'LRSNO
SET LRQUIT=1
End DoDot:1
if LRQUIT
QUIT
+35 ;
+36 ;
RESET ; Reset DR string if altered by prior accession/patient
+1 ; Reset DR to orig value in LRAPD1
+2 IF LRSOP'=""
IF "AMBS"[LRSOP
IF $GET(LRD)'=""
DO @LRD
+3 ;For CY,EM Supp entry
IF LRSFLG="S"
IF $GET(LRD)'=""
DO @LRD
+4 ;Modify DR string if only SNOMED coding permitted
if LRSNO
SET DR=10
+5 ;Set DR string to null in only CPT coding
IF 'LRSNO
IF LRCPT
SET DR=""
+6 ; If adding supp rpt to released rpt, remove date rpt completed from DR
+7 IF LRRDT1
IF LRSOP="S"!(LRSFLG="S")
SET DR=".09///^S X=LRWHO;10"
+8 ;
EDIT ; Call to ^DIE
+1 WRITE !
+2 SET LRA=^LR(LRDFN,LRSS,LRI,0)
SET LRRC=$PIECE(LRA,"^",10)
+3 IF LRCAPA
IF "SPCYEM"[LRSS
DO C^LRAPSWK
+4 SET DIE="^LR(LRDFN,LRSS,"
SET DA=LRI
SET DA(1)=LRDFN
+5 DO CK^LRU
if $DATA(LR("CK"))
QUIT
+6 IF LRSS="SP"
IF LRSOP="B"
IF $ORDER(^LR(LRDFN,LRSS,LRI,1.3,0))
Begin DoDot:1
+7 WRITE $CHAR(7),!!,"This accession has a FROZEN SECTION report."
+8 WRITE !,"Be sure 'FROZEN SECTION' is entered as a SNOMED code in the PROCEDURE field"
+9 WRITE !,"for the appropriate organ or tissue.",!!
End DoDot:1
+10 ; Code S LRELSD is in DR string setup in LRAPR
+11 NEW LRELSD
SET LRELSD=0
+12 DO ^DIE
+13 ;
+14 ; Ask for performing laboratory assignment
+15 IF LRSFLG'="S"
DO EDIT^LRRPLU(LRDFN,LRSS,LRI)
+16 ;
+17 ; Update accession and order file, releasing facility and send CPRS alerts
+18 IF LRELSD
Begin DoDot:1
+19 DO ACCCOMP^LRAPRES
+20 IF LRSS'="AU"
Begin DoDot:2
+21 DO SETRL^LRVERA(LRDFN,LRSS,LRI,DUZ(2))
+22 DO MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,$PIECE(LRA,"^",6))
+23 ;;*Make call to update CPRS order on release *462
+24 NEW LRTEST
SET LRTEST(+$GET(LRT))=""
DO NEW^LR7OB1(LRODT,LRSN,"RE",,.LRTEST)
End DoDot:2
End DoDot:1
+25 ;
+26 ; Update clinical reminders
+27 DO UPDATE^LRPXRM(LRDFN,LRSS,LRI)
+28 ;
+29 if LRSFLG="S"&('$DATA(Y))
DO ^LRAPDSR
+30 DO FRE^LRU
+31 IF LRSOP'=""
IF "ABM"[LRSOP
DO CPTCOD
+32 ;
WKLD ; Capture Workload
+1 IF LRSOP="Z"
IF "CYSP"[LRSS
IF LRCAPA
DO S^LRAPR
QUIT
+2 IF LRCAPA
IF "SPCYEM"[LRSS
IF LRD(1)'=""
IF "MBA"[LRD(1)
DO C1^LRAPSWK
+3 IF LRCAPA
IF "SPCYEM"[LRSS
IF LRSOP="G"
DO C1^LRAPSWK
+4 ;
QUEUES ; Update Queues
+1 SET X=$PIECE(^LR(LRDFN,LRSS,LRI,0),"^",4)
+2 IF X
IF $DATA(^VA(200,X,0))
SET LR("TR")=$PIECE(^(0),"^")
+3 IF "CYEMSP"[LRSS
IF $DATA(LR(6))
IF LRSOP="G"
if $DATA(^LRO(69.2,LRAA,1,LRAN,0))
QUIT
Begin DoDot:1
+4 LOCK +^LRO(69.2,LRAA,1):DILOCKTM
IF '$TEST
Begin DoDot:2
+5 NEW MSG
+6 SET MSG(1)="The preliminary reports queue is in use by another person."
SET MSG(1,"F")="!!"
+7 SET MSG(2)=" You will need to add this accession to the queue later."
+8 DO EN^DDIOL(.MSG)
End DoDot:2
QUIT
+9 SET ^LRO(69.2,LRAA,1,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
+10 SET X=^LRO(69.2,LRAA,1,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRAN_"^"_($PIECE(X,"^",4)+1)
+11 LOCK -^LRO(69.2,LRAA,1)
End DoDot:1
QUIT
+12 IF "CYEMSP"[LRSS
IF $DATA(LR(7))
IF '$DATA(^LRO(69.2,LRAA,2,LRAN,0))
IF LRD(1)'="S"
Begin DoDot:1
+13 LOCK +^LRO(69.2,LRAA,2):DILOCKTM
IF '$TEST
Begin DoDot:2
+14 NEW MSG
+15 SET MSG(1)="The final reports queue is in use by another person. "
SET MSG(1,"F")="!!"
+16 SET MSG(2)="You will need to add this accession to the queue later."
+17 DO EN^DDIOL(.MSG)
End DoDot:2
QUIT
+18 SET ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN_"^"_LRI_"^"_LRH(0)
+19 SET X=^LRO(69.2,LRAA,2,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRAN_"^"_($PIECE(X,"^",4)+1)
+20 LOCK -^LRO(69.2,LRAA,2)
End DoDot:1
+21 if LRSOP="M"!(LRSOP="B")
DO EN^LRSPGD
+22 QUIT
+23 ;
+24 ;
NM ;
+1 IF X'["@"!(X["@"&(Y(Z)=""))
Begin DoDot:1
+2 WRITE $CHAR(7),!?4,"ENTER WHOLE NUMBERS ONLY",!
KILL X
End DoDot:1
QUIT
+3 IF Y(Z)'=""
WRITE $CHAR(7),?40,"OK TO DELETE"
SET %=2
DO YN^LRU
IF %'=1
KILL X
QUIT
+4 SET Y(Z)=""
QUIT
+5 ;
+6 ;
AUE ; Autopsy Data Entry
+1 WRITE !
+2 NEW LREL,LRQUIT,LRSNO,LRESCPT,LRCPT
+3 SET (LREL,LRQUIT,LRSNO,LRCPT)=0
+4 SET LREL=+$$GET1^DIQ(63,LRDFN_",",14.7,"I")
+5 ; Determine if CPT activated
+6 IF $TEXT(ES^LRCAPES)'=""
SET LRESCPT=$$ES^LRCAPES()
+7 ; Allow supp report to be added on verified AU
+8 IF LRSOP'=""
IF "AFIP"[LRSOP
IF LREL
Begin DoDot:1
+9 if LRESCPT&("AP"[LRSOP)
QUIT
+10 WRITE $CHAR(7),!!,"Report verified. Cannot edit with this option!"
+11 SET LRQUIT=1
End DoDot:1
if LRQUIT
QUIT
+12 IF LRSOP'=""
IF "ABP"[LRSOP
IF LREL
Begin DoDot:1
+13 WRITE $CHAR(7),!!,"Report has been verified. "
+14 WRITE "Only "
+15 IF LRESCPT
WRITE "CPT "
if LRSOP="B"
WRITE "and "
+16 if LRSOP="B"
WRITE "SNOMED "
+17 WRITE "coding permitted.",!
+18 IF LRSOP="B"
Begin DoDot:2
+19 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Enter SNOMED coding"
SET DIR("B")="NO"
+20 DO ^DIR
WRITE !
+21 SET LRSNO=+Y
End DoDot:2
+22 if 'LRESCPT
QUIT
+23 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Enter CPT coding"
SET DIR("B")="NO"
+24 DO ^DIR
WRITE !
+25 SET LRCPT=+Y
+26 IF "AP"[LRSOP
IF 'LRCPT
SET LRQUIT=1
QUIT
+27 IF LRSOP="B"
IF 'LRCPT
IF 'LRSNO
SET LRQUIT=1
End DoDot:1
if LRQUIT
QUIT
+28 ;
AURESET ; Reset DR to orig value in LRAUDA
+1 IF LRSOP'=""
IF "AP"[LRSOP
DO @(LRSOP_"DR^LRAUDA")
+2 IF LRSOP="B"
DO BDR^LRAUDA
+3 ;Modify DR string if only SNOMED coding permitted
if LRSNO
SET DR=32
+4 ;Set DR string to null inf only CPT coding
IF 'LRSNO
IF LRCPT
SET DR=""
+5 ; ;
+6 ; Not all of the autopsy fields are within the AU subscript.
+7 ; Therefore, we must lock the entire LRDFN.
+8 LOCK +^LR(LRDFN):DILOCKTM
IF '$TEST
Begin DoDot:1
+9 SET MSG="This record is locked by another user. "
+10 SET MSG=MSG_"Please wait and try again."
+11 DO EN^DDIOL(MSG,"","!!")
KILL MSG
End DoDot:1
QUIT
+12 IF LRSFLG'="S"
Begin DoDot:1
+13 NEW LRELSD
SET LRELSD=0
+14 SET DIE="^LR("
SET DA=LRDFN
+15 DO ^DIE
+16 SET LRA=^LR(LRDFN,"AU")
SET LRI=$PIECE(LRA,U)
SET LRAC=$PIECE(LRA,U,6)
+17 IF LRELSD
DO MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
End DoDot:1
+18 ;
+19 if LRSFLG="S"
DO ^LRAPDSR
+20 ;
+21 ; Ask for performing laboratory assignment
+22 WRITE !!
DO EDIT^LRRPLU(LRDFN,LRSS,LRI)
+23 ;
+24 DO UPDATE^LRPXRM(LRDFN,"AU")
+25 LOCK -^LR(LRDFN)
+26 if "BAP"[LRSOP
DO AU
+27 if LRSOP="R"
DO R
+28 IF LRSOP'=""
IF "ABP"[LRSOP
DO CPTCOD
+29 QUIT
+30 ;
+31 ;
AU IF '$DATA(^LRO(69.2,LRAA,2,LRAN,0))
Begin DoDot:1
+1 LOCK +^LRO(69.2,LRAA,2):DILOCKTM
IF '$TEST
Begin DoDot:2
+2 SET MSG(1)="The final reports queue is in use by another person. "
+3 SET MSG(1,"F")="!!"
+4 SET MSG(2)="You will need to add this accession to the queue later."
+5 DO EN^DDIOL(.MSG)
KILL MSG
End DoDot:2
QUIT
+6 SET ^LRO(69.2,LRAA,2,LRAN,0)=LRDFN
+7 SET X=^LRO(69.2,LRAA,2,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRAN_"^"_($PIECE(X,"^",4)+1)
+8 LOCK -^LRO(69.2,LRAA,2)
End DoDot:1
+9 DO AU^LRSPGD
+10 QUIT
+11 ;
+12 ;
R IF '$DATA(^LRO(69.2,LRAA,3,LRAN,0))
Begin DoDot:1
+1 LOCK +^LRO(69.2,LRAA,3):DILOCKTM
IF '$TEST
Begin DoDot:2
+2 SET MSG(1)="The interim reports queue is in use by another person. "
+3 SET MSG(1,"F")="!!"
+4 SET MSG(2)="You will need to add this accession to the queue later."
+5 DO EN^DDIOL(.MSG)
KILL MSG
End DoDot:2
QUIT
+6 SET ^LRO(69.2,LRAA,3,LRAN,0)=LRDFN
+7 SET X=^LRO(69.2,LRAA,3,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_LRAN_"^"_($PIECE(X,"^",4)+1)
+8 LOCK -^LRO(69.2,LRAA,3)
End DoDot:1
+9 QUIT
+10 ;
+11 ;
PNAME ; Patient Name Lookup
+1 ; LRPFLG tells LRUPS to limit accessions to the chosen year.
+2 NEW LRPFLG
+3 SET X=LRPNM
SET LRPFLG=1
+4 KILL LRPNM,DIC,VADM,VAIN,VA
+5 SET DFN=-1
SET DIC(0)="EQM"
SET (LRX,LRDPF)=""
+6 if '$DATA(LRLABKY)
DO LABKEY^LRPARAM
+7 DO DPA1^LRDPA
+8 IF DFN=-1
SET LRAN=-1
QUIT
+9 DO I^LRUPS
+10 QUIT
+11 ;
+12 ;
CPTCOD ; CPT Coding
+1 NEW LRPRO
+2 if $TEXT(CPT^LRCAPES)=""
QUIT
+3 if LREL&('LRCPT)
QUIT
+4 IF 'LREL
Begin DoDot:1
+5 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Enter CPT coding"
SET DIR("B")="NO"
+6 DO ^DIR
WRITE !
+7 SET LRCPT=+Y
End DoDot:1
+8 if 'LRCPT
QUIT
+9 ; SET PROVIDER TO CURRENT USER, ALLOW UPDATES
+10 SET LRPRO=DUZ
+11 DO PROVIDR^LRAPUTL
+12 if LRQUIT
QUIT
+13 DO CPT^LRCAPES(LRAA,LRAD,LRAN,LRPRO)
+14 QUIT
+15 ;
+16 ;
END KILL LRSFLG,LRICDT,LRCDSYS,ICDSYS,ICDFMT,LRDXV
+1 if $TEXT(CLEAN^LRCAPES)'=""
DO CLEAN^LRCAPES
+2 DO V^LRU
+3 QUIT
+4 ;
