- 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 Feb 18, 2025@23:47 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