LRTSTOUT ;DALOI/STAFF - JAM TESTS OFF ACCESSIONS ;July 29, 2019@10:00
;;5.2;LAB SERVICE;**100,121,153,202,221,337,350,445,527,541,566**;Sep 27, 1994;Build 12
;
; Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.
;
EN ;
N LREND
D EN^LRPARAM Q:$G(LREND)
I '$D(LRLABKY) W !?5,"You are not authorized to change test status.",!,$C(7) S LREND=1 Q
N LRXX W @IOF
F D Q:$G(LREND)
. D END
. S (LREND,LRNOP)=0
. D FIX
. I $G(LREND) D UNLOCK Q
. I '$G(LRNOP) D CHG
. D UNLOCK
D EXIT
Q
;
;
FIX ;
N LRACC,LRNATURE
S (LREND,LRNOP)=0,LRNOW=$$NOW^XLFDT
W ! S LRACC=1 D LRACC Q:$G(LRNOP)
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
D LOCK^DILF("^LRO(68,LRAA,1,LRAD,1,LRAN)")
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($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.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)
D LOCK^DILF("^LR(LRDFN,LRSS,LRIDT)")
I '$T W !,"Someone else is working on this data." 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
I $D(DIRUT) S LRNOP=1 Q
;
FX1 ;
D SHOWTST
Q
;
;
CHG ;
N DIC,I,LRCOMM,LRCTST,LROTA,LRXX
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: "
I '$O(LRCTST(0)) D Q
. D UNLOCK
. W !?5,"No Test Selected",!
I LRODT=""!(LRSN="") W !,"NO CHANGE" D UNLOCK,END Q
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
;
; Check if tests selected have results stored in file #63.
S I=0
F S I=$O(LRCTST(I)) Q:I<1 D
. N LRX
. W !?10,LRCTST(I)
. S LRX=$$CHK63(I,LRDFN,LRSS,LRIDT)
. I LRX>0 S LRNOP=1
. I LRX=1 W ?40," Results entered for this test, cannot NP until removed."
. I LRX=2 W ?40," Results entered for this test, cannot NP this test."
. I LRX=3 W ?40," Results verified for this test, cannot NP this test."
I LRNOP Q
;
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)
. ;The test being canceled might be a component of a panel which was ordered.
. ;If not a panel (i.e. "atomic test"), LRORDTST=LRTSTS
. S LRORDTST=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0),U,9) D SET,CLNPENDG
. D LEDICHK ; ccr_6164n
. W:'$G(LREND) !?5,"[ "_LRTNM_" ] ",$S('$D(LRLABKY):" Marked Canceled by Floor",1:" Marked Not Performed"),!
;
I $D(LROTA) D LEDISET(.LROTA) ; ccr_6164n
;
S LREND=0
;
Q
;
;
SHOWTST ;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRI,LRN,LRY,LRIC,X
S DIR(0)="E"
D DEMO
S (LRN,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 W ?35," "_$S($L($P(LRIC,U,3)):$P(LRIC,U,3),1:"Completed")_" "_$$FMTE^XLFDT($P(LRIC,U,2),"1FMZ")_" by "_$P(LRIC,U)
. I LRN>18 D ^DIR S:$D(DIRUT) 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 LRNOW=$$NOW^XLFDT
S LRLLOC=$P(^LRO(69,LRODT,1,LRSN,0),U,7)
;
N II,X,LRI,LRSTATUS,OCXTRACE,ORIFN,ORSTS,LRMERGSO,LRORSTAT,LR7DONE
S:$G(LRDBUG) OCXTRACE=1
;LR*5.2*527: SET^LRTSTOUT might be called from other routines
I '$G(LRORDTST),$G(LRAA)]"",$G(LRAD)]"",$G(LRAN)]"" D
. Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
. ;make sure same patient
. Q:+^LRO(68,LRAA,1,LRAD,1,LRAN,0)'=+^LRO(69,LRODT,1,LRSN,0)
. ;LRORDTST=ordered test
. S LRORDTST=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0)),U,9)
;LR*5.2*527 end
S LRI=0
F S LRI=$O(^LRO(69,LRODT,1,LRSN,2,LRI)) Q:LRI<1 I $D(^(LRI,0))#2 D
. ;LR*5.2*527: if don't have ordered test, is current test in file 63
. I '$G(LRORDTST),LRTSTS'=+^LRO(69,LRODT,1,LRSN,2,LRI,0) Q
. ;checking for ordered test or component of ordered test (i.e. panel)
. I $G(LRORDTST),LRTSTS'=+^LRO(69,LRODT,1,LRSN,2,LRI,0),LRORDTST'=+^LRO(69,LRODT,1,LRSN,2,LRI,0) Q
. ;Already canceled = if 11th piece is not null
. Q:$P(^LRO(69,LRODT,1,LRSN,2,LRI,0),U,11) S ORIFN=$P(^(0),U,7),(LRORSTAT,LR7DONE)=0
. S (LRSTATUS,II(LRTSTS))=""
. ;LR*5.2*566: LRCOMX new'd at ZAP^LR7OMERG
. I '$D(LRCOMX(LRODT,LRSN,LRI,1)) D
. . S X=1+$O(^LRO(69,LRODT,1,LRSN,2,LRI,1.1,"A"),-1),X(1)=$P($G(^(0)),U,4)
. . ;LR*5.2*527 note: If a panel component is being canceled, the comments
. . ; are filed at both the panel and component levels so that
. . ; the comments display in reports.
. . 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,"1FMZ")
. . S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,0)="^^"_X_"^"_X(1)_"^"_DT
. . S LRCOMX(LRODT,LRSN,LRI,1)=""
. I $G(LRMERG),$P(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",3,5)'=(LRAD_"^"_LRAA_"^"_LRAN) D ;Don't cancel test if accession merged to same order.
. . Q:'$G(LRSOF) ;same order flag not been set
. . I '$D(LRCOMX(LRODT,LRSN,LRI,2)) D
. . . S X=X+1,X(1)=X(1)+1
. . . S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)="*Merge from: "_$G(^LRO(68,+$G(LR1AA),1,+$G(LR1AD),1,+$G(LR1AN),.2),"Unknown")
. . . S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,0)="^^"_X_"^"_X(1)_"^"_DT
. . . S LRCOMX(LRODT,LRSN,LRI,2)=""
. . S LRMERGSO=1,LRMSTATI=6 ;indicate that a same order merge occurred & we want to keep #100 order
. ;LR*5.2*527: Check order status if deleting panel component
. ;LR*5.2*541: ... if patient is in the PATIENT (#2) file
. ; (variable LRDPF).
. I '$G(LRMERG),$G(LRORDTST),LRTSTS'=LRORDTST,$G(LRDPF)=2 D
. . S LR7DONE=1
. . S LRORSTAT=$$OR(LRORDTST,LRTSTS,ORIFN)
. . ;don't update status if any pending tests
. . Q:'LRORSTAT
. . I '$G(ORIFN),'$D(II) Q
. . D NEW^LR7OB1(LRODT,LRSN,$S(LRORSTAT=1:"SC",1:"OC"),$G(LRNATURE),.II,LRSTATUS)
. . K ^TMP("LR",$J,"PANEL")
. . ;LR*5.2*527 end
. I 'LR7DONE,$G(ORIFN),$D(II) D NEW^LR7OB1(LRODT,LRSN,$S($G(LRMSTATI)=""!($G(LRMSTATI)=1):"OC",1:"SC"),$G(LRNATURE),.II,LRSTATUS)
. ;Keep ^LR7OB1 call before ^^ update to status/DUZ in File #69 (below); see warning in 69^LR7OB69:
. ;LR*5.2*527 added below:
. I LR7DONE D
. . ;only set canceled status in file 69 if everything on ordered test is canceled
. . I LRORSTAT=2 D Q
. . . S $P(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",9)="CA",$P(^(0),U,10)="L",$P(^(0),U,11)=DUZ
. . ;if a panel and components broken out, set canceled status for each canceled component
. . I +^LRO(69,LRODT,1,LRSN,2,LRI,0)=LRTSTS D
. . . S $P(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",9)="CA",$P(^(0),U,10)="L",$P(^(0),U,11)=DUZ
. ;LR*5.2*527 end
. I 'LR7DONE,'$D(LRMERGSO) 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)=""
. ;LR*5.2*566: Do not kill LRMERGSO and LRSOF
. K II
;
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),$G(LRSS)'="",LRCCOM'="",$G(^LR(LRDFN,LRSS,LRIDT,0)) D
. D UPD63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM)
. I '$D(^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)) D XREF^LRVER3A
;
; Update status of test in file #63 ORUT node.
; Set reporting site in file #63.
I $G(LRIDT),$G(LRSS)'="" D
. D ORUT
. D SETRL^LRVERA(LRDFN,LRSS,LRIDT,DUZ(2))
;
; Put in list to check for auto download.
; Check if LEDI specimen and notify collecting facility
I $G(LRAA),$G(LRAD),$G(LRAN),$D(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)) D
. D EN^LA7ADL($P(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),"^"))
. ;I $P(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),"^",3) D LEDI ;ccr_6164n
;
Q
;
OR(LRORDTST,LRTSTS,ORIFN) ;evaluate overall status of order
;LR*5.2*527 added this section
N LRXSN,LRXSTR,LRXPEND,LRXRESULT,LRXSTATUS
;AX8^LR7OB3 is called downstream from NEW^LR7OB1 and
;refers to ^TMP("LR",$J,"PANEL" to determine whether a panel
;is canceled.
;The kill below is not necessary, but adding as a safeguard.
K ^TMP("LR",$J,"PANEL")
;Check all tests for this CPRS order number
S (LRXSN,LRXPEND,LRXRESULT,LRXSTATUS)=0
;if any pending components within panel, stop evaluating
F S LRXSN=$O(^LRO(69,LRODT,1,LRSN,2,LRXSN)) Q:'LRXSN Q:LRXPEND D
. S LRXSTR=$G(^LRO(69,LRODT,1,LRSN,2,LRXSN,0))
. ;This test has a different CPRS order number.
. Q:$P(LRXSTR,U,7)'=ORIFN
. ;don't evaluate test currently being deleted
. ;The file 68 status will be updated later.
. Q:+LRXSTR=LRTSTS
. N LRXAA,LRXAD,LRXAN
. S LRXAA=$P(LRXSTR,U,4),LRXAD=$P(LRXSTR,U,3),LRXAN=$P(LRXSTR,U,5)
. ;This test has not been accessioned, possibly because
. ;the components have been.
. Q:LRXAA=""
. ;Panels which "explode" into other panels might not be subscripted
. ;in file 68.
. Q:'$D(^LRO(68,LRXAA,1,LRXAD,1,LRXAN,4,+LRXSTR,0))
. I $P($G(^LRO(68,LRXAA,1,LRXAD,1,LRXAN,4,+LRXSTR,0)),U,5)="" S LRXPEND=1 Q
. ;Continue to check for pending panel components
. ;Due to site requests, panel is marked as complete if any components are verified
. ;so that the panel will not display on the "Incomplete Test Status Report".
. N LRX68TST
. S LRX68TST=0
. F S LRX68TST=$O(^LRO(68,LRXAA,1,LRXAD,1,LRXAN,4,LRX68TST)) Q:'LRX68TST Q:LRXPEND D
. . S LRXSTR=$G(^LRO(68,LRXAA,1,LRXAD,1,LRXAN,4,LRX68TST,0))
. . Q:$P(LRXSTR,U,9)'=LRORDTST
. . Q:LRX68TST=LRTSTS
. . I $P(LRXSTR,U,5)="" S LRXPEND=1 Q
. . ;This test contains a result.
. . I $P(LRXSTR,U,6)="" S LRXRESULT=1
;If there are any pending tests left on the order, do not call LR7OB1
;If no pending tests and any results, update to complete
;If no pending tests and no results, update to discontinued.
S LRXSTATUS=$S(LRXPEND:0,LRXRESULT:1,1:2)
S ^TMP("LR",$J,"PANEL",ORIFN)=LRXSTATUS
Q LRXSTATUS
;
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_$S($G(LRMERG):"*Merged",1:"*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 LRSS="" S LRAN=0,LRNOP=1 W !?5,"No Subscript for this Accession Area ",!!
Q
;
;
LREND ;
S LREND=1
Q
;
;
UNLOCK ;
I +$G(LRDFN),$G(LRSS)'="",+$G(LRIDT) L -^LR(LRDFN,LRSS,LRIDT)
I +$G(LRAA),+$G(LRAD),+$G(LRAN) L -^LRO(68,LRAA,1,LRAD,1,LRAN)
;
Q
;
;
EXIT ;
K LRSCNX,LREND,LRNOECHO,LRACN,LRLABRV,LRNOW
;
END ;
K LRCCOM0,LRCCOM1,LRCCOMX,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,V^LRU
Q
;
;
FX2 ;
S LREND=0,(LRCOM,LRCCOM1)=""
I LRDPF=2,$G(LRNATURE)="" D DC^LROR6() I $G(LRNATURE)="-1" W !!,$C(7),"Nothing Changed",! S LREND=1 Q
I '$D(LRLABKY) D FX3 Q
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="62.5,5",DIR("A")="Select NP comment Lab Description screen"
S DIR("?",1)="The default expansion screens are GENERAL, ORDER and LAB"
S DIR("?",2)="You may select an additional lab description expansion screen"
S DIR("?",3)="which will be used to expand your NP reason."
S DIR("?")="Press return to only use these default screens"
;
K LRNOECHO
S:$G(LRSCN)="" LRSCN="AKL"
W !
D ^DIR
I $D(DUOUT)!($D(DTOUT)) S LREND=1 Q
I Y'="" S LRSCN=LRSCN_Y
K X,Y
;
F D FX3 Q:LREND!($G(LRCCOM)'="")
Q
;
;
FX3 ;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRL,LRY
S LRL=52,LREND=0
S DIR("A")=$S('$D(LRLABKY):"Reason for Cancel",1:"Not Perform Reason")
I $G(LRXX)'="" S DIR("B")=$G(LRXX)
S DIR(0)="F^1:"_LRL_"^"
W !
D ^DIR
I $D(DUOUT)!($D(DTOUT)) S LREND=1 Q
S LRY=Y
;
I LREND Q
I $D(LRLABKY) D
. N LRSAV S LRSAV=LRSCN
. S (LRXX,X)=LRY,Q9="1,"_LRL_","_LRSCN D COM^LRNUM S LRSCN=LRSAV
. I $G(X)="" Q
. I $E(X,$L(X))=" " S X=$E(X,1,($L(X)-1))
. S LRY=X
S (LRCCOM,LRCCOMX)=LRY
I '$D(LRLABKY) W !,"("_LRCCOM_")"
K DIR
S DIR(0)="Y",DIR("A")="Satisfactory Comment",DIR("B")="Yes"
D ^DIR
I $D(DIRUT) S LREND=1 Q
I Y=1 S LRCCOM=$E($S('$D(LRLABKY):"*Floor Cancel Reason: ",1:"*NP Reason: ")_LRCCOM,1,68)
E S (LRCCOM,LRCCOMX)=""
Q
;
;
UPD63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM) ; Update file #63 with comment reflecting dispostion.
;
N FDA,LRCCOMO,LRDIE,LRFN,LRNOECHO,LRY
;
S:'$G(LRNOW) LRNOW=$$NOW^XLFDT
S LRNOECHO=1
S LRCCOMO=$E("*"_LRTNM_$S($G(LRMERG):" Merged: ",'$D(LRLABKY):" Floor Canceled: ",1:" Not Performed: ")_$$FMTE^XLFDT(LRNOW,"1FMZ")_" by "_DUZ,1,68)
;
S LRFN=$S(LRSS="CH":63.041,LRSS="MI":63.05,LRSS="SP":63.98,LRSS="CY":63.908,LRSS="EM":63.208,LRSS="BB":63.199,1:"")
I LRSS="MI" D Q
. S FDA(1,LRFN,LRIDT_","_LRDFN_",",.99)=LRCCOMO
. D FILE^DIE("","FDA(1)","LRDIE(1)")
. K FDA(1),LRDIE(1)
;
F LRY=LRCCOMO,LRCCOM D
. S FDA(1,LRFN,"+1,"_LRIDT_","_LRDFN_",",.01)=LRY
. I $D(FDA(1)) D UPDATE^DIE("","FDA(1)","","LRDIE(1)")
. K FDA(1),LRDIE(1)
D CLEAN^DILF
Q
;
;
CLNPENDG ; Remove pending and other info from Lab test when set to not performed
N LRIFN
S LRIFN=$P($G(^LAB(60,LRTSTS,.2)),U)
I LRIFN'="",LRSS="CH" D
. I $P($G(^LR(LRDFN,LRSS,LRIDT,LRIFN)),U)="pending" K ^LR(LRDFN,LRSS,LRIDT,LRIFN) Q
. I $D(^LR(LRDFN,LRSS,LRIDT,LRIFN)),$P(^LR(LRDFN,LRSS,LRIDT,LRIFN),U)="" K ^LR(LRDFN,LRSS,LRIDT,LRIFN) Q
Q
;
;
ORUT ; Update ORUT node in file #63 with this disposition
N DIERR,LRDIE,LRFDA,LR60,LR60P,LR64,LR64P,LRDISPO,LRFN,LRIEN
;
S LRDISPO="",LR60=LRTSTS,(LR64,LR64P,LRIEN)=0
S LR64=$P($G(^LAB(60,LR60,64)),"^")
;
S LR60P=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LR60,0)),"^",9)
I LR60P S LR64P=$P($G(^LAB(60,LR60P,64)),"^")
I LR64<1,LR64P<1 Q
;
; Check to see if NLT in ordered test multiple, check test or parent
S LR64(0)=$$GET1^DIQ(64,LR64_",",1),LRIEN=0
I LR64(0) S LRIEN=$O(^LR(LRDFN,LRSS,LRIDT,"ORUT","B",LR64(0),0))
I LRIEN S LRDISPO=$$FIND1^DIC(64.061,"","OQX","X","D","I $P(^(0),U,5)=""0123""")
I 'LRIEN,LR64P D
. S LR64P(0)=$$GET1^DIQ(64,LR64P_",",1)
. I LR64P(0) S LRIEN=$O(^LR(LRDFN,LRSS,LRIDT,"ORUT","B",LR64P(0),0))
. I LRIEN S LRDISPO=$$FIND1^DIC(64.061,"","OQX","A","D","I $P(^(0),U,5)=""0123""")
I LRDISPO<1 Q
;
S LRFN=$S(LRSS="CH":63.07,LRSS="MI":63.5,LRSS="SP":63.53,LRSS="CY":63.51,LRSS="EM":63.52,1:"")
I LRFN<1 Q
S LRIEN=LRIEN_","_LRIDT_","_LRDFN_","
S LRFDA(63,LRFN,LRIEN,10)=LRDISPO
S LRFDA(63,LRFN,LRIEN,11)=LRNOW
S LRFDA(63,LRFN,LRIEN,12)=DUZ
D FILE^DIE("","LRFDA(63)","LRDIE(63)")
D CLEAN^DILF
Q
;
;
LEDICHK ; Add test to LROTA array if it is a LEDI accesison - added with ccr_6164n
;
; - When tests from an exploded panel are NP'ed, only send back one OBR with the ordered test,
; instead of one OBR for each individual test on a panel that was NP'ed.
; - When tests from an exploded panel are NP'ed, send back an OBX for each individual test
; that were NP'ed so the receiving system can determine which tests from the panel were NP'ed.
;
; Process flow:
; - After NP'ing a test (via SET^LRTSTOUT), calling routine should call LEDICHK^LRTSTOUT.
; - If it is a LEDI test, LEDICHK will add the NP'ed test to the LROTA array.
; - After all tests are finished being NP'ed, calling process will then call LEDISET^LRTSTOUT.
; - LEDISET will process LROTA array to send the LEDI messages.
;
;
N LRORDTST,LRUID
;
I '$P($G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),.3)),"^",3) Q ;Not a LEDI accession
;
S LRUID=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),"^")
I LRUID="" Q
S LRORDTST=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0),U,9)
I 'LRORDTST S LRORDTST=LRTSTS
S LROTA(LRUID,LRORDTST)=LRAA_U_LRAD_U_LRAN_U_LRDFN_U_LRSS_U_LRIDT_U_LRODT
I LRORDTST'=LRTSTS D ;Send back OBX for this test, as it is part of panel
. S LROTA(LRUID,LRORDTST,LRTSTS)=""
;
;
Q
;
;
LEDISET(LROTA) ; added with ccr_6164n
;
; Called with: LROTA = array with LEDI tests (passed by reference)
; LROTA(UID,ORDERED TEST IEN)=LRAA_U_LRAD_U_LRAN_U_LRDFN_U_LRSS_U_LRIDT_U_LRODT
; LROTA(LRUID,ORDERED TEST IEN,TEST BEING NP'ED)=""
;
N LRORDTST,LRUID,LRX
;
Q:'$D(LROTA)
;
S LRUID=""
F S LRUID=$O(LROTA(LRUID)) Q:LRUID="" D
. S LRORDTST=0
. F S LRORDTST=$O(LROTA(LRUID,LRORDTST)) Q:'LRORDTST D
. . N LA7VDB,LRTSTS,LRX
. . S LRX=$G(LROTA(LRUID,LRORDTST))
. . S LA7VDB=""
. . S LRTSTS=0
. . F S LRTSTS=$O(LROTA(LRUID,LRORDTST,LRTSTS)) Q:'LRTSTS D
. . . N LA7TREE,LRSB,LRY
. . . D UNWIND^LA7ADL1(LRTSTS,9,LRTSTS)
. . . S LRY=0
. . . F S LRY=$O(LA7TREE(LRY)) Q:'LRY D
. . . . S LRSB=$P($G(^LAB(60,LRY,.2)),U)
. . . . I LRSB="" Q
. . . . I $P(LRX,U,5)="CH" S LA7VDB(LRSB)=LRSB
. . D LEDI($P(LRX,U,1),$P(LRX,U,2),$P(LRX,U,3),$P(LRX,U,4),$P(LRX,U,5),$P(LRX,U,6),$P(LRX,U,7),LRORDTST,.LA7VDB)
;
Q
;
;
LEDI(LRAA,LRAD,LRAN,LRDFN,LRSS,LRIDT,LRODT,LRORDTST,LA7VDB) ; Put accession in queue to send message back to collecting site.
;
; Made the following changes - ccr_6164n:
; - Added formal paramater list
; - Use parent test instead of individual NP'ed test (LRORDTST instead of LRTSTS)
; - Pass in LA7VDB array to SET^LA7VMSG call (so that an OBX can be generated when individual tests from a panel are NP'ed).
;
; Handle CH subscript tests
I LRSS="CH" D Q
. N LR64,LRORU3,LRTPN,LRTPNN
. S LRORU3=^LRO(68,LRAA,1,LRAD,1,LRAN,.3),LR64=$P($G(^LAB(60,LRORDTST,64)),"^") Q:'LR64
. S LRTPN=$$GET1^DIQ(64,LR64_",",.01),LRTPNN=$$GET1^DIQ(64,LR64_",",1)
. D SET^LA7VMSG($P(LRORU3,U,4),$P(LRORU3,U,2),$P(LRORU3,U,5),$P(LRORU3,U,3),LRTPN,LRTPNN,LRIDT,LRSS,LRDFN,LRODT,.LA7VDB,"ORU")
;
; Handle the other subscripts - MI, SP, CY , EM.
I LRSS?1(1"MI",1"SP",1"CY",1"EM") D MIAP^LA7VMSG(LRAA,LRAD,LRAN,LRORDTST,LRDFN,LRSS,LRIDT,LRODT)
Q
;
;
CHK63(LR60,LRDFN,LRSS,LRIDT) ; Check if tests being NP already have resuls in file #63.
; Call with LR60 = ien of entry in file #60
; LRDFN = ien of entry in file #63
; LRSS = file #63 subscript
; LRIDT = file #63 inverse date/time of specimen
;
; Returns LRFLAG = flag indicating if results exist in file #63 for this test either verified or unverified.
; 0 = no existing result in file #63
; 1 = existing node, no result value
; 2 = existing node, result value exists
; 3 = result exists and accession verified
;
N LA7TREE,LRFLAG,LRSB,LRX
;
D UNWIND^LA7ADL1(LR60,9,LR60)
S (LRFLAG,LRX)=0
F S LRX=$O(LA7TREE(LRX)) Q:'LRX D
. S LRSB=$P($P(^LAB(60,LRX,0),"^",5),";",2)
. I LRSB="" Q
. I '$D(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q
. I $P(^LR(LRDFN,LRSS,LRIDT,LRSB),"^")'="" D Q
. . I $P(^LR(LRDFN,LRSS,LRIDT,LRSB),"^")="pending" Q
. . I $P(^LR(LRDFN,LRSS,LRIDT,0),"^",3) S LRFLAG=3
. . E S LRFLAG=2
. S LRFLAG=1
;
Q LRFLAG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRTSTOUT 19995 printed Oct 16, 2024@18:21:52 Page 2
LRTSTOUT ;DALOI/STAFF - JAM TESTS OFF ACCESSIONS ;July 29, 2019@10:00
+1 ;;5.2;LAB SERVICE;**100,121,153,202,221,337,350,445,527,541,566**;Sep 27, 1994;Build 12
+2 ;
+3 ; Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.
+4 ;
EN ;
+1 NEW LREND
+2 DO EN^LRPARAM
if $GET(LREND)
QUIT
+3 IF '$DATA(LRLABKY)
WRITE !?5,"You are not authorized to change test status.",!,$CHAR(7)
SET LREND=1
QUIT
+4 NEW LRXX
WRITE @IOF
+5 FOR
Begin DoDot:1
+6 DO END
+7 SET (LREND,LRNOP)=0
+8 DO FIX
+9 IF $GET(LREND)
DO UNLOCK
QUIT
+10 IF '$GET(LRNOP)
DO CHG
+11 DO UNLOCK
End DoDot:1
if $GET(LREND)
QUIT
+12 DO EXIT
+13 QUIT
+14 ;
+15 ;
FIX ;
+1 NEW LRACC,LRNATURE
+2 SET (LREND,LRNOP)=0
SET LRNOW=$$NOW^XLFDT
+3 WRITE !
SET LRACC=1
DO LRACC
if $GET(LRNOP)
QUIT
+4 IF $GET(LRAN)<1
SET LREND=1
QUIT
+5 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
+6 DO LOCK^DILF("^LRO(68,LRAA,1,LRAD,1,LRAN)")
+7 IF '$TEST
WRITE !,"Someone else is working on this accession",!
SET LRNOP=1
QUIT
+8 ;
+9 SET LRX=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRACN=$PIECE(^(.2),U)
SET LRUID=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),U)
+10 SET LRDFN=+LRX
SET LRSN=+$PIECE(LRX,U,5)
SET LRODT=+$PIECE(LRX,U,4)
+11 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+12 DO PT^LRX
+13 WRITE !,PNM,?30,SSN
+14 SET LRIDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
+15 DO LOCK^DILF("^LR(LRDFN,LRSS,LRIDT)")
+16 IF '$TEST
WRITE !,"Someone else is working on this data."
SET LRNOP=1
QUIT
+17 ;
+18 IF '$GET(^LR(LRDFN,LRSS,LRIDT,0))
WRITE !?5," Can't find Lab Data for this accession",!
DO UNLOCK
SET LRNOP=1
QUIT
+19 ;
+20 IF LRODT
IF LRSN
IF $DATA(^LRO(69,LRODT,1,LRSN,0))#2
Begin DoDot:1
+21 NEW LRACN,LRAA,LRAD
+22 DO SHOW^LROS
End DoDot:1
+23 ;
+24 KILL DIR
+25 SET DIR(0)="E"
DO ^DIR
+26 IF $DATA(DIRUT)
SET LRNOP=1
QUIT
+27 ;
FX1 ;
+1 DO SHOWTST
+2 QUIT
+3 ;
+4 ;
CHG ;
+1 NEW DIC,I,LRCOMM,LRCTST,LROTA,LRXX
+2 WRITE !
+3 if '$DATA(DIC("A"))
SET DIC("A")="Change which LABORATORY TEST: "
+4 SET DIC="^LRO(68,"_LRAA_",1,"_LRAD_",1,"_LRAN_",4,"
SET DIC("S")="I '$L($P(^(0),U,5))"
SET DIC(0)="AEMOQ"
+5 FOR
DO ^DIC
if Y<1
QUIT
SET LRCTST(+Y)=$PIECE(^LAB(60,+Y,0),U)
SET DIC("A")="Select another test: "
+6 IF '$ORDER(LRCTST(0))
Begin DoDot:1
+7 DO UNLOCK
+8 WRITE !?5,"No Test Selected",!
End DoDot:1
QUIT
+9 IF LRODT=""!(LRSN="")
WRITE !,"NO CHANGE"
DO UNLOCK
DO END
QUIT
+10 SET LRCCOM=""
SET LREND=0
+11 IF '($DATA(^LRO(69,LRODT,1,LRSN,0))#2)
WRITE !?5,"There is no Order for this Accession",!
DO UNLOCK
DO END
QUIT
+12 WRITE @IOF,!!?5,"Change Accession : ",LRACN,?40,"UID: ",LRUID
+13 ;
+14 ; Check if tests selected have results stored in file #63.
+15 SET I=0
+16 FOR
SET I=$ORDER(LRCTST(I))
if I<1
QUIT
Begin DoDot:1
+17 NEW LRX
+18 WRITE !?10,LRCTST(I)
+19 SET LRX=$$CHK63(I,LRDFN,LRSS,LRIDT)
+20 IF LRX>0
SET LRNOP=1
+21 IF LRX=1
WRITE ?40," Results entered for this test, cannot NP until removed."
+22 IF LRX=2
WRITE ?40," Results entered for this test, cannot NP this test."
+23 IF LRX=3
WRITE ?40," Results verified for this test, cannot NP this test."
End DoDot:1
+24 IF LRNOP
QUIT
+25 ;
+26 DO FX2
if $GET(LREND)
QUIT
+27 ;
+28 SET LRTSTS=0
+29 FOR
SET LRTSTS=$ORDER(LRCTST(LRTSTS))
if LRTSTS<1
QUIT
Begin DoDot:1
+30 if '($DATA(^LAB(60,LRTSTS,0))#2)
QUIT
SET LRTNM=$PIECE(^(0),U)
+31 ;The test being canceled might be a component of a panel which was ordered.
+32 ;If not a panel (i.e. "atomic test"), LRORDTST=LRTSTS
+33 SET LRORDTST=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0),U,9)
DO SET
DO CLNPENDG
+34 ; ccr_6164n
DO LEDICHK
+35 if '$GET(LREND)
WRITE !?5,"[ "_LRTNM_" ] ",$SELECT('$DATA(LRLABKY):" Marked Canceled by Floor",1:" Marked Not Performed"),!
End DoDot:1
+36 ;
+37 ; ccr_6164n
IF $DATA(LROTA)
DO LEDISET(.LROTA)
+38 ;
+39 SET LREND=0
+40 ;
+41 QUIT
+42 ;
+43 ;
SHOWTST ;
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRI,LRN,LRY,LRIC,X
+2 SET DIR(0)="E"
+3 DO DEMO
+4 SET (LRN,LRI)=0
+5 FOR
SET LRI=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI))
if LRI<1!($GET(LRY))
QUIT
Begin DoDot:1
+6 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
+7 WRITE !,?5,$PIECE(^(0),U)
SET LRN=LRN+1
+8 IF LRIC
WRITE ?35," "_$SELECT($LENGTH($PIECE(LRIC,U,3)):$PIECE(LRIC,U,3),1:"Completed")_" "_$$FMTE^XLFDT($PIECE(LRIC,U,2),"1FMZ")_" by "_$PIECE(LRIC,U)
+9 IF LRN>18
DO ^DIR
if $DATA(DIRUT)
SET LRY=1
if $GET(LRY)
QUIT
DO DEMO
SET LRN=0
End DoDot:1
+10 ;
+11 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRODT=$PIECE(X,U,4)
SET LRSN=$PIECE(X,U,5)
+12 ;
+13 QUIT
+14 ;
+15 ;
DEMO WRITE !,PNM,?50,SSN
+1 WRITE !,"TESTS ON ACCESSION: ",LRACN,?40,"UID: ",LRUID
+2 QUIT
+3 ;
+4 ;
SET ;
+1 SET LRNOW=$$NOW^XLFDT
+2 SET LRLLOC=$PIECE(^LRO(69,LRODT,1,LRSN,0),U,7)
+3 ;
+4 NEW II,X,LRI,LRSTATUS,OCXTRACE,ORIFN,ORSTS,LRMERGSO,LRORSTAT,LR7DONE
+5 if $GET(LRDBUG)
SET OCXTRACE=1
+6 ;LR*5.2*527: SET^LRTSTOUT might be called from other routines
+7 IF '$GET(LRORDTST)
IF $GET(LRAA)]""
IF $GET(LRAD)]""
IF $GET(LRAN)]""
Begin DoDot:1
+8 if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
QUIT
+9 ;make sure same patient
+10 if +^LRO(68,LRAA,1,LRAD,1,LRAN,0)'=+^LRO(69,LRODT,1,LRSN,0)
QUIT
+11 ;LRORDTST=ordered test
+12 SET LRORDTST=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0)),U,9)
End DoDot:1
+13 ;LR*5.2*527 end
+14 SET LRI=0
+15 FOR
SET LRI=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRI))
if LRI<1
QUIT
IF $DATA(^(LRI,0))#2
Begin DoDot:1
+16 ;LR*5.2*527: if don't have ordered test, is current test in file 63
+17 IF '$GET(LRORDTST)
IF LRTSTS'=+^LRO(69,LRODT,1,LRSN,2,LRI,0)
QUIT
+18 ;checking for ordered test or component of ordered test (i.e. panel)
+19 IF $GET(LRORDTST)
IF LRTSTS'=+^LRO(69,LRODT,1,LRSN,2,LRI,0)
IF LRORDTST'=+^LRO(69,LRODT,1,LRSN,2,LRI,0)
QUIT
+20 ;Already canceled = if 11th piece is not null
+21 if $PIECE(^LRO(69,LRODT,1,LRSN,2,LRI,0),U,11)
QUIT
SET ORIFN=$PIECE(^(0),U,7)
SET (LRORSTAT,LR7DONE)=0
+22 SET (LRSTATUS,II(LRTSTS))=""
+23 ;LR*5.2*566: LRCOMX new'd at ZAP^LR7OMERG
+24 IF '$DATA(LRCOMX(LRODT,LRSN,LRI,1))
Begin DoDot:2
+25 SET X=1+$ORDER(^LRO(69,LRODT,1,LRSN,2,LRI,1.1,"A"),-1)
SET X(1)=$PIECE($GET(^(0)),U,4)
+26 ;LR*5.2*527 note: If a panel component is being canceled, the comments
+27 ; are filed at both the panel and component levels so that
+28 ; the comments display in reports.
+29 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
+30 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,"1FMZ")
+31 SET ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,0)="^^"_X_"^"_X(1)_"^"_DT
+32 SET LRCOMX(LRODT,LRSN,LRI,1)=""
End DoDot:2
+33 ;Don't cancel test if accession merged to same order.
IF $GET(LRMERG)
IF $PIECE(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",3,5)'=(LRAD_"^"_LRAA_"^"_LRAN)
Begin DoDot:2
+34 ;same order flag not been set
if '$GET(LRSOF)
QUIT
+35 IF '$DATA(LRCOMX(LRODT,LRSN,LRI,2))
Begin DoDot:3
+36 SET X=X+1
SET X(1)=X(1)+1
+37 SET ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,X,0)="*Merge from: "_$GET(^LRO(68,+$GET(LR1AA),1,+$GET(LR1AD),1,+$GET(LR1AN),.2),"Unknown")
+38 SET ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,0)="^^"_X_"^"_X(1)_"^"_DT
+39 SET LRCOMX(LRODT,LRSN,LRI,2)=""
End DoDot:3
+40 ;indicate that a same order merge occurred & we want to keep #100 order
SET LRMERGSO=1
SET LRMSTATI=6
End DoDot:2
+41 ;LR*5.2*527: Check order status if deleting panel component
+42 ;LR*5.2*541: ... if patient is in the PATIENT (#2) file
+43 ; (variable LRDPF).
+44 IF '$GET(LRMERG)
IF $GET(LRORDTST)
IF LRTSTS'=LRORDTST
IF $GET(LRDPF)=2
Begin DoDot:2
+45 SET LR7DONE=1
+46 SET LRORSTAT=$$OR(LRORDTST,LRTSTS,ORIFN)
+47 ;don't update status if any pending tests
+48 if 'LRORSTAT
QUIT
+49 IF '$GET(ORIFN)
IF '$DATA(II)
QUIT
+50 DO NEW^LR7OB1(LRODT,LRSN,$SELECT(LRORSTAT=1:"SC",1:"OC"),$GET(LRNATURE),.II,LRSTATUS)
+51 KILL ^TMP("LR",$JOB,"PANEL")
+52 ;LR*5.2*527 end
End DoDot:2
+53 IF 'LR7DONE
IF $GET(ORIFN)
IF $DATA(II)
DO NEW^LR7OB1(LRODT,LRSN,$SELECT($GET(LRMSTATI)=""!($GET(LRMSTATI)=1):"OC",1:"SC"),$GET(LRNATURE),.II,LRSTATUS)
+54 ;Keep ^LR7OB1 call before ^^ update to status/DUZ in File #69 (below); see warning in 69^LR7OB69:
+55 ;LR*5.2*527 added below:
+56 IF LR7DONE
Begin DoDot:2
+57 ;only set canceled status in file 69 if everything on ordered test is canceled
+58 IF LRORSTAT=2
Begin DoDot:3
+59 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",9)="CA"
SET $PIECE(^(0),U,10)="L"
SET $PIECE(^(0),U,11)=DUZ
End DoDot:3
QUIT
+60 ;if a panel and components broken out, set canceled status for each canceled component
+61 IF +^LRO(69,LRODT,1,LRSN,2,LRI,0)=LRTSTS
Begin DoDot:3
+62 SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",9)="CA"
SET $PIECE(^(0),U,10)="L"
SET $PIECE(^(0),U,11)=DUZ
End DoDot:3
End DoDot:2
+63 ;LR*5.2*527 end
+64 IF 'LR7DONE
IF '$DATA(LRMERGSO)
SET $PIECE(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",9)="CA"
SET $PIECE(^(0),U,10)="L"
SET $PIECE(^(0),U,11)=DUZ
+65 if $DATA(^LRO(69,LRODT,1,LRSN,"PCE"))
SET ^LRO(69,"AE",DUZ,LRODT,LRSN,LRI)=""
+66 ;LR*5.2*566: Do not kill LRMERGSO and LRSOF
+67 KILL II
End DoDot:1
+68 ;
+69 KILL ORIFN,ORSTS
+70 ;
+71 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
+72 SET LROWDT=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,3)
IF LROWDT
IF LROWDT'=LRAD
DO ROL
QUIT
+73 SET LROWDT=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,9))
IF LROWDT
DO ROL
End DoDot:1
+74 ;
+75 IF $GET(LRIDT)
IF $GET(LRSS)'=""
IF LRCCOM'=""
IF $GET(^LR(LRDFN,LRSS,LRIDT,0))
Begin DoDot:1
+76 DO UPD63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM)
+77 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN))
DO XREF^LRVER3A
End DoDot:1
+78 ;
+79 ; Update status of test in file #63 ORUT node.
+80 ; Set reporting site in file #63.
+81 IF $GET(LRIDT)
IF $GET(LRSS)'=""
Begin DoDot:1
+82 DO ORUT
+83 DO SETRL^LRVERA(LRDFN,LRSS,LRIDT,DUZ(2))
End DoDot:1
+84 ;
+85 ; Put in list to check for auto download.
+86 ; Check if LEDI specimen and notify collecting facility
+87 IF $GET(LRAA)
IF $GET(LRAD)
IF $GET(LRAN)
IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
Begin DoDot:1
+88 DO EN^LA7ADL($PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),"^"))
+89 ;I $P(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),"^",3) D LEDI ;ccr_6164n
End DoDot:1
+90 ;
+91 QUIT
+92 ;
OR(LRORDTST,LRTSTS,ORIFN) ;evaluate overall status of order
+1 ;LR*5.2*527 added this section
+2 NEW LRXSN,LRXSTR,LRXPEND,LRXRESULT,LRXSTATUS
+3 ;AX8^LR7OB3 is called downstream from NEW^LR7OB1 and
+4 ;refers to ^TMP("LR",$J,"PANEL" to determine whether a panel
+5 ;is canceled.
+6 ;The kill below is not necessary, but adding as a safeguard.
+7 KILL ^TMP("LR",$JOB,"PANEL")
+8 ;Check all tests for this CPRS order number
+9 SET (LRXSN,LRXPEND,LRXRESULT,LRXSTATUS)=0
+10 ;if any pending components within panel, stop evaluating
+11 FOR
SET LRXSN=$ORDER(^LRO(69,LRODT,1,LRSN,2,LRXSN))
if 'LRXSN
QUIT
if LRXPEND
QUIT
Begin DoDot:1
+12 SET LRXSTR=$GET(^LRO(69,LRODT,1,LRSN,2,LRXSN,0))
+13 ;This test has a different CPRS order number.
+14 if $PIECE(LRXSTR,U,7)'=ORIFN
QUIT
+15 ;don't evaluate test currently being deleted
+16 ;The file 68 status will be updated later.
+17 if +LRXSTR=LRTSTS
QUIT
+18 NEW LRXAA,LRXAD,LRXAN
+19 SET LRXAA=$PIECE(LRXSTR,U,4)
SET LRXAD=$PIECE(LRXSTR,U,3)
SET LRXAN=$PIECE(LRXSTR,U,5)
+20 ;This test has not been accessioned, possibly because
+21 ;the components have been.
+22 if LRXAA=""
QUIT
+23 ;Panels which "explode" into other panels might not be subscripted
+24 ;in file 68.
+25 if '$DATA(^LRO(68,LRXAA,1,LRXAD,1,LRXAN,4,+LRXSTR,0))
QUIT
+26 IF $PIECE($GET(^LRO(68,LRXAA,1,LRXAD,1,LRXAN,4,+LRXSTR,0)),U,5)=""
SET LRXPEND=1
QUIT
+27 ;Continue to check for pending panel components
+28 ;Due to site requests, panel is marked as complete if any components are verified
+29 ;so that the panel will not display on the "Incomplete Test Status Report".
+30 NEW LRX68TST
+31 SET LRX68TST=0
+32 FOR
SET LRX68TST=$ORDER(^LRO(68,LRXAA,1,LRXAD,1,LRXAN,4,LRX68TST))
if 'LRX68TST
QUIT
if LRXPEND
QUIT
Begin DoDot:2
+33 SET LRXSTR=$GET(^LRO(68,LRXAA,1,LRXAD,1,LRXAN,4,LRX68TST,0))
+34 if $PIECE(LRXSTR,U,9)'=LRORDTST
QUIT
+35 if LRX68TST=LRTSTS
QUIT
+36 IF $PIECE(LRXSTR,U,5)=""
SET LRXPEND=1
QUIT
+37 ;This test contains a result.
+38 IF $PIECE(LRXSTR,U,6)=""
SET LRXRESULT=1
End DoDot:2
End DoDot:1
+39 ;If there are any pending tests left on the order, do not call LR7OB1
+40 ;If no pending tests and any results, update to complete
+41 ;If no pending tests and no results, update to discontinued.
+42 SET LRXSTATUS=$SELECT(LRXPEND:0,LRXRESULT:1,1:2)
+43 SET ^TMP("LR",$JOB,"PANEL",ORIFN)=LRXSTATUS
+44 QUIT LRXSTATUS
+45 ;
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_$SELECT($GET(LRMERG):"*Merged",1:"*Not Performed")
+3 QUIT
+4 ;
+5 ;
LRACC ;
+1 KILL LRAN
+2 SET LREND=0
SET LREXMPT=1
DO ^LRWU4
KILL LREXMPT
+3 if '$GET(LRAA)!('$GET(LRAN))!('($DATA(^LRO(68,LRAA,0))#2))
QUIT
+4 SET DA(2)=LRAA
SET DA(1)=LRAD
SET LRSS=$PIECE(^LRO(68,LRAA,0),U,2)
+5 IF LRSS=""
SET LRAN=0
SET LRNOP=1
WRITE !?5,"No Subscript for this Accession Area ",!!
+6 QUIT
+7 ;
+8 ;
LREND ;
+1 SET LREND=1
+2 QUIT
+3 ;
+4 ;
UNLOCK ;
+1 IF +$GET(LRDFN)
IF $GET(LRSS)'=""
IF +$GET(LRIDT)
LOCK -^LR(LRDFN,LRSS,LRIDT)
+2 IF +$GET(LRAA)
IF +$GET(LRAD)
IF +$GET(LRAN)
LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
+3 ;
+4 QUIT
+5 ;
+6 ;
EXIT ;
+1 KILL LRSCNX,LREND,LRNOECHO,LRACN,LRLABRV,LRNOW
+2 ;
END ;
+1 KILL LRCCOM0,LRCCOM1,LRCCOMX,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 DO KVA^VADPT
DO END^LRTSTJAM
DO V^LRU
+5 QUIT
+6 ;
+7 ;
FX2 ;
+1 SET LREND=0
SET (LRCOM,LRCCOM1)=""
+2 IF LRDPF=2
IF $GET(LRNATURE)=""
DO DC^LROR6()
IF $GET(LRNATURE)="-1"
WRITE !!,$CHAR(7),"Nothing Changed",!
SET LREND=1
QUIT
+3 IF '$DATA(LRLABKY)
DO FX3
QUIT
+4 ;
+5 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+6 SET DIR(0)="62.5,5"
SET DIR("A")="Select NP comment Lab Description screen"
+7 SET DIR("?",1)="The default expansion screens are GENERAL, ORDER and LAB"
+8 SET DIR("?",2)="You may select an additional lab description expansion screen"
+9 SET DIR("?",3)="which will be used to expand your NP reason."
+10 SET DIR("?")="Press return to only use these default screens"
+11 ;
+12 KILL LRNOECHO
+13 if $GET(LRSCN)=""
SET LRSCN="AKL"
+14 WRITE !
+15 DO ^DIR
+16 IF $DATA(DUOUT)!($DATA(DTOUT))
SET LREND=1
QUIT
+17 IF Y'=""
SET LRSCN=LRSCN_Y
+18 KILL X,Y
+19 ;
+20 FOR
DO FX3
if LREND!($GET(LRCCOM)'="")
QUIT
+21 QUIT
+22 ;
+23 ;
FX3 ;
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRL,LRY
+2 SET LRL=52
SET LREND=0
+3 SET DIR("A")=$SELECT('$DATA(LRLABKY):"Reason for Cancel",1:"Not Perform Reason")
+4 IF $GET(LRXX)'=""
SET DIR("B")=$GET(LRXX)
+5 SET DIR(0)="F^1:"_LRL_"^"
+6 WRITE !
+7 DO ^DIR
+8 IF $DATA(DUOUT)!($DATA(DTOUT))
SET LREND=1
QUIT
+9 SET LRY=Y
+10 ;
+11 IF LREND
QUIT
+12 IF $DATA(LRLABKY)
Begin DoDot:1
+13 NEW LRSAV
SET LRSAV=LRSCN
+14 SET (LRXX,X)=LRY
SET Q9="1,"_LRL_","_LRSCN
DO COM^LRNUM
SET LRSCN=LRSAV
+15 IF $GET(X)=""
QUIT
+16 IF $EXTRACT(X,$LENGTH(X))=" "
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+17 SET LRY=X
End DoDot:1
+18 SET (LRCCOM,LRCCOMX)=LRY
+19 IF '$DATA(LRLABKY)
WRITE !,"("_LRCCOM_")"
+20 KILL DIR
+21 SET DIR(0)="Y"
SET DIR("A")="Satisfactory Comment"
SET DIR("B")="Yes"
+22 DO ^DIR
+23 IF $DATA(DIRUT)
SET LREND=1
QUIT
+24 IF Y=1
SET LRCCOM=$EXTRACT($SELECT('$DATA(LRLABKY):"*Floor Cancel Reason: ",1:"*NP Reason: ")_LRCCOM,1,68)
+25 IF '$TEST
SET (LRCCOM,LRCCOMX)=""
+26 QUIT
+27 ;
+28 ;
UPD63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM) ; Update file #63 with comment reflecting dispostion.
+1 ;
+2 NEW FDA,LRCCOMO,LRDIE,LRFN,LRNOECHO,LRY
+3 ;
+4 if '$GET(LRNOW)
SET LRNOW=$$NOW^XLFDT
+5 SET LRNOECHO=1
+6 SET LRCCOMO=$EXTRACT("*"_LRTNM_$SELECT($GET(LRMERG):" Merged: ",'$DATA(LRLABKY):" Floor Canceled: ",1:" Not Performed: ")_$$FMTE^XLFDT(LRNOW,"1FMZ")_" by "_DUZ,1,68)
+7 ;
+8 SET LRFN=$SELECT(LRSS="CH":63.041,LRSS="MI":63.05,LRSS="SP":63.98,LRSS="CY":63.908,LRSS="EM":63.208,LRSS="BB":63.199,1:"")
+9 IF LRSS="MI"
Begin DoDot:1
+10 SET FDA(1,LRFN,LRIDT_","_LRDFN_",",.99)=LRCCOMO
+11 DO FILE^DIE("","FDA(1)","LRDIE(1)")
+12 KILL FDA(1),LRDIE(1)
End DoDot:1
QUIT
+13 ;
+14 FOR LRY=LRCCOMO,LRCCOM
Begin DoDot:1
+15 SET FDA(1,LRFN,"+1,"_LRIDT_","_LRDFN_",",.01)=LRY
+16 IF $DATA(FDA(1))
DO UPDATE^DIE("","FDA(1)","","LRDIE(1)")
+17 KILL FDA(1),LRDIE(1)
End DoDot:1
+18 DO CLEAN^DILF
+19 QUIT
+20 ;
+21 ;
CLNPENDG ; Remove pending and other info from Lab test when set to not performed
+1 NEW LRIFN
+2 SET LRIFN=$PIECE($GET(^LAB(60,LRTSTS,.2)),U)
+3 IF LRIFN'=""
IF LRSS="CH"
Begin DoDot:1
+4 IF $PIECE($GET(^LR(LRDFN,LRSS,LRIDT,LRIFN)),U)="pending"
KILL ^LR(LRDFN,LRSS,LRIDT,LRIFN)
QUIT
+5 IF $DATA(^LR(LRDFN,LRSS,LRIDT,LRIFN))
IF $PIECE(^LR(LRDFN,LRSS,LRIDT,LRIFN),U)=""
KILL ^LR(LRDFN,LRSS,LRIDT,LRIFN)
QUIT
End DoDot:1
+6 QUIT
+7 ;
+8 ;
ORUT ; Update ORUT node in file #63 with this disposition
+1 NEW DIERR,LRDIE,LRFDA,LR60,LR60P,LR64,LR64P,LRDISPO,LRFN,LRIEN
+2 ;
+3 SET LRDISPO=""
SET LR60=LRTSTS
SET (LR64,LR64P,LRIEN)=0
+4 SET LR64=$PIECE($GET(^LAB(60,LR60,64)),"^")
+5 ;
+6 SET LR60P=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LR60,0)),"^",9)
+7 IF LR60P
SET LR64P=$PIECE($GET(^LAB(60,LR60P,64)),"^")
+8 IF LR64<1
IF LR64P<1
QUIT
+9 ;
+10 ; Check to see if NLT in ordered test multiple, check test or parent
+11 SET LR64(0)=$$GET1^DIQ(64,LR64_",",1)
SET LRIEN=0
+12 IF LR64(0)
SET LRIEN=$ORDER(^LR(LRDFN,LRSS,LRIDT,"ORUT","B",LR64(0),0))
+13 IF LRIEN
SET LRDISPO=$$FIND1^DIC(64.061,"","OQX","X","D","I $P(^(0),U,5)=""0123""")
+14 IF 'LRIEN
IF LR64P
Begin DoDot:1
+15 SET LR64P(0)=$$GET1^DIQ(64,LR64P_",",1)
+16 IF LR64P(0)
SET LRIEN=$ORDER(^LR(LRDFN,LRSS,LRIDT,"ORUT","B",LR64P(0),0))
+17 IF LRIEN
SET LRDISPO=$$FIND1^DIC(64.061,"","OQX","A","D","I $P(^(0),U,5)=""0123""")
End DoDot:1
+18 IF LRDISPO<1
QUIT
+19 ;
+20 SET LRFN=$SELECT(LRSS="CH":63.07,LRSS="MI":63.5,LRSS="SP":63.53,LRSS="CY":63.51,LRSS="EM":63.52,1:"")
+21 IF LRFN<1
QUIT
+22 SET LRIEN=LRIEN_","_LRIDT_","_LRDFN_","
+23 SET LRFDA(63,LRFN,LRIEN,10)=LRDISPO
+24 SET LRFDA(63,LRFN,LRIEN,11)=LRNOW
+25 SET LRFDA(63,LRFN,LRIEN,12)=DUZ
+26 DO FILE^DIE("","LRFDA(63)","LRDIE(63)")
+27 DO CLEAN^DILF
+28 QUIT
+29 ;
+30 ;
LEDICHK ; Add test to LROTA array if it is a LEDI accesison - added with ccr_6164n
+1 ;
+2 ; - When tests from an exploded panel are NP'ed, only send back one OBR with the ordered test,
+3 ; instead of one OBR for each individual test on a panel that was NP'ed.
+4 ; - When tests from an exploded panel are NP'ed, send back an OBX for each individual test
+5 ; that were NP'ed so the receiving system can determine which tests from the panel were NP'ed.
+6 ;
+7 ; Process flow:
+8 ; - After NP'ing a test (via SET^LRTSTOUT), calling routine should call LEDICHK^LRTSTOUT.
+9 ; - If it is a LEDI test, LEDICHK will add the NP'ed test to the LROTA array.
+10 ; - After all tests are finished being NP'ed, calling process will then call LEDISET^LRTSTOUT.
+11 ; - LEDISET will process LROTA array to send the LEDI messages.
+12 ;
+13 ;
+14 NEW LRORDTST,LRUID
+15 ;
+16 ;Not a LEDI accession
IF '$PIECE($GET(^LRO(68,+$GET(LRAA),1,+$GET(LRAD),1,+$GET(LRAN),.3)),"^",3)
QUIT
+17 ;
+18 SET LRUID=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),"^")
+19 IF LRUID=""
QUIT
+20 SET LRORDTST=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0),U,9)
+21 IF 'LRORDTST
SET LRORDTST=LRTSTS
+22 SET LROTA(LRUID,LRORDTST)=LRAA_U_LRAD_U_LRAN_U_LRDFN_U_LRSS_U_LRIDT_U_LRODT
+23 ;Send back OBX for this test, as it is part of panel
IF LRORDTST'=LRTSTS
Begin DoDot:1
+24 SET LROTA(LRUID,LRORDTST,LRTSTS)=""
End DoDot:1
+25 ;
+26 ;
+27 QUIT
+28 ;
+29 ;
LEDISET(LROTA) ; added with ccr_6164n
+1 ;
+2 ; Called with: LROTA = array with LEDI tests (passed by reference)
+3 ; LROTA(UID,ORDERED TEST IEN)=LRAA_U_LRAD_U_LRAN_U_LRDFN_U_LRSS_U_LRIDT_U_LRODT
+4 ; LROTA(LRUID,ORDERED TEST IEN,TEST BEING NP'ED)=""
+5 ;
+6 NEW LRORDTST,LRUID,LRX
+7 ;
+8 if '$DATA(LROTA)
QUIT
+9 ;
+10 SET LRUID=""
+11 FOR
SET LRUID=$ORDER(LROTA(LRUID))
if LRUID=""
QUIT
Begin DoDot:1
+12 SET LRORDTST=0
+13 FOR
SET LRORDTST=$ORDER(LROTA(LRUID,LRORDTST))
if 'LRORDTST
QUIT
Begin DoDot:2
+14 NEW LA7VDB,LRTSTS,LRX
+15 SET LRX=$GET(LROTA(LRUID,LRORDTST))
+16 SET LA7VDB=""
+17 SET LRTSTS=0
+18 FOR
SET LRTSTS=$ORDER(LROTA(LRUID,LRORDTST,LRTSTS))
if 'LRTSTS
QUIT
Begin DoDot:3
+19 NEW LA7TREE,LRSB,LRY
+20 DO UNWIND^LA7ADL1(LRTSTS,9,LRTSTS)
+21 SET LRY=0
+22 FOR
SET LRY=$ORDER(LA7TREE(LRY))
if 'LRY
QUIT
Begin DoDot:4
+23 SET LRSB=$PIECE($GET(^LAB(60,LRY,.2)),U)
+24 IF LRSB=""
QUIT
+25 IF $PIECE(LRX,U,5)="CH"
SET LA7VDB(LRSB)=LRSB
End DoDot:4
End DoDot:3
+26 DO LEDI($PIECE(LRX,U,1),$PIECE(LRX,U,2),$PIECE(LRX,U,3),$PIECE(LRX,U,4),$PIECE(LRX,U,5),$PIECE(LRX,U,6),$PIECE(LRX,U,7),LRORDTST,.LA7VDB)
End DoDot:2
End DoDot:1
+27 ;
+28 QUIT
+29 ;
+30 ;
LEDI(LRAA,LRAD,LRAN,LRDFN,LRSS,LRIDT,LRODT,LRORDTST,LA7VDB) ; Put accession in queue to send message back to collecting site.
+1 ;
+2 ; Made the following changes - ccr_6164n:
+3 ; - Added formal paramater list
+4 ; - Use parent test instead of individual NP'ed test (LRORDTST instead of LRTSTS)
+5 ; - Pass in LA7VDB array to SET^LA7VMSG call (so that an OBX can be generated when individual tests from a panel are NP'ed).
+6 ;
+7 ; Handle CH subscript tests
+8 IF LRSS="CH"
Begin DoDot:1
+9 NEW LR64,LRORU3,LRTPN,LRTPNN
+10 SET LRORU3=^LRO(68,LRAA,1,LRAD,1,LRAN,.3)
SET LR64=$PIECE($GET(^LAB(60,LRORDTST,64)),"^")
if 'LR64
QUIT
+11 SET LRTPN=$$GET1^DIQ(64,LR64_",",.01)
SET LRTPNN=$$GET1^DIQ(64,LR64_",",1)
+12 DO SET^LA7VMSG($PIECE(LRORU3,U,4),$PIECE(LRORU3,U,2),$PIECE(LRORU3,U,5),$PIECE(LRORU3,U,3),LRTPN,LRTPNN,LRIDT,LRSS,LRDFN,LRODT,.LA7VDB,"ORU")
End DoDot:1
QUIT
+13 ;
+14 ; Handle the other subscripts - MI, SP, CY , EM.
+15 IF LRSS?1(1"MI",1"SP",1"CY",1"EM")
DO MIAP^LA7VMSG(LRAA,LRAD,LRAN,LRORDTST,LRDFN,LRSS,LRIDT,LRODT)
+16 QUIT
+17 ;
+18 ;
CHK63(LR60,LRDFN,LRSS,LRIDT) ; Check if tests being NP already have resuls in file #63.
+1 ; Call with LR60 = ien of entry in file #60
+2 ; LRDFN = ien of entry in file #63
+3 ; LRSS = file #63 subscript
+4 ; LRIDT = file #63 inverse date/time of specimen
+5 ;
+6 ; Returns LRFLAG = flag indicating if results exist in file #63 for this test either verified or unverified.
+7 ; 0 = no existing result in file #63
+8 ; 1 = existing node, no result value
+9 ; 2 = existing node, result value exists
+10 ; 3 = result exists and accession verified
+11 ;
+12 NEW LA7TREE,LRFLAG,LRSB,LRX
+13 ;
+14 DO UNWIND^LA7ADL1(LR60,9,LR60)
+15 SET (LRFLAG,LRX)=0
+16 FOR
SET LRX=$ORDER(LA7TREE(LRX))
if 'LRX
QUIT
Begin DoDot:1
+17 SET LRSB=$PIECE($PIECE(^LAB(60,LRX,0),"^",5),";",2)
+18 IF LRSB=""
QUIT
+19 IF '$DATA(^LR(LRDFN,LRSS,LRIDT,LRSB))
QUIT
+20 IF $PIECE(^LR(LRDFN,LRSS,LRIDT,LRSB),"^")'=""
Begin DoDot:2
+21 IF $PIECE(^LR(LRDFN,LRSS,LRIDT,LRSB),"^")="pending"
QUIT
+22 IF $PIECE(^LR(LRDFN,LRSS,LRIDT,0),"^",3)
SET LRFLAG=3
+23 IF '$TEST
SET LRFLAG=2
End DoDot:2
QUIT
+24 SET LRFLAG=1
End DoDot:1
+25 ;
+26 QUIT LRFLAG
