- LRAPQOR1 ;AVAMC/REG/CYM - QA CODE REPORT ;2/12/98 10:46
- ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
- S LR("QA")=0 W !,"Sort by QA CODE only " S %=2 D YN^LRU G:%<1 END I %=1 S LR("QA")=1
- S ZTRTN="QUE^LRAPQOR1" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO K ^TMP($J) S LRN=0 D XR^LRU,L^LRU,S^LRU,H1 S LR("F")=1
- F X=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D I
- F LRA=0:0 S LRA=$O(^TMP($J,LRA)) Q:'LRA S LRM=0,LRB=$S($D(^LAB(62.5,LRA,0)):^(0),1:"??") D:$Y>(IOSL-6) H1 Q:LR("Q") W !!,$P(LRB,"^"),?5,$P(LRB,"^",2) D D
- W !!,"Total cases reviewed: ",LRN F P=0:0 S P=$O(^TMP($J,"P",P)) Q:'P S X=$S($D(^VA(200,P,0)):$P(^(0),"^"),1:"??"),^TMP($J,"C",X,P)=""
- I 'LR("QA") D H3 S LRP="" F LRX=0:0 S LRP=$O(^TMP($J,"C",LRP)) Q:LRP=""!(LR("Q")) F LR=0:0 S LRT=0,LR=$O(^TMP($J,"C",LRP,LR)) Q:'LR!(LR("Q")) D W1
- I LRSS="AU",LR("QA") D ^LRAPQOR2
- K ^TMP($J) W:IOST'?1"C".E @IOF D END^LRUTL,V^LRU Q
- D F LRC=0:0 S LRC=$O(^TMP($J,LRA,LRC)) Q:'LRC!(LR("Q")) S LRY=$$FMTE^XLFDT(LRC,"D"),LRD="" F LRF=0:0 S LRD=$O(^TMP($J,LRA,LRC,LRD)) Q:LRD="" S X=+^(LRD),LRE=$S($D(^VA(200,X,0)):$P(^(0),"^"),1:"??") D W
- W !,"Total QA Codes: ",LRM Q
- W D:$Y>(IOSL-6) H2 Q:LR("Q") W !,LRD,?10,LRY,?24,LRE S LRM=LRM+1 Q
- W1 D:$Y>(IOSL-6) H3 W !!,"Pathologist: ",LRP F LRA=0:0 S LRA=$O(^TMP($J,"P",LR,LRA)) Q:'LRA!(LR("Q")) S LRN=0,LRB=$S($D(^LAB(62.5,LRA,0)):^(0),1:"??") D:$Y>(IOSL-6) H4 Q:LR("Q") W !,$P(LRB,"^"),?5,$P(LRB,"^",2) D W2
- W !?24,"Total QA Codes: ",$J(LRT,3) Q
- W2 F LRD=0:0 S LRD=$O(^TMP($J,"P",LR,LRA,LRD)) Q:'LRD!(LR("Q")) S LRY=$$FMTE^XLFDT(LRD,"D"),LRE="" F LRF=0:0 S LRE=$O(^TMP($J,"P",LR,LRA,LRD,LRE)) Q:LRE=""!(LR("Q")) D:$Y>(IOSL-6) H5 Q:LR("Q") W !,LRE,?10,LRY S LRN=LRN+1
- W !,"Subtotal QA Codes: ",$J(LRN,3) S LRT=LRT+LRN Q
- I F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN!(LR("Q")) D @($S("CYEMSP"[LRSS:"L",1:"A"))
- Q
- L Q:'$D(^LR(LRDFN,0)) F LRI=0:0 S LRI=$O(^LR(LRXR,LRSDT,LRDFN,LRI)) Q:'LRI I $O(^LR(LRDFN,LRSS,LRI,9,0)) S LRN=LRN+1,X=^LR(LRDFN,LRSS,LRI,0),P=+$P(X,"^",2),Y=$P($P(X,"^",10),"."),A=$P(X,"^",6) D S
- Q
- S F LRA=0:0 S LRA=$O(^LR(LRDFN,LRSS,LRI,9,LRA)) Q:'LRA D U
- Q
- U S ^TMP($J,"P",P,LRA,Y,A)="",^TMP($J,LRA,Y,A)=P S:LRSS="AU" ^TMP($J,"S",LRA,S,T,M,Y,A)="" Q
- A Q:'$O(^LR(LRDFN,99,0)) Q:'$D(^LR(LRDFN,"AU")) S X=^("AU"),Y=$P($P(X,"^"),"."),A=$P(X,"^",6),P=$P(X,"^",10),S=$P(X,"^",8),T=$P(X,"^",14),M=$P(X,"^",12),LRN=LRN+1 S:S="" S="?" S:T="" T="?" S:M="" M="?"
- F LRA=0:0 S LRA=$O(^LR(LRDFN,99,LRA)) Q:'LRA D U
- Q
- H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !,"QA CODES for ",LRAA(1)," From: ",LRSTR," To: ",LRLST Q
- H1 D H Q:LR("Q") W !,"Acc #",?11,$S(LRSS'="AU":"Rec'd",1:"Date"),?24,"Pathologist",!,LR("%") Q
- H2 D H1 Q:LR("Q") W !,$P(LRB,"^"),?5,$P(LRB,"^",2) Q
- H3 D H Q:LR("Q") W !,"Acc #",?10,"Rec'd",!,LR("%") Q
- H4 D H3 Q:LR("Q") W !,"Pathologist: ",LRP Q
- H5 D H4 Q:LR("Q") W !,$P(LRB,"^"),?5,$P(LRB,"^",2) Q
- ;
- END D V^LRU Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPQOR1 2929 printed Apr 23, 2025@18:22:02 Page 2
- LRAPQOR1 ;AVAMC/REG/CYM - QA CODE REPORT ;2/12/98 10:46
- +1 ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
- +2 SET LR("QA")=0
- WRITE !,"Sort by QA CODE only "
- SET %=2
- DO YN^LRU
- if %<1
- GOTO END
- IF %=1
- SET LR("QA")=1
- +3 SET ZTRTN="QUE^LRAPQOR1"
- DO BEG^LRUTL
- if POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- KILL ^TMP($JOB)
- SET LRN=0
- DO XR^LRU
- DO L^LRU
- DO S^LRU
- DO H1
- SET LR("F")=1
- +1 FOR X=0:0
- SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
- if 'LRSDT!(LRSDT>LRLDT)
- QUIT
- DO I
- +2 FOR LRA=0:0
- SET LRA=$ORDER(^TMP($JOB,LRA))
- if 'LRA
- QUIT
- SET LRM=0
- SET LRB=$SELECT($DATA(^LAB(62.5,LRA,0)):^(0),1:"??")
- if $Y>(IOSL-6)
- DO H1
- if LR("Q")
- QUIT
- WRITE !!,$PIECE(LRB,"^"),?5,$PIECE(LRB,"^",2)
- DO D
- +3 WRITE !!,"Total cases reviewed: ",LRN
- FOR P=0:0
- SET P=$ORDER(^TMP($JOB,"P",P))
- if 'P
- QUIT
- SET X=$SELECT($DATA(^VA(200,P,0)):$PIECE(^(0),"^"),1:"??")
- SET ^TMP($JOB,"C",X,P)=""
- +4 IF 'LR("QA")
- DO H3
- SET LRP=""
- FOR LRX=0:0
- SET LRP=$ORDER(^TMP($JOB,"C",LRP))
- if LRP=""!(LR("Q"))
- QUIT
- FOR LR=0:0
- SET LRT=0
- SET LR=$ORDER(^TMP($JOB,"C",LRP,LR))
- if 'LR!(LR("Q"))
- QUIT
- DO W1
- +5 IF LRSS="AU"
- IF LR("QA")
- DO ^LRAPQOR2
- +6 KILL ^TMP($JOB)
- if IOST'?1"C".E
- WRITE @IOF
- DO END^LRUTL
- DO V^LRU
- QUIT
- D FOR LRC=0:0
- SET LRC=$ORDER(^TMP($JOB,LRA,LRC))
- if 'LRC!(LR("Q"))
- QUIT
- SET LRY=$$FMTE^XLFDT(LRC,"D")
- SET LRD=""
- FOR LRF=0:0
- SET LRD=$ORDER(^TMP($JOB,LRA,LRC,LRD))
- if LRD=""
- QUIT
- SET X=+^(LRD)
- SET LRE=$SELECT($DATA(^VA(200,X,0)):$PIECE(^(0),"^"),1:"??")
- DO W
- +1 WRITE !,"Total QA Codes: ",LRM
- QUIT
- W if $Y>(IOSL-6)
- DO H2
- if LR("Q")
- QUIT
- WRITE !,LRD,?10,LRY,?24,LRE
- SET LRM=LRM+1
- QUIT
- W1 if $Y>(IOSL-6)
- DO H3
- WRITE !!,"Pathologist: ",LRP
- FOR LRA=0:0
- SET LRA=$ORDER(^TMP($JOB,"P",LR,LRA))
- if 'LRA!(LR("Q"))
- QUIT
- SET LRN=0
- SET LRB=$SELECT($DATA(^LAB(62.5,LRA,0)):^(0),1:"??")
- if $Y>(IOSL-6)
- DO H4
- if LR("Q")
- QUIT
- WRITE !,$PIECE(LRB,"^"),?5,$PIECE(LRB,"^",2)
- DO W2
- +1 WRITE !?24,"Total QA Codes: ",$JUSTIFY(LRT,3)
- QUIT
- W2 FOR LRD=0:0
- SET LRD=$ORDER(^TMP($JOB,"P",LR,LRA,LRD))
- if 'LRD!(LR("Q"))
- QUIT
- SET LRY=$$FMTE^XLFDT(LRD,"D")
- SET LRE=""
- FOR LRF=0:0
- SET LRE=$ORDER(^TMP($JOB,"P",LR,LRA,LRD,LRE))
- if LRE=""!(LR("Q"))
- QUIT
- if $Y>(IOSL-6)
- DO H5
- if LR("Q")
- QUIT
- WRITE !,LRE,?10,LRY
- SET LRN=LRN+1
- +1 WRITE !,"Subtotal QA Codes: ",$JUSTIFY(LRN,3)
- SET LRT=LRT+LRN
- QUIT
- I FOR LRDFN=0:0
- SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))
- if 'LRDFN!(LR("Q"))
- QUIT
- DO @($SELECT("CYEMSP"[LRSS:"L",1:"A"))
- +1 QUIT
- L if '$DATA(^LR(LRDFN,0))
- QUIT
- FOR LRI=0:0
- SET LRI=$ORDER(^LR(LRXR,LRSDT,LRDFN,LRI))
- if 'LRI
- QUIT
- IF $ORDER(^LR(LRDFN,LRSS,LRI,9,0))
- SET LRN=LRN+1
- SET X=^LR(LRDFN,LRSS,LRI,0)
- SET P=+$PIECE(X,"^",2)
- SET Y=$PIECE($PIECE(X,"^",10),".")
- SET A=$PIECE(X,"^",6)
- DO S
- +1 QUIT
- S FOR LRA=0:0
- SET LRA=$ORDER(^LR(LRDFN,LRSS,LRI,9,LRA))
- if 'LRA
- QUIT
- DO U
- +1 QUIT
- U SET ^TMP($JOB,"P",P,LRA,Y,A)=""
- SET ^TMP($JOB,LRA,Y,A)=P
- if LRSS="AU"
- SET ^TMP($JOB,"S",LRA,S,T,M,Y,A)=""
- QUIT
- A if '$ORDER(^LR(LRDFN,99,0))
- QUIT
- if '$DATA(^LR(LRDFN,"AU"))
- QUIT
- SET X=^("AU")
- SET Y=$PIECE($PIECE(X,"^"),".")
- SET A=$PIECE(X,"^",6)
- SET P=$PIECE(X,"^",10)
- SET S=$PIECE(X,"^",8)
- SET T=$PIECE(X,"^",14)
- SET M=$PIECE(X,"^",12)
- SET LRN=LRN+1
- if S=""
- SET S="?"
- if T=""
- SET T="?"
- if M=""
- SET M="?"
- +1 FOR LRA=0:0
- SET LRA=$ORDER(^LR(LRDFN,99,LRA))
- if 'LRA
- QUIT
- DO U
- +2 QUIT
- H IF $DATA(LR("F"))
- IF IOST?1"C".E
- DO M^LRU
- if LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !,"QA CODES for ",LRAA(1)," From: ",LRSTR," To: ",LRLST
- QUIT
- H1 DO H
- if LR("Q")
- QUIT
- WRITE !,"Acc #",?11,$SELECT(LRSS'="AU":"Rec'd",1:"Date"),?24,"Pathologist",!,LR("%")
- QUIT
- H2 DO H1
- if LR("Q")
- QUIT
- WRITE !,$PIECE(LRB,"^"),?5,$PIECE(LRB,"^",2)
- QUIT
- H3 DO H
- if LR("Q")
- QUIT
- WRITE !,"Acc #",?10,"Rec'd",!,LR("%")
- QUIT
- H4 DO H3
- if LR("Q")
- QUIT
- WRITE !,"Pathologist: ",LRP
- QUIT
- H5 DO H4
- if LR("Q")
- QUIT
- WRITE !,$PIECE(LRB,"^"),?5,$PIECE(LRB,"^",2)
- QUIT
- +1 ;
- END DO V^LRU
- QUIT
