LRUTRAN.m

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 ---LRUTRAN   1199     printed  Apr 09, 2024@21:22:27                                                                                                                                                                                                     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