LRUER ;AVAMC/REG/CYM - ERROR TRACKING ;2/18/98 07:03 ;
;;5.2;LAB SERVICE;**1018,1030,1031**;NOV 1, 1997
;
;;VA LR Patch(s): 201,290
;
;;
;; Note: LR*5.2*1031 restores LR*5.2*1018 & LR*5.2*1030 modifications
;;
ASK ; W !!?5,"Find accessions with comments containing",!?20,"1. reported incorrectly as",!?20,"2. specimen rejected",!?5,"Select 1 or 2: " R X:DTIME G:X=""!(X[U) END I +X'=X!(X<1)!(X>2) G ASK
; S LRC(2)="",LRC(1)=$S(X=1:"reported incorrectly as",X=2:"specimen rejected",1:"") W !!,"List accessions with deleted comments " S %=2 D YN^LRU G:%<1 END S:%=1 LRC(2)=1
; ------ BEGIN IHS/OIT/MKK - LR*5.2*1030
W !!?5,"Find accessions with comments containing",!?20,"1. previously reported as",!?20,"2. specimen rejected",!?5,"Select 1 or 2: " R X:DTIME G:X=""!(X[U) END I +X'=X!(X<1)!(X>2) G ASK
S LRC(2)="",LRC(3)="DUMMYZZZZ",LRC(1)=$S(X=1:"previously reported as",X=2:"specimen rejected",1:"") S:X=1 LRC(3)="reported incorrectly as" W !!,"List accessions with deleted comments " S %=2 D YN^LRU G:%<1 END S:%=1 LRC(2)=1
; ------ END IHS/OIT/MKK - LR*5.2*1030
D B^LRU G:Y<0 END S LRS=LRSDT-.01,LRE=LRLDT+.99,LRLDT=9999998-LRLDT,LRSDT=9999999-LRSDT
W !!,"Do you want list of tests ordered for each accession with errors " S %=1 D YN^LRU G:%<1 END S LRF=$S(%=1:1,1:0)
W !!,"New page for each accession area " S %=1 D YN^LRU G:%<1 END S LRL=$S(%=1:1,1:0)
W ! S ZTRTN="QUE^LRUER" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO
N A,B,C,D,E,G,J,LRDFN,LRX,V,X,Y,Z
K ^TMP($J),^TMP("LRDFN",$J)
S LRQ(1)=^DD("SITE"),(LRQ,LR("Q"))=0
D L^LRU,H S LR("F")=1
F B=LRS:0 S B=$O(^LRO(69,B)) Q:'B!(B>LRE) D
. N X,I
. S I=0 F S I=$O(^LRO(69,B,1,I)) Q:'I S X=+$G(^(I,0)) I X D
. . S ^TMP("LRDFN",$J,X)=""
F LRDFN=0:0 S LRDFN=$O(^TMP("LRDFN",$J,LRDFN)) Q:'LRDFN S LRI=LRLDT F A=0:0 S LRI=$O(^LR(LRDFN,"CH",LRI)) Q:'LRI!(LRI>LRSDT) D A
K ^TMP("LRDFN",$J) D W,END^LRUTL,END Q
A I LRC(2),$O(^LR(LRDFN,"CH",LRI,1,"AC",0)) D SET Q
; F B=0:0 S B=$O(^LR(LRDFN,"CH",LRI,1,B)) Q:'B I ^(B,0)[LRC(1) D SET Q
F B=0:0 S B=$O(^LR(LRDFN,"CH",LRI,1,B)) Q:'B I $G(^LR(LRDFN,"CH",LRI,1,B,0))[LRC(1)!($G(^LR(LRDFN,"CH",LRI,1,B,0))[LRC(3)) D SET Q ; IHS/OIT/MKK - LR*5.2*1030 - Get rid of Naked References
Q
SET S X=^LR(LRDFN,"CH",LRI,0),Y=$P(X,"^",6) S:Y="" Y="?? ?? ??" S ^TMP($J,$P(Y," "),$P(Y," ",2,3),+X,LRDFN,LRI)=$P(X,"^",5) Q
Q
W S (LRA,LRC)="" F A=0:0 S LRA=$O(^TMP($J,LRA)) Q:LRA=""!(LR("Q")) S LRC=LRC+1 D:LRL&(LRC>1) H Q:LR("Q") S LRB="" F B=0:0 S LRB=$O(^TMP($J,LRA,LRB)) Q:LRB=""!(LR("Q")) D W1
Q
W1 F LRT=0:0 S LRT=$O(^TMP($J,LRA,LRB,LRT)) Q:'LRT!(LR("Q")) F LRDFN=0:0 S LRDFN=$O(^TMP($J,LRA,LRB,LRT,LRDFN)) Q:'LRDFN!(LR("Q")) D X
Q
X F LRI=0:0 S LRI=$O(^TMP($J,LRA,LRB,LRT,LRDFN,LRI)) Q:'LRI!(LR("Q")) S X=+^(LRI),LRS=$P($G(^LAB(61,X,0)),"^") D P
Q
P S LRDATE=$$FMTE^XLFDT(LRT,"M")
; S X=^LR(LRDFN,0),Y=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),V=@(X_Y_",0)"),LRP=$P(V,"^"),SSN=$P(V,"^",9) D SSN^LRU
; D:$Y>(IOSL-6) H W !!,LRA_" "_LRB,?14,LRDATE,?34,LRP," ",SSN(1),?67,LRS D:LRF TST Q:LR("Q")
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restoring LR*5.2*1018 changes
S X=^LR(LRDFN,0),(DFN,Y)=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),V=@(X_Y_",0)"),LRP=$P(V,"^"),SSN=$P(V,"^",9) D SSN^LRU ;IHS/ANMC/CLS 08/18/96
D:$Y>(IOSL-6) H W !!,LRA_" "_LRB,?14,LRDATE,?34,LRP," ",HRCN,?67,LRS D:LRF TST Q:LR("Q") ;IHS/ANMC/CLS 08/18/96
; ----- END IHS/MSC/MKK - LR*5.2*1031
F B=0:0 S B=$O(^LR(LRDFN,"CH",LRI,1,B)) Q:'B!(LR("Q")) S B(1)=^(B,0) D:$Y>(IOSL-6) H1 Q:LR("Q") W !?5,B(1)
F B=0:0 S B=$O(^LR(LRDFN,"CH",LRI,1,"AC",B)) Q:'B!(LR("Q")) S C="" F E=0:0 S C=$O(^LR(LRDFN,"CH",LRI,1,"AC",B,C)) Q:C="" D:$Y>(IOSL-6) H1 Q:LR("Q") D P1
Q
P1 S X=$G(^VA(200,B,0)) W !?5,$P(^LR(LRDFN,"CH",LRI,1,"AC",B,C),"^",3) W:$X>60 ! W " (deleted by ",$S($P(X,"^",2)]"":$P(X,"^",2),1:$P(X,",")),")" Q
;
TST S:'$D(LR(LRA)) LR(LRA)=+$O(^LRO(68,"B",LRA,0)) S X=$P(^LRO(68,LR(LRA),0),"^",3),Z=$P(LRB," ",2),G=$E(LRT,1,3) S:X="D" G=G_$P(LRB," ")
E S G=$S(X="Y":G_"0000",X="M":G_$E($P(LRB," "),1,2)_"00",1:G)
S (C,E,E(1))=0 F E(1)=0:0 S C=$O(^LRO(68,LR(LRA),1,G,1,Z,4,C)) Q:'C!(LR("Q")) S LRX=^(C,0) I $P(^LAB(60,C,0),U,4)'="WK" D B
Q
B S E=E+1,J=$P(LRX,U,4),J=$S(J:$P($G(^VA(200,J,0)),"^",2),1:J) D:$Y>(IOSL-6) H2 Q:LR("Q") W ! W:E=1 "Test(s) ordered:" W ?18,$P($G(^LAB(60,C,0)),"^"),?49,"Tech: ",J Q
;
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
; D F^LRU W !,LRC(1) W:$L(LRC(1))>44 ! W " From: ",LRSTR," To: ",LRLST,!,"Acc #",?14,"Date/Time",?34,"Name/SSN",?67,"Specimen",!,LR("%") Q
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restoring LR*5.2*1018 changes
D F^LRU W !,LRC(1) W:$L(LRC(1))>44 ! W " From: ",LRSTR," To: ",LRLST,!,"Acc #",?14,"Date/Time",?34,"Name/HRCN",?67,"Specimen",!,LR("%") Q ;IHS/ANMC/CLS 08/18/96
; ----- END IHS/MSC/MKK - LR*5.2*1031
H1 ; D H Q:LR("Q") W !,LRA," ",LRB,?14,LRDATE,?34,LRP," ",SSN(1)," ",LRS Q
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restoring LR*5.2*1018 changes
D H Q:LR("Q") W !,LRA," ",LRB,?14,LRDATE,?34,LRP," ",HRCN," ",LRS Q ;IHS/ANMC/CLS 08/18/96
; ----- END IHS/MSC/MKK - LR*5.2*1031
H2 D H1 Q:LR("Q") W !,"Test(s) ordered:" S E=2 Q
Q
END D V^LRU Q
LRUER ;AVAMC/REG/CYM - ERROR TRACKING ;2/18/98 07:03 ;
+1 ;;5.2;LAB SERVICE;**1018,1030,1031**;NOV 1, 1997
+2 ;
+3 ;;VA LR Patch(s): 201,290
+4 ;
+5 ;;
+6 ;; Note: LR*5.2*1031 restores LR*5.2*1018 & LR*5.2*1030 modifications
+7 ;;
ASK ; W !!?5,"Find accessions with comments containing",!?20,"1. reported incorrectly as",!?20,"2. specimen rejected",!?5,"Select 1 or 2: " R X:DTIME G:X=""!(X[U) END I +X'=X!(X<1)!(X>2) G ASK
+1 ; S LRC(2)="",LRC(1)=$S(X=1:"reported incorrectly as",X=2:"specimen rejected",1:"") W !!,"List accessions with deleted comments " S %=2 D YN^LRU G:%<1 END S:%=1 LRC(2)=1
+2 ; ------ BEGIN IHS/OIT/MKK - LR*5.2*1030
+3 WRITE !!?5,"Find accessions with comments containing",!?20,"1. previously reported as",!?20,"2. specimen rejected",!?5,"Select 1 or 2: "
READ X:DTIME
IF X=""!(X[U)
GOTO END
IF +X'=X!(X<1)!(X>2)
GOTO ASK
+4 SET LRC(2)=""
SET LRC(3)="DUMMYZZZZ"
SET LRC(1)=$SELECT(X=1:"previously reported as",X=2:"specimen rejected",1:"")
IF X=1
SET LRC(3)="reported incorrectly as"
WRITE !!,"List accessions with deleted comments "
SET %=2
DO YN^LRU
IF %<1
GOTO END
IF %=1
SET LRC(2)=1
+5 ; ------ END IHS/OIT/MKK - LR*5.2*1030
+6 DO B^LRU
IF Y<0
GOTO END
SET LRS=LRSDT-.01
SET LRE=LRLDT+.99
SET LRLDT=9999998-LRLDT
SET LRSDT=9999999-LRSDT
+7 WRITE !!,"Do you want list of tests ordered for each accession with errors "
SET %=1
DO YN^LRU
IF %<1
GOTO END
SET LRF=$SELECT(%=1:1,1:0)
+8 WRITE !!,"New page for each accession area "
SET %=1
DO YN^LRU
IF %<1
GOTO END
SET LRL=$SELECT(%=1:1,1:0)
+9 WRITE !
SET ZTRTN="QUE^LRUER"
DO BEG^LRUTL
IF POP!($DATA(ZTSK))
GOTO END
QUE USE IO
+1 NEW A,B,C,D,E,G,J,LRDFN,LRX,V,X,Y,Z
+2 KILL ^TMP($JOB),^TMP("LRDFN",$JOB)
+3 SET LRQ(1)=^DD("SITE")
SET (LRQ,LR("Q"))=0
+4 DO L^LRU
DO H
SET LR("F")=1
+5 FOR B=LRS:0
SET B=$ORDER(^LRO(69,B))
IF 'B!(B>LRE)
QUIT
Begin DoDot:1
+6 NEW X,I
+7 SET I=0
FOR
SET I=$ORDER(^LRO(69,B,1,I))
IF 'I
QUIT
SET X=+$GET(^(I,0))
IF X
Begin DoDot:2
+8 SET ^TMP("LRDFN",$JOB,X)=""
End DoDot:2
End DoDot:1
+9 FOR LRDFN=0:0
SET LRDFN=$ORDER(^TMP("LRDFN",$JOB,LRDFN))
IF 'LRDFN
QUIT
SET LRI=LRLDT
FOR A=0:0
SET LRI=$ORDER(^LR(LRDFN,"CH",LRI))
IF 'LRI!(LRI>LRSDT)
QUIT
DO A
+10 KILL ^TMP("LRDFN",$JOB)
DO W
DO END^LRUTL
DO END
QUIT
A IF LRC(2)
IF $ORDER(^LR(LRDFN,"CH",LRI,1,"AC",0))
DO SET
QUIT
+1 ; F B=0:0 S B=$O(^LR(LRDFN,"CH",LRI,1,B)) Q:'B I ^(B,0)[LRC(1) D SET Q
+2 ; IHS/OIT/MKK - LR*5.2*1030 - Get rid of Naked References
FOR B=0:0
SET B=$ORDER(^LR(LRDFN,"CH",LRI,1,B))
IF 'B
QUIT
IF $GET(^LR(LRDFN,"CH",LRI,1,B,0))[LRC(1)!($GET(^LR(LRDFN,"CH",LRI,1,B,0))[LRC(3))
DO SET
QUIT
+3 QUIT
SET SET X=^LR(LRDFN,"CH",LRI,0)
SET Y=$PIECE(X,"^",6)
IF Y=""
SET Y="?? ?? ??"
SET ^TMP($JOB,$PIECE(Y," "),$PIECE(Y," ",2,3),+X,LRDFN,LRI)=$PIECE(X,"^",5)
QUIT
+1 QUIT
W SET (LRA,LRC)=""
FOR A=0:0
SET LRA=$ORDER(^TMP($JOB,LRA))
IF LRA=""!(LR("Q"))
QUIT
SET LRC=LRC+1
IF LRL&(LRC>1)
DO H
IF LR("Q")
QUIT
SET LRB=""
FOR B=0:0
SET LRB=$ORDER(^TMP($JOB,LRA,LRB))
IF LRB=""!(LR("Q"))
QUIT
DO W1
+1 QUIT
W1 FOR LRT=0:0
SET LRT=$ORDER(^TMP($JOB,LRA,LRB,LRT))
IF 'LRT!(LR("Q"))
QUIT
FOR LRDFN=0:0
SET LRDFN=$ORDER(^TMP($JOB,LRA,LRB,LRT,LRDFN))
IF 'LRDFN!(LR("Q"))
QUIT
DO X
+1 QUIT
X FOR LRI=0:0
SET LRI=$ORDER(^TMP($JOB,LRA,LRB,LRT,LRDFN,LRI))
IF 'LRI!(LR("Q"))
QUIT
SET X=+^(LRI)
SET LRS=$PIECE($GET(^LAB(61,X,0)),"^")
DO P
+1 QUIT
P SET LRDATE=$$FMTE^XLFDT(LRT,"M")
+1 ; S X=^LR(LRDFN,0),Y=$P">P">P">P">P">P">P">P(X,"^",3),(LRDP">P">P">P">P">P">P">PF,X)=$P">P">P">P">P">P">P">P(X,"^",2),X=^DIC(X,0,"GL"),V=@(X_Y_",0)"),LRP">P">P">P">P">P">P">P=$P">P">P">P">P">P">P">P(V,"^"),SSN=$P">P">P">P">P">P">P">P(V,"^",9) D SSN^LRU
+2 ; D:$Y>(IOSL-6) H W !!,LRA_" "_LRB,?14,LRDATE,?34,LRP," ",SSN(1),?67,LRS D:LRF TST Q:LR("Q")
+3 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restoring LR*5.2*1018 changes
+4 ;IHS/ANMC/CLS 08/18/96
SET X=^LR(LRDFN,0)
SET (DFN,Y)=$PIECE(X,"^",3)
SET (LRDPF,X)=$PIECE(X,"^",2)
SET X=^DIC(X,0,"GL")
SET V=@(X_Y_",0)")
SET LRP=$PIECE(V,"^")
SET SSN=$PIECE(V,"^",9)
DO SSN^LRU
+5 ;IHS/ANMC/CLS 08/18/96
IF $Y>(IOSL-6)
DO H
WRITE !!,LRA_" "_LRB,?14,LRDATE,?34,LRP," ",HRCN,?67,LRS
IF LRF
DO TST
IF LR("Q")
QUIT
+6 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+7 FOR B=0:0
SET B=$ORDER(^LR(LRDFN,"CH",LRI,1,B))
IF 'B!(LR("Q"))
QUIT
SET B(1)=^(B,0)
IF $Y>(IOSL-6)
DO H1
IF LR("Q")
QUIT
WRITE !?5,B(1)
+8 FOR B=0:0
SET B=$ORDER(^LR(LRDFN,"CH",LRI,1,"AC",B))
IF 'B!(LR("Q"))
QUIT
SET C=""
FOR E=0:0
SET C=$ORDER(^LR(LRDFN,"CH",LRI,1,"AC",B,C))
IF C=""
QUIT
IF $Y>(IOSL-6)
DO H1
IF LR("Q")
QUIT
DO P1
+9 QUIT
P1 SET X=$GET(^VA(200,B,0))
WRITE !?5,$PIECE(^LR(LRDFN,"CH",LRI,1,"AC",B,C),"^",3)
IF $X>60
WRITE !
WRITE " (deleted by ",$SELECT($PIECE(X,"^",2)]"":$PIECE(X,"^",2),1:$PIECE(X,",")),")"
QUIT
+1 ;
TST IF '$DATA(LR(LRA))
SET LR(LRA)=+$ORDER(^LRO(68,"B",LRA,0))
SET X=$PIECE(^LRO(68,LR(LRA),0),"^",3)
SET Z=$PIECE(LRB," ",2)
SET G=$EXTRACT(LRT,1,3)
IF X="D"
SET G=G_$PIECE(LRB," ")
+1 IF '$TEST
SET G=$SELECT(X="Y":G_"0000",X="M":G_$EXTRACT($PIECE(LRB," "),1,2)_"00",1:G)
+2 SET (C,E,E(1))=0
FOR E(1)=0:0
SET C=$ORDER(^LRO(68,LR(LRA),1,G,1,Z,4,C))
IF 'C!(LR("Q"))
QUIT
SET LRX=^(C,0)
IF $PIECE(^LAB(60,C,0),U,4)'="WK"
DO B
+3 QUIT
B SET E=E+1
SET J=$PIECE(LRX,U,4)
SET J=$SELECT(J:$PIECE($GET(^VA(200,J,0)),"^",2),1:J)
IF $Y>(IOSL-6)
DO H2
IF LR("Q")
QUIT
WRITE !
IF E=1
WRITE "Test(s) ordered:"
WRITE ?18,$PIECE($GET(^LAB(60,C,0)),"^"),?49,"Tech: ",J
QUIT
+1 ;
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
IF LR("Q")
QUIT
+1 ; D F^LRU W !,LRC(1) W:$L(LRC(1))>44 ! W " From: ",LRSTR," To: ",LRLST,!,"Acc #",?14,"Date/Time",?34,"Name/SSN",?67,"Specimen",!,LR("%") Q
+2 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restoring LR*5.2*1018 changes
+3 ;IHS/ANMC/CLS 08/18/96
DO F^LRU
WRITE !,LRC(1)
IF $LENGTH(LRC(1))>44
WRITE !
WRITE " From: ",LRSTR," To: ",LRLST,!,"Acc #",?14,"Date/Time",?34,"Name/HRCN",?67,"Specimen",!,LR("%")
QUIT
+4 ; ----- END IHS/MSC/MKK - LR*5.2*1031
H1 ; D H Q:LR("Q") W !,LRA," ",LRB,?14,LRDATE,?34,LRP," ",SSN(1)," ",LRS Q
+1 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031 - Restoring LR*5.2*1018 changes
+2 ;IHS/ANMC/CLS 08/18/96
DO H
IF LR("Q")
QUIT
WRITE !,LRA," ",LRB,?14,LRDATE,?34,LRP," ",HRCN," ",LRS
QUIT
+3 ; ----- END IHS/MSC/MKK - LR*5.2*1031
H2 DO H1
IF LR("Q")
QUIT
WRITE !,"Test(s) ordered:"
SET E=2
QUIT
+1 QUIT
END DO V^LRU
QUIT
