LRUC ; IHS/DIR/AAB - GET PATIENT LOCATION 5/30/96 22:22 ; [ 07/22/2002 1:54 PM ]
;;5.2;LR;**1002,1013**;JUL 15, 2002
;;5.2;LAB SERVICE;**72**;Sep 27, 1994
S B=0 F C=0:0 S C=$O(^SC("B",X,C)) Q:'C I DUZ(2)=+$$SITE^VASITE(DT,($P($G(^SC(C,0)),U,15))) S B=1 Q
Q:B D REST G END
REST D END I $O(^SC("C",X,0)) K C,B,A D XR Q
S A(2)="",A=X,Z=0 I A=+A S A=A_$C(32)
W ! F B=0:1 S A=$O(^SC("B",A)) Q:$E(A,1,$L(X))'=X!(A(2)?1P) F C=0:0 S C=$O(^SC("B",A,C)) Q:'C!(A(2)?1P) I DUZ(2)=+$$SITE^VASITE(DT,($P($G(^SC(C,0)),U,15))) S Z=Z+1,^TMP("LRLOC",$J,Z)=A W $J(Z,2),?5,A,! I Z#5=0 D C Q:A(2)?1P
Q:A(2)?1P I B W ! D C K:A(2)="" X Q
W !!,"NON-STANDARD LOCATION ! OK " S %=2 D YN^LRU K:%'=1 X Q
C I Z=1 S A(2)=1 G F
W $C(13),"TYPE '^' TO STOP OR",!,"CHOOSE 1-",Z R ": ",A(2):DTIME I A(2)?1P!'$T S A=$C(126) K X Q
I A(2)="" W ! Q
F I A(2)>0,A(2)<(Z+1) S X=^TMP("LRLOC",$J,A(2)) S %=1 W ?($X+5),X," OK " D YN^LRU K:%'=1 X
S A(2)=$S(A(2)>Z:"",1:"^"),A=$C(126) Q
;
XR W ! S Z=0 F A=0:0 S A=$O(^SC("C",X,A)) Q:'A I DUZ(2)=+$$SITE^VASITE(DT,($P($G(^SC(A,0)),U,15))) S Z=Z+1,A(1)=$P(^SC(A,0),"^"),^TMP("LRLOC",$J,Z)=A(1) W $J(Z,2),?5,A(1),?40,"Abbrev: ",X,! I Z#5=0 D C Q:A(2)?1P
D C K:A(2)="" X Q
EN ;
I '$D(^SC("B")) W $C(7),"No STANDARD LOCATIONS to choose from.",!,"You may enter a NON-STANDARD LOCATION",! Q
I X'["??" W !,"ANSWER WITH ",$P(^SC(0),"^"),!,"DO YOU WANT THE ENTIRE ",$P(^(0),"^")," LIST ? " S (%,LR("%"))="" D RX^LRU Q:%'=1
S (A,A(2))=0,A(1)=$Y+21 W !?3 F B=0:0 S A=$O(^SC("B",A)) Q:A=""!(A(2)?1P) F C=0:0 S C=$O(^SC("B",A,C)) Q:'C!(A(2)?1P) D:$Y>A(1)!'$Y MORE Q:A(2)?1P N LRDIV S LRDIV=$P($G(^SC(C,0)),U,15) Q:'LRDIV Q:DUZ(2)'=+$$SITE^VASITE(DT,LRDIV) W A,!?3
Q
MORE R "'^' TO STOP: ",A(2):DTIME I A(2)?1P S A=$C(126) Q
S A(1)=A(1)+21 W $C(13),$J("",15),$C(13),?3 Q
;
END K ^TMP("LRLOC",$J) Q
LRUC ; IHS/DIR/AAB - GET PATIENT LOCATION 5/30/96 22:22 ; [ 07/22/2002 1:54 PM ]
+1 ;;5.2;LR;**1002,1013**;JUL 15, 2002
+2 ;;5.2;LAB SERVICE;**72**;Sep 27, 1994
+3 SET B=0
FOR C=0:0
SET C=$ORDER(^SC("B",X,C))
IF 'C
QUIT
IF DUZ(2)=+$$SITE^VASITE(DT,($PIECE($GET(^SC(C,0)),U,15)))
SET B=1
QUIT
+4 IF B
QUIT
DO REST
GOTO END
REST DO END
IF $ORDER(^SC("C",X,0))
KILL C,B,A
DO XR
QUIT
+1 SET A(2)=""
SET A=X
SET Z=0
IF A=+A
SET A=A_$CHAR(32)
+2 WRITE !
FOR B=0:1
SET A=$ORDER(^SC("B",A))
IF $EXTRACT(A,1,$LENGTH(X))'=X!(A(2)?1P)
QUIT
FOR C=0:0
SET C=$ORDER(^SC("B",A,C))
IF 'C!(A(2)?1P)
QUIT
IF DUZ(2)=+$$SITE^VASITE(DT,($PIECE($GET(^SC(C,0)),U,15)))
SET Z=Z+1
SET ^TMP("LRLOC",$JOB,Z)=A
WRITE $JUSTIFY(Z,2),?5,A,!
IF Z#5=0
DO C
IF A(2)?1P
QUIT
+3 IF A(2)?1P
QUIT
IF B
WRITE !
DO C
IF A(2)=""
KILL X
QUIT
+4 WRITE !!,"NON-STANDARD LOCATION ! OK "
SET %=2
DO YN^LRU
IF %'=1
KILL X
QUIT
C IF Z=1
SET A(2)=1
GOTO F
+1 WRITE $CHAR(13),"TYPE '^' TO STOP OR",!,"CHOOSE 1-",Z
READ ": ",A(2):DTIME
IF A(2)?1P!'$TEST
SET A=$CHAR(126)
KILL X
QUIT
+2 IF A(2)=""
WRITE !
QUIT
F IF A(2)>0
IF A(2)<(Z+1)
SET X=^TMP("LRLOC",$JOB,A(2))
SET %=1
WRITE ?($X+5),X," OK "
DO YN^LRU
IF %'=1
KILL X
+1 SET A(2)=$SELECT(A(2)>Z:"",1:"^")
SET A=$CHAR(126)
QUIT
+2 ;
XR WRITE !
SET Z=0
FOR A=0:0
SET A=$ORDER(^SC("C",X,A))
IF 'A
QUIT
IF DUZ(2)=+$$SITE^VASITE(DT,($PIECE($GET(^SC(A,0)),U,15)))
SET Z=Z+1
SET A(1)=$PIECE(^SC(A,0),"^")
SET ^TMP("LRLOC",$JOB,Z)=A(1)
WRITE $JUSTIFY(Z,2),?5,A(1),?40,"Abbrev: ",X,!
IF Z#5=0
DO C
IF A(2)?1P
QUIT
+1 DO C
IF A(2)=""
KILL X
QUIT
EN ;
+1 IF '$DATA(^SC("B"))
WRITE $CHAR(7),"No STANDARD LOCATIONS to choose from.",!,"You may enter a NON-STANDARD LOCATION",!
QUIT
+2 IF X'["??"
WRITE !,"ANSWER WITH ",$PIECE(^SC(0),"^"),!,"DO YOU WANT THE ENTIRE ",$PIECE(^(0),"^")," LIST ? "
SET (%,LR("%"))=""
DO RX^LRU
IF %'=1
QUIT
+3 SET (A,A(2))=0
SET A(1)=$Y+21
WRITE !?3
FOR B=0:0
SET A=$ORDER(^SC("B",A))
IF A=""!(A(2)?1P)
QUIT
FOR C=0:0
SET C=$ORDER(^SC("B",A,C))
IF 'C!(A(2)?1P)
QUIT
IF $Y>A(1)!'$Y
DO MORE
IF A(2)?1P
QUIT
NEW LRDIV
SET LRDIV=$PIECE($GET(^SC(C,0)),U,15)
IF 'LRDIV
QUIT
IF DUZ(2)'=+$$SITE^VASITE(DT,LRDIV)
QUIT
WRITE A,!?3
+4 QUIT
MORE READ "'^' TO STOP: ",A(2):DTIME
IF A(2)?1P
SET A=$CHAR(126)
QUIT
+1 SET A(1)=A(1)+21
WRITE $CHAR(13),$JUSTIFY("",15),$CHAR(13),?3
QUIT
+2 ;
END KILL ^TMP("LRLOC",$JOB)
QUIT
