- LRVRW ;SLC/CJS-LAB ROUTINE DATA VERIFICATION BY WORKLIST ;6/2/86 9:18 AM [ 04/10/2003 12:10 PM ]
- ;;5.2T9;LR;**1004,1018**;Nov 17, 2004
- ;;5.2;LAB SERVICE;**153,221**;Sep 27, 1994
- 1 D INIT^LRVR G QUIT:$G(LREND)
- S LRTRAY=1,LRCUP=0,%H=$H-60 D NEXT D YMD^LRX S LRTM60=9999999-X
- L10 K LRTEST,C5,LRSET,LRLDT,DIC,LRNM,LRNG,LRDEL,T,LRFP,LRAB,LRVER,Y,Z
- D WLN G END:$G(LREND) S X=^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,0),LRAA=+X,LRAD=$P(X,U,2),LRAN=$P(X,U,3) I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) W " ACCESSION MISSING" G L10
- D FIND I '$D(LRPRGSQ) D ISEQ
- I $D(^LAH(LRLL,1,LRSQ,0)),$P(^(0),U,3),($P(^(0),U,5)'=LRAN) W !!,"Can't use. Entry has data from accession # ",$P(^(0),U,5),!,"Suggest you Clear instrument/worklist data." D NEXT G L10
- S X=^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRORU3=$G(^(.3))
- S LRODT=$P(X,U,4),LRSN=$P(X,U,5),LRDFN=+X,LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX
- I $G(LREND) S LREND=0 W !?5," Error in Patient Lookup",! D NEXT G L10
- ;W !,PNM,?40,SSN
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- W !,PNM,?40,HRCN ;IHS/ANMC/CLS 08/18/96
- ;----- END IHS MODIFICATIONS
- D VER^LRVR1 G END:$G(LREND) D NEXT
- G L10
- YN R X:DTIME Q:X=""!(X["N")!(X["Y") W !,"Answer 'Y' or 'N': " G YN
- WLN G WLN2:LRTYPE S LRTRAY=1 W !!!,"SEQUENCE #: ",LRCUP,"//" R X3:DTIME S:X3="" X3=LRCUP S:X3[U LREND=1 Q:LREND
- I X3["?" W !,"ENTER A VALID SEQUENCE NUMBER" G WLN
- I '$D(^LRO(68.2,LRLL,1,LRTRAY,1,X3,0)) W !,"SEQUENCE NUMBER DOESN'T EXIST" G WLN
- S LRCUP=X3 Q
- WLN2 W !!!,"TRAY: ",LRTRAY,"//" R X2:DTIME S:X2="" X2=LRTRAY S:X2[U LREND=1 Q:LREND W " CUP: ",LRCUP,"//" R X3:DTIME S:X3="" X3=LRCUP S:X3[U LREND=1 Q:LREND
- I X2_X3["?" W !,"ENTER A VALID TRAY, CUP FROM THE LOAD/WORK LIST" G WLN2
- I '$D(^LRO(68.2,LRLL,1,X2,1,X3,0)) W !,"TRAY, CUP DOESN'T EXIST" G WLN2
- S LRTRAY=X2,LRCUP=X3 Q
- Q
- END I $D(LRAN),$D(LRAD) S:'$D(^LRO(68,LRAA,1,LRAD,2)) ^(2)="^^" S ^(2)=$P(^(2),U,1,3)_U_LRAN_U_$P(^(2),U,5,99),LREND=1
- G QUIT
- NEXT S X2=LRTRAY,X3=LRCUP
- NX2 S X3=$O(^LRO(68.2,LRLL,1,X2,1,X3)) I X3<1 S X3=0,X2=$O(^LRO(68.2,LRLL,1,X2)) G:X2>0 NX2
- I X3<1&(X2<1) W !,"LAST IN LIST" S (LRTRAY,LRCUP)=U Q
- S:X2>0 LRTRAY=X2 S:X3>0 LRCUP=X3 Q
- LIST W " the following tests: " F I=0:0 S I=$O(LRTST(I)) Q:I<1 W !,?10,$P(LRTST(I),"^",1)
- Q
- STOP S LREND=1 Q
- ISEQ ;
- L +^LAH(LRLL)
- S (^LAH(LRLL),LRSQ)=1+$G(^LAH(LRLL))
- S ^LAH(LRLL,1,LRSQ,0)=LRTRAY_U_LRCUP_U_LRAA_U_LRAD_U_LRAN_"^^MANUAL"
- D UID^LAGEN(LRLL,LRSQ,$P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^"))
- D UPDT^LAGEN(LRLL,LRSQ)
- S ^LAH(LRLL,1,"B",(+LRTRAY)_";"_(+LRCUP),LRSQ)=""
- S ^LAH(LRLL,1,"C",LRAN,LRSQ)=""
- L -^LAH(LRLL)
- S ^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,4,LRSQ)=""
- Q
- FIND K LRPRGSQ S N=0,LRTRCP=LRTRAY_";"_LRCUP F I=0:0 S I=$O(^LAH(LRLL,1,"B",LRTRCP,I)) Q:I="" S N=N+1,LRSQ=I,LRPRGSQ(I)="" W !,?5,I
- F I=0:0 S I=$O(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,4,I)) Q:I="" I $D(^LAH(LRLL,1,I,0)),'$D(LRPRGSQ(I)) S N=N+1,LRPRGSQ(I)=""
- T3 S X=N I N=0 W !,"No data for that tray & cup" Q
- I N>1 R !,"Choose sequence number: ",X:DTIME Q:'$T I X["?"!(X'?.N) W !,"Enter a number" G T3
- I X["^"!(X="") K LRPRGSQ Q
- S:N'=1 LRSQ=X I '$D(^LAH(LRLL,1,LRSQ,0)) K LRPRGSQ(LRSQ) W !,"No data there"
- Q
- QUIT I $D(LRCSQ),'$O(^XTMP("LRCAP",LRCSQ,DUZ,0)) K ^XTMP("LRCAP",LRCSQ,DUZ)
- E I $D(LRAA) D:$P(LRPARAM,U,14)&($P($G(^LRO(68,+LRAA,0)),U,16)) STD^LRCAPV
- K LRORU3 D ^LRGVK,^LRCAPV2
- Q
- LRVRW ;SLC/CJS-LAB ROUTINE DATA VERIFICATION BY WORKLIST ;6/2/86 9:18 AM [ 04/10/2003 12:10 PM ]
- +1 ;;5.2T9;LR;**1004,1018**;Nov 17, 2004
- +2 ;;5.2;LAB SERVICE;**153,221**;Sep 27, 1994
- 1 DO INIT^LRVR
- IF $GET(LREND)
- GOTO QUIT
- +1 SET LRTRAY=1
- SET LRCUP=0
- SET %H=$HOROLOG-60
- DO NEXT
- DO YMD^LRX
- SET LRTM60=9999999-X
- L10 KILL LRTEST,C5,LRSET,LRLDT,DIC,LRNM,LRNG,LRDEL,T,LRFP,LRAB,LRVER,Y,Z
- +1 DO WLN
- IF $GET(LREND)
- GOTO END
- SET X=^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,0)
- SET LRAA=+X
- SET LRAD=$PIECE(X,U,2)
- SET LRAN=$PIECE(X,U,3)
- IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
- WRITE " ACCESSION MISSING"
- GOTO L10
- +2 DO FIND
- IF '$DATA(LRPRGSQ)
- DO ISEQ
- +3 IF $DATA(^LAH(LRLL,1,LRSQ,0))
- IF $PIECE(^(0),U,3)
- IF ($PIECE(^(0),U,5)'=LRAN)
- WRITE !!,"Can't use. Entry has data from accession # ",$PIECE(^(0),U,5),!,"Suggest you Clear instrument/worklist data."
- DO NEXT
- GOTO L10
- +4 SET X=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
- SET LRORU3=$GET(^(.3))
- +5 SET LRODT=$PIECE(X,U,4)
- SET LRSN=$PIECE(X,U,5)
- SET LRDFN=+X
- SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- DO PT^LRX
- +6 IF $GET(LREND)
- SET LREND=0
- WRITE !?5," Error in Patient Lookup",!
- DO NEXT
- GOTO L10
- +7 ;W !,PNM,?40,SSN
- +8 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +9 ;IHS/ANMC/CLS 08/18/96
- WRITE !,PNM,?40,HRCN
- +10 ;----- END IHS MODIFICATIONS
- +11 DO VER^LRVR1
- IF $GET(LREND)
- GOTO END
- DO NEXT
- +12 GOTO L10
- YN READ X:DTIME
- IF X=""!(X["N")!(X["Y")
- QUIT
- WRITE !,"Answer 'Y' or 'N': "
- GOTO YN
- WLN IF LRTYPE
- GOTO WLN2
- SET LRTRAY=1
- WRITE !!!,"SEQUENCE #: ",LRCUP,"//"
- READ X3:DTIME
- IF X3=""
- SET X3=LRCUP
- IF X3[U
- SET LREND=1
- IF LREND
- QUIT
- +1 IF X3["?"
- WRITE !,"ENTER A VALID SEQUENCE NUMBER"
- GOTO WLN
- +2 IF '$DATA(^LRO(68.2,LRLL,1,LRTRAY,1,X3,0))
- WRITE !,"SEQUENCE NUMBER DOESN'T EXIST"
- GOTO WLN
- +3 SET LRCUP=X3
- QUIT
- WLN2 WRITE !!!,"TRAY: ",LRTRAY,"//"
- READ X2:DTIME
- IF X2=""
- SET X2=LRTRAY
- IF X2[U
- SET LREND=1
- IF LREND
- QUIT
- WRITE " CUP: ",LRCUP,"//"
- READ X3:DTIME
- IF X3=""
- SET X3=LRCUP
- IF X3[U
- SET LREND=1
- IF LREND
- QUIT
- +1 IF X2_X3["?"
- WRITE !,"ENTER A VALID TRAY, CUP FROM THE LOAD/WORK LIST"
- GOTO WLN2
- +2 IF '$DATA(^LRO(68.2,LRLL,1,X2,1,X3,0))
- WRITE !,"TRAY, CUP DOESN'T EXIST"
- GOTO WLN2
- +3 SET LRTRAY=X2
- SET LRCUP=X3
- QUIT
- +4 QUIT
- END IF $DATA(LRAN)
- IF $DATA(LRAD)
- IF '$DATA(^LRO(68,LRAA,1,LRAD,2))
- SET ^(2)="^^"
- SET ^(2)=$PIECE(^(2),U,1,3)_U_LRAN_U_$PIECE(^(2),U,5,99)
- SET LREND=1
- +1 GOTO QUIT
- NEXT SET X2=LRTRAY
- SET X3=LRCUP
- NX2 SET X3=$ORDER(^LRO(68.2,LRLL,1,X2,1,X3))
- IF X3<1
- SET X3=0
- SET X2=$ORDER(^LRO(68.2,LRLL,1,X2))
- IF X2>0
- GOTO NX2
- +1 IF X3<1&(X2<1)
- WRITE !,"LAST IN LIST"
- SET (LRTRAY,LRCUP)=U
- QUIT
- +2 IF X2>0
- SET LRTRAY=X2
- IF X3>0
- SET LRCUP=X3
- QUIT
- LIST WRITE " the following tests: "
- FOR I=0:0
- SET I=$ORDER(LRTST(I))
- IF I<1
- QUIT
- WRITE !,?10,$PIECE(LRTST(I),"^",1)
- +1 QUIT
- STOP SET LREND=1
- QUIT
- ISEQ ;
- +1 LOCK +^LAH(LRLL)
- +2 SET (^LAH(LRLL),LRSQ)=1+$GET(^LAH(LRLL))
- +3 SET ^LAH(LRLL,1,LRSQ,0)=LRTRAY_U_LRCUP_U_LRAA_U_LRAD_U_LRAN_"^^MANUAL"
- +4 DO UID^LAGEN(LRLL,LRSQ,$PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),"^"))
- +5 DO UPDT^LAGEN(LRLL,LRSQ)
- +6 SET ^LAH(LRLL,1,"B",(+LRTRAY)_";"_(+LRCUP),LRSQ)=""
- +7 SET ^LAH(LRLL,1,"C",LRAN,LRSQ)=""
- +8 LOCK -^LAH(LRLL)
- +9 SET ^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,4,LRSQ)=""
- +10 QUIT
- FIND KILL LRPRGSQ
- SET N=0
- SET LRTRCP=LRTRAY_";"_LRCUP
- FOR I=0:0
- SET I=$ORDER(^LAH(LRLL,1,"B",LRTRCP,I))
- IF I=""
- QUIT
- SET N=N+1
- SET LRSQ=I
- SET LRPRGSQ(I)=""
- WRITE !,?5,I
- +1 FOR I=0:0
- SET I=$ORDER(^LRO(68.2,LRLL,1,LRTRAY,1,LRCUP,4,I))
- IF I=""
- QUIT
- IF $DATA(^LAH(LRLL,1,I,0))
- IF '$DATA(LRPRGSQ(I))
- SET N=N+1
- SET LRPRGSQ(I)=""
- T3 SET X=N
- IF N=0
- WRITE !,"No data for that tray & cup"
- QUIT
- +1 IF N>1
- READ !,"Choose sequence number: ",X:DTIME
- IF '$TEST
- QUIT
- IF X["?"!(X'?.N)
- WRITE !,"Enter a number"
- GOTO T3
- +2 IF X["^"!(X="")
- KILL LRPRGSQ
- QUIT
- +3 IF N'=1
- SET LRSQ=X
- IF '$DATA(^LAH(LRLL,1,LRSQ,0))
- KILL LRPRGSQ(LRSQ)
- WRITE !,"No data there"
- +4 QUIT
- QUIT IF $DATA(LRCSQ)
- IF '$ORDER(^XTMP("LRCAP",LRCSQ,DUZ,0))
- KILL ^XTMP("LRCAP",LRCSQ,DUZ)
- +1 IF '$TEST
- IF $DATA(LRAA)
- IF $PIECE(LRPARAM,U,14)&($PIECE($GET(^LRO(68,+LRAA,0)),U,16))
- DO STD^LRCAPV
- +2 KILL LRORU3
- DO ^LRGVK
- DO ^LRCAPV2
- +3 QUIT
