- 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 Feb 18, 2025@23:47:07 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)
