LRUMD1 ; IHS/DIR/FJE - MD SELECTED TESTS/PATIENTS 6/16/93 13:24 ;
;;5.2;LR;;NOV 01, 1997
;
;;5.2;LAB SERVICE;;Sep 27, 1994
W @IOF S A(1)=21,LRJ="" D L I $D(L)'=11 W !,"You have no patient list. To enter patients answer the following prompt:" G A
ASK W !!,"(R)emove a patient",?19,"(A)dd/edit patients",?45,"(T)ransfer list to another user",!,"(D)elete list",?19,"(P)atient group deletion",?45,"(M)erge list with another user",!,"(S)end list to printer",!
R "Enter R, A, T, D, P, M, S or <CR> to accept list: ",X:DTIME I X=""!(X[U) S:X[U LRV=1 Q
S X=$A(X) S:X>84 X=X-32 I X=83 S LRV=2 Q
G A:X=65,K:X=68,R:X=82,T:X=84,C:X=80,M:X=77 Q:X=76 W $C(7) G LRUMD1
A ;S LRA="" F LR=0:0 D ^LRDPA Q:LRDFN<1 S X=^LRO(69.2,LRAA,7,DUZ,1,0),^(0)=$P(X,U,1,2)_U_LRDFN_U_($P(X,U,4)+1),^(LRDFN,0)=LRDFN_U_$P(Y(0),U,1,3)_"^^^^^^"_$P(Y(0),U,9),^LRO(69.2,LRAA,7,DUZ,1,"C",$P(Y(0),U,1),LRDFN)="" D G
S LRA="" F LR=0:0 D ^LRDPA Q:LRDFN<1 S X=^LRO(69.2,LRAA,7,DUZ,1,0),^(0)=$P(X,U,1,2)_U_LRDFN_U_($P(X,U,4)+1),^(LRDFN,0)=LRDFN_U_$P(Y(0),U,1,3)_"^^^^^^"_HRCN,^LRO(69.2,LRAA,7,DUZ,1,"C",$P(Y(0),U,1),LRDFN)="" D G ;IHS/ANMC/CLS 08/18/96
B Q:'$O(^LRO(69.2,LRAA,7,DUZ,1,0)) G LRUMD1
K W !,"Are you sure you want to delete the entire list " S %=2 D YN^LRU G:%'=1 B
K ^LRO(69.2,LRAA,7,DUZ,1) S ^LRO(69.2,LRAA,7,DUZ,1,0)="^69.3PA^0^0" W !,"Your patient list has been deleted" Q
R D ^LRUMD2 G LRUMD1
C D EN^LRUMD2 G LRUMD1
T W !!?3,"Transfer patient list to another user (current user list is saved)"
S DIC=200,DIC(0)="AEQM" D ^DIC K DIC Q:X=""!(X[U) S N=+Y
I '$D(^LRO(69.2,LRAA,7,N,0)) S ^(0)=N_"^"_DT L +^LRO(69.2,LRAA,7) S X=^LRO(69.2,LRAA,7,0),^(0)=$P(X,"^",1,2)_"^"_N_"^"_($P(X,"^",4)+1) L -^LRO(69.2,LRAA,7)
I '$D(^LRO(69.2,LRAA,7,N,1,0)) S ^(0)="^69.3PA^0^0"
L +^LRO(69.2,LRAA,7,N,1) S B=0 W !,"Transferring"
F A=0:0 S A=$O(^LRO(69.2,LRAA,7,DUZ,1,A)) Q:'A S X=^(A,0) I '$D(^LRO(69.2,LRAA,7,N,1,A,0)) S ^(0)=X,^LRO(69.2,LRAA,7,N,1,"C",$P(X,"^",2),A)="",B=B+1,B(1)=A I $D(^LRO(69.2,LRAA,7,DUZ,1,A,1)) S X=^(1),Z=N D H
I B S X=^LRO(69.2,LRAA,7,N,1,0),^(0)=$P(X,"^",1,2)_"^"_B(1)_"^"_($P(X,"^",4)+B)
L -^LRO(69.2,LRAA,7,N,1) W !,"Transfer completed." H 2 G LRUMD1
H Q:X="" S ^LRO(69.2,LRAA,7,Z,1,A,1)=X,^LRO(69.2,LRAA,7,Z,1,"D",$P(X,"^"),A)="" W "." Q
M W !!?3,"Merge patient list with another user's list"
S DIC=200,DIC(0)="AEQM" D ^DIC K DIC G:X=""!(X[U) LRUMD1 S N=+Y
I '$O(^LRO(69.2,LRAA,7,N,1,0)) W $C(7),!,"No patient list for ",$P(Y,U,2) G LRUMD1
S B=0 W !,"Merging"
F A=0:0 S A=$O(^LRO(69.2,LRAA,7,N,1,A)) Q:'A S X=^(A,0) I '$D(^LRO(69.2,LRAA,7,DUZ,1,A,0)) S ^(0)=X,^LRO(69.2,LRAA,7,DUZ,1,"C",$P(X,"^",2),A)="",B=B+1,B(1)=A I $D(^LRO(69.2,LRAA,7,N,1,A,1)) S X=^(1),Z=DUZ D H
I B S X=^LRO(69.2,LRAA,7,DUZ,1,0),^(0)=$P(X,"^",1,2)_"^"_B(1)_"^"_($P(X,"^",4)+B)
W !,"Merge completed." H 2 G LRUMD1
EN ;from LRUMD, LRUMDP
G:$O(LR(0)) SEL F A=0:0 S A=$O(^LRO(69.2,LRAA,7,DUZ,60,A)) Q:'A F B=0:0 S B=$O(^LRO(69.2,LRAA,7,DUZ,60,A,1,B)) Q:'B S C=+^(B,0),^TMP($J,"N",A,B)=$P(^LAB(60,C,.1),"^"),^TMP($J,"L",A,B)=$P($P(^LAB(60,C,0),"^",5),";",2)
I '$O(^TMP($J,"L",0)) F A=0:0 S A=$O(^LRO(69.2,LRAA,60,A)) Q:'A F B=0:0 S B=$O(^LRO(69.2,LRAA,60,A,1,B)) Q:'B S C=+^(B,0),^TMP($J,"N",A,B)=$P(^LAB(60,C,.1),"^"),^TMP($J,"L",A,B)=$P($P(^LAB(60,C,0),U,5),";",2)
Q
SEL F A=0:0 S A=$O(LR(A)) Q:'A F B=0:0 S B=$O(^LRO(69.2,LRAA,7,DUZ,60,A,1,B)) Q:'B S C=+^(B,0),^TMP($J,"N",A,B)=$P(^LAB(60,C,.1),"^"),^TMP($J,"L",A,B)=$P($P(^LAB(60,C,0),"^",5),";",2)
Q
L S P=0 F R=1:1 S P=$O(^LRO(69.2,LRAA,7,DUZ,1,"C",P)) Q:P=""!(LRJ["^") F L=0:0 S L=$O(^LRO(69.2,LRAA,7,DUZ,1,"C",P,L)) Q:'L!(LRJ["^") D W
Q
W S P(1)=$E(P,1,28),X=$S($D(^LRO(69.2,LRAA,7,DUZ,1,L,1)):"("_$E(^(1),1,3)_")",1:"") S:X="()" X="" W:R#2=1 !,$J(R,2),")",?5,P(1),?33,X W:R#2=0 ?40,$J(R,2),")",?44,P(1),?74,X S L(R)=L D:$Y>A(1) P Q
P S A(1)=$Y+21 R !,"Press <CR>, <RETURN>, or <ENTER> key ",LRJ:DTIME W $C(13),$J("",80),$C(13) Q
G S DIE="^LRO(69.2,LRAA,7,DUZ,1,",DA(2)=LRAA,DA(1)=DUZ,DA=LRDFN,DR="1//^S X=LRA;S LRA=X" D ^DIE K DIC,DIE,DR,DA Q
LRUMD1 ; IHS/DIR/FJE - MD SELECTED TESTS/PATIENTS 6/16/93 13:24 ;
+1 ;;5.2;LR;;NOV 01, 1997
+2 ;
+3 ;;5.2;LAB SERVICE;;Sep 27, 1994
+4 WRITE @IOF
SET A(1)=21
SET LRJ=""
DO L
IF $DATA(L)'=11
WRITE !,"You have no patient list. To enter patients answer the following prompt:"
GOTO A
ASK WRITE !!,"(R)emove a patient",?19,"(A)dd/edit patients",?45,"(T)ransfer list to another user",!,"(D)elete list",?19,"(P)atient group deletion",?45,"(M)erge list with another user",!,"(S)end list to printer",!
+1 READ "Enter R, A, T, D, P, M, S or <CR> to accept list: ",X:DTIME
IF X=""!(X[U)
IF X[U
SET LRV=1
QUIT
+2 SET X=$ASCII(X)
IF X>84
SET X=X-32
IF X=83
SET LRV=2
QUIT
+3 IF X=65
GOTO A
IF X=68
GOTO K
IF X=82
GOTO R
IF X=84
GOTO T
IF X=80
GOTO C
IF X=77
GOTO M
IF X=76
QUIT
WRITE $CHAR(7)
GOTO LRUMD1
A ;S LRA="" F LR=0:0 D ^LRDP">P">P">P">P">P">P">P">P">P">P">P">P">P">P">PA Q:LRDFN<1 S X=^LRO(69.2,LRAA,7,DUZ,1,0),^(0)=$P">P">P">P">P">P">P">P">P">P">P">P">P">P">P">P(X,U,1,2)_U_LRDFN_U_($P">P">P">P">P">P">P">P">P">P">P">P">P">P">P">P(X,U,4)+1),^(LRDFN,0)=LRDFN_U_$P">P">P">P">P">P">P">P">P">P">P">P">P">P">P">P(Y(0),U,1,3)_"^^^^^^"_$P">P">P">P">P">P">P">P">P">P">P">P">P">P">P">P(Y(0),U,9),^LRO(69.2,LRAA,7,DUZ,1,"C",$P">P">P">P">P">P">P">P">P">P">P">P">P">P">P">P(Y(0),U,1),LRDFN)="" D G
+1 ;IHS/ANMC/CLS 08/18/96
SET LRA=""
FOR LR=0:0
DO ^LRDPA
IF LRDFN<1
QUIT
SET X=^LRO(69.2,LRAA,7,DUZ,1,0)
SET ^(0)=$PIECE(X,U,1,2)_U_LRDFN_U_($PIECE(X,U,4)+1)
SET ^(LRDFN,0)=LRDFN_U_$PIECE(Y(0),U,1,3)_"^^^^^^"_HRCN
SET ^LRO(69.2,LRAA,7,DUZ,1,"C",$PIECE(Y(0),U,1),LRDFN)=""
DO G
B IF '$ORDER(^LRO(69.2,LRAA,7,DUZ,1,0))
QUIT
GOTO LRUMD1
K WRITE !,"Are you sure you want to delete the entire list "
SET %=2
DO YN^LRU
IF %'=1
GOTO B
+1 KILL ^LRO(69.2,LRAA,7,DUZ,1)
SET ^LRO(69.2,LRAA,7,DUZ,1,0)="^69.3PA^0^0"
WRITE !,"Your patient list has been deleted"
QUIT
R DO ^LRUMD2
GOTO LRUMD1
C DO EN^LRUMD2
GOTO LRUMD1
T WRITE !!?3,"Transfer patient list to another user (current user list is saved)"
+1 SET DIC=200
SET DIC(0)="AEQM"
DO ^DIC
KILL DIC
IF X=""!(X[U)
QUIT
SET N=+Y
+2 IF '$DATA(^LRO(69.2,LRAA,7,N,0))
SET ^(0)=N_"^"_DT
LOCK +^LRO(69.2,LRAA,7)
SET X=^LRO(69.2,LRAA,7,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_N_"^"_($PIECE(X,"^",4)+1)
LOCK -^LRO(69.2,LRAA,7)
+3 IF '$DATA(^LRO(69.2,LRAA,7,N,1,0))
SET ^(0)="^69.3PA^0^0"
+4 LOCK +^LRO(69.2,LRAA,7,N,1)
SET B=0
WRITE !,"Transferring"
+5 FOR A=0:0
SET A=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,A))
IF 'A
QUIT
SET X=^(A,0)
IF '$DATA(^LRO(69.2,LRAA,7,N,1,A,0))
SET ^(0)=X
SET ^LRO(69.2,LRAA,7,N,1,"C",$PIECE(X,"^",2),A)=""
SET B=B+1
SET B(1)=A
IF $DATA(^LRO(69.2,LRAA,7,DUZ,1,A,1))
SET X=^(1)
SET Z=N
DO H
+6 IF B
SET X=^LRO(69.2,LRAA,7,N,1,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_B(1)_"^"_($PIECE(X,"^",4)+B)
+7 LOCK -^LRO(69.2,LRAA,7,N,1)
WRITE !,"Transfer completed."
HANG 2
GOTO LRUMD1
H IF X=""
QUIT
SET ^LRO(69.2,LRAA,7,Z,1,A,1)=X
SET ^LRO(69.2,LRAA,7,Z,1,"D",$PIECE(X,"^"),A)=""
WRITE "."
QUIT
M WRITE !!?3,"Merge patient list with another user's list"
+1 SET DIC=200
SET DIC(0)="AEQM"
DO ^DIC
KILL DIC
IF X=""!(X[U)
GOTO LRUMD1
SET N=+Y
+2 IF '$ORDER(^LRO(69.2,LRAA,7,N,1,0))
WRITE $CHAR(7),!,"No patient list for ",$PIECE(Y,U,2)
GOTO LRUMD1
+3 SET B=0
WRITE !,"Merging"
+4 FOR A=0:0
SET A=$ORDER(^LRO(69.2,LRAA,7,N,1,A))
IF 'A
QUIT
SET X=^(A,0)
IF '$DATA(^LRO(69.2,LRAA,7,DUZ,1,A,0))
SET ^(0)=X
SET ^LRO(69.2,LRAA,7,DUZ,1,"C",$PIECE(X,"^",2),A)=""
SET B=B+1
SET B(1)=A
IF $DATA(^LRO(69.2,LRAA,7,N,1,A,1))
SET X=^(1)
SET Z=DUZ
DO H
+5 IF B
SET X=^LRO(69.2,LRAA,7,DUZ,1,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^"_B(1)_"^"_($PIECE(X,"^",4)+B)
+6 WRITE !,"Merge completed."
HANG 2
GOTO LRUMD1
EN ;from LRUMD, LRUMDP
+1 IF $ORDER(LR(0))
GOTO SEL
FOR A=0:0
SET A=$ORDER(^LRO(69.2,LRAA,7,DUZ,60,A))
IF 'A
QUIT
FOR B=0:0
SET B=$ORDER(^LRO(69.2,LRAA,7,DUZ,60,A,1,B))
IF 'B
QUIT
SET C=+^(B,0)
SET ^TMP($JOB,"N",A,B)=$PIECE(^LAB(60,C,.1),"^")
SET ^TMP($JOB,"L",A,B)=$PIECE($PIECE(^LAB(60,C,0),"^",5),";",2)
+2 IF '$ORDER(^TMP($JOB,"L",0))
FOR A=0:0
SET A=$ORDER(^LRO(69.2,LRAA,60,A))
IF 'A
QUIT
FOR B=0:0
SET B=$ORDER(^LRO(69.2,LRAA,60,A,1,B))
IF 'B
QUIT
SET C=+^(B,0)
SET ^TMP($JOB,"N",A,B)=$PIECE(^LAB(60,C,.1),"^")
SET ^TMP($JOB,"L",A,B)=$PIECE($PIECE(^LAB(60,C,0),U,5),";",2)
+3 QUIT
SEL FOR A=0:0
SET A=$ORDER(LR(A))
IF 'A
QUIT
FOR B=0:0
SET B=$ORDER(^LRO(69.2,LRAA,7,DUZ,60,A,1,B))
IF 'B
QUIT
SET C=+^(B,0)
SET ^TMP($JOB,"N",A,B)=$PIECE(^LAB(60,C,.1),"^")
SET ^TMP($JOB,"L",A,B)=$PIECE($PIECE(^LAB(60,C,0),"^",5),";",2)
+1 QUIT
L SET P=0
FOR R=1:1
SET P=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,"C",P))
IF P=""!(LRJ["^")
QUIT
FOR L=0:0
SET L=$ORDER(^LRO(69.2,LRAA,7,DUZ,1,"C",P,L))
IF 'L!(LRJ["^")
QUIT
DO W
+1 QUIT
W SET P(1)=$EXTRACT(P,1,28)
SET X=$SELECT($DATA(^LRO(69.2,LRAA,7,DUZ,1,L,1)):"("_$EXTRACT(^(1),1,3)_")",1:"")
IF X="()"
SET X=""
IF R#2=1
WRITE !,$JUSTIFY(R,2),")",?5,P(1),?33,X
IF R#2=0
WRITE ?40,$JUSTIFY(R,2),")",?44,P(1),?74,X
SET L(R)=L
IF $Y>A(1)
DO P
QUIT
P SET A(1)=$Y+21
READ !,"Press <CR>, <RETURN>, or <ENTER> key ",LRJ:DTIME
WRITE $CHAR(13),$JUSTIFY("",80),$CHAR(13)
QUIT
G SET DIE="^LRO(69.2,LRAA,7,DUZ,1,"
SET DA(2)=LRAA
SET DA(1)=DUZ
SET DA=LRDFN
SET DR="1//^S X=LRA;S LRA=X"
DO ^DIE
KILL DIC,DIE,DR,DA
QUIT
