LRHYDEL.m

LRHYDEL ;DALOI/HOAK - HOWDY DEL A TEST ;8/28/2005

 ;;5.2;LAB SERVICE;**405**;Sep 27, 1994;Build 93

 ;

 ;

 ;Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.

EN ;

 D ^LRPARAM Q:$G(LREND)

 I '$D(LRLABKY) W !?5,"You are not authorized to change test status.",!,$C(7) S LREND=1 Q

 K LRXX,LRSCNXB W @IOF

 F  S (LREND,LRNOP)=0 D FIX D  I $G(LREND) D END Q

 . I $G(LREND) D END S LREND=1 Q

 . K DIC D:'$G(LRNOP) CHG D END

 Q

FIX S (LREND,LRNOP)=0,LRNOW=$$NOW^XLFDT

 W ! S LRACC=1 D LRACC Q:$G(LRNOP)

 K LRACC,LRNATURE I $G(LRAN)<1 S LREND=1 Q

 I '$P($G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),0)),U,2) W !?5,"Accession has no Test ",! S LRNOP=1 Q

 L +^LRO(68,LRAA,1,LRAD,1,LRAN):$G(DILOCKTM,3) I '$T W !,"Someone else is working on this accession",! S LRNOP=1 Q

 S LRX=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRACN=$P(^(.2),U),LRUID=$P(^(.3),U)

 S LRDFN=+LRX,LRSN=+$P(LRX,U,5),LRODT=+$P(LRX,U,4)

 S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)

 D PT^LRX W !,PNM,?30,SSN

 S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5) L +^LR(LRDFN,LRSS,LRIDT):$G(DILOCKTM,3) I '$T W !,"Someone else is working on this data." L -^LRO(68,LRAA,1,LRAD,1,LRAN) S LRNOP=1 Q

 I '$G(^LR(LRDFN,LRSS,LRIDT,0)) W !?5," Can't find Lab Data for this accession",! D UNLOCK S LRNOP=1 Q

 I LRODT,LRSN,$D(^LRO(69,LRODT,1,LRSN,0))#2 D

 . N LRACN,LRAA,LRAD

 . D SHOW^LROS

 K DIR S DIR(0)="E" D ^DIR S:$E(X)=U LRNOP=1 Q:$G(LRNOP)

FX1 ;

 D SHOWTST

 Q

CHG K LRCTST,DIC W !

 S:'$D(DIC("A")) DIC("A")="Change which LABORATORY TEST: "

 S DIC="^LRO(68,"_LRAA_",1,"_LRAD_",1,"_LRAN_",4,",DIC("S")="I '$L($P(^(0),U,5))",DIC(0)="AEMOQ"

 F  D ^DIC Q:Y<1  S LRCTST(+Y)=$P(^LAB(60,+Y,0),U),DIC("A")="Select another test: "

 K DIC I '$O(LRCTST(0)) D  Q

 . L -^LR(LRDFN,LRSS,LRIDT) L -^LRO(68,LRAA,1,LRAD,1,LRAN)

 . W !?5,"No Test Selected",!

 I '$L(LRODT)&'$L(LRSN) W !,"NO CHANGE" D UNLOCK,END Q

 K LRCCOM S LRCCOM="",LREND=0 I '$D(^LRO(69,LRODT,1,LRSN,0))#2 W !?5,"There is no Order for this Accession",! D UNLOCK,END Q

 W @IOF,!!?5,"Change Accession : ",LRACN,?40,"UID: ",LRUID

 S I=0 F  S I=$O(LRCTST(I)) Q:I<1  W !?10,LRCTST(I)

 D FX2 Q:$G(LREND)

 S LRTSTS=0 F  S LRTSTS=$O(LRCTST(LRTSTS)) Q:LRTSTS<1  D

 . Q:'$D(^LAB(60,LRTSTS,0))#2  S LRTNM=$P(^(0),U)

 . S LRORDTST=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0),U,9) D SET

 . W:'$G(LREND) !?5,"[ "_LRTNM_" ] ",$S('$D(LRLABKY):" Marked Canceled by Floor",1:" Marked Not Performed"),!

 S LREND=0 K LRCTST

 Q

SHOWTST ;

 N LRI,LRN,DIR,LRY,LRIC,X

 S DIR(0)="E"

 D DEMO

 S LRN=0,LRI=0 F  S LRI=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI)) Q:LRI<1!($G(LRY))  D

 . S LRIC=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0)),U,4,6) Q:'$D(^LAB(60,+LRI,0))#2  W !,?5,$P(^(0),U) S LRN=LRN+1 I LRIC  D

 . . W ?35,"  "_$S($L($P(LRIC,U,3)):$P(LRIC,U,3),1:"Completed")_"  "_$$FMTE^XLFDT($P(LRIC,U,2),"5FMPZ")_" by "_$P(LRIC,U)

 . I LRN>18 D ^DIR S:$E(X)=U LRY=1 Q:$G(LRY)  D DEMO S LRN=0

 S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRODT=$P(X,U,4),LRSN=$P(X,U,5)

 Q

DEMO W !,PNM,?50,SSN

 W !,"TESTS ON ACCESSION: ",LRACN,?40,"UID: ",LRUID

 Q

SET ;

 S:'$G(LRNOW) LRNOW=$$NOW^XLFDT

 S LRLLOC=$P(^LRO(69,LRODT,1,LRSN,0),U,7) D

 . N II,X,LRI,LRSTATUS,OCXTRACE

 . S:$G(LRDBUG) OCXTRACE=1

 . S LRI=0 F  S LRI=$O(^LRO(69,LRODT,1,LRSN,2,LRI)) Q:LRI<1  I $D(^(LRI,0))#2,LRTSTS=+^(0) S (LRSTATUS,II(LRTSTS))="" D  K II

 ..  Q:$P(^LRO(69,LRODT,1,LRSN,2,LRI,0),U,12)

 . . Q:$P(^LRO(69,LRODT,1,LRSN,2,LRI,0),U,11)  S ORIFN=$P(^(0),U,7)

 . . S X=1+$O(^LRO(69,LRODT,1,LRSN,2,LRI,1.1,"A"),-1),X(1)=$P($G(^(0)),U,4)

 . . S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)=$P($G(LRNATURE),U,5)_": "_LRCCOM,X=X+1,X(1)=X(1)+1

 . . S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)="*NP Action:"_$$FMTE^XLFDT(LRNOW,"5MZ")

 . . S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,0)="^^"_X_"^"_X(1)_"^"_DT

 . . I $G(ORIFN),$D(II) D NEW^LR7OB1(LRODT,LRSN,$S($G(LRMSTATI)=""!($G(LRMSTATI)=1):"OC",1:"SC"),$G(LRNATURE),.II,LRSTATUS)

 . . I ORIFN,$$VER^LR7OU1<3 D DC^LRCENDE1

 . . S $P(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",9)="CA",$P(^(0),U,10)="L",$P(^(0),U,11)=DUZ

 . . S:$D(^LRO(69,LRODT,1,LRSN,"PCE")) ^LRO(69,"AE",DUZ,LRODT,LRSN,LRI)=""

 K ORIFN,ORSTS

 I $D(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),0))#2,$D(^(4,$G(LRTSTS),0))#2 S $P(^(0),U,4,6)=DUZ_U_LRNOW_U_$S($G(LRMERG):"*Merged",1:"*Not Performed") D

 . S LROWDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,3) I LROWDT,LROWDT'=LRAD D ROL Q

 . S LROWDT=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,9)) I LROWDT D ROL

 Q:$G(LRSS)["MI"

 I $G(LRIDT),$L($G(LRSS)),$L(LRCCOM),$G(^LR(LRDFN,LRSS,LRIDT,0)) D

 .  Q:$G(LRSS)["MI"

 . D 63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM)

 . D:'$D(^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)) XREF^LRVER3A

 D EN^LA7ADL($P($G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),.3)),"^")) ; Put in list to check for auto download.

 Q

ROL ;

 Q:+$G(^LRO(68,LRAA,1,LROWDT,1,LRAN,0))'=LRDFN  Q:'$D(^(4,LRTSTS,0))#2

 S $P(^LRO(68,LRAA,1,LROWDT,1,LRAN,4,LRTSTS,0),U,4,6)=DUZ_U_LRNOW_U_"*Not performed"

 Q

LRACC K LRAN

 S LREND=0,LREXMPT=1 D ^LRWU4 K LREXMPT

 Q:'$G(LRAA)!('$G(LRAN))!('$D(^LRO(68,LRAA,0))#2)

 S DA(2)=LRAA,DA(1)=LRAD,LRSS=$P(^LRO(68,LRAA,0),U,2)

 I '$L(LRSS) S LRAN=0,LRNOP=1 W !?5,"No Subscript for this Accession Area ",!!

 Q

LREND S LREND=1 Q

UNLOCK ;

 L -(^LR($G(LRDFN),$G(LRSS),$G(LRIDT)),^LRO(68,$G(LRAA),1,$G(LRAD),1,$G(LRAN))) D END Q

EXIT ;

 K LRSCNX,LRNOECHO,LRACN,LRLABRV,LRNOW

END ;

 K LRCCOM0,LRCCOM1,LRCCOMX,LREND,LRI,LRL,LRNATURE,LRNOP,LRSCN,LRMSTATI,LRORDTST,LROWDT,LRPRAC,LRTSTS,LRUID

 K Q9,LRXX,DIR,LRCOM,LRAGE,DI,LRCTST,LRACN,LRACN0,LRDOC,LRLL,LRNOW,LRDBUG

 K LROD0,LROD1,LROD3,LROOS,LROS,LROSD,LROT,LRROD,LRTT,X4

 D KVA^VADPT,END^LRTSTJAM

 Q

FX2 ;

 S LRLABKY="" G FX3

 S LRNATURE="W"

 S LREND=0

 S LRL=52 I '$D(LRLABKY) G FX3

 K DIR S (LRCOM,LRCCOM1)="" W !

 S DIR(0)="62.5,5",DIR("A")="Select NP comment Lab Description screen  " S:$L($G(LRSCNXB)) DIR("B")=LRSCNXB

 S DIR("?")="Select Lab Description file screen to be used to expand your NP reason."

 S DIR("?",1)=" Press return to accept the default expansion screens."

 S DIR("?",2)="  "

 S DIR("?",3)="Select the Lab Description file expansion screen."

 S DIR("?",4)="The default expansion screens are GENERAL, ORDER and LAB"

 S DIR("?",5)="You may select addition lab description expansion screens"

 S DIR("?",6)="Press return if you want to only use the default screens"

 S DIR("?",7)=" "

 K LRSCNXB,LRNOECHO

 S:'$D(LRSCN) LRSCN="AKL"

 S X="LAB"

 I $E(X)="@" S LRSCN="AKL",LRSCNXB="" G FX2

 I $L(X) S LRSCNXB=X,LRSCN=LRSCN_1

FX3 K DIR W !

 ;

 S LRL=1

 K LRLABKY

 S X="DUPLICATE"

 S DIR("A")=$S('$D(LRLABKY):"Reason for Cancel",1:"Not Perform Reason ") S:$L($G(LRXX)) DIR("B")=$G(LRXX)

 S DIR(0)="FU^1:"_LRL_"^"

 S (LRCCOM,LRCCOMX)=X

 ;

 I '$D(X) G FX2

 I $E(X,$L(X))=" " S X=$E(X,1,($L(X)-1))

 S (LRCCOM,LRCCOMX)=X

 I '$D(LRLABKY) W !,"("_LRCCOM_")"

 S Y=1

 K DIR

 I Y'=1 QUIT

 S LRCCOM=$E($S('$D(LRLABKY):"*"_$P($G(^VA(200,DUZ,0)),U)_"  Cancel Reason:",1:"*NP Reason:")_LRCCOM,1,68)

 S LRCCOM="S LRCCOM=DUPLICATE: *NP Reason: Duplicate"

 S LRCCOM="DUPLICATE: *NP Reason: Duplicate"

 D EN1^LRHY22

 Q

 ;

63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM) ;

 Q:$G(LRSS)["MI"

 N X,Y,D0,D1,DA,DR,DIC,DIE,LRCCOM0,LRNOECHO,DLAYGO

 S DLAYGO=63,DIC(0)="SL"

 S:'$G(LRNOW) LRNOW=$$NOW^XLFDT

 S LRNOECHO=1

 S LRCCOM0=$E("*"_LRTNM_$S($G(LRMERG):" Merged: ",'$D(LRLABKY):" "_$P($G(^VA(200,DUZ,0)),U)_" Canceled: ",1:" Not Performed: ")_$$FMTE^XLFDT(LRNOW,"5FMPZ")_" by "_DUZ,1,68)

 S DA=LRIDT,DA(1)=LRDFN,DIE="^LR("_LRDFN_","""_LRSS_""","

 S LRCCOM0=$TR(LRCCOM0,";","-") ; Strip ";" - FileMan uses ";" to parse DR string.

 S DR=".99///^S X="_""""_LRCCOM0_"""" D ^DIE

 Q:LRSS="MI"

631 K D0,D1,DA,DR,DIC,DIE

 S DIC(0)="SL"

 S DA=LRIDT,DA(1)=LRDFN,DIE="^LR("_LRDFN_","""_LRSS_""",",DIC=DIE

 S LRCCOM=$TR(LRCCOM,";","-") ; Strip ";" - FileMan uses ";" to parse DR string.

 S DR=".99///^S X="_""""_LRCCOM_""""

 D ^DIE

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LRHYDEL   7903     printed  Feb 18, 2025@23:41:09                                                                                                                                                                                                     Page 2

LRHYDEL   ;DALOI/HOAK - HOWDY DEL A TEST ;8/28/2005

 +1       ;;5.2;LAB SERVICE;**405**;Sep 27, 1994;Build 93

 +2       ;

 +3       ;

 +4       ;Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.

EN        ;

 +1        DO ^LRPARAM

           if $GET(LREND)

               QUIT 

 +2        IF '$DATA(LRLABKY)

               WRITE !?5,"You are not authorized to change test status.",!,$CHAR(7)

               SET LREND=1

               QUIT 

 +3        KILL LRXX,LRSCNXB

           WRITE @IOF

 +4        FOR 

               SET (LREND,LRNOP)=0

               DO FIX

               Begin DoDot:1

 +5                IF $GET(LREND)

                       DO END

                       SET LREND=1

                       QUIT 

 +6                KILL DIC

                   if '$GET(LRNOP)

                       DO CHG

                   DO END

               End DoDot:1

               IF $GET(LREND)

                   DO END

                   QUIT 

 +7        QUIT 

FIX        SET (LREND,LRNOP)=0

           SET LRNOW=$$NOW^XLFDT

 +1        WRITE !

           SET LRACC=1

           DO LRACC

           if $GET(LRNOP)

               QUIT 

 +2        KILL LRACC,LRNATURE

           IF $GET(LRAN)<1

               SET LREND=1

               QUIT 

 +3        IF '$PIECE($GET(^LRO(68,+$GET(LRAA),1,+$GET(LRAD),1,+$GET(LRAN),0)),U,2)

               WRITE !?5,"Accession has no Test ",!

               SET LRNOP=1

               QUIT 

 +4        LOCK +^LRO(68,LRAA,1,LRAD,1,LRAN):$GET(DILOCKTM,3)

           IF '$TEST

               WRITE !,"Someone else is working on this accession",!

               SET LRNOP=1

               QUIT 

 +5        SET LRX=^LRO(68,LRAA,1,LRAD,1,LRAN,0)

           SET LRACN=$PIECE(^(.2),U)

           SET LRUID=$PIECE(^(.3),U)

 +6        SET LRDFN=+LRX

           SET LRSN=+$PIECE(LRX,U,5)

           SET LRODT=+$PIECE(LRX,U,4)

 +7        SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)

           SET DFN=$PIECE(^(0),U,3)

 +8        DO PT^LRX

           WRITE !,PNM,?30,SSN

 +9        SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)

           LOCK +^LR(LRDFN,LRSS,LRIDT):$GET(DILOCKTM,3)

           IF '$TEST

               WRITE !,"Someone else is working on this data."

               LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)

               SET LRNOP=1

               QUIT 

 +10       IF '$GET(^LR(LRDFN,LRSS,LRIDT,0))

               WRITE !?5," Can't find Lab Data for this accession",!

               DO UNLOCK

               SET LRNOP=1

               QUIT 

 +11       IF LRODT

               IF LRSN

                   IF $DATA(^LRO(69,LRODT,1,LRSN,0))#2

                       Begin DoDot:1

 +12                       NEW LRACN,LRAA,LRAD

 +13                       DO SHOW^LROS

                       End DoDot:1

 +14       KILL DIR

           SET DIR(0)="E"

           DO ^DIR

           if $EXTRACT(X)=U

               SET LRNOP=1

           if $GET(LRNOP)

               QUIT 

FX1       ;

 +1        DO SHOWTST

 +2        QUIT 

CHG        KILL LRCTST,DIC

           WRITE !

 +1        if '$DATA(DIC("A"))

               SET DIC("A")="Change which LABORATORY TEST: "

 +2        SET DIC="^LRO(68,"_LRAA_",1,"_LRAD_",1,"_LRAN_",4,"

           SET DIC("S")="I '$L($P(^(0),U,5))"

           SET DIC(0)="AEMOQ"

 +3        FOR 

               DO ^DIC

               if Y<1

                   QUIT 

               SET LRCTST(+Y)=$PIECE(^LAB(60,+Y,0),U)

               SET DIC("A")="Select another test: "

 +4        KILL DIC

           IF '$ORDER(LRCTST(0))

               Begin DoDot:1

 +5                LOCK -^LR(LRDFN,LRSS,LRIDT)

                   LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)

 +6                WRITE !?5,"No Test Selected",!

               End DoDot:1

               QUIT 

 +7        IF '$LENGTH(LRODT)&'$LENGTH(LRSN)

               WRITE !,"NO CHANGE"

               DO UNLOCK

               DO END

               QUIT 

 +8        KILL LRCCOM

           SET LRCCOM=""

           SET LREND=0

           IF '$DATA(^LRO(69,LRODT,1,LRSN,0))#2

               WRITE !?5,"There is no Order for this Accession",!

               DO UNLOCK

               DO END

               QUIT 

 +9        WRITE @IOF,!!?5,"Change Accession : ",LRACN,?40,"UID: ",LRUID

 +10       SET I=0

           FOR 

               SET I=$ORDER(LRCTST(I))

               if I<1

                   QUIT 

               WRITE !?10,LRCTST(I)

 +11       DO FX2

           if $GET(LREND)

               QUIT 

 +12       SET LRTSTS=0

           FOR 

               SET LRTSTS=$ORDER(LRCTST(LRTSTS))

               if LRTSTS<1

                   QUIT 

               Begin DoDot:1

 +13               if '$DATA(^LAB(60,LRTSTS,0))#2

                       QUIT 

                   SET LRTNM=$PIECE(^(0),U)

 +14               SET LRORDTST=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0),U,9)

                   DO SET

 +15               if '$GET(LREND)

                       WRITE !?5,"[ "_LRTNM_" ] ",$SELECT('$DATA(LRLABKY):" Marked Canceled by Floor",1:" Marked Not Performed"),!

               End DoDot:1

 +16       SET LREND=0

           KILL LRCTST

 +17       QUIT 

SHOWTST   ;

 +1        NEW LRI,LRN,DIR,LRY,LRIC,X

 +2        SET DIR(0)="E"

 +3        DO DEMO

 +4        SET LRN=0

           SET LRI=0

           FOR 

               SET LRI=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI))

               if LRI<1!($GET(LRY))

                   QUIT 

               Begin DoDot:1

 +5                SET LRIC=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0)),U,4,6)

                   if '$DATA(^LAB(60,+LRI,0))#2

                       QUIT 

                   WRITE !,?5,$PIECE(^(0),U)

                   SET LRN=LRN+1

                   IF LRIC

                       Begin DoDot:2

 +6                        WRITE ?35,"  "_$SELECT($LENGTH($PIECE(LRIC,U,3)):$PIECE(LRIC,U,3),1:"Completed")_"  "_$$FMTE^XLFDT($PIECE(LRIC,U,2),"5FMPZ")_" by "_$PIECE(LRIC,U)

                       End DoDot:2

 +7                IF LRN>18

                       DO ^DIR

                       if $EXTRACT(X)=U

                           SET LRY=1

                       if $GET(LRY)

                           QUIT 

                       DO DEMO

                       SET LRN=0

               End DoDot:1

 +8        SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)

           SET LRODT=$PIECE(X,U,4)

           SET LRSN=$PIECE(X,U,5)

 +9        QUIT 

DEMO       WRITE !,PNM,?50,SSN

 +1        WRITE !,"TESTS ON ACCESSION: ",LRACN,?40,"UID: ",LRUID

 +2        QUIT 

SET       ;

 +1        if '$GET(LRNOW)

               SET LRNOW=$$NOW^XLFDT

 +2        SET LRLLOC=$PIECE(^LRO(69,LRODT,1,LRSN,0),U,7)

           Begin DoDot:1

 +3            NEW II,X,LRI,LRSTATUS,OCXTRACE

 +4            if $GET(LRDBUG)

                   SET OCXTRACE=1

 +5            SET LRI=0

               FOR 

                   SET LRI=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRI))

                   if LRI<1

                       QUIT 

                   IF $DATA(^(LRI,0))#2

                       IF LRTSTS=+^(0)

                           SET (LRSTATUS,II(LRTSTS))=""

                           Begin DoDot:2

 +6                            if $PIECE(^LRO(69,LRODT,1,LRSN,2,LRI,0),U,12)

                                   QUIT 

 +7                            if $PIECE(^LRO(69,LRODT,1,LRSN,2,LRI,0),U,11)

                                   QUIT 

                               SET ORIFN=$PIECE(^(0),U,7)

 +8                            SET X=1+$ORDER(^LRO(69,LRODT,1,LRSN,2,LRI,1.1,"A"),-1)

                               SET X(1)=$PIECE($GET(^(0)),U,4)

 +9                            SET ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)=$PIECE($GET(LRNATURE),U,5)_": "_LRCCOM

                               SET X=X+1

                               SET X(1)=X(1)+1

 +10                           SET ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)="*NP Action:"_$$FMTE^XLFDT(LRNOW,"5MZ")

 +11                           SET ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,0)="^^"_X_"^"_X(1)_"^"_DT

 +12                           IF $GET(ORIFN)

                                   IF $DATA(II)

                                       DO NEW^LR7OB1(LRODT,LRSN,$SELECT($GET(LRMSTATI)=""!($GET(LRMSTATI)=1):"OC",1:"SC"),$GET(LRNATURE),.II,LRSTATUS)

 +13                           IF ORIFN

                                   IF $$VER^LR7OU1<3

                                       DO DC^LRCENDE1

 +14                           SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",9)="CA"

                               SET $PIECE(^(0),U,10)="L"

                               SET $PIECE(^(0),U,11)=DUZ

 +15                           if $DATA(^LRO(69,LRODT,1,LRSN,"PCE"))

                                   SET ^LRO(69,"AE",DUZ,LRODT,LRSN,LRI)=""

                           End DoDot:2

                           KILL II

           End DoDot:1

 +16       KILL ORIFN,ORSTS

 +17       IF $DATA(^LRO(68,+$GET(LRAA),1,+$GET(LRAD),1,+$GET(LRAN),0))#2

               IF $DATA(^(4,$GET(LRTSTS),0))#2

                   SET $PIECE(^(0),U,4,6)=DUZ_U_LRNOW_U_$SELECT($GET(LRMERG):"*Merged",1:"*Not Performed")

                   Begin DoDot:1

 +18                   SET LROWDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,3)

                       IF LROWDT

                           IF LROWDT'=LRAD

                               DO ROL

                               QUIT 

 +19                   SET LROWDT=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,9))

                       IF LROWDT

                           DO ROL

                   End DoDot:1

 +20       if $GET(LRSS)["MI"

               QUIT 

 +21       IF $GET(LRIDT)

               IF $LENGTH($GET(LRSS))

                   IF $LENGTH(LRCCOM)

                       IF $GET(^LR(LRDFN,LRSS,LRIDT,0))

                           Begin DoDot:1

 +22                           if $GET(LRSS)["MI"

                                   QUIT 

 +23                           DO 63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM)

 +24                           if '$DATA(^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN))

                                   DO XREF^LRVER3A

                           End DoDot:1

 +25      ; Put in list to check for auto download.

           DO EN^LA7ADL($PIECE($GET(^LRO(68,+$GET(LRAA),1,+$GET(LRAD),1,+$GET(LRAN),.3)),"^"))

 +26       QUIT 

ROL       ;

 +1        if +$GET(^LRO(68,LRAA,1,LROWDT,1,LRAN,0))'=LRDFN

               QUIT 

           if '$DATA(^(4,LRTSTS,0))#2

               QUIT 

 +2        SET $PIECE(^LRO(68,LRAA,1,LROWDT,1,LRAN,4,LRTSTS,0),U,4,6)=DUZ_U_LRNOW_U_"*Not performed"

 +3        QUIT 

LRACC      KILL LRAN

 +1        SET LREND=0

           SET LREXMPT=1

           DO ^LRWU4

           KILL LREXMPT

 +2        if '$GET(LRAA)!('$GET(LRAN))!('$DATA(^LRO(68,LRAA,0))#2)

               QUIT 

 +3        SET DA(2)=LRAA

           SET DA(1)=LRAD

           SET LRSS=$PIECE(^LRO(68,LRAA,0),U,2)

 +4        IF '$LENGTH(LRSS)

               SET LRAN=0

               SET LRNOP=1

               WRITE !?5,"No Subscript for this Accession Area ",!!

 +5        QUIT 

LREND      SET LREND=1

           QUIT 

UNLOCK    ;

 +1        LOCK -(^LR($GET(LRDFN),$GET(LRSS),$GET(LRIDT)),^LRO(68,$GET(LRAA),1,$GET(LRAD),1,$GET(LRAN)))

           DO END

           QUIT 

EXIT      ;

 +1        KILL LRSCNX,LRNOECHO,LRACN,LRLABRV,LRNOW

END       ;

 +1        KILL LRCCOM0,LRCCOM1,LRCCOMX,LREND,LRI,LRL,LRNATURE,LRNOP,LRSCN,LRMSTATI,LRORDTST,LROWDT,LRPRAC,LRTSTS,LRUID

 +2        KILL Q9,LRXX,DIR,LRCOM,LRAGE,DI,LRCTST,LRACN,LRACN0,LRDOC,LRLL,LRNOW,LRDBUG

 +3        KILL LROD0,LROD1,LROD3,LROOS,LROS,LROSD,LROT,LRROD,LRTT,X4

 +4        DO KVA^VADPT

           DO END^LRTSTJAM

 +5        QUIT 

FX2       ;

 +1        SET LRLABKY=""

           GOTO FX3

 +2        SET LRNATURE="W"

 +3        SET LREND=0

 +4        SET LRL=52

           IF '$DATA(LRLABKY)

               GOTO FX3

 +5        KILL DIR

           SET (LRCOM,LRCCOM1)=""

           WRITE !

 +6        SET DIR(0)="62.5,5"

           SET DIR("A")="Select NP comment Lab Description screen  "

           if $LENGTH($GET(LRSCNXB))

               SET DIR("B")=LRSCNXB

 +7        SET DIR("?")="Select Lab Description file screen to be used to expand your NP reason."

 +8        SET DIR("?",1)=" Press return to accept the default expansion screens."

 +9        SET DIR("?",2)="  "

 +10       SET DIR("?",3)="Select the Lab Description file expansion screen."

 +11       SET DIR("?",4)="The default expansion screens are GENERAL, ORDER and LAB"

 +12       SET DIR("?",5)="You may select addition lab description expansion screens"

 +13       SET DIR("?",6)="Press return if you want to only use the default screens"

 +14       SET DIR("?",7)=" "

 +15       KILL LRSCNXB,LRNOECHO

 +16       if '$DATA(LRSCN)

               SET LRSCN="AKL"

 +17       SET X="LAB"

 +18       IF $EXTRACT(X)="@"

               SET LRSCN="AKL"

               SET LRSCNXB=""

               GOTO FX2

 +19       IF $LENGTH(X)

               SET LRSCNXB=X

               SET LRSCN=LRSCN_1

FX3        KILL DIR

           WRITE !

 +1       ;

 +2        SET LRL=1

 +3        KILL LRLABKY

 +4        SET X="DUPLICATE"

 +5        SET DIR("A")=$SELECT('$DATA(LRLABKY):"Reason for Cancel",1:"Not Perform Reason ")

           if $LENGTH($GET(LRXX))

               SET DIR("B")=$GET(LRXX)

 +6        SET DIR(0)="FU^1:"_LRL_"^"

 +7        SET (LRCCOM,LRCCOMX)=X

 +8       ;

 +9        IF '$DATA(X)

               GOTO FX2

 +10       IF $EXTRACT(X,$LENGTH(X))=" "

               SET X=$EXTRACT(X,1,($LENGTH(X)-1))

 +11       SET (LRCCOM,LRCCOMX)=X

 +12       IF '$DATA(LRLABKY)

               WRITE !,"("_LRCCOM_")"

 +13       SET Y=1

 +14       KILL DIR

 +15       IF Y'=1

               QUIT 

 +16       SET LRCCOM=$EXTRACT($SELECT('$DATA(LRLABKY):"*"_$PIECE($GET(^VA(200,DUZ,0)),U)_"  Cancel Reason:",1:"*NP Reason:")_LRCCOM,1,68)

 +17       SET LRCCOM="S LRCCOM=DUPLICATE: *NP Reason: Duplicate"

 +18       SET LRCCOM="DUPLICATE: *NP Reason: Duplicate"

 +19       DO EN1^LRHY22

 +20       QUIT 

 +21      ;

63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM) ;