source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPSM1.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1LRAPSM1 ;AVAMC/REG/CYM - SEARCH BY SNOMED CODE PRINT ;8/13/97 09:58 ;
2 ;;5.2;LAB SERVICE;**72,173**;Sep 27, 1994
3 S (LR(13),N)=0,T="," S:LRN="" LRN="MANY" D H S LR("F")=1 D H1
4 F A=0:1 S N=$O(^TMP($J,"B",N)) Q:N=""!(LR("Q")) S LRYA=$O(^(N,0)),LRAX=$O(^(LRYA,0)),LR(11)=^TMP($J,LRYA,LRAX) D:$Y>(IOSL-6) H,H1 Q:LR("Q") D Y
5 S H(2)=1 D H,H2 Q:LR("Q") D L
6 D H Q:LR("Q") W !,?21,"RESULT OF ",LRO(68)," SEARCH: "
7 W !,LRAA(1)," PATIENTS WITHIN PERIOD SEARCHED: ",LR(2) W:LRSS'="AU" !,LRO(68)," ACCESSIONS WITHIN PERIOD SEARCHED: ",LR(3)
8 I LR(2) W !!,$J(A,5)," OF ",$J(LR(2),5)," PATIENTS(",$J(A*100/LR(2),5,2),"%)"
9 I LR(1) W !,$J(LR(13),5)," OF ",$J(LR(1),5)," SNOMED CODE ",S(2)," SPECIMENS(",$J(LR(13)*100/LR(1),5,2),"%)"
10 I LR W !,$J(LR,14)," ORGAN/TISSUE SPECIMENS WITHIN PERIOD SEARCHED",!?15,"(SNOMED TOPOGRAPHY CODE ",S(2)," IS ",$J(LR(1)*100/LR,5,2),"%)"
11 Q
12Y W ! W:$P(LR(11),"^",7)'=2 "#" W $E(N,1,17),?19,$P(LR(11),"^",5),?25,$P(LR(11),"^",3) S H(2)=0 F B=0:1 S H(2)=$O(^TMP($J,"B",N,H(2))) Q:'H(2)!(LR("Q")) W:B ! D ABC
13 Q
14ABC S LRAN=0 F C=0:1 S LRAN=$O(^TMP($J,"B",N,H(2),LRAN)) Q:'LRAN!(LR("Q")) D PRT
15 Q
16PRT S LR(11)=^TMP($J,H(2),LRAN) W:C>0 ! W ?27,$P(LR(11),"^",2) W ?31,$J($P(LR(11),"^"),7)
17 S LR(7)=0 F E=1:1 S LR(7)=$O(^TMP($J,H(2),LRAN,LR(7))) Q:'LR(7)!(LR("Q")) S LR(5)=^(LR(7),0),LR(13)=LR(13)+1 D:$Y>(IOSL-6) H3 Q:LR("Q") W:E>1 ! W ?46,$E(LR(5),1,15) D M1
18 Q
19M1 S M=0 F Z=1:1 S M=$O(^TMP($J,H(2),LRAN,LR(7),M)) Q:M=""!(LR("Q")) S LR(6)=^(M) D:$Y>(IOSL-6) H5 Q:LR("Q") W:Z>1 ! S X=$P(LR(6),"^",2),Y=$S(X]"":16,1:80) W ?62,$E($P(LR(6),"^"),1,Y) W:X]"" ?80,$S(X=0:"Neg",X=1:"Pos",1:"?")
20 Q
21L F B=0:1 S H(2)=$O(^TMP($J,H(2))) Q:'H(2)!(LR("Q")) D W
22 Q
23W S LRAN=0 F C=0:1 S LRAN=$O(^TMP($J,H(2),LRAN)) Q:'LRAN!(LR("Q")) D PT
24 Q
25PT D:$Y>(IOSL-6) H,H2 Q:LR("Q")
26 S LR(11)=^TMP($J,H(2),LRAN) W !,$P(LR(11),"^"),?16 W:$P(LR(11),"^",7)'=2 "#" W $E($P(LR(11),"^",4),1,15),?33,$P(LR(11),"^",5),?38,$P(LR(11),"^",3),?41,$J($P(LR(11),"^",2),3),?45,$J($P(LR(11),"^",6),5)
27 S LR(7)=0 F E=1:1 S LR(7)=$O(^TMP($J,H(2),LRAN,LR(7))) Q:'LR(7)!(LR("Q")) S LR(5)=^(LR(7),0) D:$Y>(IOSL-6) H4 Q:LR("Q") W:E>1 ! W ?52,$E(LR(5),1,15) D M
28 Q
29M S M=0 F Z=1:1 S M=$O(^TMP($J,H(2),LRAN,LR(7),M)) Q:M=""!(LR("Q")) S LR(6)=^(M) D:$Y>(IOSL-6) H6 Q:LR("Q") W:Z>1 ! S X=$P(LR(6),"^",2),Y=$S(X]"":11,1:80) W ?69,$E($P(LR(6),"^"),1,Y) W:Y=11 ?86,$S(X=0:"Neg",X=1:"Pos",1:"?")
30 Q
31H I $D(LR("F")),$E(IOST,1,2)="C-" D M^LRU Q:LR("Q")
32 D F^LRU W !,LRO(68)," (",LRABV,") SEARCH(",LRSTR,"=>",LRLST,")"
33 W !,"# = Not VA patient",!,"SNOMED TOPOGRAPHY CODE: ",S(2)_$E("-----",1,5-$L(S(2))),?46,"SNOMED ",S(7)," CODE: ",LRN_$E("-----",1,5-$L(LRN))
34 W !,LR("%") Q
35H1 Q:LR("Q") W !!,?8,"NAME",?19,"ID",?23,"SEX",?27,"AGE",?32,"ACC #",?43,"ORGAN/TISSUE",?62,S(7) W !! Q
36H2 Q:LR("Q") W !!,"ACC #",?16,"NAME",?33,"ID",?37,"SEX",?41,"AGE",?45,"MO/DA",?52,"ORGAN/TISSUE",?69,S(7) Q
37H3 D H,H1 Q:LR("Q") W !,$E(N,1,18),?19,$P(LR(11),"^",5),?25,$P(LR(11),"^",3),?27,$P(LR(11),"^",2),?31,$J($P(LR(11),"^"),7) Q
38H4 D H,H2 Q:LR("Q") W !,$P(LR(11),"^"),?16,$E($P(LR(11),"^",4),1,15),?33,$P(LR(11),"^",5),?38,$P(LR(11),"^",3),?41,$J($P(LR(11),"^",2),3),?45,$J($P(LR(11),"^",6),5) Q
39H5 D H3 Q:LR("Q") W ?43,$E(LR(5),1,15) Q
40H6 D H4 Q:LR("Q") W ?55,$E(LR(5),1,15) Q
Note: See TracBrowser for help on using the repository browser.