LRAPDA ;DALOI/REG/WTY/KLL/CKA - ANATOMIC PATH DATA ENTRY; 17-Oct-2014 09:22 ; MKK
;;5.2;LAB SERVICE;**72,73,1002,91,121,1003,248,1018,259,295,317,365,1030,1031,1033,1034**;NOV 01, 1997;Build 88
;
;;VA LR Patche(s):
;
;Reference to ^%DT supported by IA #10003
;Reference to ^DIE supported by IA #10018
;Reference to ^VA(200 supported by IA #10060
;Reference to EN^DDIOL supported by IA #10142
;
EP ; EP
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 ; EP - 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 K X,Y,LR("CK")
R !!,"Select Accession Number/Pt name: ",LRAN:DTIME
G:LRAN=""!(LRAN[U) END
I LRAN["?" D G W
.W !!,"Enter the year ",LRH(0)," ",LRO(68)," accession number to be "
.W "updated"
.W !,"or locate the accession by entering the patient name."
I LRAN'?1N.N D PNAME G:LRAN<1 W D OE1^LR7OB63D,REST,OERR^LR7OB63D G W
D OE1^LR7OB63D,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
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
S 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 AUE Q
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:LRRDT1!LRRDT2 LREL=1
;Determine if CPT activated
; I $$PATCH^BLRUTIL4("PX*1.0*119") I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES() ; IHS/MSC/MKK - LR*5.2*1031
I $$PATCH^BLRUTIL4("PX*1.0*197") I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES() ; IHS/MSC/MKK - LR*5.2*1033
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 "
.W "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
S LRAC=$P(LRA,U,6)
I LRELSD D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
; D UPDATE^LRPXRM(LRDFN,LRSS,LRI) ; IHS/OIT/MKK - LR*5.2*1030 - RPMS Does NOT use Clinical Reminders
I $$PATCH^BLRUTIL4("PXRM*1.5*12") D UPDATE^LRPXRM(LRDFN,LRSS,LRI) ; IHS/MSC/MKK - LR*5.2*1031
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):5 I '$T D Q
..S MSG(1)="The preliminary 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,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):5 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_"^"_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 $$PATCH^BLRUTIL4("PX*1.0*119") I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES() ; IHS/MSC/MKK - LR*5.2*1031
I $$PATCH^BLRUTIL4("PX*1.0*197") I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES() ; IHS/MSC/MKK - LR*5.2*1033
; 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):5 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")
.S LRI=$P(LRA,U)
.S LRAC=$P(LRA,U,6)
.I LRELSD D MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
D:LRSFLG="S" ^LRAPDSR
; D UPDATE^LRPXRM(LRDFN,"AU") ; IHS/OIT/MKK - LR*5.2*1030 - RPMS Does NOT use Clinical Reminders
I $$PATCH^BLRUTIL4("PXRM*1.5*12") D UPDATE^LRPXRM(LRDFN,"AU") ; IHS/MSC/MKK - LR*5.2*1031
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):5 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):5 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
N LRPFLG ;LRPFLG tells LRUPS to limit accessions to
S X=LRAN,LRPFLG=1 ;the chosen year.
K LRAN,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)=""
; I '$$PATCH^BLRUTIL4("PX*1.0*119") Q ; IHS/MSC/MKK - LR*5.2*1031
I '$$PATCH^BLRUTIL4("PX*1.0*197") Q ; IHS/MSC/MKK - LR*5.2*1034
;
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
D:$T(CLEAN^LRCAPES)'="" CLEAN^LRCAPES
D V^LRU
Q
LRAPDA ;DALOI/REG/WTY/KLL/CKA - ANATOMIC PATH DATA ENTRY; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**72,73,1002,91,121,1003,248,1018,259,295,317,365,1030,1031,1033,1034**;NOV 01, 1997;Build 88
+2 ;
+3 ;;VA LR Patche(s):
+4 ;
+5 ;Reference to ^%DT supported by IA #10003
+6 ;Reference to ^DIE supported by IA #10018
+7 ;Reference to ^VA(200 supported by IA #10060
+8 ;Reference to EN^DDIOL supported by IA #10142
+9 ;
EP ; EP
+1 WRITE !?20,LRO(68)," (",LRABV,")",!
+2 IF '$DATA(LRSOP)
SET LRSOP=1
IF '$DATA(LRD(1))
SET LRD(1)="0"
+3 IF '$DATA(^LRO(69.2,LRAA,2,0))
SET ^(0)="^69.23A^0^0"
+4 ;
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 ;
AK ; EP - 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
+9 ;
W KILL X,Y,LR("CK")
+1 READ !!,"Select Accession Number/Pt name: ",LRAN:DTIME
+2 IF LRAN=""!(LRAN[U)
GOTO END
+3 IF LRAN["?"
Begin DoDot:1
+4 WRITE !!,"Enter the year ",LRH(0)," ",LRO(68)," accession number to be "
+5 WRITE "updated"
+6 WRITE !,"or locate the accession by entering the patient name."
End DoDot:1
GOTO W
+7 IF LRAN'?1N.N
DO PNAME
IF LRAN<1
GOTO W
DO OE1^LR7OB63D
DO REST
DO OERR^LR7OB63D
GOTO W
+8 DO OE1^LR7OB63D
DO REST
IF $DATA(DR(1))#2
SET DR=DR(1)
DO OERR^LR7OB63D
GOTO W
+9 ;
REST ;
+1 NEW LRXSTOP,LRX,LRX1
+2 WRITE " 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
+6 IF '$DATA(^LR(LRDFN,0))
QUIT
SET X=^(0)
DO ^LRUP
+7 ; W !,LRP," ID: ",SSN
+8 ; IHS/MSC/MKK - LR*5.2*1031
WRITE !,LRP," ID: ",HRCN
+9 SET LRI=+$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",5)
+10 IF LRSS'="AU"
IF '$DATA(^LR(LRDFN,LRSS,LRI,0))
Begin DoDot:1
+11 WRITE $CHAR(7),!,"Inverse date missing or incorrect in Accession Area file "
+12 WRITE "for",!,LRO(68)," Year: ",$EXTRACT(LRAD,2,3)," Accession: ",LRAN
End DoDot:1
QUIT
+13 IF "SPCYEM"[LRSS
IF $ORDER(^LR(LRDFN,LRSS,LRI,.1,0))
Begin DoDot:1
+14 WRITE !,"Specimen(s):"
+15 SET X=0
FOR
SET X=$ORDER(^LR(LRDFN,LRSS,LRI,.1,X))
IF 'X
QUIT
Begin DoDot:2
+16 WRITE !,$PIECE($GET(^LR(LRDFN,LRSS,LRI,.1,X,0)),"^")
End DoDot:2
End DoDot:1
+17 ;
+18 ;Don't allow supp. report to be added to a released report if
+19 ; modifications are being added via MM option
+20 SET LRXSTOP=0
SET (LRX,LRX1)=""
+21 IF LRSS'="AU"
IF LRD(1)="S"
Begin DoDot:1
+22 ;release date/time
SET LRX=$PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),"^",11)
+23 ;orig rel date/time
SET LRX1=$PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),"^",15)
End DoDot:1
+24 IF LRSS="AU"
IF LRSOP="R"
Begin DoDot:1
+25 ;release date/time
SET LRX=$PIECE($GET(^LR(LRDFN,"AU")),"^",15)
+26 ;date report completed
SET LRX1=$PIECE($GET(^LR(LRDFN,"AU")),"^",3)
End DoDot:1
+27 IF 'LRX
IF LRX1
Begin DoDot:1
+28 WRITE $CHAR(7),!!,"This "_$GET(LRAA(1))_" report is currently being"
+29 WRITE !,"modified; it must first be released before Supplementary"
+30 WRITE !,"report can be added.",!
+31 SET LRXSTOP=1
End DoDot:1
+32 IF LRXSTOP
QUIT
+33 ;
DIE ;Edit
+1 IF LRSS="AU"
DO AUE
QUIT
+2 NEW LRRDT1,LRRDT2,LRIENS,LREL,LRQUIT,LRSNO,LRCPT,LRESCPT
+3 SET (LREL,LRESCPT,LRQUIT,LRSNO,LRCPT)=0
SET LRIENS=LRI_","_LRDFN_","
+4 SET LRRDT1=$$GET1^DIQ(LRSF,LRIENS,.11,"I")
+5 SET LRRDT2=$$GET1^DIQ(LRSF,LRIENS,.15,"I")
+6 IF LRRDT1!LRRDT2
SET LREL=1
+7 ;Determine if CPT activated
+8 ; I $$PATCH^BLRUTIL4("PX*1.0*119") I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES() ; IHS/MSC/MKK - LR*5.2*1031
+9 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")
IF $TEXT(ES^LRCAPES)'=""
SET LRESCPT=$$ES^LRCAPES()
+10 IF LRSOP="G"
IF LREL
Begin DoDot:1
+11 WRITE $CHAR(7),!!,"Report verified. Cannot edit with this option."
End DoDot:1
QUIT
+12 IF LRSOP'=""
IF "ABM"[LRSOP
IF LREL
Begin DoDot:1
+13 ;Allow SNOMED and CPT coding even after release.
+14 WRITE $CHAR(7),!!,"Report has been verified. "
+15 IF 'LRESCPT
IF LRSOP'="B"
Begin DoDot:2
+16 WRITE "Cannot edit with this option."
+17 SET LRQUIT=1
End DoDot:2
QUIT
+18 WRITE "Only "
+19 IF LRESCPT
WRITE "CPT "
IF LRSOP="B"
WRITE "and "
+20 IF LRSOP="B"
WRITE "SNOMED "
+21 WRITE "coding permitted.",!
+22 IF LRSOP="B"
Begin DoDot:2
+23 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Enter SNOMED coding"
SET DIR("B")="NO"
+24 DO ^DIR
WRITE !
+25 SET LRSNO=+Y
End DoDot:2
+26 IF 'LRESCPT
QUIT
+27 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Enter CPT coding"
SET DIR("B")="NO"
+28 DO ^DIR
WRITE !
+29 SET LRCPT=+Y
+30 IF "AM"[LRSOP
IF 'LRCPT
SET LRQUIT=1
QUIT
+31 IF LRSOP="B"
IF 'LRCPT
IF 'LRSNO
SET LRQUIT=1
End DoDot:1
IF LRQUIT
QUIT
+32 ;
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 !
SET LRA=^LR(LRDFN,LRSS,LRI,0)
SET LRRC=$PIECE(LRA,"^",10)
+2 IF LRCAPA
IF "SPCYEM"[LRSS
DO C^LRAPSWK
+3 SET DIE="^LR(LRDFN,LRSS,"
SET DA=LRI
SET DA(1)=LRDFN
+4 DO CK^LRU
IF $DATA(LR("CK"))
QUIT
+5 IF LRSS="SP"
IF LRSOP="B"
IF $ORDER(^LR(LRDFN,LRSS,LRI,1.3,0))
Begin DoDot:1
+6 WRITE $CHAR(7),!!,"This accession has a FROZEN SECTION report."
+7 WRITE !,"Be sure 'FROZEN SECTION' is entered as a SNOMED code in the "
+8 WRITE "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 SET LRAC=$PIECE(LRA,U,6)
+14 IF LRELSD
DO MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
+15 ; D UPDATE^LRPXRM(LRDFN,LRSS,LRI) ; IHS/OIT/MKK - LR*5.2*1030 - RPMS Does NOT use Clinical Reminders
+16 ; IHS/MSC/MKK - LR*5.2*1031
IF $$PATCH^BLRUTIL4("PXRM*1.5*12")
DO UPDATE^LRPXRM(LRDFN,LRSS,LRI)
+17 IF LRSFLG="S"&('$DATA(Y))
DO ^LRAPDSR
+18 DO FRE^LRU
+19 IF LRSOP'=""
IF "ABM"[LRSOP
DO CPTCOD
+20 ;
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):5
IF '$TEST
Begin DoDot:2
+5 SET MSG(1)="The preliminary reports queue is in use by another person."
+6 SET MSG(1,"F")="!!"
+7 SET MSG(2)=" You will need to add this accession to the queue later."
+8 DO EN^DDIOL(.MSG)
KILL 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):5
IF '$TEST
Begin DoDot:2
+14 SET MSG(1)="The final reports queue is in use by another person. "
+15 SET MSG(1,"F")="!!"
+16 SET MSG(2)="You will need to add this accession to the queue later."
+17 DO EN^DDIOL(.MSG)
KILL 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 ;
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 ;
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 ; I $$PATCH^BLRUTIL4("PX*1.0*119") I $T(ES^LRCAPES)'="" S LRESCPT=$$ES^LRCAPES() ; IHS/MSC/MKK - LR*5.2*1031
+7 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")
IF $TEXT(ES^LRCAPES)'=""
SET LRESCPT=$$ES^LRCAPES()
+8 ; Allow supp report to be added on verified AU
+9 IF LRSOP'=""
IF "AFIP"[LRSOP
IF LREL
Begin DoDot:1
+10 IF LRESCPT&("AP"[LRSOP)
QUIT
+11 WRITE $CHAR(7),!!,"Report verified. Cannot edit with this option!"
+12 SET LRQUIT=1
End DoDot:1
IF LRQUIT
QUIT
+13 IF LRSOP'=""
IF "ABP"[LRSOP
IF LREL
Begin DoDot:1
+14 WRITE $CHAR(7),!!,"Report has been verified. "
+15 WRITE "Only "
+16 IF LRESCPT
WRITE "CPT "
IF LRSOP="B"
WRITE "and "
+17 IF LRSOP="B"
WRITE "SNOMED "
+18 WRITE "coding permitted.",!
+19 IF LRSOP="B"
Begin DoDot:2
+20 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Enter SNOMED coding"
SET DIR("B")="NO"
+21 DO ^DIR
WRITE !
+22 SET LRSNO=+Y
End DoDot:2
+23 IF 'LRESCPT
QUIT
+24 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Enter CPT coding"
SET DIR("B")="NO"
+25 DO ^DIR
WRITE !
+26 SET LRCPT=+Y
+27 IF "AP"[LRSOP
IF 'LRCPT
SET LRQUIT=1
QUIT
+28 IF LRSOP="B"
IF 'LRCPT
IF 'LRSNO
SET LRQUIT=1
End DoDot:1
IF LRQUIT
QUIT
+29 ;
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):5
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")
+17 SET LRI=$PIECE(LRA,U)
+18 SET LRAC=$PIECE(LRA,U,6)
+19 IF LRELSD
DO MAIN^LRAPRES1(LRDFN,LRSS,LRI,LRSF,LRP,LRAC)
End DoDot:1
+20 IF LRSFLG="S"
DO ^LRAPDSR
+21 ; D UPDATE^LRPXRM(LRDFN,"AU") ; IHS/OIT/MKK - LR*5.2*1030 - RPMS Does NOT use Clinical Reminders
+22 ; IHS/MSC/MKK - LR*5.2*1031
IF $$PATCH^BLRUTIL4("PXRM*1.5*12")
DO UPDATE^LRPXRM(LRDFN,"AU")
+23 LOCK -^LR(LRDFN)
+24 IF "BAP"[LRSOP
DO AU
+25 IF LRSOP="R"
DO R
+26 IF LRSOP'=""
IF "ABP"[LRSOP
DO CPTCOD
+27 QUIT
+28 ;
AU IF '$DATA(^LRO(69.2,LRAA,2,LRAN,0))
Begin DoDot:1
+1 LOCK +^LRO(69.2,LRAA,2):5
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 ;
R IF '$DATA(^LRO(69.2,LRAA,3,LRAN,0))
Begin DoDot:1
+1 LOCK +^LRO(69.2,LRAA,3):5
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 ;
PNAME ;Patient Name Lookup
+1 ;LRPFLG tells LRUPS to limit accessions to
NEW LRPFLG
+2 ;the chosen year.
SET X=LRAN
SET LRPFLG=1
+3 KILL LRAN,DIC,VADM,VAIN,VA
+4 SET DFN=-1
SET DIC(0)="EQM"
SET (LRX,LRDPF)=""
+5 IF '$DATA(LRLABKY)
DO LABKEY^LRPARAM
+6 DO DPA1^LRDPA
+7 IF DFN=-1
SET LRAN=-1
QUIT
+8 DO I^LRUPS
+9 QUIT
+10 ;
CPTCOD ;CPT Coding
+1 NEW LRPRO
+2 ; Q:$T(CPT^LRCAPES)=""
+3 ; I '$$PATCH^BLRUTIL4("PX*1.0*119") Q ; IHS/MSC/MKK - LR*5.2*1031
+4 ; IHS/MSC/MKK - LR*5.2*1034
IF '$$PATCH^BLRUTIL4("PX*1.0*197")
QUIT
+5 ;
+6 IF LREL&('LRCPT)
QUIT
+7 IF 'LREL
Begin DoDot:1
+8 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Enter CPT coding"
SET DIR("B")="NO"
+9 DO ^DIR
WRITE !
+10 SET LRCPT=+Y
End DoDot:1
+11 IF 'LRCPT
QUIT
+12 ;SET PROVIDER TO CURRENT USER, ALLOW UPDATES
+13 SET LRPRO=DUZ
+14 DO PROVIDR^LRAPUTL
+15 IF LRQUIT
QUIT
+16 DO CPT^LRCAPES(LRAA,LRAD,LRAN,LRPRO)
+17 QUIT
+18 ;
END KILL LRSFLG
+1 IF $TEXT(CLEAN^LRCAPES)'=""
DO CLEAN^LRCAPES
+2 DO V^LRU
+3 QUIT
