Routine: LRAPMRL

LRAPMRL ;DALOI/STAFF - AP MODIFY RELEASED REPORT;02/28/12  20:38

 ;;5.2;LAB SERVICE;**259,295,317,368,397,350**;Sep 27, 1994;Build 230

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,LRSEL

 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

 D V^LRU

ACCPN ; Prompt for accession number or patient name or UID

 F  D  Q:LREND

 . S (LRQUIT,LREND)=0

 . D CPTCHK

 . D LOOKUP^LRAPUTL(.LRDATA,LRH(0),LRO(68),LRSS,LRAD,LRAA)

 . I LRSEL=3,$D(X) I X=""!(X[U) S LREND=1 Q

 . I '$D(LRSEL)!(LRDATA<1)!('$G(LRAN))!($G(LRAN)=-1) S LREND=1 Q

 . I 'LRSEL S LREND=1 Q

 . S LRDFN=LRDATA,LRI=LRDATA(1)

 . S LRLOCK="^LR(LRDFN"_$S(LRAU:")",1:",LRSS,LRI)")

 . L +@(LRLOCK):DILOCKTM 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 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

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

NOTICE ; Warn the user and allow an exit

 N LRMSG

 S LRMSG(1)=$$CJ^XLFSTR("NOTICE",IOM),LRMSG(1,"F")="!!"

 S LRMSG(2)=" ",LRMSG(2,"F")="!"

 S LRMSG(3)=$C(7)_"This option allows modification of a verified/released pathology report.",LRMSG(3,"F")="!?3"

 S LRMSG(4)="Continuing with this option will unrelease the report and flag the report",LRMSG(4,"F")="!?3"

 S LRMSG(5)="as modified even if the data is unchanged.  It will also be queued to the",LRMSG(5,"F")="!?3"

 S LRMSG(6)="final report queue so that it may be verified/released again.",LRMSG(6,"F")="!?3"

 D EN^DDIOL(.LRMSG)

 W !!

 S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="NO"

 D ^DIR

 S:Y<1 LRQUIT=1

WHAT ; What is to be edited

 N XASK

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(DIRUT) S LRQUIT=1 Q

 S LREDIAG=$S(Y=2:1,1:0)

CPTCHK ; Determine if CPT is activated

 Q:$T(ES^LRCAPES)=""

 S LRESCPT=$$ES^LRCAPES()

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

 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

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)

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)

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

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

 . N LRMSG

 . S LRMSG(1)="There is no "_LRDSC_" text to modify.",LRMSG(1,"F")="!!"

 . S LRMSG(2)="Report was released before entering text.",LRMSG(2,"F")="!"

 . D EN^DDIOL(.LRMSG)

 . S LRNOTXT=1

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)

 ; Indicate that the diagnosis has been modified.

 I LRCHG&(LRFLD=1.4!(LRFLD=32.3)) D

 . K LRFDA

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

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

STORE ;

 K LRIENS1

 S LRIENS1=LRORIEN(1)_","_LRIENS

 S LRWPROOT="^TMP(""DIQ1"",$J)"

 D WP^DIE(LRFILE,LRIENS1,1,"",LRWPROOT)

 K ^TMP("DIQ1",$J),LRORIEN

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

UNLOCK ; Unlock the record

 D UPDATE^LRPXRM(LRDFN,$G(LRSS,"AU"),$G(LRI))

 L -@(LRLOCK)

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPMRL   7745     printed  Feb 18, 2025@23:33:35                                                                                                                                                                                                     Page 2

LRAPMRL   ;DALOI/STAFF - AP MODIFY RELEASED REPORT;02/28/12  20:38

 +1       ;;5.2;LAB SERVICE;**259,295,317,368,397,350**;Sep 27, 1994;Build 230

 +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,LRSEL

 +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       DO V^LRU

 +25       QUIT

 +26      ;

 +27      ;

ACCPN     ; Prompt for accession number or patient name or UID

 +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 LRSEL=3

                       IF $DATA(X)

                           IF X=""!(X[U)

                               SET LREND=1

                               QUIT

 +6                IF '$DATA(LRSEL)!(LRDATA<1)!('$GET(LRAN))!($GET(LRAN)=-1)

                       SET LREND=1

                       QUIT

 +7                IF 'LRSEL

                       SET LREND=1

                       QUIT

 +8                SET LRDFN=LRDATA

                   SET LRI=LRDATA(1)

 +9                SET LRLOCK="^LR(LRDFN"_$SELECT(LRAU:")",1:",LRSS,LRI)")

 +10               LOCK +@(LRLOCK):DILOCKTM

                   IF '$TEST

                       Begin DoDot:2

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

 +12                       SET LRMSG=LRMSG_"Please try again later."

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

                           KILL LRMSG

                       End DoDot:2

                       QUIT

 +14               SET LRIENS=$SELECT('LRAU:LRI_",",1:"")_LRDFN_","

 +15               DO RELCHK^LRAPMRL1

 +16               IF LRQUIT

                       DO UNLOCK

                       QUIT

 +17               DO RELEASE^LRAPMRL1

 +18               DO QUEUPD^LRAPMRL1

 +19               if LRCAPA

                       DO C^LRAPSWK

 +20               if 'LREDIAG

                       DO SETDR^LRAPMRL1

                       DO EDIT^LRAPMRL1

 +21               IF LRQUIT

                       DO UNLOCK

                       QUIT

 +22               IF 'LRAU

                       Begin DoDot:2

 +23                       FOR LRFLD=1,1.1,1.4,1.3

                               Begin DoDot:3

 +24                               if LREDIAG&(LRFLD'=1.4)

                                       QUIT

 +25                               if 'LREDIAG&(LRFLD=1.4)

                                       QUIT

 +26                               if LRFLD=1.3&(LRSS'="SP")

                                       QUIT

 +27                               DO ASK2

                                   if LRQUIT!('LRGMDF)

                                       QUIT

 +28                               DO SAVTXT

 +29                               KILL DR

                                   SET DR=LRFLD

 +30                               DO EDIT^LRAPMRL1

 +31                               DO COMPARE

                                   if LRQUIT

                                       QUIT

 +32                               DO AUDIT

                                   if LRQUIT

                                       QUIT

 +33                               DO STORE

                               End DoDot:3

                               if LRQUIT

                                   QUIT

                       End DoDot:2

 +34               IF LRAU

                       IF LREDIAG

                           Begin DoDot:2

 +35                           SET LRDSC="PATHOLOGICAL DIAGNOSIS"

 +36                           SET LRFLD=32.3

 +37                           DO SAVTXT

 +38                           KILL DR

                               SET DR=LRFLD

 +39                           DO EDIT^LRAPMRL1

 +40                           DO COMPARE

                           End DoDot:2

 +41               IF $GET(SEX)["F"

                       IF "SPCY"[LRSS

                           DO DEL^LRWOMEN

 +42               IF LRQUIT

                       DO UNLOCK

                       QUIT

 +43               IF LREDIAG

                       DO UNLOCK

                       QUIT

 +44               if LRESCPT

                       DO CPTCODE^LRAPMRL1

 +45               DO UNLOCK

               End DoDot:1

               if LREND

                   QUIT

 +46       QUIT

 +47      ;

 +48      ;

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

 +11      ;

 +12      ;

NOTICE    ; Warn the user and allow an exit

 +1        NEW LRMSG

 +2        SET LRMSG(1)=$$CJ^XLFSTR("NOTICE",IOM)

           SET LRMSG(1,"F")="!!"

 +3        SET LRMSG(2)=" "

           SET LRMSG(2,"F")="!"

 +4        SET LRMSG(3)=$CHAR(7)_"This option allows modification of a verified/released pathology report."

           SET LRMSG(3,"F")="!?3"

 +5        SET LRMSG(4)="Continuing with this option will unrelease the report and flag the report"

           SET LRMSG(4,"F")="!?3"

 +6        SET LRMSG(5)="as modified even if the data is unchanged.  It will also be queued to the"

           SET LRMSG(5,"F")="!?3"

 +7        SET LRMSG(6)="final report queue so that it may be verified/released again."

           SET LRMSG(6,"F")="!?3"

 +8        DO EN^DDIOL(.LRMSG)

 +9        WRITE !!

 +10       SET DIR(0)="Y"

           SET DIR("A")="Do you wish to continue"

           SET DIR("B")="NO"

 +11       DO ^DIR

 +12       if Y<1

               SET LRQUIT=1

 +13       QUIT

 +14      ;

 +15      ;

WHAT      ; What is to be edited

 +1        NEW XASK

 +2        WRITE !

 +3        KILL DIR

 +4       ; Don't ask to Edit Diagnosis if initial entry of diagnosis is turned 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(DIRUT)

               SET LRQUIT=1

               QUIT

 +15       SET LREDIAG=$SELECT(Y=2:1,1:0)

 +16       QUIT

 +17      ;

 +18      ;

CPTCHK    ; Determine if CPT is activated

 +1        if $TEXT(ES^LRCAPES)=""

               QUIT

 +2        SET LRESCPT=$$ES^LRCAPES()

 +3        QUIT

 +4       ;

 +5       ;

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

           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

 +12      ;

 +13      ;

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

 +18      ;

 +19      ;

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

 +5       ;

 +6       ;

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

 +18      ;

 +19      ;

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                NEW LRMSG

 +9                SET LRMSG(1)="There is no "_LRDSC_" text to modify."

                   SET LRMSG(1,"F")="!!"

 +10               SET LRMSG(2)="Report was released before entering text."

                   SET LRMSG(2,"F")="!"

 +11               DO EN^DDIOL(.LRMSG)

 +12               SET LRNOTXT=1

               End DoDot:1

 +13       QUIT

 +14      ;

 +15      ;

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      ;

 +13       IF 'LRCHG

               Begin DoDot:1

 +14               SET LRCT=0

FOR

                       SET LRCT=$ORDER(^TMP("DIQ1",$JOB,LRCT))

                       if 'LRCT

                           QUIT

                       Begin DoDot:2

 +15                       IF '$DATA(@(LRFILE_"LRCT,0)"))

                               SET LRCHG=1

                       End DoDot:2

               End DoDot:1

 +16      ;

 +17       IF 'LRCHG

               Begin DoDot:1

 +18               DO EN^DDIOL("No changes made to "_LRDSC_".","","!!")

 +19               WRITE !

 +20               KILL ^TMP("DIQ1",$JOB)

               End DoDot:1

               QUIT

 +21      ;

 +22      ; Indicate that the diagnosis has been modified.

 +23       IF LRCHG&(LRFLD=1.4!(LRFLD=32.3))

               Begin DoDot:1

 +24               KILL LRFDA

 +25               if 'LRAU

                       SET LRFDA(LRSF,LRIENS,.172)=1

 +26      ;KLL-CORRECT BUG WHERE LRSF IS NULL, REPLACE LRSF WITH 63

 +27               if LRAU

                       SET LRFDA(63,LRIENS,102.2)=1

 +28      ;S:LRAU LRFDA(LRSF,LRIENS,102.2)=1

 +29               DO FILE^DIE("","LRFDA")

               End DoDot:1

 +30      ;

 +31       QUIT

 +32      ;

 +33      ;

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

 +11      ;

 +12      ;

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),LRORIEN

 +6        QUIT

 +7       ;

 +8       ;

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

 +19      ;

 +20      ;

UNLOCK    ; Unlock the record

 +1        DO UPDATE^LRPXRM(LRDFN,$GET(LRSS,"AU"),$GET(LRI))

 +2        LOCK -@(LRLOCK)

 +3        QUIT

 +4       ;

 +5       ;

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

LRAPMRL.m