- LRAPQAC ; IHS/DIR/AAB - AP QA 7/25/96 09:11 ;
- ;;5.2;LR;**1002**;JUN 01, 1998
- ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- D END S X="T",%DT="" D ^%DT S LRT=Y D D^LRU S LRTOD=Y S IOP="HOME" D ^%ZIS
- W @IOF,!?20,"Quality assurance cum path data summaries",!?21,"for accessions from one date to another",!
- D A G:'$D(Y) END W !,"Do you want to specify a site/specimen (Topography) " S %=2 D YN^LRU G:%<1 END D:%=1 TP
- D B^LRU G:Y<0 END S ZTRTN="QUE^LRAPQAC" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO K ^TMP("LRAP",$J),^TMP($J) S (LR("W"),LRS(5),LRQ(3),LRQ(9))=1,LRSDT=LRSDT-.1,LRLDT=LRLDT+.9 D L^LRU,S^LRU,EN^LRUA
- F LRA=LRSDT:0 S LRA=$O(^LR(LRXR,LRA)) Q:'LRA!(LRA>LRLDT) F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRA,LRDFN)) Q:'LRDFN D @($S('$D(S(2)):"S",1:"T"))
- F LRDFN=0:0 S LRDFN=$O(^TMP("LRAP",$J,LRDFN)) Q:'LRDFN S X=^LR(LRDFN,0),Y=$P(X,"^",3),(LRDPF,X)=^DIC($P(X,"^",2),0,"GL"),X=@(X_Y_",0)"),^TMP("LRAP",$J,"B",$P(X,"^"),LRDFN)=X
- S LRA=0 F LRB=0:0 S LRA=$O(^TMP("LRAP",$J,"B",LRA)) Q:LRA="" F LRDFN=0:0 S LRDFN=$O(^TMP("LRAP",$J,"B",LRA,LRDFN)) Q:'LRDFN!(LR("Q")) S LRPPT=^(LRDFN) D L
- K ^TMP("LRAP",$J),LRAU W @IOF D END,END^LRUTL Q
- L ;S LRQ=0,LRP=$P(LRPPT,"^"),SEX=$P(LRPPT,"^",2),Y=$P(LRPPT,"^",3),SSN=$P(LRPPT,"^",9) D D^LRU,SSN^LRU S DOB=$S(Y[1700:"",1:Y)
- S LRQ=0,LRP=$P(LRPPT,"^"),SEX=$P(LRPPT,"^",2),Y=$P(LRPPT,"^",3),SSN=$P(LRPPT,"^",9),DFN=$P(^LR(LRDFN,0),"^",3) D D^LRU,SSN^LRU S DOB=$S(Y[1700:"",1:Y) ;IHS/ANMC/CLS 11/1/95
- G:'$D(^LR(LRDFN,"SP"))&('$D(^LR(LRDFN,"CY")))&('$D(^LR(LRDFN,"EM"))) AU
- D ^LRAPT1 Q:LR("Q")
- AU I $P($P($G(^LR(LRDFN,"AU")),U,6)," ")=LRABV D ^LRAPT2
- Q
- O S ^TMP("LRAP",$J,LRDFN)="" Q
- S S LRI=0 F S LRI=$O(^LR(LRXR,LRA,LRDFN,LRI)) Q:'LRI I $P($P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV D O
- Q
- T S LRI=0 F S LRI=$O(^LR(LRXR,LRA,LRDFN,LRI)) Q:'LRI I $P($P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV S T=0 F S T=$O(^LR(LRDFN,LRSS,LRI,2,T)) Q:'T S T(1)=+^(T,0) Q:'$D(^LAB(61,T(1),0)) S T(2)=$P(^(0),"^",2) D F
- Q
- F I $E(T(2),1,S(1))'=S(2) Q:S(2)'["*" S Y(1)=S(1),X=T(2),Y(2)=S(2) D Y1 Q:'I
- D O Q
- TP K A("B") W !!,"TOPOGRAPHY (Organ/Tissue)",!?5,"Select 1 or more characters of the code",!?5 R "For all sites type 'ALL' : ",X:DTIME Q:X=""!(X[U) I X["ALL" K S(2)
- E D CK^LRAUSM G:$D(A("B")) TP S S(2)=X,S(1)=$L(X)
- Q
- Y1 S I=1 F I(1)=1:1:Y(1) S I(2)=$E(Y(2),I(1)) I I(2)'="*",I(2)'=$E(X,I(1)) S I=0 Q
- Q
- A D ^LRAP Q:'$D(Y) D XR^LRU Q
- ;
- END D V^LRU Q
- LRAPQAC ; IHS/DIR/AAB - AP QA 7/25/96 09:11 ;
- +1 ;;5.2;LR;**1002**;JUN 01, 1998
- +2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
- +3 DO END
- SET X="T"
- SET %DT=""
- DO ^%DT
- SET LRT=Y
- DO D^LRU
- SET LRTOD=Y
- SET IOP="HOME"
- DO ^%ZIS
- +4 WRITE @IOF,!?20,"Quality assurance cum path data summaries",!?21,"for accessions from one date to another",!
- +5 DO A
- IF '$DATA(Y)
- GOTO END
- WRITE !,"Do you want to specify a site/specimen (Topography) "
- SET %=2
- DO YN^LRU
- IF %<1
- GOTO END
- IF %=1
- DO TP
- +6 DO B^LRU
- IF Y<0
- GOTO END
- SET ZTRTN="QUE^LRAPQAC"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- KILL ^TMP("LRAP",$JOB),^TMP($JOB)
- SET (LR("W"),LRS(5),LRQ(3),LRQ(9))=1
- SET LRSDT=LRSDT-.1
- SET LRLDT=LRLDT+.9
- DO L^LRU
- DO S^LRU
- DO EN^LRUA
- +1 FOR LRA=LRSDT:0
- SET LRA=$ORDER(^LR(LRXR,LRA))
- IF 'LRA!(LRA>LRLDT)
- QUIT
- FOR LRDFN=0:0
- SET LRDFN=$ORDER(^LR(LRXR,LRA,LRDFN))
- IF 'LRDFN
- QUIT
- DO @($SELECT('$DATA(S(2)):"S",1:"T"))
- +2 FOR LRDFN=0:0
- SET LRDFN=$ORDER(^TMP("LRAP",$JOB,LRDFN))
- IF 'LRDFN
- QUIT
- SET X=^LR(LRDFN,0)
- SET Y=$PIECE(X,"^",3)
- SET (LRDPF,X)=^DIC($PIECE(X,"^",2),0,"GL")
- SET X=@(X_Y_",0)")
- SET ^TMP("LRAP",$JOB,"B",$PIECE(X,"^"),LRDFN)=X
- +3 SET LRA=0
- FOR LRB=0:0
- SET LRA=$ORDER(^TMP("LRAP",$JOB,"B",LRA))
- IF LRA=""
- QUIT
- FOR LRDFN=0:0
- SET LRDFN=$ORDER(^TMP("LRAP",$JOB,"B",LRA,LRDFN))
- IF 'LRDFN!(LR("Q"))
- QUIT
- SET LRPPT=^(LRDFN)
- DO L
- +4 KILL ^TMP("LRAP",$JOB),LRAU
- WRITE @IOF
- DO END
- DO END^LRUTL
- QUIT
- L ;S LRQ=0,LRP=$P(LRPPT,"^"),SEX=$P(LRPPT,"^",2),Y=$P(LRPPT,"^",3),SSN=$P(LRPPT,"^",9) D D^LRU,SSN^LRU S DOB=$S(Y[1700:"",1:Y)
- +1 ;IHS/ANMC/CLS 11/1/95
- SET LRQ=0
- SET LRP=$PIECE(LRPPT,"^")
- SET SEX=$PIECE(LRPPT,"^",2)
- SET Y=$PIECE(LRPPT,"^",3)
- SET SSN=$PIECE(LRPPT,"^",9)
- SET DFN=$PIECE(^LR(LRDFN,0),"^",3)
- DO D^LRU
- DO SSN^LRU
- SET DOB=$SELECT(Y[1700:"",1:Y)
- +2 IF '$DATA(^LR(LRDFN,"SP"))&('$DATA(^LR(LRDFN,"CY")))&('$DATA(^LR(LRDFN,"EM")))
- GOTO AU
- +3 DO ^LRAPT1
- IF LR("Q")
- QUIT
- AU IF $PIECE($PIECE($GET(^LR(LRDFN,"AU")),U,6)," ")=LRABV
- DO ^LRAPT2
- +1 QUIT
- O SET ^TMP("LRAP",$JOB,LRDFN)=""
- QUIT
- S SET LRI=0
- FOR
- SET LRI=$ORDER(^LR(LRXR,LRA,LRDFN,LRI))
- IF 'LRI
- QUIT
- IF $PIECE($PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV
- DO O
- +1 QUIT
- T SET LRI=0
- FOR
- SET LRI=$ORDER(^LR(LRXR,LRA,LRDFN,LRI))
- IF 'LRI
- QUIT
- IF $PIECE($PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,6)," ")=LRABV
- SET T=0
- FOR
- SET T=$ORDER(^LR(LRDFN,LRSS,LRI,2,T))
- IF 'T
- QUIT
- SET T(1)=+^(T,0)
- IF '$DATA(^LAB(61,T(1),0))
- QUIT
- SET T(2)=$PIECE(^(0),"^",2)
- DO F
- +1 QUIT
- F IF $EXTRACT(T(2),1,S(1))'=S(2)
- IF S(2)'["*"
- QUIT
- SET Y(1)=S(1)
- SET X=T(2)
- SET Y(2)=S(2)
- DO Y1
- IF 'I
- QUIT
- +1 DO O
- QUIT
- TP KILL A("B")
- WRITE !!,"TOPOGRAPHY (Organ/Tissue)",!?5,"Select 1 or more characters of the code",!?5
- READ "For all sites type 'ALL' : ",X:DTIME
- IF X=""!(X[U)
- QUIT
- IF X["ALL"
- KILL S(2)
- +1 IF '$TEST
- DO CK^LRAUSM
- IF $DATA(A("B"))
- GOTO TP
- SET S(2)=X
- SET S(1)=$LENGTH(X)
- +2 QUIT
- Y1 SET I=1
- FOR I(1)=1:1:Y(1)
- SET I(2)=$EXTRACT(Y(2),I(1))
- IF I(2)'="*"
- IF I(2)'=$EXTRACT(X,I(1))
- SET I=0
- QUIT
- +1 QUIT
- A DO ^LRAP
- IF '$DATA(Y)
- QUIT
- DO XR^LRU
- QUIT
- +1 ;
- END DO V^LRU
- QUIT
