Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRTSTOUT

LRTSTOUT.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.
  1. ;
  1. EN ;
  1. N LREND
  1. D EN^LRPARAM Q:$G(LREND)
  1. I '$D(LRLABKY) W !?5,"You are not authorized to change test status.",!,$C(7) S LREND=1 Q
  1. N LRXX W @IOF
  1. F D Q:$G(LREND)
  1. . D END
  1. . S (LREND,LRNOP)=0
  1. . D FIX
  1. . I $G(LREND) D UNLOCK Q
  1. . I '$G(LRNOP) D CHG
  1. . D UNLOCK
  1. D EXIT
  1. Q
  1. ;
  1. ;
  1. FIX ;
  1. N LRACC,LRNATURE
  1. S (LREND,LRNOP)=0,LRNOW=$$NOW^XLFDT
  1. W ! S LRACC=1 D LRACC Q:$G(LRNOP)
  1. I $G(LRAN)<1 S LREND=1 Q
  1. 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
  1. D LOCK^DILF("^LRO(68,LRAA,1,LRAD,1,LRAN)")
  1. I '$T W !,"Someone else is working on this accession",! S LRNOP=1 Q
  1. ;
  1. 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)
  1. S LRDFN=+LRX,LRSN=+$P(LRX,U,5),LRODT=+$P(LRX,U,4)
  1. S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
  1. D PT^LRX
  1. W !,PNM,?30,SSN
  1. S LRIDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),U,5)
  1. D LOCK^DILF("^LR(LRDFN,LRSS,LRIDT)")
  1. I '$T W !,"Someone else is working on this data." S LRNOP=1 Q
  1. ;
  1. I '$G(^LR(LRDFN,LRSS,LRIDT,0)) W !?5," Can't find Lab Data for this accession",! D UNLOCK S LRNOP=1 Q
  1. ;
  1. I LRODT,LRSN,$D(^LRO(69,LRODT,1,LRSN,0))#2 D
  1. . N LRACN,LRAA,LRAD
  1. . D SHOW^LROS
  1. ;
  1. K DIR
  1. S DIR(0)="E" D ^DIR
  1. I $D(DIRUT) S LRNOP=1 Q
  1. ;
  1. FX1 ;
  1. D SHOWTST
  1. Q
  1. ;
  1. ;
  1. CHG ;
  1. N DIC,I,LRCOMM,LRCTST,LROTA,LRXX
  1. W !
  1. S:'$D(DIC("A")) DIC("A")="Change which LABORATORY TEST: "
  1. S DIC="^LRO(68,"_LRAA_",1,"_LRAD_",1,"_LRAN_",4,",DIC("S")="I '$L($P(^(0),U,5))",DIC(0)="AEMOQ"
  1. F D ^DIC Q:Y<1 S LRCTST(+Y)=$P(^LAB(60,+Y,0),U),DIC("A")="Select another test: "
  1. I '$O(LRCTST(0)) D Q
  1. . D UNLOCK
  1. . W !?5,"No Test Selected",!
  1. I LRODT=""!(LRSN="") W !,"NO CHANGE" D UNLOCK,END Q
  1. S LRCCOM="",LREND=0
  1. I '($D(^LRO(69,LRODT,1,LRSN,0))#2) W !?5,"There is no Order for this Accession",! D UNLOCK,END Q
  1. W @IOF,!!?5,"Change Accession : ",LRACN,?40,"UID: ",LRUID
  1. ;
  1. ; Check if tests selected have results stored in file #63.
  1. S I=0
  1. F S I=$O(LRCTST(I)) Q:I<1 D
  1. . N LRX
  1. . W !?10,LRCTST(I)
  1. . S LRX=$$CHK63(I,LRDFN,LRSS,LRIDT)
  1. . I LRX>0 S LRNOP=1
  1. . I LRX=1 W ?40," Results entered for this test, cannot NP until removed."
  1. . I LRX=2 W ?40," Results entered for this test, cannot NP this test."
  1. . I LRX=3 W ?40," Results verified for this test, cannot NP this test."
  1. I LRNOP Q
  1. ;
  1. D FX2 Q:$G(LREND)
  1. ;
  1. S LRTSTS=0
  1. F S LRTSTS=$O(LRCTST(LRTSTS)) Q:LRTSTS<1 D
  1. . Q:'($D(^LAB(60,LRTSTS,0))#2) S LRTNM=$P(^(0),U)
  1. . ;The test being canceled might be a component of a panel which was ordered.
  1. . ;If not a panel (i.e. "atomic test"), LRORDTST=LRTSTS
  1. . S LRORDTST=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0),U,9) D SET,CLNPENDG
  1. . D LEDICHK ; ccr_6164n
  1. . W:'$G(LREND) !?5,"[ "_LRTNM_" ] ",$S('$D(LRLABKY):" Marked Canceled by Floor",1:" Marked Not Performed"),!
  1. ;
  1. I $D(LROTA) D LEDISET(.LROTA) ; ccr_6164n
  1. ;
  1. S LREND=0
  1. ;
  1. Q
  1. ;
  1. ;
  1. SHOWTST ;
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRI,LRN,LRY,LRIC,X
  1. S DIR(0)="E"
  1. D DEMO
  1. S (LRN,LRI)=0
  1. F S LRI=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI)) Q:LRI<1!($G(LRY)) D
  1. . S LRIC=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRI,0)),U,4,6) Q:'($D(^LAB(60,+LRI,0))#2)
  1. . W !,?5,$P(^(0),U) S LRN=LRN+1
  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)
  1. . I LRN>18 D ^DIR S:$D(DIRUT) LRY=1 Q:$G(LRY) D DEMO S LRN=0
  1. ;
  1. S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRODT=$P(X,U,4),LRSN=$P(X,U,5)
  1. ;
  1. Q
  1. ;
  1. ;
  1. DEMO W !,PNM,?50,SSN
  1. W !,"TESTS ON ACCESSION: ",LRACN,?40,"UID: ",LRUID
  1. Q
  1. ;
  1. ;
  1. SET ;
  1. S LRNOW=$$NOW^XLFDT
  1. S LRLLOC=$P(^LRO(69,LRODT,1,LRSN,0),U,7)
  1. ;
  1. N II,X,LRI,LRSTATUS,OCXTRACE,ORIFN,ORSTS,LRMERGSO,LRORSTAT,LR7DONE
  1. S:$G(LRDBUG) OCXTRACE=1
  1. ;LR*5.2*527: SET^LRTSTOUT might be called from other routines
  1. I '$G(LRORDTST),$G(LRAA)]"",$G(LRAD)]"",$G(LRAN)]"" D
  1. . Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
  1. . ;make sure same patient
  1. . Q:+^LRO(68,LRAA,1,LRAD,1,LRAN,0)'=+^LRO(69,LRODT,1,LRSN,0)
  1. . ;LRORDTST=ordered test
  1. . S LRORDTST=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0)),U,9)
  1. ;LR*5.2*527 end
  1. S LRI=0
  1. F S LRI=$O(^LRO(69,LRODT,1,LRSN,2,LRI)) Q:LRI<1 I $D(^(LRI,0))#2 D
  1. . ;LR*5.2*527: if don't have ordered test, is current test in file 63
  1. . I '$G(LRORDTST),LRTSTS'=+^LRO(69,LRODT,1,LRSN,2,LRI,0) Q
  1. . ;checking for ordered test or component of ordered test (i.e. panel)
  1. . I $G(LRORDTST),LRTSTS'=+^LRO(69,LRODT,1,LRSN,2,LRI,0),LRORDTST'=+^LRO(69,LRODT,1,LRSN,2,LRI,0) Q
  1. . ;Already canceled = if 11th piece is not null
  1. . Q:$P(^LRO(69,LRODT,1,LRSN,2,LRI,0),U,11) S ORIFN=$P(^(0),U,7),(LRORSTAT,LR7DONE)=0
  1. . S (LRSTATUS,II(LRTSTS))=""
  1. . ;LR*5.2*566: LRCOMX new'd at ZAP^LR7OMERG
  1. . I '$D(LRCOMX(LRODT,LRSN,LRI,1)) D
  1. . . S X=1+$O(^LRO(69,LRODT,1,LRSN,2,LRI,1.1,"A"),-1),X(1)=$P($G(^(0)),U,4)
  1. . . ;LR*5.2*527 note: If a panel component is being canceled, the comments
  1. . . ; are filed at both the panel and component levels so that
  1. . . ; the comments display in reports.
  1. . . 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
  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")
  1. . . S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,0)="^^"_X_"^"_X(1)_"^"_DT
  1. . . S LRCOMX(LRODT,LRSN,LRI,1)=""
  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.
  1. . . Q:'$G(LRSOF) ;same order flag not been set
  1. . . I '$D(LRCOMX(LRODT,LRSN,LRI,2)) D
  1. . . . S X=X+1,X(1)=X(1)+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")
  1. . . . S ^LRO(69,LRODT,1,LRSN,2,LRI,1.1,0)="^^"_X_"^"_X(1)_"^"_DT
  1. . . . S LRCOMX(LRODT,LRSN,LRI,2)=""
  1. . . S LRMERGSO=1,LRMSTATI=6 ;indicate that a same order merge occurred & we want to keep #100 order
  1. . ;LR*5.2*527: Check order status if deleting panel component
  1. . ;LR*5.2*541: ... if patient is in the PATIENT (#2) file
  1. . ; (variable LRDPF).
  1. . I '$G(LRMERG),$G(LRORDTST),LRTSTS'=LRORDTST,$G(LRDPF)=2 D
  1. . . S LR7DONE=1
  1. . . S LRORSTAT=$$OR(LRORDTST,LRTSTS,ORIFN)
  1. . . ;don't update status if any pending tests
  1. . . Q:'LRORSTAT
  1. . . I '$G(ORIFN),'$D(II) Q
  1. . . D NEW^LR7OB1(LRODT,LRSN,$S(LRORSTAT=1:"SC",1:"OC"),$G(LRNATURE),.II,LRSTATUS)
  1. . . K ^TMP("LR",$J,"PANEL")
  1. . . ;LR*5.2*527 end
  1. . I 'LR7DONE,$G(ORIFN),$D(II) D NEW^LR7OB1(LRODT,LRSN,$S($G(LRMSTATI)=""!($G(LRMSTATI)=1):"OC",1:"SC"),$G(LRNATURE),.II,LRSTATUS)
  1. . ;Keep ^LR7OB1 call before ^^ update to status/DUZ in File #69 (below); see warning in 69^LR7OB69:
  1. . ;LR*5.2*527 added below:
  1. . I LR7DONE D
  1. . . ;only set canceled status in file 69 if everything on ordered test is canceled
  1. . . I LRORSTAT=2 D Q
  1. . . . S $P(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",9)="CA",$P(^(0),U,10)="L",$P(^(0),U,11)=DUZ
  1. . . ;if a panel and components broken out, set canceled status for each canceled component
  1. . . I +^LRO(69,LRODT,1,LRSN,2,LRI,0)=LRTSTS D
  1. . . . S $P(^LRO(69,LRODT,1,LRSN,2,LRI,0),"^",9)="CA",$P(^(0),U,10)="L",$P(^(0),U,11)=DUZ
  1. . ;LR*5.2*527 end
  1. . 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
  1. . S:$D(^LRO(69,LRODT,1,LRSN,"PCE")) ^LRO(69,"AE",DUZ,LRODT,LRSN,LRI)=""
  1. . ;LR*5.2*566: Do not kill LRMERGSO and LRSOF
  1. . K II
  1. ;
  1. K ORIFN,ORSTS
  1. ;
  1. 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
  1. . S LROWDT=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,3) I LROWDT,LROWDT'=LRAD D ROL Q
  1. . S LROWDT=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,9)) I LROWDT D ROL
  1. ;
  1. I $G(LRIDT),$G(LRSS)'="",LRCCOM'="",$G(^LR(LRDFN,LRSS,LRIDT,0)) D
  1. . D UPD63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM)
  1. . I '$D(^LRO(68,LRAA,1,LRAD,1,"AD",DT,LRAN)) D XREF^LRVER3A
  1. ;
  1. ; Update status of test in file #63 ORUT node.
  1. ; Set reporting site in file #63.
  1. I $G(LRIDT),$G(LRSS)'="" D
  1. . D ORUT
  1. . D SETRL^LRVERA(LRDFN,LRSS,LRIDT,DUZ(2))
  1. ;
  1. ; Put in list to check for auto download.
  1. ; Check if LEDI specimen and notify collecting facility
  1. I $G(LRAA),$G(LRAD),$G(LRAN),$D(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)) D
  1. . D EN^LA7ADL($P(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),"^"))
  1. . ;I $P(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),"^",3) D LEDI ;ccr_6164n
  1. ;
  1. Q
  1. ;
  1. OR(LRORDTST,LRTSTS,ORIFN) ;evaluate overall status of order
  1. ;LR*5.2*527 added this section
  1. N LRXSN,LRXSTR,LRXPEND,LRXRESULT,LRXSTATUS
  1. ;AX8^LR7OB3 is called downstream from NEW^LR7OB1 and
  1. ;refers to ^TMP("LR",$J,"PANEL" to determine whether a panel
  1. ;is canceled.
  1. ;The kill below is not necessary, but adding as a safeguard.
  1. K ^TMP("LR",$J,"PANEL")
  1. ;Check all tests for this CPRS order number
  1. S (LRXSN,LRXPEND,LRXRESULT,LRXSTATUS)=0
  1. ;if any pending components within panel, stop evaluating
  1. F S LRXSN=$O(^LRO(69,LRODT,1,LRSN,2,LRXSN)) Q:'LRXSN Q:LRXPEND D
  1. . S LRXSTR=$G(^LRO(69,LRODT,1,LRSN,2,LRXSN,0))
  1. . ;This test has a different CPRS order number.
  1. . Q:$P(LRXSTR,U,7)'=ORIFN
  1. . ;don't evaluate test currently being deleted
  1. . ;The file 68 status will be updated later.
  1. . Q:+LRXSTR=LRTSTS
  1. . N LRXAA,LRXAD,LRXAN
  1. . S LRXAA=$P(LRXSTR,U,4),LRXAD=$P(LRXSTR,U,3),LRXAN=$P(LRXSTR,U,5)
  1. . ;This test has not been accessioned, possibly because
  1. . ;the components have been.
  1. . Q:LRXAA=""
  1. . ;Panels which "explode" into other panels might not be subscripted
  1. . ;in file 68.
  1. . Q:'$D(^LRO(68,LRXAA,1,LRXAD,1,LRXAN,4,+LRXSTR,0))
  1. . I $P($G(^LRO(68,LRXAA,1,LRXAD,1,LRXAN,4,+LRXSTR,0)),U,5)="" S LRXPEND=1 Q
  1. . ;Continue to check for pending panel components
  1. . ;Due to site requests, panel is marked as complete if any components are verified
  1. . ;so that the panel will not display on the "Incomplete Test Status Report".
  1. . N LRX68TST
  1. . S LRX68TST=0
  1. . F S LRX68TST=$O(^LRO(68,LRXAA,1,LRXAD,1,LRXAN,4,LRX68TST)) Q:'LRX68TST Q:LRXPEND D
  1. . . S LRXSTR=$G(^LRO(68,LRXAA,1,LRXAD,1,LRXAN,4,LRX68TST,0))
  1. . . Q:$P(LRXSTR,U,9)'=LRORDTST
  1. . . Q:LRX68TST=LRTSTS
  1. . . I $P(LRXSTR,U,5)="" S LRXPEND=1 Q
  1. . . ;This test contains a result.
  1. . . I $P(LRXSTR,U,6)="" S LRXRESULT=1
  1. ;If there are any pending tests left on the order, do not call LR7OB1
  1. ;If no pending tests and any results, update to complete
  1. ;If no pending tests and no results, update to discontinued.
  1. S LRXSTATUS=$S(LRXPEND:0,LRXRESULT:1,1:2)
  1. S ^TMP("LR",$J,"PANEL",ORIFN)=LRXSTATUS
  1. Q LRXSTATUS
  1. ;
  1. ROL ;
  1. Q:+$G(^LRO(68,LRAA,1,LROWDT,1,LRAN,0))'=LRDFN Q:'($D(^(4,LRTSTS,0))#2)
  1. 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")
  1. Q
  1. ;
  1. ;
  1. LRACC ;
  1. K LRAN
  1. S LREND=0,LREXMPT=1 D ^LRWU4 K LREXMPT
  1. Q:'$G(LRAA)!('$G(LRAN))!('($D(^LRO(68,LRAA,0))#2))
  1. S DA(2)=LRAA,DA(1)=LRAD,LRSS=$P(^LRO(68,LRAA,0),U,2)
  1. I LRSS="" S LRAN=0,LRNOP=1 W !?5,"No Subscript for this Accession Area ",!!
  1. Q
  1. ;
  1. ;
  1. LREND ;
  1. S LREND=1
  1. Q
  1. ;
  1. ;
  1. UNLOCK ;
  1. I +$G(LRDFN),$G(LRSS)'="",+$G(LRIDT) L -^LR(LRDFN,LRSS,LRIDT)
  1. I +$G(LRAA),+$G(LRAD),+$G(LRAN) L -^LRO(68,LRAA,1,LRAD,1,LRAN)
  1. ;
  1. Q
  1. ;
  1. ;
  1. EXIT ;
  1. K LRSCNX,LREND,LRNOECHO,LRACN,LRLABRV,LRNOW
  1. ;
  1. END ;
  1. K LRCCOM0,LRCCOM1,LRCCOMX,LRI,LRL,LRNATURE,LRNOP,LRSCN,LRMSTATI,LRORDTST,LROWDT,LRPRAC,LRTSTS,LRUID
  1. K Q9,LRXX,DIR,LRCOM,LRAGE,DI,LRCTST,LRACN,LRACN0,LRDOC,LRLL,LRNOW
  1. K LROD0,LROD1,LROD3,LROOS,LROS,LROSD,LROT,LRROD,LRTT,X4
  1. D KVA^VADPT,END^LRTSTJAM,V^LRU
  1. Q
  1. ;
  1. ;
  1. FX2 ;
  1. S LREND=0,(LRCOM,LRCCOM1)=""
  1. I LRDPF=2,$G(LRNATURE)="" D DC^LROR6() I $G(LRNATURE)="-1" W !!,$C(7),"Nothing Changed",! S LREND=1 Q
  1. I '$D(LRLABKY) D FX3 Q
  1. ;
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1. S DIR(0)="62.5,5",DIR("A")="Select NP comment Lab Description screen"
  1. S DIR("?",1)="The default expansion screens are GENERAL, ORDER and LAB"
  1. S DIR("?",2)="You may select an additional lab description expansion screen"
  1. S DIR("?",3)="which will be used to expand your NP reason."
  1. S DIR("?")="Press return to only use these default screens"
  1. ;
  1. K LRNOECHO
  1. S:$G(LRSCN)="" LRSCN="AKL"
  1. W !
  1. D ^DIR
  1. I $D(DUOUT)!($D(DTOUT)) S LREND=1 Q
  1. I Y'="" S LRSCN=LRSCN_Y
  1. K X,Y
  1. ;
  1. F D FX3 Q:LREND!($G(LRCCOM)'="")
  1. Q
  1. ;
  1. ;
  1. FX3 ;
  1. N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRL,LRY
  1. S LRL=52,LREND=0
  1. S DIR("A")=$S('$D(LRLABKY):"Reason for Cancel",1:"Not Perform Reason")
  1. I $G(LRXX)'="" S DIR("B")=$G(LRXX)
  1. S DIR(0)="F^1:"_LRL_"^"
  1. W !
  1. D ^DIR
  1. I $D(DUOUT)!($D(DTOUT)) S LREND=1 Q
  1. S LRY=Y
  1. ;
  1. I LREND Q
  1. I $D(LRLABKY) D
  1. . N LRSAV S LRSAV=LRSCN
  1. . S (LRXX,X)=LRY,Q9="1,"_LRL_","_LRSCN D COM^LRNUM S LRSCN=LRSAV
  1. . I $G(X)="" Q
  1. . I $E(X,$L(X))=" " S X=$E(X,1,($L(X)-1))
  1. . S LRY=X
  1. S (LRCCOM,LRCCOMX)=LRY
  1. I '$D(LRLABKY) W !,"("_LRCCOM_")"
  1. K DIR
  1. S DIR(0)="Y",DIR("A")="Satisfactory Comment",DIR("B")="Yes"
  1. D ^DIR
  1. I $D(DIRUT) S LREND=1 Q
  1. I Y=1 S LRCCOM=$E($S('$D(LRLABKY):"*Floor Cancel Reason: ",1:"*NP Reason: ")_LRCCOM,1,68)
  1. E S (LRCCOM,LRCCOMX)=""
  1. Q
  1. ;
  1. ;
  1. UPD63(LRDFN,LRSS,LRIDT,LRTNM,LRCCOM) ; Update file #63 with comment reflecting dispostion.
  1. ;
  1. N FDA,LRCCOMO,LRDIE,LRFN,LRNOECHO,LRY
  1. ;
  1. S:'$G(LRNOW) LRNOW=$$NOW^XLFDT
  1. S LRNOECHO=1
  1. S LRCCOMO=$E("*"_LRTNM_$S($G(LRMERG):" Merged: ",'$D(LRLABKY):" Floor Canceled: ",1:" Not Performed: ")_$$FMTE^XLFDT(LRNOW,"1FMZ")_" by "_DUZ,1,68)
  1. ;
  1. 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:"")
  1. I LRSS="MI" D Q
  1. . S FDA(1,LRFN,LRIDT_","_LRDFN_",",.99)=LRCCOMO
  1. . D FILE^DIE("","FDA(1)","LRDIE(1)")
  1. . K FDA(1),LRDIE(1)
  1. ;
  1. F LRY=LRCCOMO,LRCCOM D
  1. . S FDA(1,LRFN,"+1,"_LRIDT_","_LRDFN_",",.01)=LRY
  1. . I $D(FDA(1)) D UPDATE^DIE("","FDA(1)","","LRDIE(1)")
  1. . K FDA(1),LRDIE(1)
  1. D CLEAN^DILF
  1. Q
  1. ;
  1. ;
  1. CLNPENDG ; Remove pending and other info from Lab test when set to not performed
  1. N LRIFN
  1. S LRIFN=$P($G(^LAB(60,LRTSTS,.2)),U)
  1. I LRIFN'="",LRSS="CH" D
  1. . I $P($G(^LR(LRDFN,LRSS,LRIDT,LRIFN)),U)="pending" K ^LR(LRDFN,LRSS,LRIDT,LRIFN) Q
  1. . I $D(^LR(LRDFN,LRSS,LRIDT,LRIFN)),$P(^LR(LRDFN,LRSS,LRIDT,LRIFN),U)="" K ^LR(LRDFN,LRSS,LRIDT,LRIFN) Q
  1. Q
  1. ;
  1. ;
  1. ORUT ; Update ORUT node in file #63 with this disposition
  1. N DIERR,LRDIE,LRFDA,LR60,LR60P,LR64,LR64P,LRDISPO,LRFN,LRIEN
  1. ;
  1. S LRDISPO="",LR60=LRTSTS,(LR64,LR64P,LRIEN)=0
  1. S LR64=$P($G(^LAB(60,LR60,64)),"^")
  1. ;
  1. S LR60P=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LR60,0)),"^",9)
  1. I LR60P S LR64P=$P($G(^LAB(60,LR60P,64)),"^")
  1. I LR64<1,LR64P<1 Q
  1. ;
  1. ; Check to see if NLT in ordered test multiple, check test or parent
  1. S LR64(0)=$$GET1^DIQ(64,LR64_",",1),LRIEN=0
  1. I LR64(0) S LRIEN=$O(^LR(LRDFN,LRSS,LRIDT,"ORUT","B",LR64(0),0))
  1. I LRIEN S LRDISPO=$$FIND1^DIC(64.061,"","OQX","X","D","I $P(^(0),U,5)=""0123""")
  1. I 'LRIEN,LR64P D
  1. . S LR64P(0)=$$GET1^DIQ(64,LR64P_",",1)
  1. . I LR64P(0) S LRIEN=$O(^LR(LRDFN,LRSS,LRIDT,"ORUT","B",LR64P(0),0))
  1. . I LRIEN S LRDISPO=$$FIND1^DIC(64.061,"","OQX","A","D","I $P(^(0),U,5)=""0123""")
  1. I LRDISPO<1 Q
  1. ;
  1. S LRFN=$S(LRSS="CH":63.07,LRSS="MI":63.5,LRSS="SP":63.53,LRSS="CY":63.51,LRSS="EM":63.52,1:"")
  1. I LRFN<1 Q
  1. S LRIEN=LRIEN_","_LRIDT_","_LRDFN_","
  1. S LRFDA(63,LRFN,LRIEN,10)=LRDISPO
  1. S LRFDA(63,LRFN,LRIEN,11)=LRNOW
  1. S LRFDA(63,LRFN,LRIEN,12)=DUZ
  1. D FILE^DIE("","LRFDA(63)","LRDIE(63)")
  1. D CLEAN^DILF
  1. Q
  1. ;
  1. ;
  1. LEDICHK ; Add test to LROTA array if it is a LEDI accesison - added with ccr_6164n
  1. ;
  1. ; - When tests from an exploded panel are NP'ed, only send back one OBR with the ordered test,
  1. ; instead of one OBR for each individual test on a panel that was NP'ed.
  1. ; - When tests from an exploded panel are NP'ed, send back an OBX for each individual test
  1. ; that were NP'ed so the receiving system can determine which tests from the panel were NP'ed.
  1. ;
  1. ; Process flow:
  1. ; - After NP'ing a test (via SET^LRTSTOUT), calling routine should call LEDICHK^LRTSTOUT.
  1. ; - If it is a LEDI test, LEDICHK will add the NP'ed test to the LROTA array.
  1. ; - After all tests are finished being NP'ed, calling process will then call LEDISET^LRTSTOUT.
  1. ; - LEDISET will process LROTA array to send the LEDI messages.
  1. ;
  1. ;
  1. N LRORDTST,LRUID
  1. ;
  1. I '$P($G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),.3)),"^",3) Q ;Not a LEDI accession
  1. ;
  1. S LRUID=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,.3),"^")
  1. I LRUID="" Q
  1. S LRORDTST=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS,0),U,9)
  1. I 'LRORDTST S LRORDTST=LRTSTS
  1. S LROTA(LRUID,LRORDTST)=LRAA_U_LRAD_U_LRAN_U_LRDFN_U_LRSS_U_LRIDT_U_LRODT
  1. I LRORDTST'=LRTSTS D ;Send back OBX for this test, as it is part of panel
  1. . S LROTA(LRUID,LRORDTST,LRTSTS)=""
  1. ;
  1. ;
  1. Q
  1. ;
  1. ;
  1. LEDISET(LROTA) ; added with ccr_6164n
  1. ;
  1. ; Called with: LROTA = array with LEDI tests (passed by reference)
  1. ; LROTA(UID,ORDERED TEST IEN)=LRAA_U_LRAD_U_LRAN_U_LRDFN_U_LRSS_U_LRIDT_U_LRODT
  1. ; LROTA(LRUID,ORDERED TEST IEN,TEST BEING NP'ED)=""
  1. ;
  1. N LRORDTST,LRUID,LRX
  1. ;
  1. Q:'$D(LROTA)
  1. ;
  1. S LRUID=""
  1. F S LRUID=$O(LROTA(LRUID)) Q:LRUID="" D
  1. . S LRORDTST=0
  1. . F S LRORDTST=$O(LROTA(LRUID,LRORDTST)) Q:'LRORDTST D
  1. . . N LA7VDB,LRTSTS,LRX
  1. . . S LRX=$G(LROTA(LRUID,LRORDTST))
  1. . . S LA7VDB=""
  1. . . S LRTSTS=0
  1. . . F S LRTSTS=$O(LROTA(LRUID,LRORDTST,LRTSTS)) Q:'LRTSTS D
  1. . . . N LA7TREE,LRSB,LRY
  1. . . . D UNWIND^LA7ADL1(LRTSTS,9,LRTSTS)
  1. . . . S LRY=0
  1. . . . F S LRY=$O(LA7TREE(LRY)) Q:'LRY D
  1. . . . . S LRSB=$P($G(^LAB(60,LRY,.2)),U)
  1. . . . . I LRSB="" Q
  1. . . . . I $P(LRX,U,5)="CH" S LA7VDB(LRSB)=LRSB
  1. . . 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)
  1. ;
  1. Q
  1. ;
  1. ;
  1. LEDI(LRAA,LRAD,LRAN,LRDFN,LRSS,LRIDT,LRODT,LRORDTST,LA7VDB) ; Put accession in queue to send message back to collecting site.
  1. ;
  1. ; Made the following changes - ccr_6164n:
  1. ; - Added formal paramater list
  1. ; - Use parent test instead of individual NP'ed test (LRORDTST instead of LRTSTS)
  1. ; - Pass in LA7VDB array to SET^LA7VMSG call (so that an OBX can be generated when individual tests from a panel are NP'ed).
  1. ;
  1. ; Handle CH subscript tests
  1. I LRSS="CH" D Q
  1. . N LR64,LRORU3,LRTPN,LRTPNN
  1. . S LRORU3=^LRO(68,LRAA,1,LRAD,1,LRAN,.3),LR64=$P($G(^LAB(60,LRORDTST,64)),"^") Q:'LR64
  1. . S LRTPN=$$GET1^DIQ(64,LR64_",",.01),LRTPNN=$$GET1^DIQ(64,LR64_",",1)
  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")
  1. ;
  1. ; Handle the other subscripts - MI, SP, CY , EM.
  1. I LRSS?1(1"MI",1"SP",1"CY",1"EM") D MIAP^LA7VMSG(LRAA,LRAD,LRAN,LRORDTST,LRDFN,LRSS,LRIDT,LRODT)
  1. Q
  1. ;
  1. ;
  1. 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
  1. ; LRDFN = ien of entry in file #63
  1. ; LRSS = file #63 subscript
  1. ; LRIDT = file #63 inverse date/time of specimen
  1. ;
  1. ; Returns LRFLAG = flag indicating if results exist in file #63 for this test either verified or unverified.
  1. ; 0 = no existing result in file #63
  1. ; 1 = existing node, no result value
  1. ; 2 = existing node, result value exists
  1. ; 3 = result exists and accession verified
  1. ;
  1. N LA7TREE,LRFLAG,LRSB,LRX
  1. ;
  1. D UNWIND^LA7ADL1(LR60,9,LR60)
  1. S (LRFLAG,LRX)=0
  1. F S LRX=$O(LA7TREE(LRX)) Q:'LRX D
  1. . S LRSB=$P($P(^LAB(60,LRX,0),"^",5),";",2)
  1. . I LRSB="" Q
  1. . I '$D(^LR(LRDFN,LRSS,LRIDT,LRSB)) Q
  1. . I $P(^LR(LRDFN,LRSS,LRIDT,LRSB),"^")'="" D Q
  1. . . I $P(^LR(LRDFN,LRSS,LRIDT,LRSB),"^")="pending" Q
  1. . . I $P(^LR(LRDFN,LRSS,LRIDT,0),"^",3) S LRFLAG=3
  1. . . E S LRFLAG=2
  1. . S LRFLAG=1
  1. ;
  1. Q LRFLAG