LRSPSICP ;AVAMC/REG - SEARCH BY ICD CODE PRINT ;8/15/95 08:50 ;
;;5.2;LAB SERVICE;**72,422**;Sep 27, 1994;Build 29
S N=0 D H,H1 S LR("F")=1
F A=0:1 S N=$O(^TMP($J,"B",N)) Q:N=""!(LR("Q")) S V(2)=$O(^(N,0)),V(3)=$O(^(V(2),0)),V=^TMP($J,V(2),V(3)) D:$Y>(IOSL-6) H,H1 Q:LR("Q") W !,$E(N,1,18),?19,$P(V,"^",5),?25,$P(V,"^",3) D A
S H(2)=1 D H,H2 Q:LR("Q") D L
Q
A S H(2)=0 F B=0:1 S H(2)=$O(^TMP($J,"B",N,H(2))) Q:'H(2)!(LR("Q")) 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 V=^TMP($J,H(2),LRAN) W:C>0 ! W ?27,$P(V,"^",2) W ?31,$J($P(V,"^"),7),?39,$E($P(V,"^",8),1,18)
S O=0 F Z=1:1 S O=$O(^TMP($J,H(2),LRAN,O)) Q:'O!(LR("Q")) D:$Y>(IOSL-6) H3 Q:LR("Q") W:Z>1 ! W ?58,$E(^(O),1,21)
Q
L F B=0:1 S H(2)=$O(^TMP($J,H(2))) Q:'H(2)!(LR("Q")) D LRAN
Q
LRAN 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 V=^TMP($J,H(2),LRAN) W !,$J($P(V,"^"),7),?9,$E($P(V,"^",4),1,18),?28,$P(V,"^",5),?34,$P(V,"^",3),?37,$J($P(V,"^",2),3),?41
W $J($P(V,"^",6),5),?47,$E($P(V,"^",8),1,15) S O=-1 F Z=1:1 S O=$O(^TMP($J,H(2),LRAN,O)) Q:'O!(LR("Q")) D:$Y>(IOSL-6) H4 Q:LR("Q") W:Z>1 ! W ?65,$E(^(O),1,14)
Q
H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
D F^LRU W !,LRO(68)," SEARCH (",LRSTR,"=>",LRLST,")"
W !!,"ICD CODE: ",I(1),?20,I
W !,LR("%") Q
H1 Q:LR("Q") W !!,?8,"NAME",?19,"ID",?23,"SEX",?27,"AGE",?32,"ACC #",!! Q
H2 Q:LR("Q") W !!,"ACC #",?9,"NAME",?28,"ID",?33,"SEX",?37,"AGE",?41,"MO/DA" Q
H3 D H,H1 Q:LR("Q") W !,$E(N,1,18),?19,$P(V,"^",5),?25,$P(V,"^",3),?27,$P(V,"^",2),?31,$J($P(V,"^"),7) Q
H4 D H,H2 Q:LR("Q") W !,$J($P(V,"^"),7),?9,$E($P(V,"^",4),1,18),?28,$P(V,"^",5),?34,$P(V,"^",3),?37,$J($P(V,"^",2),3),?41,$J($P(V,"^",6),5) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRSPSICP 1793 printed Dec 13, 2024@02:20:45 Page 2
LRSPSICP ;AVAMC/REG - SEARCH BY ICD CODE PRINT ;8/15/95 08:50 ;
+1 ;;5.2;LAB SERVICE;**72,422**;Sep 27, 1994;Build 29
+2 SET N=0
DO H
DO H1
SET LR("F")=1
+3 FOR A=0:1
SET N=$ORDER(^TMP($JOB,"B",N))
if N=""!(LR("Q"))
QUIT
SET V(2)=$ORDER(^(N,0))
SET V(3)=$ORDER(^(V(2),0))
SET V=^TMP($JOB,V(2),V(3))
if $Y>(IOSL-6)
DO H
DO H1
if LR("Q")
QUIT
WRITE !,$EXTRACT(N,1,18),?19,$PIECE(V,"^",5),?25,$PIECE(V,"^",3)
DO A
+4 SET H(2)=1
DO H
DO H2
if LR("Q")
QUIT
DO L
+5 QUIT
A SET H(2)=0
FOR B=0:1
SET H(2)=$ORDER(^TMP($JOB,"B",N,H(2)))
if 'H(2)!(LR("Q"))
QUIT
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 V=^TMP($JOB,H(2),LRAN)
if C>0
WRITE !
WRITE ?27,$PIECE(V,"^",2)
WRITE ?31,$JUSTIFY($PIECE(V,"^"),7),?39,$EXTRACT($PIECE(V,"^",8),1,18)
+1 SET O=0
FOR Z=1:1
SET O=$ORDER(^TMP($JOB,H(2),LRAN,O))
if 'O!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H3
if LR("Q")
QUIT
if Z>1
WRITE !
WRITE ?58,$EXTRACT(^(O),1,21)
+2 QUIT
L FOR B=0:1
SET H(2)=$ORDER(^TMP($JOB,H(2)))
if 'H(2)!(LR("Q"))
QUIT
DO LRAN
+1 QUIT
LRAN 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 V=^TMP($JOB,H(2),LRAN)
WRITE !,$JUSTIFY($PIECE(V,"^"),7),?9,$EXTRACT($PIECE(V,"^",4),1,18),?28,$PIECE(V,"^",5),?34,$PIECE(V,"^",3),?37,$JUSTIFY($PIECE(V,"^",2),3),?41
+2 WRITE $JUSTIFY($PIECE(V,"^",6),5),?47,$EXTRACT($PIECE(V,"^",8),1,15)
SET O=-1
FOR Z=1:1
SET O=$ORDER(^TMP($JOB,H(2),LRAN,O))
if 'O!(LR("Q"))
QUIT
if $Y>(IOSL-6)
DO H4
if LR("Q")
QUIT
if Z>1
WRITE !
WRITE ?65,$EXTRACT(^(O),1,14)
+3 QUIT
H IF $DATA(LR("F"))
IF IOST?1"C".E
DO M^LRU
if LR("Q")
QUIT
+1 DO F^LRU
WRITE !,LRO(68)," SEARCH (",LRSTR,"=>",LRLST,")"
+2 WRITE !!,"ICD CODE: ",I(1),?20,I
+3 WRITE !,LR("%")
QUIT
H1 if LR("Q")
QUIT
WRITE !!,?8,"NAME",?19,"ID",?23,"SEX",?27,"AGE",?32,"ACC #",!!
QUIT
H2 if LR("Q")
QUIT
WRITE !!,"ACC #",?9,"NAME",?28,"ID",?33,"SEX",?37,"AGE",?41,"MO/DA"
QUIT
H3 DO H
DO H1
if LR("Q")
QUIT
WRITE !,$EXTRACT(N,1,18),?19,$PIECE(V,"^",5),?25,$PIECE(V,"^",3),?27,$PIECE(V,"^",2),?31,$JUSTIFY($PIECE(V,"^"),7)
QUIT
H4 DO H
DO H2
if LR("Q")
QUIT
WRITE !,$JUSTIFY($PIECE(V,"^"),7),?9,$EXTRACT($PIECE(V,"^",4),1,18),?28,$PIECE(V,"^",5),?34,$PIECE(V,"^",3),?37,$JUSTIFY($PIECE(V,"^",2),3),?41,$JUSTIFY($PIECE(V,"^",6),5)
QUIT
