LRGV2 ;DALOI/RWF - PART2 OF INSTRUMENT GROUP VERIFY DATA ;8/11/97
;;5.2T9;LR;**1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**121,153,269**;Sep 27, 1994
;
N LRGVP,LRSB,LRX
;
I $P(LR0,U,8)'[LRMETH S $P(^LR(LRDFN,"CH",LRIDT,0),U,8)=LRMETH_";"_$P(LR0,U,8)
S LRLDT=LRIDT
D FINDPS
I LRLDT="" W !,"NO DELTA SAMPLE",!
;
; If results exist in ^LR then delete results from LAH.
I LRVF D
. S LRX=1
. F S LRX=$O(^LR(LRDFN,"CH",LRIDT,LRX)) Q:LRX'>0 I ^(LRX)'["pending" K ^LAH(LRLL,1,LRSQ,LRX)
;
S LRX=1
F S LRX=$O(^LAH(LRLL,1,LRSQ,LRX)) Q:LRX'>0 S LRSB(LRX)=^LAH(LRLL,1,LRSQ,LRX)
;
S LRVRM=1,(LRDELTA,LRCRIT,LRCNT,LRNX)=0
F S LRNX=$O(LRORD(LRNX)) Q:LRNX'>0 D DC
;
I 'LRVRFYAL,(LRDELTA!LRCRIT) D NOP Q
;
S LREXEC=LRCFL D ^LREXEC:LRCFL]""
;
S:'$P(^LR(LRDFN,"CH",LRIDT,0),U,5) $P(^LR(LRDFN,"CH",LRIDT,0),U,5)=LRSPEC
;
; Move comments from LAH to LR
I $O(^LAH(LRLL,1,LRSQ,1,0)) D LRSBCOM^LRVR4
;
; Verify results and update files.
K LRPRGSQ
D V11^LRVR3
W !!,">> Accession #: ",LRAN," VERIFIED <<"
;
; Display results which were not verified.
I $O(^LAH(LRLL,1,LRSQ,1))>1 D
. W !," STILL TO BE VERIFIED:"
. S LRX=1
. F S LRX=$O(^LAH(LRLL,1,LRSQ,LRX)) Q:LRX<1 W ?25,$$GET1^DID(63.04,LRX,"","LABEL"),!
;
D DASH^LRX
;
K LRSB
Q
;
;
DC ; Perform range and delta checks
;
N LRCW,LRQ,X,Y
;
S LRSB=+LRORD(LRNX),LRTS=$S($D(^TMP("LR",$J,"TMP",LRSB)):^(LRSB),1:0) Q:'LRTS
S X=$P($G(LRSB(LRSB)),U),X1="",LRFLG=""
I X=""!(X["pending") Q
I LRLDT'="" S X1=$G(^LR(LRDFN,"CH",LRLDT,LRSB))
;
; Setup variable for range and delta checking
D V25^LRVER5
;
; Do range checking
S LRQ=""
D RANGE^LRVR4
I LRFLG["*" S LRCRIT=1
;
; Display test name, results, flags and units
S X=$P(LRSB(LRSB),"^"),LRCW=8
;W !,$P(^LAB(60,+LRTS,0),"^"),?31,@LRFP," ",$$LJ^XLFSTR(LRFLG,2)," ",$$LJ^XLFSTR($P(LRNGS,"^",7),10)
W !,$P(^LAB(60,+LRTS,0),"^"),?31,@LRFP," ",$$LJ^XLFSTR(LRFLG,2)," ",$P(LRNGS,"^",7)
I LRFLG["*" D
. N X
. S X="CRITICAL "_$S(LRFLG["L":"LOW",LRFLG["H":"HIGH",1:"")_"!!"
. I $E(IOST,1,2)="C-" W " ",@LRVIDO,X,@LRVIDOF,$C(7,7,7)
. E W " ",X
;
; Do delta checking
S X=$P(LRSB(LRSB),"^")
S Y=0 I LRDEL'="" X LRDEL S:Y LRDELTA=Y
Q
;
;
NOP ;
W !,">> Accession #: ",LRAN," NOT VERIFIED"
I LRDELTA W " - DELTA check flag"
I LRCRIT W " - CRITICAL range flag"
W " <<"
I $E(IOST,1,2)="C-" W $C(7)
Q
;
;
INFO ;
W !,"Sequence #: ",LRSQ
S X=$P(^LAH(LRLL,1,LRSQ,0),"^",1),Y=$P(^(0),"^",2)
W:$L(X)!$L(Y) ?20,"TRAY: ",X,?33,"CUP: ",Y,?45,"DUPLICATE "
Q
;
;
FINDPS ; Find previous specimen to use for delta check
; Specimen needs to be within "days back (LRTM60)" parameter and have
; a dataname in common with a dataname on the sequence entry in LAH.
;
N LRQUIT,LRX
;
S LRQUIT=0
F S LRLDT=$O(^LR(LRDFN,"CH",LRLDT)) Q:'LRLDT D Q:LRQUIT
. I LRLDT>LRTM60 S LRLDT="",LRQUIT=1 Q
. S LRX=$G(^LR(LRDFN,"CH",LRLDT,0))
. I $P(LRX,U,5)'=LRSPEC!('$P(LRX,U,3)) Q
. S LRX=1
. F S LRX=$O(^LAH(LRLL,1,LRSQ,LRX)) Q:LRX'>0 I $D(^LR(LRDFN,"CH",LRLDT,LRX)) S LRQUIT=1 Q
;
Q
LRGV2 ;DALOI/RWF - PART2 OF INSTRUMENT GROUP VERIFY DATA ;8/11/97
+1 ;;5.2T9;LR;**1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**121,153,269**;Sep 27, 1994
+3 ;
+4 NEW LRGVP,LRSB,LRX
+5 ;
+6 IF $PIECE(LR0,U,8)'[LRMETH
SET $PIECE(^LR(LRDFN,"CH",LRIDT,0),U,8)=LRMETH_";"_$PIECE(LR0,U,8)
+7 SET LRLDT=LRIDT
+8 DO FINDPS
+9 IF LRLDT=""
WRITE !,"NO DELTA SAMPLE",!
+10 ;
+11 ; If results exist in ^LR then delete results from LAH.
+12 IF LRVF
Begin DoDot:1
+13 SET LRX=1
+14 FOR
SET LRX=$ORDER(^LR(LRDFN,"CH",LRIDT,LRX))
IF LRX'>0
QUIT
IF ^(LRX)'["pending"
KILL ^LAH(LRLL,1,LRSQ,LRX)
End DoDot:1
+15 ;
+16 SET LRX=1
+17 FOR
SET LRX=$ORDER(^LAH(LRLL,1,LRSQ,LRX))
IF LRX'>0
QUIT
SET LRSB(LRX)=^LAH(LRLL,1,LRSQ,LRX)
+18 ;
+19 SET LRVRM=1
SET (LRDELTA,LRCRIT,LRCNT,LRNX)=0
+20 FOR
SET LRNX=$ORDER(LRORD(LRNX))
IF LRNX'>0
QUIT
DO DC
+21 ;
+22 IF 'LRVRFYAL
IF (LRDELTA!LRCRIT)
DO NOP
QUIT
+23 ;
+24 SET LREXEC=LRCFL
IF LRCFL]""
DO ^LREXEC
+25 ;
+26 IF '$PIECE(^LR(LRDFN,"CH",LRIDT,0),U,5)
SET $PIECE(^LR(LRDFN,"CH",LRIDT,0),U,5)=LRSPEC
+27 ;
+28 ; Move comments from LAH to LR
+29 IF $ORDER(^LAH(LRLL,1,LRSQ,1,0))
DO LRSBCOM^LRVR4
+30 ;
+31 ; Verify results and update files.
+32 KILL LRPRGSQ
+33 DO V11^LRVR3
+34 WRITE !!,">> Accession #: ",LRAN," VERIFIED <<"
+35 ;
+36 ; Display results which were not verified.
+37 IF $ORDER(^LAH(LRLL,1,LRSQ,1))>1
Begin DoDot:1
+38 WRITE !," STILL TO BE VERIFIED:"
+39 SET LRX=1
+40 FOR
SET LRX=$ORDER(^LAH(LRLL,1,LRSQ,LRX))
IF LRX<1
QUIT
WRITE ?25,$$GET1^DID(63.04,LRX,"","LABEL"),!
End DoDot:1
+41 ;
+42 DO DASH^LRX
+43 ;
+44 KILL LRSB
+45 QUIT
+46 ;
+47 ;
DC ; Perform range and delta checks
+1 ;
+2 NEW LRCW,LRQ,X,Y
+3 ;
+4 SET LRSB=+LRORD(LRNX)
SET LRTS=$SELECT($DATA(^TMP("LR",$JOB,"TMP",LRSB)):^(LRSB),1:0)
IF 'LRTS
QUIT
+5 SET X=$PIECE($GET(LRSB(LRSB)),U)
SET X1=""
SET LRFLG=""
+6 IF X=""!(X["pending")
QUIT
+7 IF LRLDT'=""
SET X1=$GET(^LR(LRDFN,"CH",LRLDT,LRSB))
+8 ;
+9 ; Setup variable for range and delta checking
+10 DO V25^LRVER5
+11 ;
+12 ; Do range checking
+13 SET LRQ=""
+14 DO RANGE^LRVR4
+15 IF LRFLG["*"
SET LRCRIT=1
+16 ;
+17 ; Display test name, results, flags and units
+18 SET X=$PIECE(LRSB(LRSB),"^")
SET LRCW=8
+19 ;W !,$P(^LAB(60,+LRTS,0),"^"),?31,@LRFP," ",$$LJ^XLFSTR(LRFLG,2)," ",$$LJ^XLFSTR($P(LRNGS,"^",7),10)
+20 WRITE !,$PIECE(^LAB(60,+LRTS,0),"^"),?31,@LRFP," ",$$LJ^XLFSTR(LRFLG,2)," ",$PIECE(LRNGS,"^",7)
+21 IF LRFLG["*"
Begin DoDot:1
+22 NEW X
+23 SET X="CRITICAL "_$SELECT(LRFLG["L":"LOW",LRFLG["H":"HIGH",1:"")_"!!"
+24 IF $EXTRACT(IOST,1,2)="C-"
WRITE " ",@LRVIDO,X,@LRVIDOF,$CHAR(7,7,7)
+25 IF '$TEST
WRITE " ",X
End DoDot:1
+26 ;
+27 ; Do delta checking
+28 SET X=$PIECE(LRSB(LRSB),"^")
+29 SET Y=0
IF LRDEL'=""
XECUTE LRDEL
IF Y
SET LRDELTA=Y
+30 QUIT
+31 ;
+32 ;
NOP ;
+1 WRITE !,">> Accession #: ",LRAN," NOT VERIFIED"
+2 IF LRDELTA
WRITE " - DELTA check flag"
+3 IF LRCRIT
WRITE " - CRITICAL range flag"
+4 WRITE " <<"
+5 IF $EXTRACT(IOST,1,2)="C-"
WRITE $CHAR(7)
+6 QUIT
+7 ;
+8 ;
INFO ;
+1 WRITE !,"Sequence #: ",LRSQ
+2 SET X=$PIECE(^LAH(LRLL,1,LRSQ,0),"^",1)
SET Y=$PIECE(^(0),"^",2)
+3 IF $LENGTH(X)!$LENGTH(Y)
WRITE ?20,"TRAY: ",X,?33,"CUP: ",Y,?45,"DUPLICATE "
+4 QUIT
+5 ;
+6 ;
FINDPS ; Find previous specimen to use for delta check
+1 ; Specimen needs to be within "days back (LRTM60)" parameter and have
+2 ; a dataname in common with a dataname on the sequence entry in LAH.
+3 ;
+4 NEW LRQUIT,LRX
+5 ;
+6 SET LRQUIT=0
+7 FOR
SET LRLDT=$ORDER(^LR(LRDFN,"CH",LRLDT))
IF 'LRLDT
QUIT
Begin DoDot:1
+8 IF LRLDT>LRTM60
SET LRLDT=""
SET LRQUIT=1
QUIT
+9 SET LRX=$GET(^LR(LRDFN,"CH",LRLDT,0))
+10 IF $PIECE(LRX,U,5)'=LRSPEC!('$PIECE(LRX,U,3))
QUIT
+11 SET LRX=1
+12 FOR
SET LRX=$ORDER(^LAH(LRLL,1,LRSQ,LRX))
IF LRX'>0
QUIT
IF $DATA(^LR(LRDFN,"CH",LRLDT,LRX))
SET LRQUIT=1
QUIT
End DoDot:1
IF LRQUIT
QUIT
+13 ;
+14 QUIT
