- LRUMI ;AVAMC/REG - MICRO RREJCTED SPECIMEN REPORT ;10/6/93 11:52 ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- D END S DIC=68,DIC(0)="QMZ",X="MICROBIOLOGY" D ^DIC K DIC G:Y<1 END S X=$P(Y,U,2) D ^LRUTL G:Y=-1 END
- D B^LRU G:Y<0 END
- S ZTRTN="QUE^LRUMI" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO S (LRG,LR("Q"),LRQ)=0,LRQ(1)=^DD("SITE") D L^LRU,H S LR("F")=1
- S LRLDT=LRLDT+.99,LRB=$E(LRSDT,1,3)_"0000",LRE=$E(LRLDT,1,3)_"0000"
- S LRB=LRB-1 F I=LRB:0 S I=$O(^LRO(68,LRAA,1,I)) Q:'I!(I>LRE)!(LR("Q")) S LRSA=LRSDT-.01 F B=LRSA:0 S B=$O(^LRO(68,LRAA,1,I,1,"E",B)) Q:'B!(B>LRLDT)!(LR("Q")) D O
- S LRA=0 F LRB=0:0 S LRA=$O(^TMP($J,"L",LRA)) Q:LRA=""!(LR("Q")) D:$Y>(IOSL-3) H Q:LR("Q") W !!,"Location: ",LRA,!,"---------" D L
- S LRG=1 D H S LRA=0 F LRB=0:0 S LRA=$O(^TMP($J,"S",LRA)) Q:LRA=""!(LR("Q")) D:$Y>(IOSL-3) H Q:LR("Q") W !!,"Specimen: ",LRA,!,"---------" D T
- D END^LRUTL,END Q
- L S LRC=0 F LRD=0:0 S LRC=$O(^TMP($J,"L",LRA,LRC)) Q:LRC=""!(LR("Q")) D:$Y>(IOSL-3) H1 Q:LR("Q") D A
- Q
- T S LRC=0 F LRD=0:0 S LRC=$O(^TMP($J,"S",LRA,LRC)) Q:LRC=""!(LR("Q")) D:$Y>(IOSL-3) H2 Q:LR("Q") D A
- Q
- O F LRAN=0:0 S LRAN=$O(^LRO(68,LRAA,1,I,1,"E",B,LRAN)) Q:'LRAN S LRDFN=+^LRO(68,LRAA,1,I,1,LRAN,0),LRI=$P(^(3),"^",5) D S
- Q
- S S LRC=$S($D(^LR(LRDFN,"MI",LRI,1)):$P(^(1),"^",5),1:"") I LRC["CON" S LRAC=^(0),LRN=5 D SET
- S LRC=$S($D(^LR(LRDFN,"MI",LRI,99)):^(99),1:"") I LRC["rej"!(X["REJ") S LRAC=^(0),LRN=99 D SET
- F LR=0:0 S LR=$O(^LR(LRDFN,"MI",LRI,4,LR)) Q:'LR S LRC=^(LR,0) I LRC["rej"!(LRC["REJ") S LRAC=^LR(LRDFN,"MI",LRI,0),LRN=4 D SET Q
- F LR=0:0 S LR=$O(^LR(LRDFN,"MI",LRI,7,LR)) Q:'LR S LRC=^(LR,0) I LRC["rej"!(LRC["REJ") S LRAC=^LR(LRDFN,"MI",LRI,0),LRN=7 D SET Q
- Q
- SET S A=$P(LRAC,"^",6),L=$P(LRAC,"^",8),S=+$P(LRAC,"^",5),S=$S($D(^LAB(61,S,0)):$P(^(0),"^"),1:"") S:S="" S="?" S:L="" L="?"
- S ^TMP($J,"A",A)=LRDFN_"^"_LRI_"^"_L_"^"_S_"^"_+LRAC,^(A,LRN)=LRC,^TMP($J,"L",L,A)="",^TMP($J,"S",S,A)="" Q
- A S LRZ=^TMP($J,"A",LRC),LRDFN=+LRZ,LRI=$P(LRZ,"^",2),X=^LR(LRDFN,0),Y=$P(X,"^",3),X=^DIC($P(X,"^",2),0,"GL"),LRY=@(X_Y_",0)") D W
- F LRF=0:0 S LRF=$O(^TMP($J,"A",LRC,LRF)) Q:'LRF!(LR("Q")) D:$Y>(IOSL-3) H Q:LR("Q") W !,^TMP($J,"A",LRC,LRF)
- Q
- W S Z=$S('LRG:$P(LRZ,"^",4),1:$P(LRZ,"^",3)),Y=$P(LRZ,"^",5) D DT^LRU W !,LRC,?15,$E(Z,1,12),?28,Y,?43,$P(LRY,"^"),?74,$E($P(LRY,"^",9),6,10) Q
- Q
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"MICROBIOLOGY REJECTED SPECIMENS FROM: ",LRSTR," THROUGH: ",LRLST,!,"ACCESSION",?15,$S('LRG:"SPECIMEN",1:"LOCATION"),?28,"DATE TAKEN",?43,"PATIENT",?75,"SSN",!,LR("%") Q
- H1 D H Q:LR("Q") W !!,"Location: ",LRA,!,"---------" Q
- H2 D H Q:LR("Q") W !!,"Specimen: ",LRA,!,"---------" Q
- ;
- END D V^LRU Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUMI 2695 printed Feb 18, 2025@23:47:39 Page 2
- LRUMI ;AVAMC/REG - MICRO RREJCTED SPECIMEN REPORT ;10/6/93 11:52 ;
- +1 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +2 DO END
- SET DIC=68
- SET DIC(0)="QMZ"
- SET X="MICROBIOLOGY"
- DO ^DIC
- KILL DIC
- if Y<1
- GOTO END
- SET X=$PIECE(Y,U,2)
- DO ^LRUTL
- if Y=-1
- GOTO END
- +3 DO B^LRU
- if Y<0
- GOTO END
- +4 SET ZTRTN="QUE^LRUMI"
- DO BEG^LRUTL
- if POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- SET (LRG,LR("Q"),LRQ)=0
- SET LRQ(1)=^DD("SITE")
- DO L^LRU
- DO H
- SET LR("F")=1
- +1 SET LRLDT=LRLDT+.99
- SET LRB=$EXTRACT(LRSDT,1,3)_"0000"
- SET LRE=$EXTRACT(LRLDT,1,3)_"0000"
- +2 SET LRB=LRB-1
- FOR I=LRB:0
- SET I=$ORDER(^LRO(68,LRAA,1,I))
- if 'I!(I>LRE)!(LR("Q"))
- QUIT
- SET LRSA=LRSDT-.01
- FOR B=LRSA:0
- SET B=$ORDER(^LRO(68,LRAA,1,I,1,"E",B))
- if 'B!(B>LRLDT)!(LR("Q"))
- QUIT
- DO O
- +3 SET LRA=0
- FOR LRB=0:0
- SET LRA=$ORDER(^TMP($JOB,"L",LRA))
- if LRA=""!(LR("Q"))
- QUIT
- if $Y>(IOSL-3)
- DO H
- if LR("Q")
- QUIT
- WRITE !!,"Location: ",LRA,!,"---------"
- DO L
- +4 SET LRG=1
- DO H
- SET LRA=0
- FOR LRB=0:0
- SET LRA=$ORDER(^TMP($JOB,"S",LRA))
- if LRA=""!(LR("Q"))
- QUIT
- if $Y>(IOSL-3)
- DO H
- if LR("Q")
- QUIT
- WRITE !!,"Specimen: ",LRA,!,"---------"
- DO T
- +5 DO END^LRUTL
- DO END
- QUIT
- L SET LRC=0
- FOR LRD=0:0
- SET LRC=$ORDER(^TMP($JOB,"L",LRA,LRC))
- if LRC=""!(LR("Q"))
- QUIT
- if $Y>(IOSL-3)
- DO H1
- if LR("Q")
- QUIT
- DO A
- +1 QUIT
- T SET LRC=0
- FOR LRD=0:0
- SET LRC=$ORDER(^TMP($JOB,"S",LRA,LRC))
- if LRC=""!(LR("Q"))
- QUIT
- if $Y>(IOSL-3)
- DO H2
- if LR("Q")
- QUIT
- DO A
- +1 QUIT
- O FOR LRAN=0:0
- SET LRAN=$ORDER(^LRO(68,LRAA,1,I,1,"E",B,LRAN))
- if 'LRAN
- QUIT
- SET LRDFN=+^LRO(68,LRAA,1,I,1,LRAN,0)
- SET LRI=$PIECE(^(3),"^",5)
- DO S
- +1 QUIT
- S SET LRC=$SELECT($DATA(^LR(LRDFN,"MI",LRI,1)):$PIECE(^(1),"^",5),1:"")
- IF LRC["CON"
- SET LRAC=^(0)
- SET LRN=5
- DO SET
- +1 SET LRC=$SELECT($DATA(^LR(LRDFN,"MI",LRI,99)):^(99),1:"")
- IF LRC["rej"!(X["REJ")
- SET LRAC=^(0)
- SET LRN=99
- DO SET
- +2 FOR LR=0:0
- SET LR=$ORDER(^LR(LRDFN,"MI",LRI,4,LR))
- if 'LR
- QUIT
- SET LRC=^(LR,0)
- IF LRC["rej"!(LRC["REJ")
- SET LRAC=^LR(LRDFN,"MI",LRI,0)
- SET LRN=4
- DO SET
- QUIT
- +3 FOR LR=0:0
- SET LR=$ORDER(^LR(LRDFN,"MI",LRI,7,LR))
- if 'LR
- QUIT
- SET LRC=^(LR,0)
- IF LRC["rej"!(LRC["REJ")
- SET LRAC=^LR(LRDFN,"MI",LRI,0)
- SET LRN=7
- DO SET
- QUIT
- +4 QUIT
- SET SET A=$PIECE(LRAC,"^",6)
- SET L=$PIECE(LRAC,"^",8)
- SET S=+$PIECE(LRAC,"^",5)
- SET S=$SELECT($DATA(^LAB(61,S,0)):$PIECE(^(0),"^"),1:"")
- if S=""
- SET S="?"
- if L=""
- SET L="?"
- +1 SET ^TMP($JOB,"A",A)=LRDFN_"^"_LRI_"^"_L_"^"_S_"^"_+LRAC
- SET ^(A,LRN)=LRC
- SET ^TMP($JOB,"L",L,A)=""
- SET ^TMP($JOB,"S",S,A)=""
- QUIT
- A SET LRZ=^TMP($JOB,"A",LRC)
- SET LRDFN=+LRZ
- SET LRI=$PIECE(LRZ,"^",2)
- SET X=^LR(LRDFN,0)
- SET Y=$PIECE(X,"^",3)
- SET X=^DIC($PIECE(X,"^",2),0,"GL")
- SET LRY=@(X_Y_",0)")
- DO W
- +1 FOR LRF=0:0
- SET LRF=$ORDER(^TMP($JOB,"A",LRC,LRF))
- if 'LRF!(LR("Q"))
- QUIT
- if $Y>(IOSL-3)
- DO H
- if LR("Q")
- QUIT
- WRITE !,^TMP($JOB,"A",LRC,LRF)
- +2 QUIT
- W SET Z=$SELECT('LRG:$PIECE(LRZ,"^",4),1:$PIECE(LRZ,"^",3))
- SET Y=$PIECE(LRZ,"^",5)
- DO DT^LRU
- WRITE !,LRC,?15,$EXTRACT(Z,1,12),?28,Y,?43,$PIECE(LRY,"^"),?74,$EXTRACT($PIECE(LRY,"^",9),6,10)
- QUIT
- +1 QUIT
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- if LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"MICROBIOLOGY REJECTED SPECIMENS FROM: ",LRSTR," THROUGH: ",LRLST,!,"ACCESSION",?15,$SELECT('LRG:"SPECIMEN",1:"LOCATION"),?28,"DATE TAKEN",?43,"PATIENT",?75,"SSN",!,LR("%")
- QUIT
- H1 DO H
- if LR("Q")
- QUIT
- WRITE !!,"Location: ",LRA,!,"---------"
- QUIT
- H2 DO H
- if LR("Q")
- QUIT
- WRITE !!,"Specimen: ",LRA,!,"---------"
- QUIT
- +1 ;
- END DO V^LRU
- QUIT