- 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 Feb 18, 2025@23:48:11 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