LRVR3 ;DALOI/STAFF - LAB ROUTINE DATA VERIFICATION ;04/05/16 12:22
;;5.2;LAB SERVICE;**42,121,153,286,291,350,458,499**;Sep 27, 1994;Build 2
;
D V1
I $D(LRLOCKER)#2 L -@(LRLOCKER) K LRLOCKER
K LRSA,LRSB,LRNOVER,LRSBCOM,LRLKOK
; Leave LRVR3, back to LRVR2
Q
;
;
V1 ;
;
; Warn and prompt if it appears user is entering reference lab result and message came from auto instrument (UI type=1)
I $G(LRDUZ(2)),LRDUZ(2)'=DUZ(2),$P($G(^LAH(LRLL,1,LRSQ,0)),"^",12)=1,'$$UICHK Q
;
;
S LRTN=1
I $D(LRLOCKER)#2 L -@(LRLOCKER)
S LRLOCKER="^LR("_LRDFN_","""_LRSS_""","_LRIDT_")"
L +@(LRLOCKER):DILOCKTM
I '$T W !," This entry is being edited by someone else." Q
; LRNOVER set in LRVR2
K LRLKOK D LINK Q:'$D(LRLKOK) K LRLKOK D LKCHK Q:'$D(LRLKOK)
K LRSA,LRSB,LRSBCOM,LRSBEPR
;
; Calculate days back for delta check based on specimen collection date/time.
S LRTM60=$$LRTM60^LRVR(LRCDT)
;
S LRCMTDSP=$$CHKCDSP^LRVERA
N LRX
S LRX=1
F S LRX=$O(^LAH(LRLL,1,LRSQ,LRX)) Q:LRX<1 D
. S LRSB(LRX)=^LAH(LRLL,1,LRSQ,LRX)
. I $D(LRNOVER),$D(LRVTS(LRX)),$D(^TMP("LR",$J,"TMP",LRX)) S LRNOVER(LRX)=""
; Copy comments from LAH
S LRX=0
F S LRX=$O(^LAH(LRLL,1,LRSQ,1,LRX)) Q:LRX="" S LRSBCOM(LRX)=^(LRX)
;
; Copy filler id associated with each dataname from LAH.
M LRSBEPR=^LAH(LRLL,1,LRSQ,.1,"OBR","FID")
;
;
EDIT ;
I $D(^LAH(LRLL,1,LRSQ,0)) D
. N X
. S LREDIT=1
. F LRX=0,.1,.3 M X(LRX)=^LAH(LRLL,1,LRSQ,LRX)
. K ^LAH(LRLL,1,LRSQ),LRNUF
. F LRX=0,.1,.3 M ^LAH(LRLL,1,LRSQ,LRX)=X(LRX) K X(LRX)
. D ^LRVR4
. F LRX=1:0 S LRX=$O(LRSB(LRX)) Q:LRX<1 S ^LAH(LRLL,1,LRSQ,LRX)=LRSB(LRX)
I $O(^LAH(LRLL,1,LRSQ,1))<1 W !,"NO DATA TO APPROVE" Q
Q:$D(LRGVP)
;
N LRI
S LRI=1
F S LRI=$O(LRNOVER(LRI)) Q:LRI="" D
. N LRX,LRERR
. S LRX="Test Not Reviewed: "_$$GET1^DID(63.04,LRI,"","LABEL","","LRERR")
. I $G(LRERR("DIERR",1)) W !,"For DATANAME "_LRI_" - "_LRERR("DIERR",1,"TEXT",1) Q
. W !,LRX
. I $D(LRSB(LRI))#2 W " = "_$P(LRSB(LRI),U)_" "_$P(LRSB(LRI),U,2)
I $O(LRNOVER(0)) W !,"Have not been reviewed and have data. Not approved." QUIT
;
I '$P($G(LRLABKY),U) W !,$C(7),"ENTERED BUT NOT APPROVED" QUIT
;
N CNT S CNT=1
;
AGAIN ;
R !,"Approve for release by entering your initials: ",LRINI:DTIME
I $E(LRINI)="^"!(LRINI="") W !!?5,$C(7),"Nothing verified!" D READ Q
I LRINI'=LRUSI,$$UP^XLFSTR(LRINI)=$$UP^XLFSTR(LRUSI) S LRINI=LRUSI
I $S($E(LRINI)="?":1,LRINI'=LRUSI&(CNT<2):1,1:0) W !,$C(7),"Please enter your correct initials" S:$E(LRINI)="?" CNT=0 S CNT=CNT+1 G AGAIN
I LRINI'=LRUSI W !!?5,$C(7),"Nothing verified!" D READ Q
;
D V11
D ASKXQA^LRVER3
Q
;
;
V11 ; Still locked from V1 L ^LR(LRDFN,LRSS,LRIDT)
; Set filler id as external package reference for each data name
N LRCORECT,LRNOW,LRX
S (LRCORECT,LRX)=0,LRNOW=$$NOW^XLFDT
F S LRX=$O(^TMP("LR",$J,"TMP",LRX)) Q:LRX<1 I $D(LRVTS(LRX)),$D(LRSB(LRX)),$D(^(LRX)) D
. K ^LAH(LRLL,1,LRSQ,LRX)
. I $P(LRSB(LRX),"^")="" Q
. S $P(LRSB(LRX),U,6)=LRNOW
. S ^LR(LRDFN,LRSS,LRIDT,LRX)=LRSB(LRX)
. S:'$D(^LRO(68,"AC",LRDFN,LRIDT,LRX)) ^(LRX)="" I LRVF S ^(LRX)=""
. I $G(LRSBEPR(LRX))="" Q
. N LRDATA,LRSITE
. S LRSITE=$G(LRDUZ(2))
. I LRSITE="" S LRSITE=$P(LRSB(LRX),"^",9)
. S LRDATA(.01)=LRDFN_","_LRSS_","_LRIDT_","_LRX,LRDATA(.02)=4,LRDATA(1)=LRSBEPR(LRX)
. I LRSITE'="" S LRDATA(.03)=LRSITE_";DIC(4,"
. D SETREF^LRUEPR(LRDFN,LRDATA(.01),.LRDATA,1)
;
A3 ; Called from LRVRPOC, LRVRAR
;
; Set reporting site in file #63.
D SETRL^LRVERA(LRDFN,LRSS,LRIDT,DUZ(2))
;
I +LRDPF=2&($G(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT)) D
. D BAWRK^LRBEBA(LRODT,LRSN,1,.LRBEY,.LRBETST)
;
D VER^LRVER3A ;unlocked in LRVER
;
; Check for LEDI and return results
I $P($G(LRORU3),U,3),$O(LRSB(0)) D LRORU3^LRVER3
;
K LRSBCOM
D:$P(LRPARAM,U,14)&($P($G(^LRO(68,LRAA,0)),U,16)) LOOK^LRCAPV1
;
; Check for LEDI tests not reviewed
I $G(LRDUZ(2)),LRDUZ(2)'=DUZ(2),LRSS="CH",'$D(ZTQUEUED) D TNR
;
I +$O(^LAH(LRLL,1,LRSQ,1))<1 D ZAPALL(LRLL,LRSQ)
I $D(LRPRGSQ),'$D(ZTQUEUED) D
. W !,"Purge data from sequence number(s): "
. F I=0:0 S I=$O(LRPRGSQ(I)) Q:I<1 W " ",I
. S %=2 D YN^DICN Q:%'=1
. N LAIEN
. S LAIEN=0
. F S LAIEN=$O(LRPRGSQ(LAIEN)) Q:LAIEN<1 D ZAPALL(LRLL,LAIEN)
Q
;
;
ZAP ; from LRLLS3
D ZAPALL(LRLL,I)
Q
;
;
LINK ; Check and save link
D LKCHK Q:$D(LRLKOK)
S X=$S($D(^LRO(68,+$P(LRLK,U,3),1,+$P(LRLK,U,4),1,+$P(LRLK,U,5),0)):+^(0),1:"") G LINKOK:+X=LRDFN
S S1=PNM,S2=SSN,S3=LRDPF
;
W !,$C(7),"WARNING - NO MATCHING ACCESSION WAS FOUND."
W !,"You may need to Clear instrument/worklist data,"
W !,"or correctly identify the sample to the system."
;
I X S LRDPF=$P(^LR(X,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,PNM,?30,SSN,!,$C(7) S PNM=S1,SSN=S2,LRDPF=S3
K S1,S2,S3
Q:$D(LRGVP)
W !,"ARE YOU SURE THIS IS THE CORRECT DATA" S %=2 D YN^DICN Q:%'=1
;
LINKOK ;
K:$P(LRLK,U,5) ^LAH(LRLL,1,"C",+$P(LRLK,U,5),LRSQ)
S ^LAH(LRLL,1,"C",LRAN,LRSQ)="",$P(^LAH(LRLL,1,LRSQ,0),U,3,5)=LRAA_U_LRAD_U_LRAN,LRLKOK=1
Q
;
LKCHK S LRLK=$S($D(^LAH(LRLL,1,LRSQ,0)):^(0),1:"") I $P(LRLK,U,3)=LRAA&($P(LRLK,U,4)=LRAD)&($P(LRLK,U,5)=LRAN) S LRLKOK=1
Q
;
;
ZAP2 ;Clear ^LAH(
D ZAPALL(LRLL,I)
Q
;
;
ZAPALL(LRLL,LAIEN) ;Clean up
N I,NODE,SEG,SEGID,SUB
Q:'$G(LRLL)!('$G(LAIEN))
;
S NODE=$G(^LAH(LRLL,1,LAIEN,0))
K ^LAH(LRLL,1,"AUTOREL",LAIEN)
K ^LAH(LRLL,1,"B",+$P(NODE,U)_";"_+$P(NODE,U,2),LAIEN)
K ^LAH(LRLL,1,"C",+$P(NODE,U,5),LAIEN)
K ^LAH(LRLL,1,"D",+$P(NODE,U,6),LAIEN)
K ^LAH(LRLL,1,"E",+$P(NODE,U,8),LAIEN)
;
S NODE("U")=$P($G(^LAH(LRLL,1,LAIEN,.3)),U)
I NODE("U")'="" D
. K ^LAH(LRLL,1,"AUTOREL-UID",NODE("U"),LAIEN)
. K ^LAH(LRLL,1,"U",NODE("U"),LAIEN)
. S I=0
. F S I=$O(^LAH("LA7 AMENDED RESULTS",NODE("U"),I)) Q:'I D
. . K ^LAH("LA7 AMENDED RESULTS",NODE("U"),I,LRLL,LAIEN)
;
S SEG=""
F S SEG=$O(^LAH(LRLL,1,LAIEN,.1,SEG)) Q:SEG="" D
. S SEGID=""
. F S SEGID=$O(^LAH(LRLL,1,LAIEN,.1,SEG,SEGID)) Q:SEGID="" D
. . S SUB=$P($G(^LAH(LRLL,1,LAIEN,.1,SEG,SEGID)),U)
. . I SUB'="" K ^LAH(LRLL,1,"A"_SEGID,SUB,LAIEN)
;
K ^LAH(LRLL,1,LAIEN)
;
; Reset counter if loadlist is clear.
I '$O(^LAH(LRLL,1,0)) D
. L +^LAH(LRLL):DILOCKTM Q:'$T
. S ^LAH(LRLL)=0
. L -^LAH(LRLL)
;
Q
;
;
TNR ; List tests not reviewed and ask if user wants to delete.
;
N DIR,DIROUT,DIRUT,DUOUT,LR60,I,X,Y
;
; Check if these results have already been verified
S I=1
F S I=$O(^LAH(LRLL,1,LRSQ,I)) Q:'I D
. S X=^LAH(LRLL,1,LRSQ,I)
. I $P(X,"^")=$P($G(^LR(LRDFN,LRSS,LRIDT,I)),"^") K ^LAH(LRLL,1,LRSQ,I)
;
; Quit if no unreviewed results
I +$O(^LAH(LRLL,1,LRSQ,1))'>1 Q
;
W !,"Test(s) Not Reviewed:",!
S I=1
F S I=$O(^LAH(LRLL,1,LRSQ,I)) Q:'I D
. S X=^LAH(LRLL,1,LRSQ,I)
. S LR60=+$O(^LAB(60,"C","CH;"_I_";1",0))
. I LR60 W $$GET1^DIQ(60,LR60_",",.01)
. E W $$GET1^DID(63.04,I,"","LABEL")
. W " = "_$P(X,"^")_" "_$P(X,"^",2)_" "_$P($P(X,"^",5),"!",7),!
;
S DIR(0)="Y",DIR("A")="Purge these test results",DIR("B")="NO"
S DIR("?",1)="Answer 'NO' if you want to keep these results for later verification."
S DIR("?",2)="You may need to add these tests to the loadlist profile you are using"
S DIR("?")="and/or add these tests to the accession you are verifying."
D ^DIR Q:$D(DIRUT)
;
I Y=1 D ZAPALL(LRLL,LRSQ)
Q
;
;
READ ;
N X W !!,"Press ENTER or RETURN to continue: " R X:DTIME
Q
;
;
UICHK() ; Confirm that user wants to process UI type results as reference lab results.
;
N DIR,DIRUT,DTOUT,DUOUT,LROK,X,Y
;
S LROK=0
S DIR(0)="YO",DIR("B")="NO"
S DIR("A",1)="These results were received via an automated instrument interface and you've"
S DIR("A",2)="indicated you're processing reference lab results. If you continue processing"
S DIR("A",3)="then only units and reference ranges received from the instrument will be"
S DIR("A",4)="stored. This could result in the report lacking units, reference ranges,"
S DIR("A",5)="abnormality flags and designating an incorrect performing lab."
S DIR("A",6)=" "
S DIR("A",7)="Contact your local LIM or Lab ADPAC with any questions."
S DIR("A",8)=" "
S DIR("A")="Sure you want to continue"
D ^DIR
I Y=1 S LROK=1
;
Q LROK
;
;
LRNIGHT ; Entry point from LRNIGHT to clean up LAH global for selected entries.
;
;ZEXCEPT: ZTQUEUED,ZTREQ,ZTSTOP
;
N I,LRCNT,LRCUTOFFDT,LRDAYSKEEP,LRERROR,LRI,LRINST,LRISQN,LRLIST,LRLL,LRROOT,X
S DT=$$DT^XLFDT
;
; If rollover has not completed then requeue task 5 minutes in future.
I +$G(^LAB(69.9,1,"RO"))'=(+$H) D Q
. I $D(ZTQUEUED) S ZTREQ=$$HADD^XLFDT($H,0,0,5,0) Q
. W !!,"Lab Rollover has not completed as of "_$$HTE^XLFDT($H,"1M")_" ... Aborting."
;
D GETLST^XPAR(.LRLIST,"PKG","LR WORKLIST DATA CLEANUP",,.LRERROR)
I '$D(LRLIST) Q
;
S LRI=0
F S LRI=$O(LRLIST(LRI)) Q:'LRI D Q:$G(ZTSTOP)
. S LRLL=$P(LRLIST(LRI),U),LRDAYSKEEP=$P(LRLIST(LRI),U,2),LRCUTOFFDT=DT
. I LRDAYSKEEP>0 S LRCUTOFFDT=$$FMADD^XLFDT(DT,-LRDAYSKEEP)
. I '$D(^LAH(LRLL)) Q
. I $$S^%ZTLOAD("Processing LRLL: "_LRLL) S ZTSTOP=1 Q
. L +^LAH(LRLL):DILOCKTM+60 Q:'$T
. S (LRCNT,LRISQN)=0
. F S LRISQN=$O(^LAH(LRLL,1,LRISQN)) Q:'LRISQN D Q:$G(ZTSTOP)
. . S LRCNT=LRCNT+1
. . I '(LRCNT#100) I $$S^%ZTLOAD("Processing LRLL: "_LRLL_" LRISQN: "_LRISQN) S ZTSTOP=1 Q
. . I '$P($G(^LAH(LRLL,1,LRISQN,0)),"^",11) D UPDT^LAGEN(LRLL,LRISQN) Q ; No date, put current d/t, skip
. . I $P($G(^LAH(LRLL,1,LRISQN,0)),"^",11)'<LRCUTOFFDT Q ; Skip - Keep
. . S LRINST=LRLL,I=LRISQN
. . N LRLL,LRISQN,LRCUTOFFDT
. . D ZAPALL(LRINST,I)
. L -^LAH(LRLL)
;
D CHECKARI
;
I $D(ZTQUEUED) S ZTREQ="@"
;
Q
;
;
CHECKARI ; Check amended result index for orphans.
;
;ZEXCEPT: ZTQUEUED
;
N LRCNT,LRI,LRISQN,LRLL,LRROOT
;
I '$D(ZTQUEUED) W !!,"Checking LAH global Amended Result Index for Orphans",!
S LRROOT="^LAH(""LA7 AMENDED RESULTS"")",LRCNT=0
F S LRROOT=$Q(@LRROOT) Q:LRROOT="" Q:$QS(LRROOT,1)'="LA7 AMENDED RESULTS" D
. S LRI=$QS(LRROOT,3),LRLL=$QS(LRROOT,4),LRISQN=$QS(LRROOT,5)
. I $D(^LAH(LRLL,1,LRISQN,LRI)) Q
. I '$D(ZTQUEUED) W !,"Deleting index: ",LRROOT," = ",@LRROOT
. K @LRROOT S LRCNT=LRCNT+1
;
I '$D(ZTQUEUED) W !,$S(LRCNT:LRCNT,1:"No")," indexes found needing deletion."
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRVR3 10374 printed Jan 18, 2025@03:23:22 Page 2
LRVR3 ;DALOI/STAFF - LAB ROUTINE DATA VERIFICATION ;04/05/16 12:22
+1 ;;5.2;LAB SERVICE;**42,121,153,286,291,350,458,499**;Sep 27, 1994;Build 2
+2 ;
+3 DO V1
+4 IF $DATA(LRLOCKER)#2
LOCK -@(LRLOCKER)
KILL LRLOCKER
+5 KILL LRSA,LRSB,LRNOVER,LRSBCOM,LRLKOK
+6 ; Leave LRVR3, back to LRVR2
+7 QUIT
+8 ;
+9 ;
V1 ;
+1 ;
+2 ; Warn and prompt if it appears user is entering reference lab result and message came from auto instrument (UI type=1)
+3 IF $GET(LRDUZ(2))
IF LRDUZ(2)'=DUZ(2)
IF $PIECE($GET(^LAH(LRLL,1,LRSQ,0)),"^",12)=1
IF '$$UICHK
QUIT
+4 ;
+5 ;
+6 SET LRTN=1
+7 IF $DATA(LRLOCKER)#2
LOCK -@(LRLOCKER)
+8 SET LRLOCKER="^LR("_LRDFN_","""_LRSS_""","_LRIDT_")"
+9 LOCK +@(LRLOCKER):DILOCKTM
+10 IF '$TEST
WRITE !," This entry is being edited by someone else."
QUIT
+11 ; LRNOVER set in LRVR2
+12 KILL LRLKOK
DO LINK
if '$DATA(LRLKOK)
QUIT
KILL LRLKOK
DO LKCHK
if '$DATA(LRLKOK)
QUIT
+13 KILL LRSA,LRSB,LRSBCOM,LRSBEPR
+14 ;
+15 ; Calculate days back for delta check based on specimen collection date/time.
+16 SET LRTM60=$$LRTM60^LRVR(LRCDT)
+17 ;
+18 SET LRCMTDSP=$$CHKCDSP^LRVERA
+19 NEW LRX
+20 SET LRX=1
+21 FOR
SET LRX=$ORDER(^LAH(LRLL,1,LRSQ,LRX))
if LRX<1
QUIT
Begin DoDot:1
+22 SET LRSB(LRX)=^LAH(LRLL,1,LRSQ,LRX)
+23 IF $DATA(LRNOVER)
IF $DATA(LRVTS(LRX))
IF $DATA(^TMP("LR",$JOB,"TMP",LRX))
SET LRNOVER(LRX)=""
End DoDot:1
+24 ; Copy comments from LAH
+25 SET LRX=0
+26 FOR
SET LRX=$ORDER(^LAH(LRLL,1,LRSQ,1,LRX))
if LRX=""
QUIT
SET LRSBCOM(LRX)=^(LRX)
+27 ;
+28 ; Copy filler id associated with each dataname from LAH.
+29 MERGE LRSBEPR=^LAH(LRLL,1,LRSQ,.1,"OBR","FID")
+30 ;
+31 ;
EDIT ;
+1 IF $DATA(^LAH(LRLL,1,LRSQ,0))
Begin DoDot:1
+2 NEW X
+3 SET LREDIT=1
+4 FOR LRX=0,.1,.3
MERGE X(LRX)=^LAH(LRLL,1,LRSQ,LRX)
+5 KILL ^LAH(LRLL,1,LRSQ),LRNUF
+6 FOR LRX=0,.1,.3
MERGE ^LAH(LRLL,1,LRSQ,LRX)=X(LRX)
KILL X(LRX)
+7 DO ^LRVR4
+8 FOR LRX=1:0
SET LRX=$ORDER(LRSB(LRX))
if LRX<1
QUIT
SET ^LAH(LRLL,1,LRSQ,LRX)=LRSB(LRX)
End DoDot:1
+9 IF $ORDER(^LAH(LRLL,1,LRSQ,1))<1
WRITE !,"NO DATA TO APPROVE"
QUIT
+10 if $DATA(LRGVP)
QUIT
+11 ;
+12 NEW LRI
+13 SET LRI=1
+14 FOR
SET LRI=$ORDER(LRNOVER(LRI))
if LRI=""
QUIT
Begin DoDot:1
+15 NEW LRX,LRERR
+16 SET LRX="Test Not Reviewed: "_$$GET1^DID(63.04,LRI,"","LABEL","","LRERR")
+17 IF $GET(LRERR("DIERR",1))
WRITE !,"For DATANAME "_LRI_" - "_LRERR("DIERR",1,"TEXT",1)
QUIT
+18 WRITE !,LRX
+19 IF $DATA(LRSB(LRI))#2
WRITE " = "_$PIECE(LRSB(LRI),U)_" "_$PIECE(LRSB(LRI),U,2)
End DoDot:1
+20 IF $ORDER(LRNOVER(0))
WRITE !,"Have not been reviewed and have data. Not approved."
QUIT
+21 ;
+22 IF '$PIECE($GET(LRLABKY),U)
WRITE !,$CHAR(7),"ENTERED BUT NOT APPROVED"
QUIT
+23 ;
+24 NEW CNT
SET CNT=1
+25 ;
AGAIN ;
+1 READ !,"Approve for release by entering your initials: ",LRINI:DTIME
+2 IF $EXTRACT(LRINI)="^"!(LRINI="")
WRITE !!?5,$CHAR(7),"Nothing verified!"
DO READ
QUIT
+3 IF LRINI'=LRUSI
IF $$UP^XLFSTR(LRINI)=$$UP^XLFSTR(LRUSI)
SET LRINI=LRUSI
+4 IF $SELECT($EXTRACT(LRINI)="?":1,LRINI'=LRUSI&(CNT<2):1,1:0)
WRITE !,$CHAR(7),"Please enter your correct initials"
if $EXTRACT(LRINI)="?"
SET CNT=0
SET CNT=CNT+1
GOTO AGAIN
+5 IF LRINI'=LRUSI
WRITE !!?5,$CHAR(7),"Nothing verified!"
DO READ
QUIT
+6 ;
+7 DO V11
+8 DO ASKXQA^LRVER3
+9 QUIT
+10 ;
+11 ;
V11 ; Still locked from V1 L ^LR(LRDFN,LRSS,LRIDT)
+1 ; Set filler id as external package reference for each data name
+2 NEW LRCORECT,LRNOW,LRX
+3 SET (LRCORECT,LRX)=0
SET LRNOW=$$NOW^XLFDT
+4 FOR
SET LRX=$ORDER(^TMP("LR",$JOB,"TMP",LRX))
if LRX<1
QUIT
IF $DATA(LRVTS(LRX))
IF $DATA(LRSB(LRX))
IF $DATA(^(LRX))
Begin DoDot:1
+5 KILL ^LAH(LRLL,1,LRSQ,LRX)
+6 IF $PIECE(LRSB(LRX),"^")=""
QUIT
+7 SET $PIECE(LRSB(LRX),U,6)=LRNOW
+8 SET ^LR(LRDFN,LRSS,LRIDT,LRX)=LRSB(LRX)
+9 if '$DATA(^LRO(68,"AC",LRDFN,LRIDT,LRX))
SET ^(LRX)=""
IF LRVF
SET ^(LRX)=""
+10 IF $GET(LRSBEPR(LRX))=""
QUIT
+11 NEW LRDATA,LRSITE
+12 SET LRSITE=$GET(LRDUZ(2))
+13 IF LRSITE=""
SET LRSITE=$PIECE(LRSB(LRX),"^",9)
+14 SET LRDATA(.01)=LRDFN_","_LRSS_","_LRIDT_","_LRX
SET LRDATA(.02)=4
SET LRDATA(1)=LRSBEPR(LRX)
+15 IF LRSITE'=""
SET LRDATA(.03)=LRSITE_";DIC(4,"
+16 DO SETREF^LRUEPR(LRDFN,LRDATA(.01),.LRDATA,1)
End DoDot:1
+17 ;
A3 ; Called from LRVRPOC, LRVRAR
+1 ;
+2 ; Set reporting site in file #63.
+3 DO SETRL^LRVERA(LRDFN,LRSS,LRIDT,DUZ(2))
+4 ;
+5 IF +LRDPF=2&($GET(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT))
Begin DoDot:1
+6 DO BAWRK^LRBEBA(LRODT,LRSN,1,.LRBEY,.LRBETST)
End DoDot:1
+7 ;
+8 ;unlocked in LRVER
DO VER^LRVER3A
+9 ;
+10 ; Check for LEDI and return results
+11 IF $PIECE($GET(LRORU3),U,3)
IF $ORDER(LRSB(0))
DO LRORU3^LRVER3
+12 ;
+13 KILL LRSBCOM
+14 if $PIECE(LRPARAM,U,14)&($PIECE($GET(^LRO(68,LRAA,0)),U,16))
DO LOOK^LRCAPV1
+15 ;
+16 ; Check for LEDI tests not reviewed
+17 IF $GET(LRDUZ(2))
IF LRDUZ(2)'=DUZ(2)
IF LRSS="CH"
IF '$DATA(ZTQUEUED)
DO TNR
+18 ;
+19 IF +$ORDER(^LAH(LRLL,1,LRSQ,1))<1
DO ZAPALL(LRLL,LRSQ)
+20 IF $DATA(LRPRGSQ)
IF '$DATA(ZTQUEUED)
Begin DoDot:1
+21 WRITE !,"Purge data from sequence number(s): "
+22 FOR I=0:0
SET I=$ORDER(LRPRGSQ(I))
if I<1
QUIT
WRITE " ",I
+23 SET %=2
DO YN^DICN
if %'=1
QUIT
+24 NEW LAIEN
+25 SET LAIEN=0
+26 FOR
SET LAIEN=$ORDER(LRPRGSQ(LAIEN))
if LAIEN<1
QUIT
DO ZAPALL(LRLL,LAIEN)
End DoDot:1
+27 QUIT
+28 ;
+29 ;
ZAP ; from LRLLS3
+1 DO ZAPALL(LRLL,I)
+2 QUIT
+3 ;
+4 ;
LINK ; Check and save link
+1 DO LKCHK
if $DATA(LRLKOK)
QUIT
+2 SET X=$SELECT($DATA(^LRO(68,+$PIECE(LRLK,U,3),1,+$PIECE(LRLK,U,4),1,+$PIECE(LRLK,U,5),0)):+^(0),1:"")
if +X=LRDFN
GOTO LINKOK
+3 SET S1=PNM
SET S2=SSN
SET S3=LRDPF
+4 ;
+5 WRITE !,$CHAR(7),"WARNING - NO MATCHING ACCESSION WAS FOUND."
+6 WRITE !,"You may need to Clear instrument/worklist data,"
+7 WRITE !,"or correctly identify the sample to the system."
+8 ;
+9 IF X
SET LRDPF=$PIECE(^LR(X,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
WRITE !,PNM,?30,SSN,!,$CHAR(7)
SET PNM=S1
SET SSN=S2
SET LRDPF=S3
+10 KILL S1,S2,S3
+11 if $DATA(LRGVP)
QUIT
+12 WRITE !,"ARE YOU SURE THIS IS THE CORRECT DATA"
SET %=2
DO YN^DICN
if %'=1
QUIT
+13 ;
LINKOK ;
+1 if $PIECE(LRLK,U,5)
KILL ^LAH(LRLL,1,"C",+$PIECE(LRLK,U,5),LRSQ)
+2 SET ^LAH(LRLL,1,"C",LRAN,LRSQ)=""
SET $PIECE(^LAH(LRLL,1,LRSQ,0),U,3,5)=LRAA_U_LRAD_U_LRAN
SET LRLKOK=1
+3 QUIT
+4 ;
LKCHK SET LRLK=$SELECT($DATA(^LAH(LRLL,1,LRSQ,0)):^(0),1:"")
IF $PIECE(LRLK,U,3)=LRAA&($PIECE(LRLK,U,4)=LRAD)&($PIECE(LRLK,U,5)=LRAN)
SET LRLKOK=1
+1 QUIT
+2 ;
+3 ;
ZAP2 ;Clear ^LAH(
+1 DO ZAPALL(LRLL,I)
+2 QUIT
+3 ;
+4 ;
ZAPALL(LRLL,LAIEN) ;Clean up
+1 NEW I,NODE,SEG,SEGID,SUB
+2 if '$GET(LRLL)!('$GET(LAIEN))
QUIT
+3 ;
+4 SET NODE=$GET(^LAH(LRLL,1,LAIEN,0))
+5 KILL ^LAH(LRLL,1,"AUTOREL",LAIEN)
+6 KILL ^LAH(LRLL,1,"B",+$PIECE(NODE,U)_";"_+$PIECE(NODE,U,2),LAIEN)
+7 KILL ^LAH(LRLL,1,"C",+$PIECE(NODE,U,5),LAIEN)
+8 KILL ^LAH(LRLL,1,"D",+$PIECE(NODE,U,6),LAIEN)
+9 KILL ^LAH(LRLL,1,"E",+$PIECE(NODE,U,8),LAIEN)
+10 ;
+11 SET NODE("U")=$PIECE($GET(^LAH(LRLL,1,LAIEN,.3)),U)
+12 IF NODE("U")'=""
Begin DoDot:1
+13 KILL ^LAH(LRLL,1,"AUTOREL-UID",NODE("U"),LAIEN)
+14 KILL ^LAH(LRLL,1,"U",NODE("U"),LAIEN)
+15 SET I=0
+16 FOR
SET I=$ORDER(^LAH("LA7 AMENDED RESULTS",NODE("U"),I))
if 'I
QUIT
Begin DoDot:2
+17 KILL ^LAH("LA7 AMENDED RESULTS",NODE("U"),I,LRLL,LAIEN)
End DoDot:2
End DoDot:1
+18 ;
+19 SET SEG=""
+20 FOR
SET SEG=$ORDER(^LAH(LRLL,1,LAIEN,.1,SEG))
if SEG=""
QUIT
Begin DoDot:1
+21 SET SEGID=""
+22 FOR
SET SEGID=$ORDER(^LAH(LRLL,1,LAIEN,.1,SEG,SEGID))
if SEGID=""
QUIT
Begin DoDot:2
+23 SET SUB=$PIECE($GET(^LAH(LRLL,1,LAIEN,.1,SEG,SEGID)),U)
+24 IF SUB'=""
KILL ^LAH(LRLL,1,"A"_SEGID,SUB,LAIEN)
End DoDot:2
End DoDot:1
+25 ;
+26 KILL ^LAH(LRLL,1,LAIEN)
+27 ;
+28 ; Reset counter if loadlist is clear.
+29 IF '$ORDER(^LAH(LRLL,1,0))
Begin DoDot:1
+30 LOCK +^LAH(LRLL):DILOCKTM
if '$TEST
QUIT
+31 SET ^LAH(LRLL)=0
+32 LOCK -^LAH(LRLL)
End DoDot:1
+33 ;
+34 QUIT
+35 ;
+36 ;
TNR ; List tests not reviewed and ask if user wants to delete.
+1 ;
+2 NEW DIR,DIROUT,DIRUT,DUOUT,LR60,I,X,Y
+3 ;
+4 ; Check if these results have already been verified
+5 SET I=1
+6 FOR
SET I=$ORDER(^LAH(LRLL,1,LRSQ,I))
if 'I
QUIT
Begin DoDot:1
+7 SET X=^LAH(LRLL,1,LRSQ,I)
+8 IF $PIECE(X,"^")=$PIECE($GET(^LR(LRDFN,LRSS,LRIDT,I)),"^")
KILL ^LAH(LRLL,1,LRSQ,I)
End DoDot:1
+9 ;
+10 ; Quit if no unreviewed results
+11 IF +$ORDER(^LAH(LRLL,1,LRSQ,1))'>1
QUIT
+12 ;
+13 WRITE !,"Test(s) Not Reviewed:",!
+14 SET I=1
+15 FOR
SET I=$ORDER(^LAH(LRLL,1,LRSQ,I))
if 'I
QUIT
Begin DoDot:1
+16 SET X=^LAH(LRLL,1,LRSQ,I)
+17 SET LR60=+$ORDER(^LAB(60,"C","CH;"_I_";1",0))
+18 IF LR60
WRITE $$GET1^DIQ(60,LR60_",",.01)
+19 IF '$TEST
WRITE $$GET1^DID(63.04,I,"","LABEL")
+20 WRITE " = "_$PIECE(X,"^")_" "_$PIECE(X,"^",2)_" "_$PIECE($PIECE(X,"^",5),"!",7),!
End DoDot:1
+21 ;
+22 SET DIR(0)="Y"
SET DIR("A")="Purge these test results"
SET DIR("B")="NO"
+23 SET DIR("?",1)="Answer 'NO' if you want to keep these results for later verification."
+24 SET DIR("?",2)="You may need to add these tests to the loadlist profile you are using"
+25 SET DIR("?")="and/or add these tests to the accession you are verifying."
+26 DO ^DIR
if $DATA(DIRUT)
QUIT
+27 ;
+28 IF Y=1
DO ZAPALL(LRLL,LRSQ)
+29 QUIT
+30 ;
+31 ;
READ ;
+1 NEW X
WRITE !!,"Press ENTER or RETURN to continue: "
READ X:DTIME
+2 QUIT
+3 ;
+4 ;
UICHK() ; Confirm that user wants to process UI type results as reference lab results.
+1 ;
+2 NEW DIR,DIRUT,DTOUT,DUOUT,LROK,X,Y
+3 ;
+4 SET LROK=0
+5 SET DIR(0)="YO"
SET DIR("B")="NO"
+6 SET DIR("A",1)="These results were received via an automated instrument interface and you've"
+7 SET DIR("A",2)="indicated you're processing reference lab results. If you continue processing"
+8 SET DIR("A",3)="then only units and reference ranges received from the instrument will be"
+9 SET DIR("A",4)="stored. This could result in the report lacking units, reference ranges,"
+10 SET DIR("A",5)="abnormality flags and designating an incorrect performing lab."
+11 SET DIR("A",6)=" "
+12 SET DIR("A",7)="Contact your local LIM or Lab ADPAC with any questions."
+13 SET DIR("A",8)=" "
+14 SET DIR("A")="Sure you want to continue"
+15 DO ^DIR
+16 IF Y=1
SET LROK=1
+17 ;
+18 QUIT LROK
+19 ;
+20 ;
LRNIGHT ; Entry point from LRNIGHT to clean up LAH global for selected entries.
+1 ;
+2 ;ZEXCEPT: ZTQUEUED,ZTREQ,ZTSTOP
+3 ;
+4 NEW I,LRCNT,LRCUTOFFDT,LRDAYSKEEP,LRERROR,LRI,LRINST,LRISQN,LRLIST,LRLL,LRROOT,X
+5 SET DT=$$DT^XLFDT
+6 ;
+7 ; If rollover has not completed then requeue task 5 minutes in future.
+8 IF +$GET(^LAB(69.9,1,"RO"))'=(+$HOROLOG)
Begin DoDot:1
+9 IF $DATA(ZTQUEUED)
SET ZTREQ=$$HADD^XLFDT($HOROLOG,0,0,5,0)
QUIT
+10 WRITE !!,"Lab Rollover has not completed as of "_$$HTE^XLFDT($HOROLOG,"1M")_" ... Aborting."
End DoDot:1
QUIT
+11 ;
+12 DO GETLST^XPAR(.LRLIST,"PKG","LR WORKLIST DATA CLEANUP",,.LRERROR)
+13 IF '$DATA(LRLIST)
QUIT
+14 ;
+15 SET LRI=0
+16 FOR
SET LRI=$ORDER(LRLIST(LRI))
if 'LRI
QUIT
Begin DoDot:1
+17 SET LRLL=$PIECE(LRLIST(LRI),U)
SET LRDAYSKEEP=$PIECE(LRLIST(LRI),U,2)
SET LRCUTOFFDT=DT
+18 IF LRDAYSKEEP>0
SET LRCUTOFFDT=$$FMADD^XLFDT(DT,-LRDAYSKEEP)
+19 IF '$DATA(^LAH(LRLL))
QUIT
+20 IF $$S^%ZTLOAD("Processing LRLL: "_LRLL)
SET ZTSTOP=1
QUIT
+21 LOCK +^LAH(LRLL):DILOCKTM+60
if '$TEST
QUIT
+22 SET (LRCNT,LRISQN)=0
+23 FOR
SET LRISQN=$ORDER(^LAH(LRLL,1,LRISQN))
if 'LRISQN
QUIT
Begin DoDot:2
+24 SET LRCNT=LRCNT+1
+25 IF '(LRCNT#100)
IF $$S^%ZTLOAD("Processing LRLL: "_LRLL_" LRISQN: "_LRISQN)
SET ZTSTOP=1
QUIT
+26 ; No date, put current d/t, skip
IF '$PIECE($GET(^LAH(LRLL,1,LRISQN,0)),"^",11)
DO UPDT^LAGEN(LRLL,LRISQN)
QUIT
+27 ; Skip - Keep
IF $PIECE($GET(^LAH(LRLL,1,LRISQN,0)),"^",11)'<LRCUTOFFDT
QUIT
+28 SET LRINST=LRLL
SET I=LRISQN
+29 NEW LRLL,LRISQN,LRCUTOFFDT
+30 DO ZAPALL(LRINST,I)
End DoDot:2
if $GET(ZTSTOP)
QUIT
+31 LOCK -^LAH(LRLL)
End DoDot:1
if $GET(ZTSTOP)
QUIT
+32 ;
+33 DO CHECKARI
+34 ;
+35 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+36 ;
+37 QUIT
+38 ;
+39 ;
CHECKARI ; Check amended result index for orphans.
+1 ;
+2 ;ZEXCEPT: ZTQUEUED
+3 ;
+4 NEW LRCNT,LRI,LRISQN,LRLL,LRROOT
+5 ;
+6 IF '$DATA(ZTQUEUED)
WRITE !!,"Checking LAH global Amended Result Index for Orphans",!
+7 SET LRROOT="^LAH(""LA7 AMENDED RESULTS"")"
SET LRCNT=0
+8 FOR
SET LRROOT=$QUERY(@LRROOT)
if LRROOT=""
QUIT
if $QSUBSCRIPT(LRROOT,1)'="LA7 AMENDED RESULTS"
QUIT
Begin DoDot:1
+9 SET LRI=$QSUBSCRIPT(LRROOT,3)
SET LRLL=$QSUBSCRIPT(LRROOT,4)
SET LRISQN=$QSUBSCRIPT(LRROOT,5)
+10 IF $DATA(^LAH(LRLL,1,LRISQN,LRI))
QUIT
+11 IF '$DATA(ZTQUEUED)
WRITE !,"Deleting index: ",LRROOT," = ",@LRROOT
+12 KILL @LRROOT
SET LRCNT=LRCNT+1
End DoDot:1
+13 ;
+14 IF '$DATA(ZTQUEUED)
WRITE !,$SELECT(LRCNT:LRCNT,1:"No")," indexes found needing deletion."
+15 ;
+16 QUIT
