LRVR3 ;DALOI/CJS/JAH - LAB ROUTINE DATA VERIFICATION ; 03-Oct-2016 10:28 ; MKK
;;5.2;LAB SERVICE;**42,121,153,1018,286,1027,291,1031,1038,1039**;NOV 1, 1997;Build 38
;
D V1
I $D(LRLOCKER)#2 L -@(LRLOCKER) K LRLOCKER
K LRSA,LRSB,LRNOVER,LRSBCOM,LRLKOK
Q ;Leave LRVR3, back to LRVR2
;
;
V1 S LRTN=1
I $D(LRLOCKER)#2 L -@(LRLOCKER)
S LRLOCKER="^LR("_LRDFN_","""_LRSS_""","_LRIDT_")"
L +@(LRLOCKER):1
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
;
S LRCMTDSP=$$CHKCDSP^LRVERA
N LRX
S LRX=1
F S LRX=$O(^LAH(LRLL,1,LRSQ,LRX)) Q:LRX<1 D
. Q:LRX=9009027 ; IHS/OIT/MKK LR*5.2*1027 - Skip E-SIG Entry
. 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)
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
F S LRX=$O(^LAH(LRLL,1,LRSQ,1,LRX)) Q:LRX="" D
. Q:LRX=9009027 ; Skip E-SIG Entry
. S LRSBCOM(LRX)=^LAH(LRLL,1,LRSQ,1,LRX)
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
;
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)
F I=0:0 S I=$O(LRNOVER(I)) Q:I="" W !,$P(^DD(63.04,I,0),U)
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
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038 -- Mask User input.
D ; DO Statement used to ensure variables ANSWER, STEP, & TEXT are strictly local
. NEW ANSWER,STEP,TEXT
. W !,"Approve for release by entering your initials: "
. S ANSWER=""
. ; F STEP=1:1:4 R TEXT#1 S:TEXT="^" ANSWER="^" Q:TEXT="^"!(TEXT="") S ANSWER=ANSWER_TEXT W $C(8),"*"
. F STEP=1:1:6 R TEXT#1 S:TEXT="^" ANSWER="^" Q:TEXT="^"!(TEXT="") S ANSWER=ANSWER_TEXT W $C(8),"*" ; IHS/MSC/MKK - LR*5.2*1039
. S LRINI=ANSWER
; ----- END IHS/MSC/MKK - LR*5.2*1038
;
I $E(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
;
V11 ;Still locked from V1 L ^LR(LRDFN,LRSS,LRIDT)
N LRCORECT S LRCORECT=0
N LRX
NEW LRNOW S LRNOW=$$NOW^XLFDT ; IHS/MSC/MKK - LR*5.2*1039 - LEDI IV Update
S LRX=0
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 LRSB(LRX)'="" S ^LR(LRDFN,LRSS,LRIDT,LRX)=LRSB(LRX) S:'$D(^LRO(68,"AC",LRDFN,LRIDT,LRX)) ^(LRX)="" I LRVF S ^(LRX)=""
. I LRSB(LRX)'="" S $P(LRSB(LRX),U,6)=LRNOW,^LR(LRDFN,LRSS,LRIDT,LRX)=LRSB(LRX) S:'$D(^LRO(68,"AC",LRDFN,LRIDT,LRX)) ^(LRX)="" I LRVF S ^(LRX)="" ; IHS/MSC/MKK - LR*5.2*1039 - LEDI IV Update
;
I $P($G(LRORU3),U,3),$O(LRSB(0)) D LRORU3^LRVER3
;
A3 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
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 %=1 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.",!,"You may need to Clear instrument/worklist data,",!,"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
;
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
S S1=PNM,S2=HRCN,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
. D PT^LRX
. W !,PNM,?30,HRCN,!,$C(7)
. S PNM=S1,HRCN=S2,LRDPF=S3
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
;
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,SUB
Q:'$G(LRLL)!('$G(LAIEN))
;
S NODE=$G(^LAH(LRLL,1,LAIEN,0))
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,"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):1 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 your using"
S DIR("?")="and/or add these tests to the accession your 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
LRVR3 ;DALOI/CJS/JAH - LAB ROUTINE DATA VERIFICATION ; 03-Oct-2016 10:28 ; MKK
+1 ;;5.2;LAB SERVICE;**42,121,153,1018,286,1027,291,1031,1038,1039**;NOV 1, 1997;Build 38
+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
QUIT
+7 ;
+8 ;
V1 SET LRTN=1
+1 IF $DATA(LRLOCKER)#2
LOCK -@(LRLOCKER)
+2 SET LRLOCKER="^LR("_LRDFN_","""_LRSS_""","_LRIDT_")"
+3 LOCK +@(LRLOCKER):1
+4 IF '$TEST
WRITE !," This entry is being edited by someone else."
QUIT
+5 ;LRNOVER set in LRVR2
+6 KILL LRLKOK
DO LINK
IF '$DATA(LRLKOK)
QUIT
KILL LRLKOK
DO LKCHK
IF '$DATA(LRLKOK)
QUIT
+7 KILL LRSA,LRSB,LRSBCOM
+8 ;
+9 SET LRCMTDSP=$$CHKCDSP^LRVERA
+10 NEW LRX
+11 SET LRX=1
+12 FOR
SET LRX=$ORDER(^LAH(LRLL,1,LRSQ,LRX))
IF LRX<1
QUIT
Begin DoDot:1
+13 ; IHS/OIT/MKK LR*5.2*1027 - Skip E-SIG Entry
IF LRX=9009027
QUIT
+14 SET LRSB(LRX)=^LAH(LRLL,1,LRSQ,LRX)
+15 IF $DATA(LRNOVER)
IF $DATA(LRVTS(LRX))
IF $DATA(^TMP("LR",$JOB,"TMP",LRX))
SET LRNOVER(LRX)=""
End DoDot:1
+16 ; Copy comments from LAH
+17 SET LRX=0
+18 ; F S LRX=$O(^LAH(LRLL,1,LRSQ,1,LRX)) Q:LRX="" S LRSBCOM(LRX)=^(LRX)
+19 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
+20 FOR
SET LRX=$ORDER(^LAH(LRLL,1,LRSQ,1,LRX))
IF LRX=""
QUIT
Begin DoDot:1
+21 ; Skip E-SIG Entry
IF LRX=9009027
QUIT
+22 SET LRSBCOM(LRX)=^LAH(LRLL,1,LRSQ,1,LRX)
End DoDot:1
+23 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
+24 ;
EDIT IF $DATA(^LAH(LRLL,1,LRSQ,0))
Begin DoDot:1
+1 NEW X
+2 SET LREDIT=1
+3 FOR LRX=0,.1,.3
MERGE X(LRX)=^LAH(LRLL,1,LRSQ,LRX)
+4 KILL ^LAH(LRLL,1,LRSQ),LRNUF
+5 FOR LRX=0,.1,.3
MERGE ^LAH(LRLL,1,LRSQ,LRX)=X(LRX)
KILL X(LRX)
+6 DO ^LRVR4
+7 FOR LRX=1:0
SET LRX=$ORDER(LRSB(LRX))
IF LRX<1
QUIT
SET ^LAH(LRLL,1,LRSQ,LRX)=LRSB(LRX)
End DoDot:1
+8 IF $ORDER(^LAH(LRLL,1,LRSQ,1))<1
WRITE !,"NO DATA TO APPROVE"
QUIT
+9 IF $DATA(LRGVP)
QUIT
+10 FOR I=0:0
SET I=$ORDER(LRNOVER(I))
IF I=""
QUIT
WRITE !,$PIECE(^DD(63.04,I,0),U)
+11 IF $ORDER(LRNOVER(0))
WRITE !,"Have not been reviewed and have data. Not approved."
QUIT
+12 IF '$PIECE($GET(LRLABKY),U)
WRITE !,$CHAR(7),"ENTERED BUT NOT APPROVED"
QUIT
+13 NEW CNT
SET CNT=1
AGAIN ;
+1 ; R !,"Approve for release by entering your initials: ",LRINI:DTIME
+2 ;
+3 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038 -- Mask User input.
+4 ; DO Statement used to ensure variables ANSWER, STEP, & TEXT are strictly local
Begin DoDot:1
+5 NEW ANSWER,STEP,TEXT
+6 WRITE !,"Approve for release by entering your initials: "
+7 SET ANSWER=""
+8 ; F STEP=1:1:4 R TEXT#1 S:TEXT="^" ANSWER="^" Q:TEXT="^"!(TEXT="") S ANSWER=ANSWER_TEXT W $C(8),"*"
+9 ; IHS/MSC/MKK - LR*5.2*1039
FOR STEP=1:1:6
READ TEXT#1
IF TEXT="^"
SET ANSWER="^"
IF TEXT="^"!(TEXT="")
QUIT
SET ANSWER=ANSWER_TEXT
WRITE $CHAR(8),"*"
+10 SET LRINI=ANSWER
End DoDot:1
+11 ; ----- END IHS/MSC/MKK - LR*5.2*1038
+12 ;
+13 IF $EXTRACT(LRINI)="^"
WRITE !!?5,$CHAR(7),"Nothing verified!"
DO READ
QUIT
+14 IF LRINI'=LRUSI
IF $$UP^XLFSTR(LRINI)=$$UP^XLFSTR(LRUSI)
SET LRINI=LRUSI
+15 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
+16 IF LRINI'=LRUSI
WRITE !!?5,$CHAR(7),"Nothing verified!"
DO READ
QUIT
+17 ;
V11 ;Still locked from V1 L ^LR(LRDFN,LRSS,LRIDT)
+1 NEW LRCORECT
SET LRCORECT=0
+2 NEW LRX
+3 ; IHS/MSC/MKK - LR*5.2*1039 - LEDI IV Update
NEW LRNOW
SET LRNOW=$$NOW^XLFDT
+4 SET LRX=0
+5 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
+6 KILL ^LAH(LRLL,1,LRSQ,LRX)
+7 ; I LRSB(LRX)'="" S ^LR(LRDFN,LRSS,LRIDT,LRX)=LRSB(LRX) S:'$D(^LRO(68,"AC",LRDFN,LRIDT,LRX)) ^(LRX)="" I LRVF S ^(LRX)=""
+8 ; IHS/MSC/MKK - LR*5.2*1039 - LEDI IV Update
IF LRSB(LRX)'=""
SET $PIECE(LRSB(LRX),U,6)=LRNOW
SET ^LR(LRDFN,LRSS,LRIDT,LRX)=LRSB(LRX)
IF '$DATA(^LRO(68,"AC",LRDFN,LRIDT,LRX))
SET ^(LRX)=""
IF LRVF
SET ^(LRX)=""
End DoDot:1
+9 ;
+10 IF $PIECE($GET(LRORU3),U,3)
IF $ORDER(LRSB(0))
DO LRORU3^LRVER3
+11 ;
A3 IF +LRDPF=2&($GET(LRSS)'="BB")&('$$CHKINP^LRBEBA4(LRDFN,LRODT))
Begin DoDot:1
+1 DO BAWRK^LRBEBA(LRODT,LRSN,1,.LRBEY,.LRBETST)
End DoDot:1
+2 ;unlocked in LRVER
DO VER^LRVER3A
+3 KILL LRSBCOM
+4 IF $PIECE(LRPARAM,U,14)&($PIECE($GET(^LRO(68,LRAA,0)),U,16))
DO LOOK^LRCAPV1
+5 ; Check for LEDI tests not reviewed
+6 IF $GET(LRDUZ(2))
IF LRDUZ(2)'=DUZ(2)
IF LRSS="CH"
IF '$DATA(ZTQUEUED)
DO TNR
+7 ;
+8 IF +$ORDER(^LAH(LRLL,1,LRSQ,1))<1
DO ZAPALL(LRLL,LRSQ)
+9 IF $DATA(LRPRGSQ)
IF '$DATA(ZTQUEUED)
Begin DoDot:1
+10 WRITE !,"Purge data from sequence number(s): "
+11 FOR I=0:0
SET I=$ORDER(LRPRGSQ(I))
IF I<1
QUIT
WRITE " ",I
+12 SET %=1
DO YN^DICN
IF %'=1
QUIT
+13 NEW LAIEN
+14 SET LAIEN=0
+15 FOR
SET LAIEN=$ORDER(LRPRGSQ(LAIEN))
IF LAIEN<1
QUIT
DO ZAPALL(LRLL,LAIEN)
End DoDot:1
+16 QUIT
+17 ;
+18 ;
ZAP ; from LRLLS3
+1 DO ZAPALL(LRLL,I)
+2 QUIT
+3 ;
+4 ;
LINK ; Check and save link
+1 DO LKCHK
IF $DATA(LRLKOK)
QUIT
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
+2 ; S S1=PNM,S2=SSN,S3=LRDPF W !,$C(7),"WARNING - NO MATCHING ACCESSION WAS FOUND.",!,"You may need to Clear instrument/worklist data,",!,"or correctly identify the sample to the system."
+3 ; 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
+4 ;
+5 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
+6 SET S1=PNM
SET S2=HRCN
SET S3=LRDPF
+7 WRITE !,$CHAR(7),"WARNING - NO MATCHING ACCESSION WAS FOUND."
+8 WRITE !,"You may need to Clear instrument/worklist data,"
+9 WRITE !,"or correctly identify the sample to the system."
+10 IF X
SET LRDPF=$PIECE(^LR(X,0),U,2)
SET DFN=$PIECE(^(0),U,3)
Begin DoDot:1
+11 DO PT^LRX
+12 WRITE !,PNM,?30,HRCN,!,$CHAR(7)
+13 SET PNM=S1
SET HRCN=S2
SET LRDPF=S3
End DoDot:1
+14 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1027
+15 ;
+16 KILL S1,S2,S3
IF $DATA(LRGVP)
QUIT
WRITE !,"ARE YOU SURE THIS IS THE CORRECT DATA"
SET %=2
DO YN^DICN
IF %'=1
QUIT
LINKOK IF $PIECE(LRLK,U,5)
KILL ^LAH(LRLL,1,"C",+$PIECE(LRLK,U,5),LRSQ)
+1 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
+2 QUIT
+3 ;
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,SUB
+2 IF '$GET(LRLL)!('$GET(LAIEN))
QUIT
+3 ;
+4 SET NODE=$GET(^LAH(LRLL,1,LAIEN,0))
+5 KILL ^LAH(LRLL,1,"B",+$PIECE(NODE,U)_";"_+$PIECE(NODE,U,2),LAIEN)
+6 KILL ^LAH(LRLL,1,"C",+$PIECE(NODE,U,5),LAIEN)
+7 KILL ^LAH(LRLL,1,"D",+$PIECE(NODE,U,6),LAIEN)
+8 KILL ^LAH(LRLL,1,"E",+$PIECE(NODE,U,8),LAIEN)
+9 ;
+10 SET NODE("U")=$PIECE($GET(^LAH(LRLL,1,LAIEN,.3)),U)
+11 IF NODE("U")'=""
Begin DoDot:1
+12 KILL ^LAH(LRLL,1,"U",NODE("U"),LAIEN)
+13 SET I=0
+14 FOR
SET I=$ORDER(^LAH("LA7 AMENDED RESULTS",NODE("U"),I))
IF 'I
QUIT
Begin DoDot:2
+15 KILL ^LAH("LA7 AMENDED RESULTS",NODE("U"),I,LRLL,LAIEN)
End DoDot:2
End DoDot:1
+16 ;
+17 SET SEG=""
+18 FOR
SET SEG=$ORDER(^LAH(LRLL,1,LAIEN,.1,SEG))
IF SEG=""
QUIT
Begin DoDot:1
+19 SET SEGID=""
+20 FOR
SET SEGID=$ORDER(^LAH(LRLL,1,LAIEN,.1,SEG,SEGID))
IF SEGID=""
QUIT
Begin DoDot:2
+21 SET SUB=$PIECE($GET(^LAH(LRLL,1,LAIEN,.1,SEG,SEGID)),U)
+22 IF SUB'=""
KILL ^LAH(LRLL,1,"A"_SEGID,SUB,LAIEN)
End DoDot:2
End DoDot:1
+23 ;
+24 KILL ^LAH(LRLL,1,LAIEN)
+25 ;
+26 ; Reset counter if loadlist is clear.
+27 IF '$ORDER(^LAH(LRLL,1,0))
Begin DoDot:1
+28 LOCK +^LAH(LRLL):1
IF '$TEST
QUIT
+29 SET ^LAH(LRLL)=0
+30 LOCK -^LAH(LRLL)
End DoDot:1
+31 ;
+32 QUIT
+33 ;
+34 ;
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 your using"
+25 SET DIR("?")="and/or add these tests to the accession your 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
