- 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
