LRAPSM1 ;AVAMC/REG/CYM - SEARCH BY SNOMED CODE PRINT ;8/13/97 09:58 ;
;;5.2;LAB SERVICE;**72,173**;Sep 27, 1994
S (LR(13),N)=0,T="," S:LRN="" LRN="MANY" D H S LR("F")=1 D H1
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
S H(2)=1 D H,H2 Q:LR("Q") D L
D H Q:LR("Q") W !,?21,"RESULT OF ",LRO(68)," SEARCH: "
W !,LRAA(1)," PATIENTS WITHIN PERIOD SEARCHED: ",LR(2) W:LRSS'="AU" !,LRO(68)," ACCESSIONS WITHIN PERIOD SEARCHED: ",LR(3)
I LR(2) W !!,$J(A,5)," OF ",$J(LR(2),5)," PATIENTS(",$J(A*100/LR(2),5,2),"%)"
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),"%)"
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),"%)"
Q
Y 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
Q
ABC S LRAN=0 F C=0:1 S LRAN=$O(^TMP($J,"B",N,H(2),LRAN)) Q:'LRAN!(LR("Q")) D PRT
Q
PRT S LR(11)=^TMP($J,H(2),LRAN) W:C>0 ! W ?27,$P(LR(11),"^",2) W ?31,$J($P(LR(11),"^"),7)
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
Q
M1 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:"?")
Q
L F B=0:1 S H(2)=$O(^TMP($J,H(2))) Q:'H(2)!(LR("Q")) D W
Q
W S LRAN=0 F C=0:1 S LRAN=$O(^TMP($J,H(2),LRAN)) Q:'LRAN!(LR("Q")) D PT
Q
PT D:$Y>(IOSL-6) H,H2 Q:LR("Q")
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)
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
Q
M 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:"?")
Q
H I $D(LR("F")),$E(IOST,1,2)="C-" D M^LRU Q:LR("Q")
D F^LRU W !,LRO(68)," (",LRABV,") SEARCH(",LRSTR,"=>",LRLST,")"
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))
W !,LR("%") Q
H1 Q:LR("Q") W !!,?8,"NAME",?19,"ID",?23,"SEX",?27,"AGE",?32,"ACC #",?43,"ORGAN/TISSUE",?62,S(7) W !! Q
H2 Q:LR("Q") W !!,"ACC #",?16,"NAME",?33,"ID",?37,"SEX",?41,"AGE",?45,"MO/DA",?52,"ORGAN/TISSUE",?69,S(7) Q
H3 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
H4 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
H5 D H3 Q:LR("Q") W ?43,$E(LR(5),1,15) Q
H6 D H4 Q:LR("Q") W ?55,$E(LR(5),1,15) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRAPSM1 3284 printed Dec 13, 2024@02:08:23 Page 2
LRAPSM1 ;AVAMC/REG/CYM - SEARCH BY SNOMED CODE PRINT ;8/13/97 09:58 ;
+1 ;;5.2;LAB SERVICE;**72,173**;Sep 27, 1994
+2 SET (LR(13),N)=0
SET T=","
if LRN=""
SET LRN="MANY"
DO H
SET LR("F")=1
DO H1
+3 FOR A=0:1
SET N=$ORDER(^TMP($JOB,"B",N))
if N=""!(LR("Q"))
QUIT
SET LRYA=$ORDER(^(N,0))
SET LRAX=$ORDER(^(LRYA,0))
SET LR(11)=^TMP($JOB,LRYA,LRAX)
if $Y>(IOSL-6)
DO H
DO H1
if LR("Q")
QUIT
DO Y
+4 SET H(2)=1
DO H
DO H2
if LR("Q")
QUIT
DO L
+5 DO H
if LR("Q")
QUIT
WRITE !,?21,"RESULT OF ",LRO(68)," SEARCH: "
+6 WRITE !,LRAA(1)," PATIENTS WITHIN PERIOD SEARCHED: ",LR(2)
if LRSS'="AU"
WRITE !,LRO(68)," ACCESSIONS WITHIN PERIOD SEARCHED: ",LR(3)
+7 IF LR(2)
WRITE !!,$JUSTIFY(A,5)," OF ",$JUSTIFY(LR(2),5)," PATIENTS(",$JUSTIFY(A*100/LR(2),5,2),"%)"
+8 IF LR(1)
WRITE !,$JUSTIFY(LR(13),5)," OF ",$JUSTIFY(LR(1),5)," SNOMED CODE ",S(2)," SPECIMENS(",$JUSTIFY(LR(13)*100/LR(1),5,2),"%)"
+9 IF LR
WRITE !,$JUSTIFY(LR,14)," ORGAN/TISSUE SPECIMENS WITHIN PERIOD SEARCHED",!?15,"(SNOMED TOPOGRAPHY CODE ",S(2)," IS ",$JUSTIFY(LR(1)*100/LR,5,2),"%)"
+10 QUIT
Y WRITE !
if $PIECE(LR(11),"^",7)'=2
WRITE "#"
WRITE $EXTRACT(N,1,17),?19,$PIECE(LR(11),"^",5),?25,$PIECE(LR(11),"^",3)
SET H(2)=0
FOR B=0:1
SET H(2)=$ORDER(^TMP($JOB,"B",N,H(2)))
if 'H(2)!(LR("Q"))
QUIT
if B
WRITE !
DO ABC
+1 QUIT
ABC SET LRAN=0
FOR C=0:1
SET LRAN=$ORDER(^TMP($JOB,"B",N,H(2),LRAN))
if 'LRAN!(LR("Q"))
QUIT
DO PRT
+1 QUIT
PRT SET LR(11)=^TMP($JOB,H(2),LRAN)
if C>0
WRITE !
WRITE ?27,$PIECE(LR(11),"^",2)
WRITE ?31,$JUSTIFY($PIECE(LR(11),"^"),7)
+1 SET LR(7)=0
FOR E=1:1
SET LR(7)=$ORDER(^TMP($JOB,H(2),LRAN,LR(7)))
if 'LR(7)!(LR("Q"))
QUIT
SET LR(5)=^(LR(7),0)
SET LR(13)=LR(13)+1
if $Y>(IOSL-6)
DO H3
if LR("Q")
QUIT
if E>1
WRITE !
WRITE ?46,$EXTRACT(LR(5),1,15)
DO M1
+2 QUIT
M1 SET M=0
FOR Z=1:1
SET M=$ORDER(^TMP($JOB,H(2),LRAN,LR(7),M))
if M=""!(LR("Q"))
QUIT
SET LR(6)=^(M)
if $Y>(IOSL-6)
DO H5
if LR("Q")
QUIT
if Z>1
WRITE !
SET X=$PIECE(LR(6),"^",2)
SET Y=$SELECT(X]"":16,1:80)
WRITE ?62,$EXTRACT($PIECE(LR(6),"^"),1,Y)
if X]""
WRITE ?80,$SELECT(X=0:"Neg",X=1:"Pos",1:"?")
+1 QUIT
L FOR B=0:1
SET H(2)=$ORDER(^TMP($JOB,H(2)))
if 'H(2)!(LR("Q"))
QUIT
DO W
+1 QUIT
W SET LRAN=0
FOR C=0:1
SET LRAN=$ORDER(^TMP($JOB,H(2),LRAN))
if 'LRAN!(LR("Q"))
QUIT
DO PT
+1 QUIT
PT if $Y>(IOSL-6)
DO H
DO H2
if LR("Q")
QUIT
+1 SET LR(11)=^TMP($JOB,H(2),LRAN)
WRITE !,$PIECE(LR(11),"^"),?16
if $PIECE(LR(11),"^",7)'=2
WRITE "#"
WRITE $EXTRACT($PIECE(LR(11),"^",4),1,15),?33,$PIECE(LR(11),"^",5),?38,$PIECE(LR(11),"^",3),?41,$JUSTIFY($PIECE(LR(11),"^",2),3),?45,$JUSTIFY($PIECE(LR(11),"^",6),5)
+2 SET LR(7)=0
FOR E=1:1
SET LR(7)=$ORDER(^TMP($JOB,H(2),LRAN,LR(7)))
if 'LR(7)!(LR("Q"))
QUIT
SET LR(5)=^(LR(7),0)
if $Y>(IOSL-6)
DO H4
if LR("Q")
QUIT
if E>1
WRITE !
WRITE ?52,$EXTRACT(LR(5),1,15)
DO M
+3 QUIT
M SET M=0
FOR Z=1:1
SET M=$ORDER(^TMP($JOB,H(2),LRAN,LR(7),M))
if M=""!(LR("Q"))
QUIT
SET LR(6)=^(M)
if $Y>(IOSL-6)
DO H6
if LR("Q")
QUIT
if Z>1
WRITE !
SET X=$PIECE(LR(6),"^",2)
SET Y=$SELECT(X]"":11,1:80)
WRITE ?69,$EXTRACT($PIECE(LR(6),"^"),1,Y)
if Y=11
WRITE ?86,$SELECT(X=0:"Neg",X=1:"Pos",1:"?")
+1 QUIT
H IF $DATA(LR("F"))
IF $EXTRACT(IOST,1,2)="C-"
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,LRO(68)," (",LRABV,") SEARCH(",LRSTR,"=>",LRLST,")"
+2 WRITE !,"# = Not VA patient",!,"SNOMED TOPOGRAPHY CODE: ",S(2)_$EXTRACT("-----",1,5-$LENGTH(S(2))),?46,"SNOMED ",S(7)," CODE: ",LRN_$EXTRACT("-----",1,5-$LENGTH(LRN))
+3 WRITE !,LR("%")
QUIT
H1 if LR("Q")
QUIT
WRITE !!,?8,"NAME",?19,"ID",?23,"SEX",?27,"AGE",?32,"ACC #",?43,"ORGAN/TISSUE",?62,S(7)
WRITE !!
QUIT
H2 if LR("Q")
QUIT
WRITE !!,"ACC #",?16,"NAME",?33,"ID",?37,"SEX",?41,"AGE",?45,"MO/DA",?52,"ORGAN/TISSUE",?69,S(7)
QUIT
H3 DO H
DO H1
if LR("Q")
QUIT
WRITE !,$EXTRACT(N,1,18),?19,$PIECE(LR(11),"^",5),?25,$PIECE(LR(11),"^",3),?27,$PIECE(LR(11),"^",2),?31,$JUSTIFY($PIECE(LR(11),"^"),7)
QUIT
H4 DO H
DO H2
if LR("Q")
QUIT
WRITE !,$PIECE(LR(11),"^"),?16,$EXTRACT($PIECE(LR(11),"^",4),1,15),?33,$PIECE(LR(11),"^",5),?38,$PIECE(LR(11),"^",3),?41,$JUSTIFY($PIECE(LR(11),"^",2),3),?45,$JUSTIFY($PIECE(LR(11),"^",6),5)
QUIT
H5 DO H3
if LR("Q")
QUIT
WRITE ?43,$EXTRACT(LR(5),1,15)
QUIT
H6 DO H4
if LR("Q")
QUIT
WRITE ?55,$EXTRACT(LR(5),1,15)
QUIT
