LRAPMRL ;DALOI/WTY/KLL- AP MODIFY RELEASED REPORT; 17-Oct-2014 09:22 ; MKK
;;5.2;LAB SERVICE;**259,295,317,1030,368,1031,397,1033,1034**;NOV 1, 1997;Build 88
;
MAIN ;
N LRQUIT,LRMSG,LREND,LRDATA,LRREL,LRAU,LREFPD,LRWM,LRCT,LRTMP,LRGMDF
N LRFLD,LRDSC,LRCHG,LRXTMP,LRYTMP,LRIENS1,LRFILE,LRFLDA,LRAD1,LRIENS
N LRORIEN,LRWPROOT,LRFDA,LRDA,LRFIELD,LRFILE1,LRIENS2,LRDT0,LRESCPT
N LRQUIT1,LREDIAG,LRLOCK,LRNOTXT,LRORIEN
S LRESCPT=0
D TITLE
I LRQUIT D END Q
D NOTICE
I LRQUIT D END Q
D SECTION
I LRQUIT D END Q
D WHAT
I LRQUIT D END Q
D CPTCHK
;D SECTION
I LRQUIT D END Q
D ASK
I LRQUIT D END Q
D SETDR^LRAPMRL1
D ACCYR
I LRQUIT D END Q
D ACCPN
D END
Q
ACCPN ;Prompt for accesion number or patient name
F D Q:LREND
.S (LRQUIT,LREND)=0
.D CPTCHK
.D LOOKUP^LRAPUTL(.LRDATA,LRH(0),LRO(68),LRSS,LRAD,LRAA)
.I (LRDATA<1)!('$G(LRAN))!($G(LRAN)=-1) S LREND=1 Q
.S LRDFN=LRDATA,LRI=LRDATA(1)
.S LRLOCK="^LR(LRDFN"_$S(LRAU:")",1:",LRSS,LRI)")
.L +@(LRLOCK):5 I '$T D Q
..S LRMSG="This record is locked by another user. "
..S LRMSG=LRMSG_"Please try again later."
..D EN^DDIOL(LRMSG,"","!!") K LRMSG
.S LRIENS=$S('LRAU:LRI_",",1:"")_LRDFN_","
.D RELCHK^LRAPMRL1
.I LRQUIT D UNLOCK Q
.D RELEASE^LRAPMRL1
.D QUEUPD^LRAPMRL1
.D:LRCAPA&'LRAU C^LRAPSWK
.D:'LREDIAG SETDR^LRAPMRL1,EDIT^LRAPMRL1
.I LRQUIT D UNLOCK Q
.I 'LRAU D
..F LRFLD=1,1.1,1.4,1.3 D Q:LRQUIT
...Q:LREDIAG&(LRFLD'=1.4)
...Q:'LREDIAG&(LRFLD=1.4)
...Q:LRFLD=1.3&(LRSS'="SP")
...D ASK2 Q:LRQUIT!('LRGMDF)
...D SAVTXT
...K DR S DR=LRFLD
...D EDIT^LRAPMRL1
...D COMPARE Q:LRQUIT
...D AUDIT Q:LRQUIT
...D STORE
.I LRAU,LREDIAG D
..S LRDSC="PATHOLOGICAL DIAGNOSIS"
..S LRFLD=32.3
..D SAVTXT
..K DR S DR=LRFLD
..D EDIT^LRAPMRL1
..D COMPARE
.I $G(SEX)["F","SPCY"[LRSS D DEL^LRWOMEN
.I LRQUIT D UNLOCK Q
.I LREDIAG D UNLOCK Q
.D:LRESCPT CPTCODE^LRAPMRL1
.D UNLOCK
Q
TITLE ;Title
S (LRQUIT,LRQUIT1)=0
D CK^LRAP
I Y=-1 S LRQUIT=1 Q
W @IOF
S LRMSG="Modify Released Pathology Reports"
S LRMSG(1)=$$CJ^XLFSTR(LRMSG,IOM)
S LRMSG(1,"F")="!!"
S LRMSG(2)="",LRMSG(2,"F")="!"
D EN^DDIOL(.LRMSG) K LRMSG
Q
NOTICE ;Warn the user and allow an exit
K LRMSG
S LRMSG="NOTICE"
S LRMSG(1)=$$CJ^XLFSTR(LRMSG,IOM),LRMSG(1,"F")="!!"
S LRMSG(2)="",LRMSG(2,"F")="!"
S LRMSG(3)=$C(7)_"This option allows modification of a verified/"
S LRMSG(3)=LRMSG(3)_"released pathology report."
S LRMSG(3,"F")="!?3"
S LRMSG(4)="Continuing with this option will unrelease the report "
S LRMSG(4)=LRMSG(4)_"and flag the report",LRMSG(4,"F")="!?3"
S LRMSG(5)="as modified even if the data is unchanged. It will "
S LRMSG(5)=LRMSG(5)_"also be queued to the",LRMSG(5,"F")="!?3"
S LRMSG(6)="final report queue so that it may be verified/released "
S LRMSG(6)=LRMSG(6)_"again.",LRMSG(6,"F")="!?3"
D EN^DDIOL(.LRMSG) K LRMSG
W !!
S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="NO"
D ^DIR
S:Y<1 LRQUIT=1
Q
WHAT ;What is to be edited
W !
K DIR
;Don't ask to Edit Diagnosis if initial entry of diagnosis is turned
; off at data entry for SP, CY, EM's
S LRASK=1,XASK=""
I 'LRAU D
.S XASK=$S(LRSS="SP":11.2,LRSS="CY":11.3,1:"")
.S:XASK="" XASK=$S(LRSS="EM":11.4,1:"")
.S LRASK=$$GET1^DIQ(69.9,"1,",XASK,"I")
S:LRASK DIR(0)="S^1:Edit Report;2:Edit Diagnosis"
S:LRASK DIR("A")="Enter selection",DIR("B")=1
S:'LRASK DIR(0)="Y",DIR("B")="YES",DIR("A")="Edit Report?"
D ^DIR
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) S LRQUIT=1 Q
S:Y=0 LRQUIT=1
Q:LRQUIT=1
S LREDIAG=Y
S LREDIAG=$S(LREDIAG=2:1,1:0)
Q
CPTCHK ;Determine if CPT is activated
Q:$T(ES^LRCAPES)=""
; I $$PATCH^BLRUTIL4("PX*1.0*119") 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
Q
SECTION ;Choose Anatomic Pathology section (AU,SP,CY,EM)
W !
D ^LRAP
I '$D(Y)!('$D(LRSS)) S LRQUIT=1 Q
S:LRO(68)="EM" LRO(68)="ELECTRON MICROSCOPY"
S LRAU=0 ; LRAU = 0 - Not Autopsy
S:LRSS="AU" LRAU=1 ; = 1 - Autosy
I LRCAPA D @(LRSS_"^LRAPSWK")
S LRMSG(1)=LRO(68)_" ("_LRABV_")",LRMSG(1,"F")="!?20"
S LRMSG(2)="",LRMSG(2,"F")="!"
D EN^DDIOL(.LRMSG) K LRMSG
Q
ASK ;Ask etiology,function,procedure,disease,weights,measures
I LREDIAG D Q
.S:'LRAU LREFPD=0
.S:LRAU LRWM=0
W !
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Edit etiology, function, procedure & disease"
D ^DIR
I Y="^" S LRQUIT=1 Q
S LREFPD=$S(+Y:1,1:0)
I LRAU D
.W !
.S DIR(0)="Y",DIR("B")="NO"
.S DIR("A")="Edit weights and measures"
.D ^DIR
.I Y="^" S LRQUIT=1 Q
.S LRWM=$S(+Y:1,1:0)
Q
ACCYR ;Determine Accession Year
D ACCYR^LRAPUTL(.LRAD1,LRH(0),LRAA,LRO(68))
I LRAD1=-1 S LRQUIT=1 Q
I LRAD1 S LRAD=$P(LRAD1,U),LRH(0)=$P(LRAD1,U,2)
Q
ASK2 ;Ask about other fields
S LRGMDF=0
K LRDSC
I LRFLD=1!(LRFLD=1.1) D
.S:LRFLD=1 LRFLDA=7
.S:LRFLD=1.1 LRFLDA=4
.S LRDSC=$S(LRFLD=1:"GROSS",LRFLD=1.1:"MICROSCOPIC",1:"")
.S LRDSC=LRDSC_" DESCRIPTION"
S:LRFLD=1.4 LRDSC="DIAGNOSIS",LRFLDA=5
S:LRFLD=1.3 LRDSC="FROZEN SECTION",LRFLDA=6
I 'LREDIAG D
.S DIR(0)="Y",DIR("B")="NO"
.S DIR("A")="Edit "_LRDSC
.D ^DIR
.I Y="^" S LRQUIT=1 Q
.S LRGMDF=$S(+Y:1,1:0)
S:LREDIAG LRGMDF=1
Q
SAVTXT ;Save word processing field text.
S LRNOTXT=0
K ^TMP("DIQ1",$J)
S:'LRAU LRIENS=LRI_","_LRDFN_",",LRFILE=LRSF
S:LRAU LRIENS=LRDFN_",",LRFILE=63
Q:LRFLD=""
S LRTMP=$$GET1^DIQ(LRFILE,LRIENS,LRFLD,"","^TMP(""DIQ1"",$J)")
I LRTMP="" D
.K LRMSG
.S LRMSG(1)="There is no "_LRDSC_" text to modify."
.S LRMSG(1,"F")="!!"
.S LRMSG(2)="Report was released before entering text."
.S LRMSG(2,"F")="!"
.D EN^DDIOL(.LRMSG)
.S LRNOTXT=1
Q
COMPARE ;Compare report text
S (LRCHG,LRQUIT,LRCT)=0
S:'LRAU LRFILE="^LR(LRDFN,LRSS,LRI,LRFLD,"
S:LRAU LRFILE="^LR(LRDFN,82,"
I '$D(@(LRFILE_"0)")) D Q
.Q:LRNOTXT
.S LRQUIT=1
F S LRCT=$O(@(LRFILE_"LRCT)")) Q:'LRCT D
.S LRXTMP=@(LRFILE_"LRCT,0)")
.I '$D(^TMP("DIQ1",$J,LRCT)) S LRCHG=1 Q
.S LRYTMP=^TMP("DIQ1",$J,LRCT)
.I LRXTMP'=LRYTMP S LRCHG=1
I 'LRCHG D
.S LRCT=0 F S LRCT=$O(^TMP("DIQ1",$J,LRCT)) Q:'LRCT D
..I '$D(@(LRFILE_"LRCT,0)")) S LRCHG=1
I 'LRCHG D Q
.D EN^DDIOL("No changes made to "_LRDSC_".","","!!")
.W !
.K ^TMP("DIQ1",$J)
I LRCHG&(LRFLD=1.4!(LRFLD=32.3)) D ;Indicate that the diagnosis
.K LRFDA ;has been modified.
.S:'LRAU LRFDA(LRSF,LRIENS,.172)=1
.;KLL-CORRECT BUG WHERE LRSF IS NULL, REPLACE LRSF WITH 63
.S:LRAU LRFDA(63,LRIENS,102.2)=1
.;S:LRAU LRFDA(LRSF,LRIENS,102.2)=1
.D FILE^DIE("","LRFDA")
Q
AUDIT ;
N LRNTIME
K LRFDA
D NOW^%DTC S LRNTIME=%
S LRIENS1="+1,"_LRIENS
S LRFILE=+$$GET1^DID(LRSF,LRFLDA,"","SPECIFIER")
I LRFILE="" S LRQUIT=1 Q
S LRFDA(1,LRFILE,LRIENS1,.01)=LRNTIME
S LRFDA(1,LRFILE,LRIENS1,.02)=DUZ
D UPDATE^DIE("","LRFDA(1)","LRORIEN")
Q
STORE ;
K LRIENS1
S LRIENS1=LRORIEN(1)_","_LRIENS
S LRWPROOT="^TMP(""DIQ1"",$J)"
D WP^DIE(LRFILE,LRIENS1,1,"",LRWPROOT)
K ^TMP("DIQ1",$J)
Q
SUPRPT ;Supplementary Report
K DIR
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Edit SUPPLEMENTARY REPORTS"
D ^DIR
I Y="^" S LRQUIT1=1 Q
Q:Y<1
N LRX,LRRLS,LRA,LRFLG,LRNOW
D GETRPT^LRAPDSR Q:LRQUIT
S LRRLS=1,LRRLS1=0
D COPY^LRAPDSR Q:LRQUIT
D RPT^LRAPDSR Q:LRQUIT
S Y=LRDA
D RELEAS2^LRAPDSR
D COMPARE^LRAPDSR Q:LRQUIT
D UNRELEAS^LRAPDSR
D UPDATE^LRAPDSR Q:LRQUIT
D STORE^LRAPDSR
Q
UNLOCK ;Unlock the record
; D UPDATE^LRPXRM(LRDFN,$G(LRSS,"AU"),$G(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,$G(LRSS,"AU"),$G(LRI)) ; IHS/MSC/MKK - LR*5.2*1031
L -@(LRLOCK)
Q
END ;Clean-up variables and quit
K ^TMP("LRAPBR",$J),^TMP("TIUP",$J)
D CLEAN^DILF
D:$T(CLEAN^LRCAPES)'="" CLEAN^LRCAPES
D V^LRU
Q
LRAPMRL ;DALOI/WTY/KLL- AP MODIFY RELEASED REPORT; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**259,295,317,1030,368,1031,397,1033,1034**;NOV 1, 1997;Build 88
+2 ;
MAIN ;
+1 NEW LRQUIT,LRMSG,LREND,LRDATA,LRREL,LRAU,LREFPD,LRWM,LRCT,LRTMP,LRGMDF
+2 NEW LRFLD,LRDSC,LRCHG,LRXTMP,LRYTMP,LRIENS1,LRFILE,LRFLDA,LRAD1,LRIENS
+3 NEW LRORIEN,LRWPROOT,LRFDA,LRDA,LRFIELD,LRFILE1,LRIENS2,LRDT0,LRESCPT
+4 NEW LRQUIT1,LREDIAG,LRLOCK,LRNOTXT,LRORIEN
+5 SET LRESCPT=0
+6 DO TITLE
+7 IF LRQUIT
DO END
QUIT
+8 DO NOTICE
+9 IF LRQUIT
DO END
QUIT
+10 DO SECTION
+11 IF LRQUIT
DO END
QUIT
+12 DO WHAT
+13 IF LRQUIT
DO END
QUIT
+14 DO CPTCHK
+15 ;D SECTION
+16 IF LRQUIT
DO END
QUIT
+17 DO ASK
+18 IF LRQUIT
DO END
QUIT
+19 DO SETDR^LRAPMRL1
+20 DO ACCYR
+21 IF LRQUIT
DO END
QUIT
+22 DO ACCPN
+23 DO END
+24 QUIT
ACCPN ;Prompt for accesion number or patient name
+1 FOR
Begin DoDot:1
+2 SET (LRQUIT,LREND)=0
+3 DO CPTCHK
+4 DO LOOKUP^LRAPUTL(.LRDATA,LRH(0),LRO(68),LRSS,LRAD,LRAA)
+5 IF (LRDATA<1)!('$GET(LRAN))!($GET(LRAN)=-1)
SET LREND=1
QUIT
+6 SET LRDFN=LRDATA
SET LRI=LRDATA(1)
+7 SET LRLOCK="^LR(LRDFN"_$SELECT(LRAU:")",1:",LRSS,LRI)")
+8 LOCK +@(LRLOCK):5
IF '$TEST
Begin DoDot:2
+9 SET LRMSG="This record is locked by another user. "
+10 SET LRMSG=LRMSG_"Please try again later."
+11 DO EN^DDIOL(LRMSG,"","!!")
KILL LRMSG
End DoDot:2
QUIT
+12 SET LRIENS=$SELECT('LRAU:LRI_",",1:"")_LRDFN_","
+13 DO RELCHK^LRAPMRL1
+14 IF LRQUIT
DO UNLOCK
QUIT
+15 DO RELEASE^LRAPMRL1
+16 DO QUEUPD^LRAPMRL1
+17 IF LRCAPA&'LRAU
DO C^LRAPSWK
+18 IF 'LREDIAG
DO SETDR^LRAPMRL1
DO EDIT^LRAPMRL1
+19 IF LRQUIT
DO UNLOCK
QUIT
+20 IF 'LRAU
Begin DoDot:2
+21 FOR LRFLD=1,1.1,1.4,1.3
Begin DoDot:3
+22 IF LREDIAG&(LRFLD'=1.4)
QUIT
+23 IF 'LREDIAG&(LRFLD=1.4)
QUIT
+24 IF LRFLD=1.3&(LRSS'="SP")
QUIT
+25 DO ASK2
IF LRQUIT!('LRGMDF)
QUIT
+26 DO SAVTXT
+27 KILL DR
SET DR=LRFLD
+28 DO EDIT^LRAPMRL1
+29 DO COMPARE
IF LRQUIT
QUIT
+30 DO AUDIT
IF LRQUIT
QUIT
+31 DO STORE
End DoDot:3
IF LRQUIT
QUIT
End DoDot:2
+32 IF LRAU
IF LREDIAG
Begin DoDot:2
+33 SET LRDSC="PATHOLOGICAL DIAGNOSIS"
+34 SET LRFLD=32.3
+35 DO SAVTXT
+36 KILL DR
SET DR=LRFLD
+37 DO EDIT^LRAPMRL1
+38 DO COMPARE
End DoDot:2
+39 IF $GET(SEX)["F"
IF "SPCY"[LRSS
DO DEL^LRWOMEN
+40 IF LRQUIT
DO UNLOCK
QUIT
+41 IF LREDIAG
DO UNLOCK
QUIT
+42 IF LRESCPT
DO CPTCODE^LRAPMRL1
+43 DO UNLOCK
End DoDot:1
IF LREND
QUIT
+44 QUIT
TITLE ;Title
+1 SET (LRQUIT,LRQUIT1)=0
+2 DO CK^LRAP
+3 IF Y=-1
SET LRQUIT=1
QUIT
+4 WRITE @IOF
+5 SET LRMSG="Modify Released Pathology Reports"
+6 SET LRMSG(1)=$$CJ^XLFSTR(LRMSG,IOM)
+7 SET LRMSG(1,"F")="!!"
+8 SET LRMSG(2)=""
SET LRMSG(2,"F")="!"
+9 DO EN^DDIOL(.LRMSG)
KILL LRMSG
+10 QUIT
NOTICE ;Warn the user and allow an exit
+1 KILL LRMSG
+2 SET LRMSG="NOTICE"
+3 SET LRMSG(1)=$$CJ^XLFSTR(LRMSG,IOM)
SET LRMSG(1,"F")="!!"
+4 SET LRMSG(2)=""
SET LRMSG(2,"F")="!"
+5 SET LRMSG(3)=$CHAR(7)_"This option allows modification of a verified/"
+6 SET LRMSG(3)=LRMSG(3)_"released pathology report."
+7 SET LRMSG(3,"F")="!?3"
+8 SET LRMSG(4)="Continuing with this option will unrelease the report "
+9 SET LRMSG(4)=LRMSG(4)_"and flag the report"
SET LRMSG(4,"F")="!?3"
+10 SET LRMSG(5)="as modified even if the data is unchanged. It will "
+11 SET LRMSG(5)=LRMSG(5)_"also be queued to the"
SET LRMSG(5,"F")="!?3"
+12 SET LRMSG(6)="final report queue so that it may be verified/released "
+13 SET LRMSG(6)=LRMSG(6)_"again."
SET LRMSG(6,"F")="!?3"
+14 DO EN^DDIOL(.LRMSG)
KILL LRMSG
+15 WRITE !!
+16 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue"
SET DIR("B")="NO"
+17 DO ^DIR
+18 IF Y<1
SET LRQUIT=1
+19 QUIT
WHAT ;What is to be edited
+1 WRITE !
+2 KILL DIR
+3 ;Don't ask to Edit Diagnosis if initial entry of diagnosis is turned
+4 ; off at data entry for SP, CY, EM's
+5 SET LRASK=1
SET XASK=""
+6 IF 'LRAU
Begin DoDot:1
+7 SET XASK=$SELECT(LRSS="SP":11.2,LRSS="CY":11.3,1:"")
+8 IF XASK=""
SET XASK=$SELECT(LRSS="EM":11.4,1:"")
+9 SET LRASK=$$GET1^DIQ(69.9,"1,",XASK,"I")
End DoDot:1
+10 IF LRASK
SET DIR(0)="S^1:Edit Report;2:Edit Diagnosis"
+11 IF LRASK
SET DIR("A")="Enter selection"
SET DIR("B")=1
+12 IF 'LRASK
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Edit Report?"
+13 DO ^DIR
+14 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
SET LRQUIT=1
QUIT
+15 IF Y=0
SET LRQUIT=1
+16 IF LRQUIT=1
QUIT
+17 SET LREDIAG=Y
+18 SET LREDIAG=$SELECT(LREDIAG=2:1,1:0)
+19 QUIT
CPTCHK ;Determine if CPT is activated
+1 IF $TEXT(ES^LRCAPES)=""
QUIT
+2 ; I $$PATCH^BLRUTIL4("PX*1.0*119") S LRESCPT=$$ES^LRCAPES() ; IHS/MSC/MKK - LR*5.2*1031
+3 ; IHS/MSC/MKK - LR*5.2*1033
IF $$PATCH^BLRUTIL4("PX*1.0*197")
IF $TEXT(ES^LRCAPES)'=""
SET LRESCPT=$$ES^LRCAPES()
+4 QUIT
SECTION ;Choose Anatomic Pathology section (AU,SP,CY,EM)
+1 WRITE !
+2 DO ^LRAP
+3 IF '$DATA(Y)!('$DATA(LRSS))
SET LRQUIT=1
QUIT
+4 IF LRO(68)="EM"
SET LRO(68)="ELECTRON MICROSCOPY"
+5 ; LRAU = 0 - Not Autopsy
SET LRAU=0
+6 ; = 1 - Autosy
IF LRSS="AU"
SET LRAU=1
+7 IF LRCAPA
DO @(LRSS_"^LRAPSWK")
+8 SET LRMSG(1)=LRO(68)_" ("_LRABV_")"
SET LRMSG(1,"F")="!?20"
+9 SET LRMSG(2)=""
SET LRMSG(2,"F")="!"
+10 DO EN^DDIOL(.LRMSG)
KILL LRMSG
+11 QUIT
ASK ;Ask etiology,function,procedure,disease,weights,measures
+1 IF LREDIAG
Begin DoDot:1
+2 IF 'LRAU
SET LREFPD=0
+3 IF LRAU
SET LRWM=0
End DoDot:1
QUIT
+4 WRITE !
+5 SET DIR(0)="Y"
SET DIR("B")="NO"
+6 SET DIR("A")="Edit etiology, function, procedure & disease"
+7 DO ^DIR
+8 IF Y="^"
SET LRQUIT=1
QUIT
+9 SET LREFPD=$SELECT(+Y:1,1:0)
+10 IF LRAU
Begin DoDot:1
+11 WRITE !
+12 SET DIR(0)="Y"
SET DIR("B")="NO"
+13 SET DIR("A")="Edit weights and measures"
+14 DO ^DIR
+15 IF Y="^"
SET LRQUIT=1
QUIT
+16 SET LRWM=$SELECT(+Y:1,1:0)
End DoDot:1
+17 QUIT
ACCYR ;Determine Accession Year
+1 DO ACCYR^LRAPUTL(.LRAD1,LRH(0),LRAA,LRO(68))
+2 IF LRAD1=-1
SET LRQUIT=1
QUIT
+3 IF LRAD1
SET LRAD=$PIECE(LRAD1,U)
SET LRH(0)=$PIECE(LRAD1,U,2)
+4 QUIT
ASK2 ;Ask about other fields
+1 SET LRGMDF=0
+2 KILL LRDSC
+3 IF LRFLD=1!(LRFLD=1.1)
Begin DoDot:1
+4 IF LRFLD=1
SET LRFLDA=7
+5 IF LRFLD=1.1
SET LRFLDA=4
+6 SET LRDSC=$SELECT(LRFLD=1:"GROSS",LRFLD=1.1:"MICROSCOPIC",1:"")
+7 SET LRDSC=LRDSC_" DESCRIPTION"
End DoDot:1
+8 IF LRFLD=1.4
SET LRDSC="DIAGNOSIS"
SET LRFLDA=5
+9 IF LRFLD=1.3
SET LRDSC="FROZEN SECTION"
SET LRFLDA=6
+10 IF 'LREDIAG
Begin DoDot:1
+11 SET DIR(0)="Y"
SET DIR("B")="NO"
+12 SET DIR("A")="Edit "_LRDSC
+13 DO ^DIR
+14 IF Y="^"
SET LRQUIT=1
QUIT
+15 SET LRGMDF=$SELECT(+Y:1,1:0)
End DoDot:1
+16 IF LREDIAG
SET LRGMDF=1
+17 QUIT
SAVTXT ;Save word processing field text.
+1 SET LRNOTXT=0
+2 KILL ^TMP("DIQ1",$JOB)
+3 IF 'LRAU
SET LRIENS=LRI_","_LRDFN_","
SET LRFILE=LRSF
+4 IF LRAU
SET LRIENS=LRDFN_","
SET LRFILE=63
+5 IF LRFLD=""
QUIT
+6 SET LRTMP=$$GET1^DIQ(LRFILE,LRIENS,LRFLD,"","^TMP(""DIQ1"",$J)")
+7 IF LRTMP=""
Begin DoDot:1
+8 KILL LRMSG
+9 SET LRMSG(1)="There is no "_LRDSC_" text to modify."
+10 SET LRMSG(1,"F")="!!"
+11 SET LRMSG(2)="Report was released before entering text."
+12 SET LRMSG(2,"F")="!"
+13 DO EN^DDIOL(.LRMSG)
+14 SET LRNOTXT=1
End DoDot:1
+15 QUIT
COMPARE ;Compare report text
+1 SET (LRCHG,LRQUIT,LRCT)=0
+2 IF 'LRAU
SET LRFILE="^LR(LRDFN,LRSS,LRI,LRFLD,"
+3 IF LRAU
SET LRFILE="^LR(LRDFN,82,"
+4 IF '$DATA(@(LRFILE_"0)"))
Begin DoDot:1
+5 IF LRNOTXT
QUIT
+6 SET LRQUIT=1
End DoDot:1
QUIT
+7 FOR
SET LRCT=$ORDER(@(LRFILE_"LRCT)"))
IF 'LRCT
QUIT
Begin DoDot:1
+8 SET LRXTMP=@(LRFILE_"LRCT,0)")
+9 IF '$DATA(^TMP("DIQ1",$JOB,LRCT))
SET LRCHG=1
QUIT
+10 SET LRYTMP=^TMP("DIQ1",$JOB,LRCT)
+11 IF LRXTMP'=LRYTMP
SET LRCHG=1
End DoDot:1
+12 IF 'LRCHG
Begin DoDot:1
+13 SET LRCT=0
FOR
SET LRCT=$ORDER(^TMP("DIQ1",$JOB,LRCT))
IF 'LRCT
QUIT
Begin DoDot:2
+14 IF '$DATA(@(LRFILE_"LRCT,0)"))
SET LRCHG=1
End DoDot:2
End DoDot:1
+15 IF 'LRCHG
Begin DoDot:1
+16 DO EN^DDIOL("No changes made to "_LRDSC_".","","!!")
+17 WRITE !
+18 KILL ^TMP("DIQ1",$JOB)
End DoDot:1
QUIT
+19 ;Indicate that the diagnosis
IF LRCHG&(LRFLD=1.4!(LRFLD=32.3))
Begin DoDot:1
+20 ;has been modified.
KILL LRFDA
+21 IF 'LRAU
SET LRFDA(LRSF,LRIENS,.172)=1
+22 ;KLL-CORRECT BUG WHERE LRSF IS NULL, REPLACE LRSF WITH 63
+23 IF LRAU
SET LRFDA(63,LRIENS,102.2)=1
+24 ;S:LRAU LRFDA(LRSF,LRIENS,102.2)=1
+25 DO FILE^DIE("","LRFDA")
End DoDot:1
+26 QUIT
AUDIT ;
+1 NEW LRNTIME
+2 KILL LRFDA
+3 DO NOW^%DTC
SET LRNTIME=%
+4 SET LRIENS1="+1,"_LRIENS
+5 SET LRFILE=+$$GET1^DID(LRSF,LRFLDA,"","SPECIFIER")
+6 IF LRFILE=""
SET LRQUIT=1
QUIT
+7 SET LRFDA(1,LRFILE,LRIENS1,.01)=LRNTIME
+8 SET LRFDA(1,LRFILE,LRIENS1,.02)=DUZ
+9 DO UPDATE^DIE("","LRFDA(1)","LRORIEN")
+10 QUIT
STORE ;
+1 KILL LRIENS1
+2 SET LRIENS1=LRORIEN(1)_","_LRIENS
+3 SET LRWPROOT="^TMP(""DIQ1"",$J)"
+4 DO WP^DIE(LRFILE,LRIENS1,1,"",LRWPROOT)
+5 KILL ^TMP("DIQ1",$JOB)
+6 QUIT
SUPRPT ;Supplementary Report
+1 KILL DIR
+2 SET DIR(0)="Y"
SET DIR("B")="NO"
+3 SET DIR("A")="Edit SUPPLEMENTARY REPORTS"
+4 DO ^DIR
+5 IF Y="^"
SET LRQUIT1=1
QUIT
+6 IF Y<1
QUIT
+7 NEW LRX,LRRLS,LRA,LRFLG,LRNOW
+8 DO GETRPT^LRAPDSR
IF LRQUIT
QUIT
+9 SET LRRLS=1
SET LRRLS1=0
+10 DO COPY^LRAPDSR
IF LRQUIT
QUIT
+11 DO RPT^LRAPDSR
IF LRQUIT
QUIT
+12 SET Y=LRDA
+13 DO RELEAS2^LRAPDSR
+14 DO COMPARE^LRAPDSR
IF LRQUIT
QUIT
+15 DO UNRELEAS^LRAPDSR
+16 DO UPDATE^LRAPDSR
IF LRQUIT
QUIT
+17 DO STORE^LRAPDSR
+18 QUIT
UNLOCK ;Unlock the record
+1 ; D UPDATE^LRPXRM(LRDFN,$G(LRSS,"AU"),$G(LRI)) ; IHS/OIT/MKK - LR*5.2*1030 - RPMS Does NOT use Clinical Reminders
+2 ; IHS/MSC/MKK - LR*5.2*1031
IF $$PATCH^BLRUTIL4("PXRM*1.5*12")
DO UPDATE^LRPXRM(LRDFN,$GET(LRSS,"AU"),$GET(LRI))
+3 LOCK -@(LRLOCK)
+4 QUIT
END ;Clean-up variables and quit
+1 KILL ^TMP("LRAPBR",$JOB),^TMP("TIUP",$JOB)
+2 DO CLEAN^DILF
+3 IF $TEXT(CLEAN^LRCAPES)'=""
DO CLEAN^LRCAPES
+4 DO V^LRU
+5 QUIT
