- 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
