LRUTRAN ;AVAMC/REG - TRANSFER ^LR(LRDF,LRSS, TO ^LR(LRDFN#2,LRSS, ;5/9/91 18:24 ;
;;5.2;LAB SERVICE;;Sep 27, 1994
W !,"Transfer data in Lab Data File (#63) from one entry to another"
S LRDPAF=1,U="^",DIC=68,DIC(0)="AEMOQZ",DIC("A")="Select AP section: ",DIC("S")="I ""CYEMSP""[$P(^(0),U,2)&($P(^(0),U,2)]"""")" D ^DIC G:Y<1 END S LRAA=+Y,LRSS=$P(Y(0),U,2) D XR^LRU
;
A K DIC W !!?7,"Transfer from" D ^LRDPA G:LRDFN<1 END S LR(1)=LRDFN
S X=$S('$D(^LR(LRDFN,LRSS,0)):1,'$P(^(0),U,4):1,1:0) I X W $C(7),!,"There are no entries to transfer !" G A
W !!?7,"Transfer to" D ^LRDPA G:LRDFN<1 A S LR(2)=LRDFN
I LR(1)=LR(2) W $C(7),!!?22,"Same patient- transfer not necessary!" G A
W !!,"OK to transfer " S %=2 D YN^LRU G:%'=1 A
F A=0:0 S A=$O(^LR(LR(1),LRSS,A)) Q:'A S X=^(A,0),R=$P(X,"^",10),N=$P(X,"^",6),Y=$E(R,1,3) K ^LR(LRXR,R,LR(1),A),^LR(LRXREF,Y,N,LR(1),A) S ^LR(LRXR,R,LR(2),A)="",^LR(LRXREF,Y,N,LR(2),A)="" D B
S %X="^LR(LR(1),LRSS,",%Y="^LR(LR(2),LRSS," D %XY^%RCR
K ^LR(LR(1),LRSS) S X=0 F A=0:1 S X=$O(^LR(LR(2),LRSS,X)) Q:'X
S X=^LR(LR(2),LRSS,0),^(0)=$P(X,"^",1,2)_"^^"_A Q
;
B I $D(^LRO(68,LRAA,1,Y,1,N,0)) S Y=Y_"0000",$P(^(0),"^")=LR(2) Q
;
END D V^LRU Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUTRAN 1199 printed Dec 13, 2024@02:22:19 Page 2
LRUTRAN ;AVAMC/REG - TRANSFER ^LR(LRDF,LRSS, TO ^LR(LRDFN#2,LRSS, ;5/9/91 18:24 ;
+1 ;;5.2;LAB SERVICE;;Sep 27, 1994
+2 WRITE !,"Transfer data in Lab Data File (#63) from one entry to another"
+3 SET LRDPAF=1
SET U="^"
SET DIC=68
SET DIC(0)="AEMOQZ"
SET DIC("A")="Select AP section: "
SET DIC("S")="I ""CYEMSP""[$P(^(0),U,2)&($P(^(0),U,2)]"""")"
DO ^DIC
if Y<1
GOTO END
SET LRAA=+Y
SET LRSS=$PIECE(Y(0),U,2)
DO XR^LRU
+4 ;
A KILL DIC
WRITE !!?7,"Transfer from"
DO ^LRDPA
if LRDFN<1
GOTO END
SET LR(1)=LRDFN
+1 SET X=$SELECT('$DATA(^LR(LRDFN,LRSS,0)):1,'$PIECE(^(0),U,4):1,1:0)
IF X
WRITE $CHAR(7),!,"There are no entries to transfer !"
GOTO A
+2 WRITE !!?7,"Transfer to"
DO ^LRDPA
if LRDFN<1
GOTO A
SET LR(2)=LRDFN
+3 IF LR(1)=LR(2)
WRITE $CHAR(7),!!?22,"Same patient- transfer not necessary!"
GOTO A
+4 WRITE !!,"OK to transfer "
SET %=2
DO YN^LRU
if %'=1
GOTO A
+5 FOR A=0:0
SET A=$ORDER(^LR(LR(1),LRSS,A))
if 'A
QUIT
SET X=^(A,0)
SET R=$PIECE(X,"^",10)
SET N=$PIECE(X,"^",6)
SET Y=$EXTRACT(R,1,3)
KILL ^LR(LRXR,R,LR(1),A),^LR(LRXREF,Y,N,LR(1),A)
SET ^LR(LRXR,R,LR(2),A)=""
SET ^LR(LRXREF,Y,N,LR(2),A)=""
DO B
+6 SET %X="^LR(LR(1),LRSS,"
SET %Y="^LR(LR(2),LRSS,"
DO %XY^%RCR
+7 KILL ^LR(LR(1),LRSS)
SET X=0
FOR A=0:1
SET X=$ORDER(^LR(LR(2),LRSS,X))
if 'X
QUIT
+8 SET X=^LR(LR(2),LRSS,0)
SET ^(0)=$PIECE(X,"^",1,2)_"^^"_A
QUIT
+9 ;
B IF $DATA(^LRO(68,LRAA,1,Y,1,N,0))
SET Y=Y_"0000"
SET $PIECE(^(0),"^")=LR(2)
QUIT
+1 ;
END DO V^LRU
QUIT