LRGV2 ;DALOI/STAFF - PART2 OF INSTRUMENT GROUP VERIFY DATA ;02/11/11 12:21
;;5.2;LAB SERVICE;**121,153,269,350,438,519**;Sep 27, 1994;Build 16
;
;removed NEW of LRGVP in line below - LR*5.2*519
N 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 I $D(^TMP("LR",$J,"TMP",LRX)) 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
;
; Display test name, results
S X=$P(LRSB(LRSB),"^"),LRCW=8
W !,$P(^LAB(60,+LRTS,0),"^"),?31,@LRFP," "
;
; Do delta checking
S X=$P(LRSB(LRSB),"^"),Y=0,LRQ=""
I LRDEL'="" S LRQ=1 D XDELTACK^LRVERA S:Y LRDELTA=Y
;
; Do range checking
D RANGE^LRVR4
I LRFLG["*" S LRCRIT=1
;
; Display test flags and units
W $$LJ^XLFSTR(LRFLG,2),?56," ",$P(LRNGS,"^",7)
I LRFLG["*" D DISPFLG^LRVER4
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRGV2 3004 printed Apr 09, 2024@21:18:19 Page 2
LRGV2 ;DALOI/STAFF - PART2 OF INSTRUMENT GROUP VERIFY DATA ;02/11/11 12:21
+1 ;;5.2;LAB SERVICE;**121,153,269,350,438,519**;Sep 27, 1994;Build 16
+2 ;
+3 ;removed NEW of LRGVP in line below - LR*5.2*519
+4 NEW 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
IF $DATA(^TMP("LR",$JOB,"TMP",LRX))
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 ; Display test name, results
+13 SET X=$PIECE(LRSB(LRSB),"^")
SET LRCW=8
+14 WRITE !,$PIECE(^LAB(60,+LRTS,0),"^"),?31,@LRFP," "
+15 ;
+16 ; Do delta checking
+17 SET X=$PIECE(LRSB(LRSB),"^")
SET Y=0
SET LRQ=""
+18 IF LRDEL'=""
SET LRQ=1
DO XDELTACK^LRVERA
if Y
SET LRDELTA=Y
+19 ;
+20 ; Do range checking
+21 DO RANGE^LRVR4
+22 IF LRFLG["*"
SET LRCRIT=1
+23 ;
+24 ; Display test flags and units
+25 WRITE $$LJ^XLFSTR(LRFLG,2),?56," ",$PIECE(LRNGS,"^",7)
+26 IF LRFLG["*"
DO DISPFLG^LRVER4
+27 ;
+28 QUIT
+29 ;
+30 ;
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
