- 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
