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 Sep 23, 2025@19:43:43 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
