- LRAPQOR ; IHS/DIR/AAB - QA CODE REPORT 2/12/98 09:21 ; [ 2/12/98 9:11 AM ]
- ;;5.2;LR;**1002,1006**;SEP 01, 1998
- ;
- ;;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
- LRAPQOR ; IHS/DIR/AAB - QA CODE REPORT 2/12/98 09:21 ; [ 2/12/98 9:11 AM ]
- +1 ;;5.2;LR;**1002,1006**;SEP 01, 1998
- +2 ;
- +3 ;;5.2;LAB SERVICE;**72,201**;Sep 27, 1994
- +4 DO ^LRAP
- IF '$DATA(Y)
- GOTO END
- DO B^LRU
- IF Y<0
- GOTO END
- +5 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
- +6 WRITE !!,"Print all QA codes "
- SET %=1
- DO YN^LRU
- IF %<1
- GOTO END
- IF %=2
- DO T
- IF '$DATA(LRB)
- GOTO END
- +7 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
