- 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
