- 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 Feb 18, 2025@23:34:16 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