LRAPQOR ;AVAMC/REG/CYM - QA CODE REPORT ;2/12/98 09:21
;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
D ^LRAP G:'$D(Y) END D B^LRU G:Y<0 END
S (LRSDT(1),LRSDT)=LRSDT-.01,LRLDT=LRLDT+.99 W !!,"Sort by QA CODE / PATHOLOGIST " S %=2 D YN^LRU G:%<1 END I %=1 G ^LRAPQOR1
W !!,"Print all QA codes " S %=1 D YN^LRU G:%<1 END I %=2 D T G:'$D(LRB) END
S ZTRTN="QUE^LRAPQOR" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J) D XR^LRU,L^LRU,S^LRU,H S LR("F")=1
F X=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D I
K ^TMP($J) W:IOST'?1"C".E @IOF D END^LRUTL,V^LRU 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 $P($P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV,$O(^LR(LRDFN,LRSS,LRI,9,0)) D B
Q
B I $D(LRB) K LRF F X=0:0 S X=$O(LRB(X)) Q:'X I $D(^LR(LRDFN,LRSS,LRI,9,X)) S LRF=1 Q
I $D(LRB),'$D(LRF) Q
S X=^LR(LRDFN,LRSS,LRI,0),Z=$P(X,"^",2),Y=$P($P(X,"^",10),"."),LRZ=$P(X,"^",6) D S Q
W S LRY=$$FMTE^XLFDT(Y),LRC=$S('Z:"",'$D(^VA(200,Z,0)):"",1:$P(^(0),"^")) D:$Y>(IOSL-6) H Q:LR("Q") W !!,LRZ,?10,LRY,?24,LRC Q
W1 D:$Y>(IOSL-6) H1 Q:LR("Q") S X=$S($D(^LAB(62.5,LRA,0)):^(0),1:"") W !,$P(X,"^"),?4,$P(X,"^",2) Q
S D W Q:LR("Q") F LRA=0:0 S LRA=$O(^LR(LRDFN,LRSS,LRI,9,LRA)) Q:'LRA D W1 Q:LR("Q")
Q
A Q:$P($P($G(^LR(LRDFN,"AU")),U,6)," ")'=LRABV Q:'$O(^LR(LRDFN,99,0)) I $D(LRB) K LRF F X=0:0 S X=$O(LRB(X)) Q:'X I $D(^LR(LRDFN,99,X)) S LRF=1 Q
I $D(LRB),'$D(LRF) Q
Q:'$D(^LR(LRDFN,"AU")) S X=^("AU"),Y=$P($P(X,"^"),"."),LRZ=$P(X,"^",6),Z=$P(X,"^",10) D W Q:LR("Q") F LRA=0:0 S LRA=$O(^LR(LRDFN,99,LRA)) Q:'LRA D W1 Q:LR("Q")
Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,"QA CODES for ",LRO(68)," From: ",LRSTR," To: ",LRLST
W !,"Acc #",?10,$S(LRSS'="AU":"Rec'd",1:"Date"),?24,"Pathologist",!,LR("%") Q
H1 D H Q:LR("Q") W !,LRZ,?10,LRY,?20,LRC Q
T S DIC="^LAB(62.5,",DIC(0)="AEQ",D="AI",DIC("A")="Select QA CODE: ",DIC("S")="I $L($P(^(0),U))<3" D IX^DIC K DIC I Y>0 S LRB(+Y)="" G T
Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPQOR 2115 printed Apr 09, 2024@21:08:20 Page 2
LRAPQOR ;AVAMC/REG/CYM - QA CODE REPORT ;2/12/98 09:21
+1 ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
+2 DO ^LRAP
if '$DATA(Y)
GOTO END
DO B^LRU
if Y<0
GOTO END
+3 SET (LRSDT(1),LRSDT)=LRSDT-.01
SET LRLDT=LRLDT+.99
WRITE !!,"Sort by QA CODE / PATHOLOGIST "
SET %=2
DO YN^LRU
if %<1
GOTO END
IF %=1
GOTO ^LRAPQOR1
+4 WRITE !!,"Print all QA codes "
SET %=1
DO YN^LRU
if %<1
GOTO END
IF %=2
DO T
if '$DATA(LRB)
GOTO END
+5 SET ZTRTN="QUE^LRAPQOR"
DO BEG^LRUTL
if POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB)
DO XR^LRU
DO L^LRU
DO S^LRU
DO H
SET LR("F")=1
+1 FOR X=0:0
SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
if 'LRSDT!(LRSDT>LRLDT)
QUIT
DO I
+2 KILL ^TMP($JOB)
if IOST'?1"C".E
WRITE @IOF
DO END^LRUTL
DO V^LRU
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 $PIECE($PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV
IF $ORDER(^LR(LRDFN,LRSS,LRI,9,0))
DO B
+1 QUIT
B IF $DATA(LRB)
KILL LRF
FOR X=0:0
SET X=$ORDER(LRB(X))
if 'X
QUIT
IF $DATA(^LR(LRDFN,LRSS,LRI,9,X))
SET LRF=1
QUIT
+1 IF $DATA(LRB)
IF '$DATA(LRF)
QUIT
+2 SET X=^LR(LRDFN,LRSS,LRI,0)
SET Z=$PIECE(X,"^",2)
SET Y=$PIECE($PIECE(X,"^",10),".")
SET LRZ=$PIECE(X,"^",6)
DO S
QUIT
W SET LRY=$$FMTE^XLFDT(Y)
SET LRC=$SELECT('Z:"",'$DATA(^VA(200,Z,0)):"",1:$PIECE(^(0),"^"))
if $Y>(IOSL-6)
DO H
if LR("Q")
QUIT
WRITE !!,LRZ,?10,LRY,?24,LRC
QUIT
W1 if $Y>(IOSL-6)
DO H1
if LR("Q")
QUIT
SET X=$SELECT($DATA(^LAB(62.5,LRA,0)):^(0),1:"")
WRITE !,$PIECE(X,"^"),?4,$PIECE(X,"^",2)
QUIT
S DO W
if LR("Q")
QUIT
FOR LRA=0:0
SET LRA=$ORDER(^LR(LRDFN,LRSS,LRI,9,LRA))
if 'LRA
QUIT
DO W1
if LR("Q")
QUIT
+1 QUIT
A if $PIECE($PIECE($GET(^LR(LRDFN,"AU")),U,6)," ")'=LRABV
QUIT
if '$ORDER(^LR(LRDFN,99,0))
QUIT
IF $DATA(LRB)
KILL LRF
FOR X=0:0
SET X=$ORDER(LRB(X))
if 'X
QUIT
IF $DATA(^LR(LRDFN,99,X))
SET LRF=1
QUIT
+1 IF $DATA(LRB)
IF '$DATA(LRF)
QUIT
+2 if '$DATA(^LR(LRDFN,"AU"))
QUIT
SET X=^("AU")
SET Y=$PIECE($PIECE(X,"^"),".")
SET LRZ=$PIECE(X,"^",6)
SET Z=$PIECE(X,"^",10)
DO W
if LR("Q")
QUIT
FOR LRA=0:0
SET LRA=$ORDER(^LR(LRDFN,99,LRA))
if 'LRA
QUIT
DO W1
if LR("Q")
QUIT
+3 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 ",LRO(68)," From: ",LRSTR," To: ",LRLST
+2 WRITE !,"Acc #",?10,$SELECT(LRSS'="AU":"Rec'd",1:"Date"),?24,"Pathologist",!,LR("%")
QUIT
H1 DO H
if LR("Q")
QUIT
WRITE !,LRZ,?10,LRY,?20,LRC
QUIT
T SET DIC="^LAB(62.5,"
SET DIC(0)="AEQ"
SET D="AI"
SET DIC("A")="Select QA CODE: "
SET DIC("S")="I $L($P(^(0),U))<3"
DO IX^DIC
KILL DIC
IF Y>0
SET LRB(+Y)=""
GOTO T
+1 QUIT
+2 ;
END DO V^LRU
QUIT
