LRUB ;AVAMC/REG - GET 62.5 ENTRIES ; 11/12/88 07:45 ;
;;5.2;LAB SERVICE;**247**;Sep 27, 1994
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
I $D(L)'=11 S L=80
S:'$D(L(1))#2 L(1)="DRXZJT"
S L(2)="" F L(6)=1:1 Q:$P(X," ",L(6),99)="" S L(3)=$P(X," ",L(6)),L(5)="" D:L(3)]"" P S L(4)=$L(L(2))+$L(L(3)) S:L(4)'>L L(2)=L(2)_L(3)_" " I L(4)>L W " too long",! G OUT
W:X]"" " (",$E(L(2),1,$L(L(2))-1),")" S X=$E(L(2),1,$L(L(2))-1) K L Q
P F L(5)=0:0 S L(5)=$O(^LAB(62.5,"B",L(3),L(5))) Q:'L(5) I L(1)[$P(^LAB(62.5,L(5),0),U,4) S L(3)=$P(^LAB(62.5,L(5),0),"^",2) Q:'$D(^(9)) S L(5)=$P(X," ",L(6)-1) S:L(5)>1 L(3)=^(9) Q
Q
OUT K L,X Q
Q ;
I $L(L(1))>1,$E(L(1))="J" S L(1)=$E(L(1),2,$L(L(1)))
W !!,"CHOOSE FROM:",!
S L(2)="A"_L(1),L(3)=0 F L(5)=1:1 S L(3)=$O(^LAB(62.5,L(2),L(3))) Q:L(3)="" S L(4)=$O(^LAB(62.5,L(2),L(3),0)) D W Q:'$D(X)
Q
W Q:'L(4) I '$D(^LAB(62.5,L(4),0)) K ^LAB(62.5,L(2),L(3),L(4)) Q
D:L(5)#21=0 ASK Q:'$D(X) S X=^LAB(62.5,L(4),0) W $P(X,"^")," ",$P(X,"^",2),! Q
;
ASK R "'^' TO STOP: ",X:DTIME W $C(13),$J("",15),$C(13) K:X[U!('$T) X Q
;
;L=length of entry ;L(1)=Screen (set this in input transform/xecutable help)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUB 1216 printed Dec 13, 2024@02:21:15 Page 2
LRUB ;AVAMC/REG - GET 62.5 ENTRIES ; 11/12/88 07:45 ;
+1 ;;5.2;LAB SERVICE;**247**;Sep 27, 1994
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 IF $DATA(L)'=11
SET L=80
+4 if '$DATA(L(1))#2
SET L(1)="DRXZJT"
+5 SET L(2)=""
FOR L(6)=1:1
if $PIECE(X," ",L(6),99)=""
QUIT
SET L(3)=$PIECE(X," ",L(6))
SET L(5)=""
if L(3)]""
DO P
SET L(4)=$LENGTH(L(2))+$LENGTH(L(3))
if L(4)'>L
SET L(2)=L(2)_L(3)_" "
IF L(4)>L
WRITE " too long",!
GOTO OUT
+6 if X]""
WRITE " (",$EXTRACT(L(2),1,$LENGTH(L(2))-1),")"
SET X=$EXTRACT(L(2),1,$LENGTH(L(2))-1)
KILL L
QUIT
P FOR L(5)=0:0
SET L(5)=$ORDER(^LAB(62.5,"B",L(3),L(5)))
if 'L(5)
QUIT
IF L(1)[$PIECE(^LAB(62.5,L(5),0),U,4)
SET L(3)=$PIECE(^LAB(62.5,L(5),0),"^",2)
if '$DATA(^(9))
QUIT
SET L(5)=$PIECE(X," ",L(6)-1)
if L(5)>1
SET L(3)=^(9)
QUIT
+1 QUIT
OUT KILL L,X
QUIT
Q ;
+1 IF $LENGTH(L(1))>1
IF $EXTRACT(L(1))="J"
SET L(1)=$EXTRACT(L(1),2,$LENGTH(L(1)))
+2 WRITE !!,"CHOOSE FROM:",!
+3 SET L(2)="A"_L(1)
SET L(3)=0
FOR L(5)=1:1
SET L(3)=$ORDER(^LAB(62.5,L(2),L(3)))
if L(3)=""
QUIT
SET L(4)=$ORDER(^LAB(62.5,L(2),L(3),0))
DO W
if '$DATA(X)
QUIT
+4 QUIT
W if 'L(4)
QUIT
IF '$DATA(^LAB(62.5,L(4),0))
KILL ^LAB(62.5,L(2),L(3),L(4))
QUIT
+1 if L(5)#21=0
DO ASK
if '$DATA(X)
QUIT
SET X=^LAB(62.5,L(4),0)
WRITE $PIECE(X,"^")," ",$PIECE(X,"^",2),!
QUIT
+2 ;
ASK READ "'^' TO STOP: ",X:DTIME
WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13)
if X[U!('$TEST)
KILL X
QUIT
+1 ;
+2 ;L=length of entry ;L(1)=Screen (set this in input transform/xecutable help)
