LRGV1 ;DALOI/RWF - PART2 OF INSTRUMENT GROUP VERIFY DATA ;2/8/91 09:29
;;5.2;LAB SERVICE;**112,153,269**;Sep 27, 1994
;
STUFF ;from LRGV
;
; Check if task has been asked to stop.
I $D(ZTQUEUED),$$S^%ZTLOAD D Q
. S ZTSTOP=1
. W !!,"*** Report requested to stop by TaskMan ***"
. W !,"*** Task #",$G(ZTQUEUED,"UNKNOWN")," stopped at ",$$HTE^XLFDT($H)," ***"
;
N LRQUIT
;
S LRQUIT=0
;
L +^LAH(LRLL,1,LRSQ):1
I '$T W !,"Unable to obtain lock on sequence #",LRSQ Q
;
; Skip this sequence number if accession number is for a different area/date
S LRSQ(0)=^LAH(LRLL,1,LRSQ,0)
I $P(LRSQ(0),U,3)=LRAA,$P(LRSQ(0),U,4)=LRAD,$P(LRSQ(0),U,5)=LRAN
I '$T L -^LAH(LRLL,1,LRSQ) Q
;
I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,2) D
. W !?5,"Corrupt Accession ",!
. D NOP
;
S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
S LRDFN=+X,LRODT=+$P(X,U,4),LRSN=+$P(X,U,5),LRLLOC=$P(X,U,7)
S:'$L(LRLLOC) LRLLOC=0
S LRORD=$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)),"^")
S X(3)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
S LRIDT=$P(X(3),U,5)
S:'LRIDT LRIDT=9999999-X(3)
S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
;
K LRSA,LRSB,X
W " Auto Sequence #",LRSQ
I '$D(^LRO(68,+LRAA,1,+LRAD,1,+LRAN,0))!'$D(^(3)) D Q
. W ?40,"Accession NOT found."
. L -^LAH(LRLL,1,LRSQ)
;
K ^TMP("LR",$J,"TMP")
D TEST^LRVR1
;
; Check for more than one sequence relating to this accession
S LRI=0
F S LRI=$O(^LAH(LRLL,1,"C",LRAN,LRI)) Q:'LRI D Q:LRQUIT
. I LRI=LRSQ Q
. S LRI(0)=$G(^LAH(LRLL,1,LRI,0))
. I $P(LRI(0),"^",3,5)'=LRAA_"^"_LRAD_"^"_LRAN Q
. S LRQUIT=1
. D INFO,NOP
I LRQUIT Q
;
S LRMETH=$P(^LAH(LRLL,1,LRSQ,0),U,7)
I $O(^LAH(LRLL,1,LRSQ,1))<1 D Q
. W ?45,"There's NO Instrument Data "
. D NOP
;
; Get patient demographics
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX
S:'$L($G(SEX)) SEX="M"
S:'$L($G(AGE)) AGE=99
W ! D DISPLAY^LRGP
;
L +^LR(LRDFN,"CH",LRIDT):1
I '$T W !,"Unable to obtain lock on LAB DATA file" Q
;
S LR0=$G(^LR(LRDFN,"CH",LRIDT,0))
I LR0="" W !,"DATA HEADER MISSING " D NOP Q
;
S X=+$P(LR0,U,5),LRSPEC=-1,LRSPNAM="??"
I X S LRSPNAM=$P(^LAB(61,+X,0),U,1),LRSPEC=X
W !," Specimen: ",LRSPNAM
W ?26," Collection date/time: ",$$FMTE^XLFDT($P(LR0,"^"),"1M"),!
;
I LRDPF'=62.3,LRSPEC'=$P(LR0,U,5) D Q
. W !," << SPECIMEN IS NOT ",LRSPNAM," >> "
. D NOP
;
S LRVF=+$P(LR0,U,3)
I LRVF W !,"Some Data Already Verified ",!
;
I '$T,$O(^LR(LRDFN,"CH",LRIDT,1))>1 D Q
. W !,"Some Unverified Data Already Entered. "
. D NOP
;
D ^LRGV2
;
L -^LR(LRDFN,"CH",LRIDT)
L -^LAH(LRLL,1,LRSQ)
;
Q
;
NOP ; unlock from above
L -^LR(LRDFN,"CH",LRIDT)
L -^LAH(LRLL,1,LRSQ)
W !,">> Accession: ",LRAN," NOT VERIFIED <<"
I $E(IOST,1,2)="C-" W $C(7)
Q
;
;
INFO ;
N X
W !,"Sequence #: ",LRSQ
S X=^LAH(LRLL,1,LRSQ,0)
;
I LRWT="T" D
. I $P(X,"^") W ?20,"TRAY: ",$P(X,"^")
. I $P(X,"^",2) W ?33,"CUP: ",$P(X,"^",2)
;
W ?45,"DUPLICATE "
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRGV1 2991 printed Nov 22, 2024@17:25:03 Page 2
LRGV1 ;DALOI/RWF - PART2 OF INSTRUMENT GROUP VERIFY DATA ;2/8/91 09:29
+1 ;;5.2;LAB SERVICE;**112,153,269**;Sep 27, 1994
+2 ;
STUFF ;from LRGV
+1 ;
+2 ; Check if task has been asked to stop.
+3 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
Begin DoDot:1
+4 SET ZTSTOP=1
+5 WRITE !!,"*** Report requested to stop by TaskMan ***"
+6 WRITE !,"*** Task #",$GET(ZTQUEUED,"UNKNOWN")," stopped at ",$$HTE^XLFDT($HOROLOG)," ***"
End DoDot:1
QUIT
+7 ;
+8 NEW LRQUIT
+9 ;
+10 SET LRQUIT=0
+11 ;
+12 LOCK +^LAH(LRLL,1,LRSQ):1
+13 IF '$TEST
WRITE !,"Unable to obtain lock on sequence #",LRSQ
QUIT
+14 ;
+15 ; Skip this sequence number if accession number is for a different area/date
+16 SET LRSQ(0)=^LAH(LRLL,1,LRSQ,0)
+17 IF $PIECE(LRSQ(0),U,3)=LRAA
IF $PIECE(LRSQ(0),U,4)=LRAD
IF $PIECE(LRSQ(0),U,5)=LRAN
+18 IF '$TEST
LOCK -^LAH(LRLL,1,LRSQ)
QUIT
+19 ;
+20 IF '$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),U,2)
Begin DoDot:1
+21 WRITE !?5,"Corrupt Accession ",!
+22 DO NOP
End DoDot:1
+23 ;
+24 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
+25 SET LRDFN=+X
SET LRODT=+$PIECE(X,U,4)
SET LRSN=+$PIECE(X,U,5)
SET LRLLOC=$PIECE(X,U,7)
+26 if '$LENGTH(LRLLOC)
SET LRLLOC=0
+27 SET LRORD=$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.1)),"^")
+28 SET X(3)=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
+29 SET LRIDT=$PIECE(X(3),U,5)
+30 if 'LRIDT
SET LRIDT=9999999-X(3)
+31 SET LRORU3=$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
+32 ;
+33 KILL LRSA,LRSB,X
+34 WRITE " Auto Sequence #",LRSQ
+35 IF '$DATA(^LRO(68,+LRAA,1,+LRAD,1,+LRAN,0))!'$DATA(^(3))
Begin DoDot:1
+36 WRITE ?40,"Accession NOT found."
+37 LOCK -^LAH(LRLL,1,LRSQ)
End DoDot:1
QUIT
+38 ;
+39 KILL ^TMP("LR",$JOB,"TMP")
+40 DO TEST^LRVR1
+41 ;
+42 ; Check for more than one sequence relating to this accession
+43 SET LRI=0
+44 FOR
SET LRI=$ORDER(^LAH(LRLL,1,"C",LRAN,LRI))
if 'LRI
QUIT
Begin DoDot:1
+45 IF LRI=LRSQ
QUIT
+46 SET LRI(0)=$GET(^LAH(LRLL,1,LRI,0))
+47 IF $PIECE(LRI(0),"^",3,5)'=LRAA_"^"_LRAD_"^"_LRAN
QUIT
+48 SET LRQUIT=1
+49 DO INFO
DO NOP
End DoDot:1
if LRQUIT
QUIT
+50 IF LRQUIT
QUIT
+51 ;
+52 SET LRMETH=$PIECE(^LAH(LRLL,1,LRSQ,0),U,7)
+53 IF $ORDER(^LAH(LRLL,1,LRSQ,1))<1
Begin DoDot:1
+54 WRITE ?45,"There's NO Instrument Data "
+55 DO NOP
End DoDot:1
QUIT
+56 ;
+57 ; Get patient demographics
+58 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
DO PT^LRX
+59 if '$LENGTH($GET(SEX))
SET SEX="M"
+60 if '$LENGTH($GET(AGE))
SET AGE=99
+61 WRITE !
DO DISPLAY^LRGP
+62 ;
+63 LOCK +^LR(LRDFN,"CH",LRIDT):1
+64 IF '$TEST
WRITE !,"Unable to obtain lock on LAB DATA file"
QUIT
+65 ;
+66 SET LR0=$GET(^LR(LRDFN,"CH",LRIDT,0))
+67 IF LR0=""
WRITE !,"DATA HEADER MISSING "
DO NOP
QUIT
+68 ;
+69 SET X=+$PIECE(LR0,U,5)
SET LRSPEC=-1
SET LRSPNAM="??"
+70 IF X
SET LRSPNAM=$PIECE(^LAB(61,+X,0),U,1)
SET LRSPEC=X
+71 WRITE !," Specimen: ",LRSPNAM
+72 WRITE ?26," Collection date/time: ",$$FMTE^XLFDT($PIECE(LR0,"^"),"1M"),!
+73 ;
+74 IF LRDPF'=62.3
IF LRSPEC'=$PIECE(LR0,U,5)
Begin DoDot:1
+75 WRITE !," << SPECIMEN IS NOT ",LRSPNAM," >> "
+76 DO NOP
End DoDot:1
QUIT
+77 ;
+78 SET LRVF=+$PIECE(LR0,U,3)
+79 IF LRVF
WRITE !,"Some Data Already Verified ",!
+80 ;
+81 IF '$TEST
IF $ORDER(^LR(LRDFN,"CH",LRIDT,1))>1
Begin DoDot:1
+82 WRITE !,"Some Unverified Data Already Entered. "
+83 DO NOP
End DoDot:1
QUIT
+84 ;
+85 DO ^LRGV2
+86 ;
+87 LOCK -^LR(LRDFN,"CH",LRIDT)
+88 LOCK -^LAH(LRLL,1,LRSQ)
+89 ;
+90 QUIT
+91 ;
NOP ; unlock from above
+1 LOCK -^LR(LRDFN,"CH",LRIDT)
+2 LOCK -^LAH(LRLL,1,LRSQ)
+3 WRITE !,">> Accession: ",LRAN," NOT VERIFIED <<"
+4 IF $EXTRACT(IOST,1,2)="C-"
WRITE $CHAR(7)
+5 QUIT
+6 ;
+7 ;
INFO ;
+1 NEW X
+2 WRITE !,"Sequence #: ",LRSQ
+3 SET X=^LAH(LRLL,1,LRSQ,0)
+4 ;
+5 IF LRWT="T"
Begin DoDot:1
+6 IF $PIECE(X,"^")
WRITE ?20,"TRAY: ",$PIECE(X,"^")
+7 IF $PIECE(X,"^",2)
WRITE ?33,"CUP: ",$PIECE(X,"^",2)
End DoDot:1
+8 ;
+9 WRITE ?45,"DUPLICATE "
+10 QUIT
