LRTSTOUT ;VA/SLC/CJS - JAM TESTS OFF ACCESSIONS ;8/11/97
;;5.2;LAB SERVICE;**1018,1031**;NOV 1, 1997
;
;;VA LR Patch(s): 100,121,153,202,221,337
;
;Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.
EN ;
S BLROPT="DELACC" ; IHS/MSC/MKK - LR*5.2*1031
;
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):1 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
D PT^LRX W !,PNM,?30,HRCN ; IHS/MSC/MKK - LR*5.2*1031
;
S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5) L +^LR(LRDFN,LRSS,LRIDT):1 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 !
N LRIFN
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,CLNPENDG
. W:'$G(LREND) !?5,"[ "_LRTNM_" ] ",$S('$D(LRLABKY):" Marked Canceled by Floor",1:" Marked Not Performed"),!
. ;
. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 -- RPMS Code Added back in
. ; The following lines added per appendix A of RPMS Lab
. ; E-Sig Enhancement clinical manual IHS/HQW/SCR - 8/23/01
. I $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2)) D ^BLRALAF
. D:BLRLOG ^BLREVTQ("M","D",$G(BLROPT),,LRAA_","_LRAD_","_LRAN)
. ; ----- END IHS/MSC/MKK - LR*5.2*1031
;
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 !,PNM,?50,HRCN ; IHS/MSC/MKK - LR*5.2*1031
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,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)=$S($G(LRMERG):"*Merged:",'$D(LRLABKY):"*Cancel by Floor:",1:"*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
I $G(LRIDT),$L($G(LRSS)),$L(LRCCOM),$G(^LR(LRDFN,LRSS,LRIDT,0)) D
. 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
K LROD0,LROD1,LROD3,LROOS,LROS,LROSD,LROT,LRROD,LRTT,X4
; D KVA^VADPT,END^LRTSTJAM
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 -- RPMS Code Added back in
D @$S($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")
D END^LRTSTJAM
K HRCN
; ----- END IHS/MSC/MKK - LR*5.2*1031
Q
FX2 ;
S LREND=0
I '$L($G(LRNATURE)) D DC^LROR6() I $G(LRNATURE)="-1" W !!,$C(7),"Nothing Changed",! S LREND=1 Q
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"
D ^DIR I $E(X)=U S LREND=1 Q
I $E(X)="@" S LRSCN="AKL",LRSCNXB="" G FX2
I $L(X) S LRSCNXB=Y(0),LRSCN=LRSCN_Y
FX3 K DIR W !
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_"^"
D ^DIR I $E(X)=U S LREND=1 Q
I '$L(X) W !,"You must enter Reason",! G FX2
I $D(LRLABKY) S LRXX=Y,Q9="1,"_LRL_","_LRSCN D COM^LRNUM
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_")"
K DIR S DIR(0)="Y",DIR("A")="Satisfactory Comment ",DIR("B")="Yes"
D ^DIR W ! K DIR
I Y'=1 G FX2
S LRCCOM=$E($S('$D(LRLABKY):"*Floor Cancel Reason:",1:"*NP Reason:")_LRCCOM,1,68)
Q
;
63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM) ;
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):" Floor 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 LRCCOM=$TR(LRCCOM,"""","'") ; Change " to ' -- " causes FileMan error.
S DR=".99///^S X="_""""_LRCCOM_""""
D ^DIE
Q
CLNPENDG ;Remove pending from Lab test when set to not performed
N LRIFN
S LRIFN=$P($G(^LAB(60,LRTSTS,.2)),U)
Q:LRIFN=""
S:$P($G(^LR(LRDFN,LRSS,LRIDT,LRIFN)),U)="pending" $P(^LR(LRDFN,LRSS,LRIDT,LRIFN),U)=""
Q
LRTSTOUT ;VA/SLC/CJS - JAM TESTS OFF ACCESSIONS ;8/11/97
+1 ;;5.2;LAB SERVICE;**1018,1031**;NOV 1, 1997
+2 ;
+3 ;;VA LR Patch(s): 100,121,153,202,221,337
+4 ;
+5 ;Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.
EN ;
+1 ; IHS/MSC/MKK - LR*5.2*1031
SET BLROPT="DELACC"
+2 ;
+3 DO ^LRPARAM
IF $GET(LREND)
QUIT
+4 IF '$DATA(LRLABKY)
WRITE !?5,"You are not authorized to change test status.",!,$CHAR(7)
SET LREND=1
QUIT
+5 KILL LRXX,LRSCNXB
WRITE @IOF
+6 FOR
SET (LREND,LRNOP)=0
DO FIX
Begin DoDot:1
+7 IF $GET(LREND)
DO END
SET LREND=1
QUIT
+8 KILL DIC
IF '$GET(LRNOP)
DO CHG
DO END
End DoDot:1
IF $GET(LREND)
DO END
QUIT
+9 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):1
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 ;
+9 ; D PT^LRX W !,PNM,?30,SSN
+10 ; IHS/MSC/MKK - LR*5.2*1031
DO PT^LRX
WRITE !,PNM,?30,HRCN
+11 ;
+12 SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
LOCK +^LR(LRDFN,LRSS,LRIDT):1
IF '$TEST
WRITE !,"Someone else is working on this data."
LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
SET LRNOP=1
QUIT
+13 IF '$GET(^LR(LRDFN,LRSS,LRIDT,0))
WRITE !?5," Can't find Lab Data for this accession",!
DO UNLOCK
SET LRNOP=1
QUIT
+14 IF LRODT
IF LRSN
IF $DATA(^LRO(69,LRODT,1,LRSN,0))#2
Begin DoDot:1
+15 NEW LRACN,LRAA,LRAD
+16 DO SHOW^LROS
End DoDot:1
+17 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 NEW LRIFN
+2 IF '$DATA(DIC("A"))
SET DIC("A")="Change which LABORATORY TEST: "
+3 SET DIC="^LRO(68,"_LRAA_",1,"_LRAD_",1,"_LRAN_",4,"
SET DIC("S")="I '$L($P(^(0),U,5))"
SET DIC(0)="AEMOQ"
+4 FOR
DO ^DIC
IF Y<1
QUIT
SET LRCTST(+Y)=$PIECE(^LAB(60,+Y,0),U)
SET DIC("A")="Select another test: "
+5 KILL DIC
IF '$ORDER(LRCTST(0))
Begin DoDot:1
+6 LOCK -^LR(LRDFN,LRSS,LRIDT)
LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
+7 WRITE !?5,"No Test Selected",!
End DoDot:1
QUIT
+8 IF '$LENGTH(LRODT)&'$LENGTH(LRSN)
WRITE !,"NO CHANGE"
DO UNLOCK
DO END
QUIT
+9 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
+10 WRITE @IOF,!!?5,"Change Accession : ",LRACN,?40,"UID: ",LRUID
+11 SET I=0
FOR
SET I=$ORDER(LRCTST(I))
IF I<1
QUIT
WRITE !?10,LRCTST(I)
+12 DO FX2
IF $GET(LREND)
QUIT
+13 SET LRTSTS=0
FOR
SET LRTSTS=$ORDER(LRCTST(LRTSTS))
IF LRTSTS<1
QUIT
Begin DoDot:1
+14 IF '$DATA(^LAB(60,LRTSTS,0))#2
QUIT
SET LRTNM=$PIECE(^(0),U)
+15 SET LRORDTST=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0),U,9)
DO SET
DO CLNPENDG
+16 IF '$GET(LREND)
WRITE !?5,"[ "_LRTNM_" ] ",$SELECT('$DATA(LRLABKY):" Marked Canceled by Floor",1:" Marked Not Performed"),!
+17 ;
+18 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 -- RPMS Code Added back in
+19 ; The following lines added per appendix A of RPMS Lab
+20 ; E-Sig Enhancement clinical manual IHS/HQW/SCR - 8/23/01
+21 IF $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2))
DO ^BLRALAF
+22 IF BLRLOG
DO ^BLREVTQ("M","D",$GET(BLROPT),,LRAA_","_LRAD_","_LRAN)
+23 ; ----- END IHS/MSC/MKK - LR*5.2*1031
End DoDot:1
+24 ;
+25 SET LREND=0
KILL LRCTST
+26 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 ; W !,PNM,?50,SSN
+1 ; IHS/MSC/MKK - LR*5.2*1031
WRITE !,PNM,?50,HRCN
+2 WRITE !,"TESTS ON ACCESSION: ",LRACN,?40,"UID: ",LRUID
+3 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,11)
QUIT
SET ORIFN=$PIECE(^(0),U,7)
+7 SET X=1+$ORDER(^LRO(69,LRODT,1,LRSN,2,LRI,1.1,"A"),-1)
SET X(1)=$PIECE($GET(^(0)),U,4)
+8 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
+9 SET ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)=$SELECT($GET(LRMERG):"*Merged:",'$DATA(LRLABKY):"*Cancel by Floor:",1:"*NP Action:")_$$FMTE^XLFDT(LRNOW,"5MZ")
+10 SET ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,0)="^^"_X_"^"_X(1)_"^"_DT
+11 IF $GET(ORIFN)
IF $DATA(II)
DO NEW^LR7OB1(LRODT,LRSN,$SELECT($GET(LRMSTATI)=""!($GET(LRMSTATI)=1):"OC",1:"SC"),$GET(LRNATURE),.II,LRSTATUS)
+12 IF ORIFN
IF $$VER^LR7OU1<3
DO DC^LRCENDE1
+13 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",9)="CA"
SET $PIECE(^(0),U,10)="L"
SET $PIECE(^(0),U,11)=DUZ
+14 IF $DATA(^LRO(69,LRODT,1,LRSN,"PCE"))
SET ^LRO(69,"AE",DUZ,LRODT,LRSN,LRI)=""
End DoDot:2
KILL II
End DoDot:1
+15 KILL ORIFN,ORSTS
+16 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
+17 SET LROWDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,3)
IF LROWDT
IF LROWDT'=LRAD
DO ROL
QUIT
+18 SET LROWDT=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,9))
IF LROWDT
DO ROL
End DoDot:1
+19 IF $GET(LRIDT)
IF $LENGTH($GET(LRSS))
IF $LENGTH(LRCCOM)
IF $GET(^LR(LRDFN,LRSS,LRIDT,0))
Begin DoDot:1
+20 DO 63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM)
+21 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN))
DO XREF^LRVER3A
End DoDot:1
+22 ; Put in list to check for auto download.
DO EN^LA7ADL($PIECE($GET(^LRO(68,+$GET(LRAA),1,+$GET(LRAD),1,+$GET(LRAN),.3)),"^"))
+23 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
+3 KILL LROD0,LROD1,LROD3,LROOS,LROS,LROSD,LROT,LRROD,LRTT,X4
+4 ; D KVA^VADPT,END^LRTSTJAM
+5 ;
+6 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 -- RPMS Code Added back in
+7 DO @$SELECT($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")
+8 DO END^LRTSTJAM
+9 KILL HRCN
+10 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+11 QUIT
FX2 ;
+1 SET LREND=0
+2 IF '$LENGTH($GET(LRNATURE))
DO DC^LROR6()
IF $GET(LRNATURE)="-1"
WRITE !!,$CHAR(7),"Nothing Changed",!
SET LREND=1
QUIT
+3 SET LRL=52
IF '$DATA(LRLABKY)
GOTO FX3
+4 KILL DIR
SET (LRCOM,LRCCOM1)=""
WRITE !
+5 SET DIR(0)="62.5,5"
SET DIR("A")="Select NP comment Lab Description screen "
IF $LENGTH($GET(LRSCNXB))
SET DIR("B")=LRSCNXB
+6 SET DIR("?")="Select Lab Description file screen to be used to expand your NP reason."
+7 SET DIR("?",1)=" Press return to accept the default expansion screens."
+8 SET DIR("?",2)=" "
+9 SET DIR("?",3)="Select the Lab Description file expansion screen."
+10 SET DIR("?",4)="The default expansion screens are GENERAL, ORDER and LAB"
+11 SET DIR("?",5)="You may select addition lab description expansion screens"
+12 SET DIR("?",6)="Press return if you want to only use the default screens"
+13 SET DIR("?",7)=" "
+14 KILL LRSCNXB,LRNOECHO
+15 IF '$DATA(LRSCN)
SET LRSCN="AKL"
+16 DO ^DIR
IF $EXTRACT(X)=U
SET LREND=1
QUIT
+17 IF $EXTRACT(X)="@"
SET LRSCN="AKL"
SET LRSCNXB=""
GOTO FX2
+18 IF $LENGTH(X)
SET LRSCNXB=Y(0)
SET LRSCN=LRSCN_Y
FX3 KILL DIR
WRITE !
+1 SET DIR("A")=$SELECT('$DATA(LRLABKY):"Reason for Cancel",1:"Not Perform Reason ")
IF $LENGTH($GET(LRXX))
SET DIR("B")=$GET(LRXX)
+2 SET DIR(0)="FU^1:"_LRL_"^"
+3 DO ^DIR
IF $EXTRACT(X)=U
SET LREND=1
QUIT
+4 IF '$LENGTH(X)
WRITE !,"You must enter Reason",!
GOTO FX2
+5 IF $DATA(LRLABKY)
SET LRXX=Y
SET Q9="1,"_LRL_","_LRSCN
DO COM^LRNUM
+6 IF '$DATA(X)
GOTO FX2
+7 IF $EXTRACT(X,$LENGTH(X))=" "
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+8 SET (LRCCOM,LRCCOMX)=X
+9 IF '$DATA(LRLABKY)
WRITE !,"("_LRCCOM_")"
+10 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Satisfactory Comment "
SET DIR("B")="Yes"
+11 DO ^DIR
WRITE !
KILL DIR
+12 IF Y'=1
GOTO FX2
+13 SET LRCCOM=$EXTRACT($SELECT('$DATA(LRLABKY):"*Floor Cancel Reason:",1:"*NP Reason:")_LRCCOM,1,68)
+14 QUIT
+15 ;
63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM) ;
+1 NEW X,Y,D0,D1,DA,DR,DIC,DIE,LRCCOM0,LRNOECHO,DLAYGO
+2 SET DLAYGO=63
SET DIC(0)="SL"
+3 IF '$GET(LRNOW)
SET LRNOW=$$NOW^XLFDT
+4 SET LRNOECHO=1
+5 SET LRCCOM0=$EXTRACT("*"_LRTNM_$SELECT($GET(LRMERG):" Merged: ",'$DATA(LRLABKY):" Floor Canceled: ",1:" Not Performed: ")_$$FMTE^XLFDT(LRNOW,"5FMPZ")_" by "_DUZ,1,68)
+6 SET DA=LRIDT
SET DA(1)=LRDFN
SET DIE="^LR("_LRDFN_","""_LRSS_""","
+7 ; Strip ";" - FileMan uses ";" to parse DR string.
SET LRCCOM0=$TRANSLATE(LRCCOM0,";","-")
+8 SET DR=".99///^S X="_""""_LRCCOM0_""""
DO ^DIE
+9 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 ; Change " to ' -- " causes FileMan error.
SET LRCCOM=$TRANSLATE(LRCCOM,"""","'")
+5 SET DR=".99///^S X="_""""_LRCCOM_""""
+6 DO ^DIE
+7 QUIT
CLNPENDG ;Remove pending from Lab test when set to not performed
+1 NEW LRIFN
+2 SET LRIFN=$PIECE($GET(^LAB(60,LRTSTS,.2)),U)
+3 IF LRIFN=""
QUIT
+4 IF $PIECE($GET(^LR(LRDFN,LRSS,LRIDT,LRIFN)),U)="pending"
SET $PIECE(^LR(LRDFN,LRSS,LRIDT,LRIFN),U)=""
+5 QUIT
