LRGV ;DALIO/RWF - INSTRUMENT GROUP VERIFY DATA ;2/5/91 13:26
;;5.2;LAB SERVICE;**269,411,519**;Sep 27, 1994;Build 16
;
N LRANYAA,LRDUZ,LRUID,LRVBY,LRGVP
;
D ^LRGVK,^LRPARAM
I $G(LREND) D END Q
;
S U="^",LRSS="CH",LROUTINE=$P(^LAB(69.9,1,3),U,2),(LRANYAA,LRUID,LRVBY)=""
;
; Get user's initials to use to verify results
S X=DUZ D DUZ^LRX
X ^%ZOSF("EOFF")
N DIR
S DIR(0)="FAO^1:10",DIR("A")="Please enter your initials to verify: "
D ^DIR K DIR
X ^%ZOSF("EON")
I $D(DIRUT)!(Y'=LRUSI) D END Q
;
D ^LRGP1
I LREND D END Q
;
D COM
I LREND D NOP,END Q
;
S %ZIS="Q" D ^%ZIS
I POP D END Q
;
I $D(IO("Q")) D Q
. N ZTDTH,ZTRTN,ZTSAVE,ZTDESC
. K IO("Q")
. ;LRGVP = indicates to downstream routines that sending to a printer
. S LRGVP=1
. S ZTRTN="DQ^LRGV",ZTSAVE("LR*")="",ZTSAVE("^TMP(""LR"",$J,")="",ZTDESC="Group verify (EA, EL, EW)"
. D ^%ZTLOAD
. U IO(0) W !,"Task ",$S($G(ZTSK):ZTSK,1:"NOT")," Queued"
. D END
;
DQ ;
U IO
S LRNOW=$$NOW^XLFDT,LRDT=$$FMTE^XLFDT(LRNOW,"1M"),(LREND,LRPAGE)=0
S LRLLNM=$P(^LRO(68.2,LRLL,0),"^")
D HDR
D LRTRAY:LRWT="T",ACCLST:LRWT="A",SEQ:LRWT="M",WRKLST:LRWT="W"
I $E(IOST,1,2)="P-" W @IOF
;
END ;
I $D(ZTQUEUED) S ZTREQ="@"
E D ^%ZISC
D ^LRGVK
K LRCSQQ,LRLLNM,LRNGS,LRPAGE
Q
;
;
ACCLST ; Verify by accession number/UID
;
S LRVWLE=""
;
; Verify by accession number
I LRVBY=1 D
. S LRAN=LRFAN
. F S LRAN=$O(^LRO(68,LRAA,1,LRAD,1,LRAN)) Q:LRAN<1!(LRAN>LRLIX) D ACC2 Q:LREND
. I $L(LRVWLE) D
. . S $P(^LRO(68,LRAA,1,LRAD,2),"^")=LRUSI
. . S $P(^LRO(68,LRAA,1,LRAD,2),"^",4)=LRVWLE
;
; Verify by UID
I LRVBY=2 D
. S LRANYAA=+$P($G(^LRO(68.2,LRLL,10,LRPROF,0)),"^",3),LRUID=""
. F D NEXT^LRVRA Q:LRUID="" D ACC2 Q:LREND
;
Q
;
;
ACC2 ; Only select those entries in ^LAH that match the accession area and
; date selected by the user.
;
I $Y>(IOSL-10) D HDR Q:LREND
W ! D DASH^LRX
W !,"Accession #: ",LRAN
I LRVBY=2 D
. W " [UID: ",LRUID,"]"
. I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D Q
. . W " No accession on file for this UID."
. W " <",$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^"),">"
;
I '$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",3) D Q
. W " Has not been received. Unable to verify."
;
I +^LRO(68,LRAA,1,LRAD,1,LRAN,3)>$$NOW^XLFDT D Q
. W " Has a collection time in the future. Unable to verify."
;
I $O(^LAH(LRLL,1,"C",LRAN,0))<1 D Q
. W " NO Instrument Data Found."
;
S LRSQ=0
F S LRSQ=$O(^LAH(LRLL,1,"C",LRAN,LRSQ)) Q:LRSQ<1 D Q:LREND
. S X=^LAH(LRLL,1,LRSQ,0)
. I LRAA'=$P(X,"^",3)!(LRAD'=$P(X,"^",4)) Q
. S LRAN=$P(X,"^",5)
. I LRAN D STUFF^LRGV1
Q
;
;
LRTRAY ; Verify by tray/cup
;
F LRTRAY=LRFTRAY:1:LRLTRAY D Q:LREND
. I $Y>(IOSL-10) D HDR Q:LREND
. W ! D DASH^LRX
. W !!,"Start TRAY: ",LRTRAY
. D TR2
Q
;
;
TR2 ; Verify by tray/cup
; Only select those entries in ^LAH that match the accession area and date
; selected by the user.
N LRSC,LREC,X
;
; Figure out starting and ending cups for this tray
S LRSC=$S(LRTRAY=LRFTRAY:LRFCUP,1:1)
S LREC=$S(LRTRAY=LRLTRAY:LRLCUP,1:LRMAXCUP)
;
F LRCUP=LRSC:1:LREC D Q:LREND
. S LRITC=LRTRAY_";"_LRCUP
. I $Y>(IOSL-10) D HDR Q:LREND
. W ! D DASH^LRX
. W !,"Tray ",$J(LRTRAY,3)," Cup ",$J(LRCUP,3)
. I $O(^LAH(LRLL,1,"B",LRITC,0))<1 W ?35,"No Instrument Data Found" Q
. ;
. S LRSQ=0
. F S LRSQ=$O(^LAH(LRLL,1,"B",LRITC,LRSQ)) Q:LRSQ<1 D Q:LREND
. . I '$D(^LAH(LRLL,1,+LRSQ,0)) D Q
. . . K ^LAH(LRLL,1,"B",LRTIC,LRSQ)
. . . W ?35,"No Instrument Data Found"
. . S X=^LAH(LRLL,1,LRSQ,0)
. . I LRAA'=$P(X,"^",3)!(LRAD'=$P(X,"^",4)) Q
. . S LRAN=$P(X,"^",5)
. . I LRAN D STUFF^LRGV1 Q
. . W ?35," Does not have a link to an Accession."
Q
;
;
SEQ ; Verify by sequence number
; Only select those entries in ^LAH that match the accession area and date
; selected by the user.
;
N X
;
S LRSQ=LRSQ-1
F S LRSQ=$O(^LAH(LRLL,1,LRSQ)) Q:LRSQ<1!(LRSQ>LRESEQ) D Q:LREND
. I $Y>(IOSL-10) D HDR Q:LREND
. W ! D DASH^LRX
. S X=^LAH(LRLL,1,LRSQ,0)
. I LRAA'=$P(X,"^",3)!(LRAD'=$P(X,"^",4)) Q
. S LRAN=$P(X,"^",5)
. I LRAN D STUFF^LRGV1 Q
. W !!,"SEQ: ",LRSQ,". Does not have a link to an Accession."
Q
;
;
WRKLST ; Verify by worklist
; Only select those entries in file #68.2 that match the profile selected
; by the user.
;
N X
;
S LRCUP=LRCUP-1
F S LRCUP=$O(^LRO(68.2,LRLL,1,1,1,LRCUP)) Q:'LRCUP!(LRCUP>LRECUP) D Q:LREND
. I $Y>(IOSL-10) D HDR Q:LREND
. W ! D DASH^LRX
. S X=^LRO(68.2,LRLL,1,1,1,LRCUP,0)
. I $P(X,"^",4),$P(X,"^",4)'=LRPROF Q
. S LRAA=$P(X,"^"),LRAD=$P(X,"^",2),LRAN=$P(X,"^",3)
. W !,"Sequence #",$J(LRCUP,4)
. I $O(^LAH(LRLL,1,"C",+LRAN,0))<1 W ?35,"No Instrument Data Found" Q
. ;
. S LRSQ=0
. F S LRSQ=$O(^LAH(LRLL,1,"C",LRAN,LRSQ)) Q:LRSQ<1 D STUFF^LRGV1 Q:LREND
Q
;
;
COM ; Ask common questions
;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
;
S LRVRFYAL=0
I $D(^XUSEC("LRSUPER",DUZ))!1 D
. S DIR(0)="YAO",DIR("B")="NO"
. S DIR("A",1)="Verify accessions specified, even if"
. S DIR("A")=" DELTA check or CRITICAL range flag? "
. D ^DIR
. I $D(DIRUT) S LREND=1 Q
. S LRVRFYAL=Y
;
I LREND Q
;
K DIR
S DIR(0)="YO",DIR("A")="Everything OK",DIR("B")="YES"
D ^DIR
I $D(DIRUT)!(Y'=1) S LREND=1
Q
;
;
NOP ;
W !!,"NOTHING VERIFIED"
Q
;
;
HDR ;
;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
;
I $E(IOST,1,2)="C-",'$D(ZTQUEUED),LRPAGE D
. S DIR(0)="E" D ^DIR
. I $D(DIRUT) S LREND=1
I LREND Q
;
I LRPAGE!($E(IOST,1,2)="C-") W @IOF
S LRPAGE=LRPAGE+1
W "Group verification report - Verify with",$S(LRVRFYAL:"",1:"out")," flags"
W ?(IOM-27)," Date: ",LRDT
W !,"Load/Work list: ",LRLLNM," Panel: ",LRPANEL,?(IOM-27)," Page: ",LRPAGE
;
; Check if task has been asked to stop.
I $D(ZTQUEUED),$$S^%ZTLOAD D Q
. S (LREND,ZTSTOP)=1
. W !!,"*** Report requested to stop by TaskMan ***"
. W !,"*** Task #",$G(ZTQUEUED,"UNKNOWN")," stopped at ",$$HTE^XLFDT($H)," ***"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRGV 6063 printed Dec 13, 2024@02:14:58 Page 2
LRGV ;DALIO/RWF - INSTRUMENT GROUP VERIFY DATA ;2/5/91 13:26
+1 ;;5.2;LAB SERVICE;**269,411,519**;Sep 27, 1994;Build 16
+2 ;
+3 NEW LRANYAA,LRDUZ,LRUID,LRVBY,LRGVP
+4 ;
+5 DO ^LRGVK
DO ^LRPARAM
+6 IF $GET(LREND)
DO END
QUIT
+7 ;
+8 SET U="^"
SET LRSS="CH"
SET LROUTINE=$PIECE(^LAB(69.9,1,3),U,2)
SET (LRANYAA,LRUID,LRVBY)=""
+9 ;
+10 ; Get user's initials to use to verify results
+11 SET X=DUZ
DO DUZ^LRX
+12 XECUTE ^%ZOSF("EOFF")
+13 NEW DIR
+14 SET DIR(0)="FAO^1:10"
SET DIR("A")="Please enter your initials to verify: "
+15 DO ^DIR
KILL DIR
+16 XECUTE ^%ZOSF("EON")
+17 IF $DATA(DIRUT)!(Y'=LRUSI)
DO END
QUIT
+18 ;
+19 DO ^LRGP1
+20 IF LREND
DO END
QUIT
+21 ;
+22 DO COM
+23 IF LREND
DO NOP
DO END
QUIT
+24 ;
+25 SET %ZIS="Q"
DO ^%ZIS
+26 IF POP
DO END
QUIT
+27 ;
+28 IF $DATA(IO("Q"))
Begin DoDot:1
+29 NEW ZTDTH,ZTRTN,ZTSAVE,ZTDESC
+30 KILL IO("Q")
+31 ;LRGVP = indicates to downstream routines that sending to a printer
+32 SET LRGVP=1
+33 SET ZTRTN="DQ^LRGV"
SET ZTSAVE("LR*")=""
SET ZTSAVE("^TMP(""LR"",$J,")=""
SET ZTDESC="Group verify (EA, EL, EW)"
+34 DO ^%ZTLOAD
+35 USE IO(0)
WRITE !,"Task ",$SELECT($GET(ZTSK):ZTSK,1:"NOT")," Queued"
+36 DO END
End DoDot:1
QUIT
+37 ;
DQ ;
+1 USE IO
+2 SET LRNOW=$$NOW^XLFDT
SET LRDT=$$FMTE^XLFDT(LRNOW,"1M")
SET (LREND,LRPAGE)=0
+3 SET LRLLNM=$PIECE(^LRO(68.2,LRLL,0),"^")
+4 DO HDR
+5 if LRWT="T"
DO LRTRAY
if LRWT="A"
DO ACCLST
if LRWT="M"
DO SEQ
if LRWT="W"
DO WRKLST
+6 IF $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
+7 ;
END ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF '$TEST
DO ^%ZISC
+3 DO ^LRGVK
+4 KILL LRCSQQ,LRLLNM,LRNGS,LRPAGE
+5 QUIT
+6 ;
+7 ;
ACCLST ; Verify by accession number/UID
+1 ;
+2 SET LRVWLE=""
+3 ;
+4 ; Verify by accession number
+5 IF LRVBY=1
Begin DoDot:1
+6 SET LRAN=LRFAN
+7 FOR
SET LRAN=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN))
if LRAN<1!(LRAN>LRLIX)
QUIT
DO ACC2
if LREND
QUIT
+8 IF $LENGTH(LRVWLE)
Begin DoDot:2
+9 SET $PIECE(^LRO(68,LRAA,1,LRAD,2),"^")=LRUSI
+10 SET $PIECE(^LRO(68,LRAA,1,LRAD,2),"^",4)=LRVWLE
End DoDot:2
End DoDot:1
+11 ;
+12 ; Verify by UID
+13 IF LRVBY=2
Begin DoDot:1
+14 SET LRANYAA=+$PIECE($GET(^LRO(68.2,LRLL,10,LRPROF,0)),"^",3)
SET LRUID=""
+15 FOR
DO NEXT^LRVRA
if LRUID=""
QUIT
DO ACC2
if LREND
QUIT
End DoDot:1
+16 ;
+17 QUIT
+18 ;
+19 ;
ACC2 ; Only select those entries in ^LAH that match the accession area and
+1 ; date selected by the user.
+2 ;
+3 IF $Y>(IOSL-10)
DO HDR
if LREND
QUIT
+4 WRITE !
DO DASH^LRX
+5 WRITE !,"Accession #: ",LRAN
+6 IF LRVBY=2
Begin DoDot:1
+7 WRITE " [UID: ",LRUID,"]"
+8 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
Begin DoDot:2
+9 WRITE " No accession on file for this UID."
End DoDot:2
QUIT
+10 WRITE " <",$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.2)),"^"),">"
End DoDot:1
+11 ;
+12 IF '$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,3)),"^",3)
Begin DoDot:1
+13 WRITE " Has not been received. Unable to verify."
End DoDot:1
QUIT
+14 ;
+15 IF +^LRO(68,LRAA,1,LRAD,1,LRAN,3)>$$NOW^XLFDT
Begin DoDot:1
+16 WRITE " Has a collection time in the future. Unable to verify."
End DoDot:1
QUIT
+17 ;
+18 IF $ORDER(^LAH(LRLL,1,"C",LRAN,0))<1
Begin DoDot:1
+19 WRITE " NO Instrument Data Found."
End DoDot:1
QUIT
+20 ;
+21 SET LRSQ=0
+22 FOR
SET LRSQ=$ORDER(^LAH(LRLL,1,"C",LRAN,LRSQ))
if LRSQ<1
QUIT
Begin DoDot:1
+23 SET X=^LAH(LRLL,1,LRSQ,0)
+24 IF LRAA'=$PIECE(X,"^",3)!(LRAD'=$PIECE(X,"^",4))
QUIT
+25 SET LRAN=$PIECE(X,"^",5)
+26 IF LRAN
DO STUFF^LRGV1
End DoDot:1
if LREND
QUIT
+27 QUIT
+28 ;
+29 ;
LRTRAY ; Verify by tray/cup
+1 ;
+2 FOR LRTRAY=LRFTRAY:1:LRLTRAY
Begin DoDot:1
+3 IF $Y>(IOSL-10)
DO HDR
if LREND
QUIT
+4 WRITE !
DO DASH^LRX
+5 WRITE !!,"Start TRAY: ",LRTRAY
+6 DO TR2
End DoDot:1
if LREND
QUIT
+7 QUIT
+8 ;
+9 ;
TR2 ; Verify by tray/cup
+1 ; Only select those entries in ^LAH that match the accession area and date
+2 ; selected by the user.
+3 NEW LRSC,LREC,X
+4 ;
+5 ; Figure out starting and ending cups for this tray
+6 SET LRSC=$SELECT(LRTRAY=LRFTRAY:LRFCUP,1:1)
+7 SET LREC=$SELECT(LRTRAY=LRLTRAY:LRLCUP,1:LRMAXCUP)
+8 ;
+9 FOR LRCUP=LRSC:1:LREC
Begin DoDot:1
+10 SET LRITC=LRTRAY_";"_LRCUP
+11 IF $Y>(IOSL-10)
DO HDR
if LREND
QUIT
+12 WRITE !
DO DASH^LRX
+13 WRITE !,"Tray ",$JUSTIFY(LRTRAY,3)," Cup ",$JUSTIFY(LRCUP,3)
+14 IF $ORDER(^LAH(LRLL,1,"B",LRITC,0))<1
WRITE ?35,"No Instrument Data Found"
QUIT
+15 ;
+16 SET LRSQ=0
+17 FOR
SET LRSQ=$ORDER(^LAH(LRLL,1,"B",LRITC,LRSQ))
if LRSQ<1
QUIT
Begin DoDot:2
+18 IF '$DATA(^LAH(LRLL,1,+LRSQ,0))
Begin DoDot:3
+19 KILL ^LAH(LRLL,1,"B",LRTIC,LRSQ)
+20 WRITE ?35,"No Instrument Data Found"
End DoDot:3
QUIT
+21 SET X=^LAH(LRLL,1,LRSQ,0)
+22 IF LRAA'=$PIECE(X,"^",3)!(LRAD'=$PIECE(X,"^",4))
QUIT
+23 SET LRAN=$PIECE(X,"^",5)
+24 IF LRAN
DO STUFF^LRGV1
QUIT
+25 WRITE ?35," Does not have a link to an Accession."
End DoDot:2
if LREND
QUIT
End DoDot:1
if LREND
QUIT
+26 QUIT
+27 ;
+28 ;
SEQ ; Verify by sequence number
+1 ; Only select those entries in ^LAH that match the accession area and date
+2 ; selected by the user.
+3 ;
+4 NEW X
+5 ;
+6 SET LRSQ=LRSQ-1
+7 FOR
SET LRSQ=$ORDER(^LAH(LRLL,1,LRSQ))
if LRSQ<1!(LRSQ>LRESEQ)
QUIT
Begin DoDot:1
+8 IF $Y>(IOSL-10)
DO HDR
if LREND
QUIT
+9 WRITE !
DO DASH^LRX
+10 SET X=^LAH(LRLL,1,LRSQ,0)
+11 IF LRAA'=$PIECE(X,"^",3)!(LRAD'=$PIECE(X,"^",4))
QUIT
+12 SET LRAN=$PIECE(X,"^",5)
+13 IF LRAN
DO STUFF^LRGV1
QUIT
+14 WRITE !!,"SEQ: ",LRSQ,". Does not have a link to an Accession."
End DoDot:1
if LREND
QUIT
+15 QUIT
+16 ;
+17 ;
WRKLST ; Verify by worklist
+1 ; Only select those entries in file #68.2 that match the profile selected
+2 ; by the user.
+3 ;
+4 NEW X
+5 ;
+6 SET LRCUP=LRCUP-1
+7 FOR
SET LRCUP=$ORDER(^LRO(68.2,LRLL,1,1,1,LRCUP))
if 'LRCUP!(LRCUP>LRECUP)
QUIT
Begin DoDot:1
+8 IF $Y>(IOSL-10)
DO HDR
if LREND
QUIT
+9 WRITE !
DO DASH^LRX
+10 SET X=^LRO(68.2,LRLL,1,1,1,LRCUP,0)
+11 IF $PIECE(X,"^",4)
IF $PIECE(X,"^",4)'=LRPROF
QUIT
+12 SET LRAA=$PIECE(X,"^")
SET LRAD=$PIECE(X,"^",2)
SET LRAN=$PIECE(X,"^",3)
+13 WRITE !,"Sequence #",$JUSTIFY(LRCUP,4)
+14 IF $ORDER(^LAH(LRLL,1,"C",+LRAN,0))<1
WRITE ?35,"No Instrument Data Found"
QUIT
+15 ;
+16 SET LRSQ=0
+17 FOR
SET LRSQ=$ORDER(^LAH(LRLL,1,"C",LRAN,LRSQ))
if LRSQ<1
QUIT
DO STUFF^LRGV1
if LREND
QUIT
End DoDot:1
if LREND
QUIT
+18 QUIT
+19 ;
+20 ;
COM ; Ask common questions
+1 ;
+2 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+3 ;
+4 SET LRVRFYAL=0
+5 IF $DATA(^XUSEC("LRSUPER",DUZ))!1
Begin DoDot:1
+6 SET DIR(0)="YAO"
SET DIR("B")="NO"
+7 SET DIR("A",1)="Verify accessions specified, even if"
+8 SET DIR("A")=" DELTA check or CRITICAL range flag? "
+9 DO ^DIR
+10 IF $DATA(DIRUT)
SET LREND=1
QUIT
+11 SET LRVRFYAL=Y
End DoDot:1
+12 ;
+13 IF LREND
QUIT
+14 ;
+15 KILL DIR
+16 SET DIR(0)="YO"
SET DIR("A")="Everything OK"
SET DIR("B")="YES"
+17 DO ^DIR
+18 IF $DATA(DIRUT)!(Y'=1)
SET LREND=1
+19 QUIT
+20 ;
+21 ;
NOP ;
+1 WRITE !!,"NOTHING VERIFIED"
+2 QUIT
+3 ;
+4 ;
HDR ;
+1 ;
+2 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+3 ;
+4 IF $EXTRACT(IOST,1,2)="C-"
IF '$DATA(ZTQUEUED)
IF LRPAGE
Begin DoDot:1
+5 SET DIR(0)="E"
DO ^DIR
+6 IF $DATA(DIRUT)
SET LREND=1
End DoDot:1
+7 IF LREND
QUIT
+8 ;
+9 IF LRPAGE!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
+10 SET LRPAGE=LRPAGE+1
+11 WRITE "Group verification report - Verify with",$SELECT(LRVRFYAL:"",1:"out")," flags"
+12 WRITE ?(IOM-27)," Date: ",LRDT
+13 WRITE !,"Load/Work list: ",LRLLNM," Panel: ",LRPANEL,?(IOM-27)," Page: ",LRPAGE
+14 ;
+15 ; Check if task has been asked to stop.
+16 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
Begin DoDot:1
+17 SET (LREND,ZTSTOP)=1
+18 WRITE !!,"*** Report requested to stop by TaskMan ***"
+19 WRITE !,"*** Task #",$GET(ZTQUEUED,"UNKNOWN")," stopped at ",$$HTE^XLFDT($HOROLOG)," ***"
End DoDot:1
QUIT
+20 QUIT
