LRHYDEL ;VA/DALOI/HOAK - HOWDY DEL A TEST ; 13-Aug-2013 09:16 ; MKK
;;5.2;LAB SERVICE;**405,1033**;NOV 01, 1997
;
;
;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
LRHYDEL ;VA/DALOI/HOAK - HOWDY DEL A TEST ; 13-Aug-2013 09:16 ; MKK
+1 ;;5.2;LAB SERVICE;**405,1033**;NOV 01, 1997
+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) ;
+1 IF $GET(LRSS)["MI"
QUIT
+2 NEW X,Y,D0,D1,DA,DR,DIC,DIE,LRCCOM0,LRNOECHO,DLAYGO
+3 SET DLAYGO=63
SET DIC(0)="SL"
+4 IF '$GET(LRNOW)
SET LRNOW=$$NOW^XLFDT
+5 SET LRNOECHO=1
+6 SET LRCCOM0=$EXTRACT("*"_LRTNM_$SELECT($GET(LRMERG):" Merged: ",'$DATA(LRLABKY):" "_$PIECE($GET(^VA(200,DUZ,0)),U)_" Canceled: ",1:" Not Performed: ")_$$FMTE^XLFDT(LRNOW,"5FMPZ")_" by "_DUZ,1,68)
+7 SET DA=LRIDT
SET DA(1)=LRDFN
SET DIE="^LR("_LRDFN_","""_LRSS_""","
+8 ; Strip ";" - FileMan uses ";" to parse DR string.
SET LRCCOM0=$TRANSLATE(LRCCOM0,";","-")
+9 SET DR=".99///^S X="_""""_LRCCOM0_""""
DO ^DIE
+10 IF LRSS="MI"
QUIT
631 KILL D0,D1,DA,DR,DIC,DIE
+1 SET DIC(0)="SL"
+2 SET DA=LRIDT
SET DA(1)=LRDFN
SET DIE="^LR("_LRDFN_","""_LRSS_""","
SET DIC=DIE
+3 ; Strip ";" - FileMan uses ";" to parse DR string.
SET LRCCOM=$TRANSLATE(LRCCOM,";","-")
+4 SET DR=".99///^S X="_""""_LRCCOM_""""
+5 DO ^DIE
+6 QUIT
