LRAPQAR ; IHS/DIR/AAB - 10% SURG PATH REVIEW 19:35 ; [ 05/28/98 2:04 PM ]
;;5.2;LR;**1002,1003**;JUN 01, 1998
;;5.2;LAB SERVICE;**72,173**;Sep 27, 1994
S LRDICS="SP" D ^LRAP G:'$D(Y) END
W !!?25,"10% ",LRO(68)," Review",!,"This report may take a while and should be queued to print at non-peak hours.",!,"OK to continue " S %=2 D YN^LRU Q:%'=1
D ASK^LRAPQAFS G:%<1 END
W ! D B^LRU G:Y<0 END S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
S ZTRTN="QUE^LRAPQAR" D BEG^LRUTL G:POP!($D(ZTSK)) END
QUE U IO K ^TMP($J),^TMP("LRAP",$J) S LRN="ALL",(LRQ(9),LRS(5),LRS(99))=1,LR("DIWF")="W",(LR,LR("A"),LR(1),LR(2),LR(3),LRQ(2),LRG,LRJ)=0 D L^LRU,S^LRU,L1^LRU,XR^LRU,H S LR("F")=1 W !,LR("%")
F X=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) F LRDFN=0:0 S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN F LRI=0:0 S LRI=$O(^LR(LRXR,LRSDT,LRDFN,LRI)) Q:'LRI D T
W !,"Total accessions:",?23,$J(LRG,5),! D A,EN2^LRUA,SET^LRUA S LRQ=0,LRA=1 D W
K ^TMP("LRAP",$J) D END^LRUTL,END Q
T I $P($P($G(^LR(LRDFN,"SP",LRI,0)),U,6)," ")=LRABV S X=^(0),Z=$E($P(X,U,10),1,3),A=+$P($P(X,U,6)," ",3) D T1
Q
T1 F X=0:0 S X=$O(^LR(LRDFN,"SP",LRI,2,X)) Q:'X S Y=+^(X,0) I Y,$D(^LAB(61,Y,0)) S Y=$E($P(^(0),U,2)) S:Y]"" ^TMP($J,"B",Y,Z,A)="",LRG=LRG+1
Q
A F X=0,1,2,3,4,5,6,7,8,9,0,"X","Y" I $D(^TMP($J,"B",X)) D C
K ^TMP($J,"B") S X=-1 F Y=0:0 S X=$O(^TMP($J,X)) Q:X="" W !?3,"Topography ",X,": ",$J(^(X),4)
F X=0,1,2,3,4,5,6,7,8,9,"X","Y" I $D(^TMP($J,X)) S T=^(X),C=0 D S
Q
W W !!,"Accessions for review: ",$J(LRJ,5) W:LRG&(LRJ) " (",$J(LRJ/LRG*100,5,2),"%)" I 'LRQA D H1 Q:LR("Q")
F LRY=0:0 S LRY=$O(^TMP("LRAP",$J,LRY)) Q:'LRY!(LR("Q")) F LRAN=0:0 S LRAN=$O(^TMP("LRAP",$J,LRY,LRAN)) Q:'LRAN!(LR("Q")) D D
S:LRQA LRQ=0 F LRY=0:0 S LRY=$O(^TMP("LRAP",$J,LRY)) Q:'LRY!(LR("Q")) D B
Q
D ;S LRDFN=$O(^LR("ASPA",LRY,LRABV,LRAN,0)),LRI=$O(^(LRDFN,0)),LRAC=$P($G(^LR(LRDFN,LRSS,LRI,0)),U,6) D:LRQA EN^LRSPRPT D:'LRQA ^LRUA S ^TMP("LRAP",$J,LRY,LRAN)=LRP_U_SSN_U_LRI_U_LRDFN_U_LRAC D:LRC L^LRAPQAMR Q
S LRDFN=$O(^LR("ASPA",LRY,LRABV,LRAN,0)),LRI=$O(^(LRDFN,0)),LRAC=$P($G(^LR(LRDFN,LRSS,LRI,0)),U,6) D:LRQA EN^LRSPRPT D:'LRQA ^LRUA S ^TMP("LRAP",$J,LRY,LRAN)=LRP_U_HRCN_U_LRI_U_LRDFN_U_LRAC D:LRC L^LRAPQAMR Q ;IHS/DIR TUC/AAB 5/4/98
B ;F LRAN=0:0 S LRAN=$O(^TMP("LRAP",$J,LRY,LRAN)) Q:'LRAN!(LR("Q")) S X=^(LRAN),LRP=$P(X,"^"),SSN=$P(X,"^",2),LRI=$P(X,"^",3),LRDFN=$P(X,"^",4),LRAC=$P(X,U,5) D:$Y>(IOSL-6) H1 Q:LR("Q") D R
F LRAN=0:0 S LRAN=$O(^TMP("LRAP",$J,LRY,LRAN)) Q:'LRAN!(LR("Q")) S X=^(LRAN),LRP=$P(X,"^"),HRCN=$P(X,"^",2),LRI=$P(X,"^",3),LRDFN=$P(X,"^",4),LRAC=$P(X,U,5) D:$Y>(IOSL-6) H1 Q:LR("Q") D R ;IHS/DIR TUC/AAB 5/4/98
Q
R ;W !,LRAC,?18,LRP,?50,SSN I LRI F LRT=0:0 S LRT=$O(^LR(LRDFN,LRSS,LRI,2,LRT)) Q:'LRT!(LR("Q")) S X=+^(LRT,0),LRX=$P(^LAB(61,X,0),"^") D:$Y>(IOSL-6) H2 Q:LR("Q") W !?5,LRX D M
W !,LRAC,?18,LRP,?50,HRCN I LRI F LRT=0:0 S LRT=$O(^LR(LRDFN,LRSS,LRI,2,LRT)) Q:'LRT!(LR("Q")) S X=+^(LRT,0),LRX=$P(^LAB(61,X,0),"^") D:$Y>(IOSL-6) H2 Q:LR("Q") W !?5,LRX D M ;IHS/DIR TUC/AAB 5/4/98
W !,LR("%") Q
M F LRM=0:0 S LRM=$O(^LR(LRDFN,LRSS,LRI,2,LRT,2,LRM)) Q:'LRM!(LR("Q")) S X=+^(LRM,0),M=$P(^LAB(61.1,X,0),"^") D:$Y>(IOSL-6) H3 Q:LR("Q") W !?10,M
Q
C S C=0 F A=0:0 S A=$O(^TMP($J,"B",X,A)) Q:'A F B=0:0 S B=$O(^TMP($J,"B",X,A,B)) Q:'B S C=C+1,^TMP($J,X,C)=A_"^"_B
S ^TMP($J,X)=C Q
S S N=T*.1 S:N<1 N=1 I N["." S N=N_"00",A=$E($P(N,".",2),1,3),B=$P(N,"."),N=$S(A>499:B+1,1:B)
I T=1 S F=^TMP($J,X,1),^TMP("LRAP",$J,$P(F,"^"),$P(F,"^",2))="",LRJ=LRJ+1 K ^TMP($J,X,1) Q
F Y=0:0 Q:C=N S E=$R(T)+1 I $D(^TMP($J,X,E)) S F=^(E),^TMP("LRAP",$J,$P(F,"^"),$P(F,"^",2))="",C=C+1,LRJ=LRJ+1 K ^TMP($J,X,E)
Q
;
H I $D(LR("F")),$E(IOST,1,2)="C-" D M^LRU Q:LR("Q")
D F^LRU W !,"10% ",LRAA(1)," Review from ",LRSTR," to ",LRLST Q
H1 ;D H Q:LR("Q") W !,"ACC #",?20,"NAME",?55,"SSN",!,LR("%") Q
D H Q:LR("Q") W !,"ACC #",?20,"NAME",?55,"HRCN",!,LR("%") Q ;IHS/DIR TUC/AAB 5/4/98
H2 ;D H1 Q:LR("Q") W !,LRAC,?18,LRP,?50,SSN Q
D H1 Q:LR("Q") W !,LRAC,?18,LRP,?50,HRCN Q ;IHS/DIR TUC/AAB 5/4/98
H3 D H2 Q:LR("Q") W !?5,LRX Q
END D V^LRU Q
LRAPQAR ; IHS/DIR/AAB - 10% SURG PATH REVIEW 19:35 ; [ 05/28/98 2:04 PM ]
+1 ;;5.2;LR;**1002,1003**;JUN 01, 1998
+2 ;;5.2;LAB SERVICE;**72,173**;Sep 27, 1994
+3 SET LRDICS="SP"
DO ^LRAP
IF '$DATA(Y)
GOTO END
+4 WRITE !!?25,"10% ",LRO(68)," Review",!,"This report may take a while and should be queued to print at non-peak hours.",!,"OK to continue "
SET %=2
DO YN^LRU
IF %'=1
QUIT
+5 DO ASK^LRAPQAFS
IF %<1
GOTO END
+6 WRITE !
DO B^LRU
IF Y<0
GOTO END
SET LRSDT=LRSDT-.01
SET LRLDT=LRLDT+.99
+7 SET ZTRTN="QUE^LRAPQAR"
DO BEG^LRUTL
IF POP!($DATA(ZTSK))
GOTO END
QUE USE IO
KILL ^TMP($JOB),^TMP("LRAP",$JOB)
SET LRN="ALL"
SET (LRQ(9),LRS(5),LRS(99))=1
SET LR("DIWF")="W"
SET (LR,LR("A"),LR(1),LR(2),LR(3),LRQ(2),LRG,LRJ)=0
DO L^LRU
DO S^LRU
DO L1^LRU
DO XR^LRU
DO H
SET LR("F")=1
WRITE !,LR("%")
+1 FOR X=0:0
SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
IF 'LRSDT!(LRSDT>LRLDT)
QUIT
FOR LRDFN=0:0
SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))
IF 'LRDFN
QUIT
FOR LRI=0:0
SET LRI=$ORDER(^LR(LRXR,LRSDT,LRDFN,LRI))
IF 'LRI
QUIT
DO T
+2 WRITE !,"Total accessions:",?23,$JUSTIFY(LRG,5),!
DO A
DO EN2^LRUA
DO SET^LRUA
SET LRQ=0
SET LRA=1
DO W
+3 KILL ^TMP("LRAP",$JOB)
DO END^LRUTL
DO END
QUIT
T IF $PIECE($PIECE($GET(^LR(LRDFN,"SP",LRI,0)),U,6)," ")=LRABV
SET X=^(0)
SET Z=$EXTRACT($PIECE(X,U,10),1,3)
SET A=+$PIECE($PIECE(X,U,6)," ",3)
DO T1
+1 QUIT
T1 FOR X=0:0
SET X=$ORDER(^LR(LRDFN,"SP",LRI,2,X))
IF 'X
QUIT
SET Y=+^(X,0)
IF Y
IF $DATA(^LAB(61,Y,0))
SET Y=$EXTRACT($PIECE(^(0),U,2))
IF Y]""
SET ^TMP($JOB,"B",Y,Z,A)=""
SET LRG=LRG+1
+1 QUIT
A FOR X=0,1,2,3,4,5,6,7,8,9,0,"X","Y"
IF $DATA(^TMP($JOB,"B",X))
DO C
+1 KILL ^TMP($JOB,"B")
SET X=-1
FOR Y=0:0
SET X=$ORDER(^TMP($JOB,X))
IF X=""
QUIT
WRITE !?3,"Topography ",X,": ",$JUSTIFY(^(X),4)
+2 FOR X=0,1,2,3,4,5,6,7,8,9,"X","Y"
IF $DATA(^TMP($JOB,X))
SET T=^(X)
SET C=0
DO S
+3 QUIT
W WRITE !!,"Accessions for review: ",$JUSTIFY(LRJ,5)
IF LRG&(LRJ)
WRITE " (",$JUSTIFY(LRJ/LRG*100,5,2),"%)"
IF 'LRQA
DO H1
IF LR("Q")
QUIT
+1 FOR LRY=0:0
SET LRY=$ORDER(^TMP("LRAP",$JOB,LRY))
IF 'LRY!(LR("Q"))
QUIT
FOR LRAN=0:0
SET LRAN=$ORDER(^TMP("LRAP",$JOB,LRY,LRAN))
IF 'LRAN!(LR("Q"))
QUIT
DO D
+2 IF LRQA
SET LRQ=0
FOR LRY=0:0
SET LRY=$ORDER(^TMP("LRAP",$JOB,LRY))
IF 'LRY!(LR("Q"))
QUIT
DO B
+3 QUIT
D ;S LRDFN=$O(^LR("ASPA",LRY,LRABV,LRAN,0)),LRI=$O(^(LRDFN,0)),LRAC=$P($G(^LR(LRDFN,LRSS,LRI,0)),U,6) D:LRQA EN^LRSPRPT D:'LRQA ^LRUA S ^TMP("LRAP",$J,LRY,LRAN)=LRP_U_SSN_U_LRI_U_LRDFN_U_LRAC D:LRC L^LRAPQAMR Q
+1 ;IHS/DIR TUC/AAB 5/4/98
SET LRDFN=$ORDER(^LR("ASPA",LRY,LRABV,LRAN,0))
SET LRI=$ORDER(^(LRDFN,0))
SET LRAC=$PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,6)
IF LRQA
DO EN^LRSPRPT
IF 'LRQA
DO ^LRUA
SET ^TMP("LRAP",$JOB,LRY,LRAN)=LRP_U_HRCN_U_LRI_U_LRDFN_U_LRAC
IF LRC
DO L^LRAPQAMR
QUIT
B ;F LRAN=0:0 S LRAN=$O(^TMP("LRAP",$J,LRY,LRAN)) Q:'LRAN!(LR("Q")) S X=^(LRAN),LRP=$P(X,"^"),SSN=$P(X,"^",2),LRI=$P(X,"^",3),LRDFN=$P(X,"^",4),LRAC=$P(X,U,5) D:$Y>(IOSL-6) H1 Q:LR("Q") D R
+1 ;IHS/DIR TUC/AAB 5/4/98
FOR LRAN=0:0
SET LRAN=$ORDER(^TMP("LRAP",$JOB,LRY,LRAN))
IF 'LRAN!(LR("Q"))
QUIT
SET X=^(LRAN)
SET LRP=$PIECE(X,"^")
SET HRCN=$PIECE(X,"^",2)
SET LRI=$PIECE(X,"^",3)
SET LRDFN=$PIECE(X,"^",4)
SET LRAC=$PIECE(X,U,5)
IF $Y>(IOSL-6)
DO H1
IF LR("Q")
QUIT
DO R
+2 QUIT
R ;W !,LRAC,?18,LRP,?50,SSN I LRI F LRT=0:0 S LRT=$O(^LR(LRDFN,LRSS,LRI,2,LRT)) Q:'LRT!(LR("Q")) S X=+^(LRT,0),LRX=$P(^LAB(61,X,0),"^") D:$Y>(IOSL-6) H2 Q:LR("Q") W !?5,LRX D M
+1 ;IHS/DIR TUC/AAB 5/4/98
WRITE !,LRAC,?18,LRP,?50,HRCN
IF LRI
FOR LRT=0:0
SET LRT=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRT))
IF 'LRT!(LR("Q"))
QUIT
SET X=+^(LRT,0)
SET LRX=$PIECE(^LAB(61,X,0),"^")
IF $Y>(IOSL-6)
DO H2
IF LR("Q")
QUIT
WRITE !?5,LRX
DO M
+2 WRITE !,LR("%")
QUIT
M FOR LRM=0:0
SET LRM=$ORDER(^LR(LRDFN,LRSS,LRI,2,LRT,2,LRM))
IF 'LRM!(LR("Q"))
QUIT
SET X=+^(LRM,0)
SET M=$PIECE(^LAB(61.1,X,0),"^")
IF $Y>(IOSL-6)
DO H3
IF LR("Q")
QUIT
WRITE !?10,M
+1 QUIT
C SET C=0
FOR A=0:0
SET A=$ORDER(^TMP($JOB,"B",X,A))
IF 'A
QUIT
FOR B=0:0
SET B=$ORDER(^TMP($JOB,"B",X,A,B))
IF 'B
QUIT
SET C=C+1
SET ^TMP($JOB,X,C)=A_"^"_B
+1 SET ^TMP($JOB,X)=C
QUIT
S SET N=T*.1
IF N<1
SET N=1
IF N["."
SET N=N_"00"
SET A=$EXTRACT($PIECE(N,".",2),1,3)
SET B=$PIECE(N,".")
SET N=$SELECT(A>499:B+1,1:B)
+1 IF T=1
SET F=^TMP($JOB,X,1)
SET ^TMP("LRAP",$JOB,$PIECE(F,"^"),$PIECE(F,"^",2))=""
SET LRJ=LRJ+1
KILL ^TMP($JOB,X,1)
QUIT
+2 FOR Y=0:0
IF C=N
QUIT
SET E=$RANDOM(T)+1
IF $DATA(^TMP($JOB,X,E))
SET F=^(E)
SET ^TMP("LRAP",$JOB,$PIECE(F,"^"),$PIECE(F,"^",2))=""
SET C=C+1
SET LRJ=LRJ+1
KILL ^TMP($JOB,X,E)
+3 QUIT
+4 ;
H IF $DATA(LR("F"))
IF $EXTRACT(IOST,1,2)="C-"
DO M^LRU
IF LR("Q")
QUIT
+1 DO F^LRU
WRITE !,"10% ",LRAA(1)," Review from ",LRSTR," to ",LRLST
QUIT
H1 ;D H Q:LR("Q") W !,"ACC #",?20,"NAME",?55,"SSN",!,LR("%") Q
+1 ;IHS/DIR TUC/AAB 5/4/98
DO H
IF LR("Q")
QUIT
WRITE !,"ACC #",?20,"NAME",?55,"HRCN",!,LR("%")
QUIT
H2 ;D H1 Q:LR("Q") W !,LRAC,?18,LRP,?50,SSN Q
+1 ;IHS/DIR TUC/AAB 5/4/98
DO H1
IF LR("Q")
QUIT
WRITE !,LRAC,?18,LRP,?50,HRCN
QUIT
H3 DO H2
IF LR("Q")
QUIT
WRITE !?5,LRX
QUIT
END DO V^LRU
QUIT
