LRPHSET2 ;DALOI/STAFF - COLLECTION LIST TO ACCESSIONS CONT ; 19 Jun 2017 9:05 PM
;;5.2;LAB SERVICE;**121,202,350,427,492**;Sep 27, 1994;Build 3
;
REUP ;FROM LRPHSET1 - ADD TO OR REBUILD TO COLLECTION LIST
N LRORDTYP
S $P(LRORDTYP,"^",2)=$$FIND1^DIC(64.061,"","OX","L","D","I $P(^(0),U,5)=""0065""")
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
S LRRB=0
I LRDPF=2 S LRRB=$$GET1^DIQ(2,DFN_",",.101),LRRB=$S(LRRB'="":LRRB,1:0)
;
S I=0
F S I=$O(^LRO(69,DT,1,LRSN,2,I)) Q:I<1 S X=^(I,0) I $P(X,U,3)'="" S LRAA($P(X,U,4))=$P(X,U,3)_"^"_$P(X,U,4)_"^"_$P(X,U,5)
;
S LRK=0
F S LRK=$O(^LRO(69,DT,1,LRSN,2,LRK)) Q:LRK<1 S X=^(LRK,0) I $P(X,U,3)="",'$P(X,"^",11) D
. S LRTS=+X,LRAA=$S($D(^LAB(60,LRTS,8,DUZ(2),0)):$P(^(0),U,2),1:"")
. I LRAA'="",$D(LRAA(LRAA)),$P(^LAB(60,LRTS,0),U,7)'=1 D JAM
;
S LRI=0
F S LRI=$O(^LRO(69,DT,1,LRSN,2,LRI)) Q:LRI<1 S X=^(LRI,0) I '$P(X,U,6),$P(X,U,3) D
. S LRTSTN=+X,LRAD=$P(X,U,3),LRAA=$P(X,U,4),LRAN=$P(X,U,5)
. I '$D(^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN,+LRTSTN)) D REUP1
;
;Commenting out re-sets to Lab Collection Date/Time.
;Per stakeholders, the value should either be the collection list scheduled date/time
;or actual collection date/time
;
I $D(REUP) S LRCOUNT=LRCOUNT+1 ;,^LRO(69,DT,1,LRSN,3)=LRDTI
;I '$D(REUP) S $P(^LRO(69,DT,1,LRSN,1),U)=$P(^LRO(69,DT,1,LRSN,3),U)
K LRAD,LRI,LRAN,LRAA,LRDPF,DFN,LRZ3,LRZB,LRZ1,LRTSTN,LRRB,LRURG,REUP,I,J,LRK,F,LRAODT,LRWRD
Q
;
REUP1 L +^LRO(69.1,LRTE):90 I '$T G REUP1
S LRZ3=$S($D(^LRO(69.1,LRTE,1,0)):$P(^(0),U,3),1:0)
;
;MFLG is set when a later order was on an earlier collection list.
;Then that later order is rolled over to an earlier order which was on a later
;collection list. This scenario has occurred at sites.
;
I $G(MFLG),$G(LRSWAP),$D(^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSWAP,LRAA,LRAN)) D
. N COLSTR,DA
. S COLSTR=$G(^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSWAP))
. S DA=$P(COLSTR,"^",5)
. I DA]"" S DA(1)=LRTE,DIK="^LRO(69.1,"_DA(1)_",1," D ^DIK
I '$D(^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN)) S REUP=1
;
REUP2 S LRZ3=LRZ3+1
G:$D(^LRO(69.1,LRTE,1,LRZ3)) REUP2
S LRZO="^LRO(69.1,"_LRTE_",1,",LRZ1="69.11P",LRZB=+LRTSTN,LRIFN=LRZ3
D Z^LRWU
L -^LRO(69.1,LRTE)
S ^LRO(69.1,LRTE,1,LRIFN,0)=+LRTSTN_"^"_LRLLOC_"^"_LRRB_"^"_LRDFN_"^"_LRSN_"^"_LRTJ_"^"_LRAD_"^"_LRAA_"^"_LRAN_"^"_LROLLOC,^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN)=LRTJ_"^"_LRAD_"^"_LRIFN,^(LRSN,LRAA,LRAN,+LRTSTN)=+LRTSTN
Q
;
JAM ;
S LRAA=$P(LRAA(LRAA),U,2),LRAD=$P(LRAA(LRAA),U),LRAODT=LRAD,LRAN=$P(LRAA(LRAA),U,3),(LRURG,Y)=$P(X,U,2)
D EN^LRTSTSET
Q
;
S7 ;FROM LRPHSET1 - COMBINE OR MERGE TESTS ON ORDERS
N MFLG
S T=0 F S T=$O(T(LRSAMP,T)) Q:T<1 D S7A
Q
S7A S LRPSN=0 F S LRPSN=$O(T(LRSAMP,T,LRPSN)) Q:LRPSN<1 D @$S(LRSTEP=0:"S8",1:"S9")
Q
S8 S J=T
D COMBINE
S J=0 F S J=$O(T(LRSAMP,J)) Q:J<1 D SCAN60
Q
S9 S J=0 F S J=$O(T(LRSAMP,J)) Q:J<1 D MERG
Q
SCAN60 S K=0 F S K=$O(^LAB(60,T,2,K)) Q:K<1 I +^(K,0)=J S LRSN=0,LRSN=$O(T(LRSAMP,J,LRSN)) D @$S(LRPSN>LRSN:"MERG",1:"COMBINE")
Q
COMBINE S LRSN=0 F S LRSN=$O(T(LRSAMP,J,LRSN)) Q:LRSN<1 D:LRPSN>LRSN SWAP I LRSN'=LRPSN D CB2
Q
CB2 I $P(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0),U,6)'="",$D(^LRO(69,DT,1,LRSN,.1)),$D(^LRO(69,DT,1,+$O(^LRO(69,"C",+^(.1),DT,0)),1)),$P(^(1),U,4)'="" Q
I $P(T(LRSAMP,T,LRPSN),U,2)'=$P(T(LRSAMP,J,LRSN),U,2) D URGENCY S $P(^LRO(69,DT,1,LRPSN,2,+T(LRSAMP,T,LRPSN),0),U,2)=LRURG
S $P(^LRO(69,DT,1,LRPSN,2,+T(LRSAMP,T,LRPSN),0),"^",14)=DT_";"_LRSN_";"_+T(LRSAMP,J,LRSN)
N X,XI,X1,I,TST
S X1=^LRO(69,DT,1,LRPSN,.1),TST=^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0),$P(^(0),U,6)=X1,$P(^LRO(69,DT,1,LRSN,1),U,4)="M",XI=$P(^(1),U,7),XI=XI_X1_"/",$P(^(1),U,7)=XI
D OERR(TST)
K T(LRSAMP,J,LRSN)
Q
;
MERG S LRSN=0 F S LRSN=$O(T(LRSAMP,J,LRSN)) Q:LRSN<1 D:LRPSN>LRSN SWAP,SWAP1 I LRSN'=LRPSN D M1
Q
;
M1 Q:$P(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0),U,6)'=""
S X=$P(^LRO(69,DT,1,LRPSN,2,0),"^",3)
LP S X=X+1
I $D(^LRO(69,DT,1,LRPSN,2,X)) G LP
;
;Some merging scenarios were causing file 69 to be set incorrectly.
;Changes were made by LR*5.2*492 so that file 69 is set correctly
;for all merging scenarios.
;
;Also, a new Order (#100) entry is created when necessary during the
;merging process.
;
S ^LRO(69,DT,1,LRPSN,2,X,0)=^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0),^LRO(69,DT,1,LRPSN,2,"B",J,X)="",$P(^LRO(69,DT,1,LRPSN,2,0),"^",3,4)=X_"^"_X
I $G(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),.3)) D
. S ^LRO(69,DT,1,LRPSN,2,X,.3)=$G(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),.3))
. D MER1
D OEADD
S $P(^LRO(69,DT,1,LRPSN,2,X,0),"^",14)=DT_";"_LRSN_";"_+T(LRSAMP,J,LRSN)
N I,XI,X1,TST
S X1=^LRO(69,DT,1,LRPSN,.1),$P(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0),"^",6)=X1
S TST=^LRO(69,DT,1,LRPSN,2,X,0),LRURG=$P(TST,"^",2),T(LRSAMP,J,LRPSN)=T(LRSAMP,J,LRSN),$P(T(LRSAMP,J,LRPSN),"^")=X
S $P(^LRO(69,DT,1,LRSN,1),U,4)="M",XI=$P(^(1),U,7),XI=XI_X1_"/",$P(^LRO(69,DT,1,LRSN,1),U,7)=XI
I '$G(MFLG) D OERR(TST)
K T(LRSAMP,J,LRSN)
Q
;
MER1 ;Merge if later order was on earlier collection list
N SAVX,SAVJ
S SAVX=X,SAVJ=J
I $D(T(LRSAMP,J,LRSN)) D
. S X1=^LRO(69,DT,1,LRSN,.1)
. D OERR(J)
S LRSWAP=LRSN,LRSN=LRPSN
S T(LRSAMP,J,LRSN)=""
S LRTJ=$P(^LRO(69,DT,1,LRPSN,0),U,3,4)_"^"_DT
S LRCOUNT=$G(LRCOUNT)+1
;
;MFLG = tell LRTSTSET to not add "Added by" comments
; and REUP1^LRPHSET2 whether previous entry should be killed
; in collection list file 69.1
S MFLG=1
D REUP
S LRSN=LRSWAP
S X=SAVX,J=SAVJ
N XSEQ
S XSEQ=1+$S($D(^LRO(69,LRODT,1,LRPSN,2,X,1,0)):$P(^(0),"^",3),1:0),^(0)="^^"_X_"^"_DT,^(X,0)=" Added by "_$G(DUZ)_" on "_$$HTE^XLFDT($H,"M")
S ^LRO(69,"AA",+$G(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
Q
;
OEADD ;add test to previous order
N LRADD,J
S LRADD=$P(^LRO(69,DT,1,LRPSN,2,X,0),"^")
S LRADD(LRADD)=""
S DFN=$P(^LR(LRDFN,0),"^",3)
S $P(^LRO(69,DT,1,LRPSN,2,X,0),"^",7)=""
S $P(^LRO(69,DT,1,LRPSN,2,X,0),"^",14)=""
N X
S LRNATURE="^^^6^SERVICE CORRECTION^99ORR"
D NEW^LR7OB1(DT,LRPSN,"SN",LRNATURE,.LRADD,6)
Q
;
SWAP S LRSWAP=LRSN,LRSN=LRPSN,LRPSN=LRSWAP K LRSWAP
Q
;
SWAP1 S LRSWAP=J,J=T,T=LRSWAP
Q
;
URGENCY S LRURG1=$P(T(LRSAMP,T,LRPSN),U,2),LRURG2=$P(T(LRSAMP,J,LRSN),U,2),LRURG=$S(LRURG1<LRURG2:LRURG1,1:LRURG2)
K LRURG1,LRURG2
Q
;
OERR(TSTNODE) ;OE/RR - CPRS calls
N X,TTT,LRNATURE,LRSJ ;OE/RR 3.0
S LRSJ=J,X=$O(^ORD(100.03,"C","LRDUP",0)),LRNATURE=$$DC1^LROR6(X,"Combined with LB #"_X1)
S TTT(+TSTNODE)="",DIE="^LRO(69,DT,1,LRSN,2,",DA=+T(LRSAMP,LRSJ,LRSN),DA(1)=LRSN,DA(2)=DT,DR="99.1///DUPLICATE TEST: "_$S($P($G(LRNATURE),"^",5)'="":$P(LRNATURE,"^",5),1:"")
D ^DIE
D NEW^LR7OB1(DT,LRSN,"OC",$G(LRNATURE),.TTT)
S $P(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,LRSJ,LRSN),0),"^",3,5)="^^",$P(^(0),"^",9,11)="CA^L^"_DUZ,J=LRSJ
I $D(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,LRSJ,LRSN),.3)) D
. S $P(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,LRSJ,LRSN),.3),"^")=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRPHSET2 7033 printed Oct 16, 2024@18:20:10 Page 2
LRPHSET2 ;DALOI/STAFF - COLLECTION LIST TO ACCESSIONS CONT ; 19 Jun 2017 9:05 PM
+1 ;;5.2;LAB SERVICE;**121,202,350,427,492**;Sep 27, 1994;Build 3
+2 ;
REUP ;FROM LRPHSET1 - ADD TO OR REBUILD TO COLLECTION LIST
+1 NEW LRORDTYP
+2 SET $PIECE(LRORDTYP,"^",2)=$$FIND1^DIC(64.061,"","OX","L","D","I $P(^(0),U,5)=""0065""")
+3 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+4 SET LRRB=0
+5 IF LRDPF=2
SET LRRB=$$GET1^DIQ(2,DFN_",",.101)
SET LRRB=$SELECT(LRRB'="":LRRB,1:0)
+6 ;
+7 SET I=0
+8 FOR
SET I=$ORDER(^LRO(69,DT,1,LRSN,2,I))
if I<1
QUIT
SET X=^(I,0)
IF $PIECE(X,U,3)'=""
SET LRAA($PIECE(X,U,4))=$PIECE(X,U,3)_"^"_$PIECE(X,U,4)_"^"_$PIECE(X,U,5)
+9 ;
+10 SET LRK=0
+11 FOR
SET LRK=$ORDER(^LRO(69,DT,1,LRSN,2,LRK))
if LRK<1
QUIT
SET X=^(LRK,0)
IF $PIECE(X,U,3)=""
IF '$PIECE(X,"^",11)
Begin DoDot:1
+12 SET LRTS=+X
SET LRAA=$SELECT($DATA(^LAB(60,LRTS,8,DUZ(2),0)):$PIECE(^(0),U,2),1:"")
+13 IF LRAA'=""
IF $DATA(LRAA(LRAA))
IF $PIECE(^LAB(60,LRTS,0),U,7)'=1
DO JAM
End DoDot:1
+14 ;
+15 SET LRI=0
+16 FOR
SET LRI=$ORDER(^LRO(69,DT,1,LRSN,2,LRI))
if LRI<1
QUIT
SET X=^(LRI,0)
IF '$PIECE(X,U,6)
IF $PIECE(X,U,3)
Begin DoDot:1
+17 SET LRTSTN=+X
SET LRAD=$PIECE(X,U,3)
SET LRAA=$PIECE(X,U,4)
SET LRAN=$PIECE(X,U,5)
+18 IF '$DATA(^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN,+LRTSTN))
DO REUP1
End DoDot:1
+19 ;
+20 ;Commenting out re-sets to Lab Collection Date/Time.
+21 ;Per stakeholders, the value should either be the collection list scheduled date/time
+22 ;or actual collection date/time
+23 ;
+24 ;,^LRO(69,DT,1,LRSN,3)=LRDTI
IF $DATA(REUP)
SET LRCOUNT=LRCOUNT+1
+25 ;I '$D(REUP) S $P(^LRO(69,DT,1,LRSN,1),U)=$P(^LRO(69,DT,1,LRSN,3),U)
+26 KILL LRAD,LRI,LRAN,LRAA,LRDPF,DFN,LRZ3,LRZB,LRZ1,LRTSTN,LRRB,LRURG,REUP,I,J,LRK,F,LRAODT,LRWRD
+27 QUIT
+28 ;
REUP1 LOCK +^LRO(69.1,LRTE):90
IF '$TEST
GOTO REUP1
+1 SET LRZ3=$SELECT($DATA(^LRO(69.1,LRTE,1,0)):$PIECE(^(0),U,3),1:0)
+2 ;
+3 ;MFLG is set when a later order was on an earlier collection list.
+4 ;Then that later order is rolled over to an earlier order which was on a later
+5 ;collection list. This scenario has occurred at sites.
+6 ;
+7 IF $GET(MFLG)
IF $GET(LRSWAP)
IF $DATA(^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSWAP,LRAA,LRAN))
Begin DoDot:1
+8 NEW COLSTR,DA
+9 SET COLSTR=$GET(^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSWAP))
+10 SET DA=$PIECE(COLSTR,"^",5)
+11 IF DA]""
SET DA(1)=LRTE
SET DIK="^LRO(69.1,"_DA(1)_",1,"
DO ^DIK
End DoDot:1
+12 IF '$DATA(^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN))
SET REUP=1
+13 ;
REUP2 SET LRZ3=LRZ3+1
+1 if $DATA(^LRO(69.1,LRTE,1,LRZ3))
GOTO REUP2
+2 SET LRZO="^LRO(69.1,"_LRTE_",1,"
SET LRZ1="69.11P"
SET LRZB=+LRTSTN
SET LRIFN=LRZ3
+3 DO Z^LRWU
+4 LOCK -^LRO(69.1,LRTE)
+5 SET ^LRO(69.1,LRTE,1,LRIFN,0)=+LRTSTN_"^"_LRLLOC_"^"_LRRB_"^"_LRDFN_"^"_LRSN_"^"_LRTJ_"^"_LRAD_"^"_LRAA_"^"_LRAN_"^"_LROLLOC
SET ^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN)=LRTJ_"^"_LRAD_"^"_LRIFN
SET ^(LRSN,LRAA,LRAN,+LRTSTN)=+LRTSTN
+6 QUIT
+7 ;
JAM ;
+1 SET LRAA=$PIECE(LRAA(LRAA),U,2)
SET LRAD=$PIECE(LRAA(LRAA),U)
SET LRAODT=LRAD
SET LRAN=$PIECE(LRAA(LRAA),U,3)
SET (LRURG,Y)=$PIECE(X,U,2)
+2 DO EN^LRTSTSET
+3 QUIT
+4 ;
S7 ;FROM LRPHSET1 - COMBINE OR MERGE TESTS ON ORDERS
+1 NEW MFLG
+2 SET T=0
FOR
SET T=$ORDER(T(LRSAMP,T))
if T<1
QUIT
DO S7A
+3 QUIT
S7A SET LRPSN=0
FOR
SET LRPSN=$ORDER(T(LRSAMP,T,LRPSN))
if LRPSN<1
QUIT
DO @$SELECT(LRSTEP=0:"S8",1:"S9")
+1 QUIT
S8 SET J=T
+1 DO COMBINE
+2 SET J=0
FOR
SET J=$ORDER(T(LRSAMP,J))
if J<1
QUIT
DO SCAN60
+3 QUIT
S9 SET J=0
FOR
SET J=$ORDER(T(LRSAMP,J))
if J<1
QUIT
DO MERG
+1 QUIT
SCAN60 SET K=0
FOR
SET K=$ORDER(^LAB(60,T,2,K))
if K<1
QUIT
IF +^(K,0)=J
SET LRSN=0
SET LRSN=$ORDER(T(LRSAMP,J,LRSN))
DO @$SELECT(LRPSN>LRSN:"MERG",1:"COMBINE")
+1 QUIT
COMBINE SET LRSN=0
FOR
SET LRSN=$ORDER(T(LRSAMP,J,LRSN))
if LRSN<1
QUIT
if LRPSN>LRSN
DO SWAP
IF LRSN'=LRPSN
DO CB2
+1 QUIT
CB2 IF $PIECE(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0),U,6)'=""
IF $DATA(^LRO(69,DT,1,LRSN,.1))
IF $DATA(^LRO(69,DT,1,+$ORDER(^LRO(69,"C",+^(.1),DT,0)),1))
IF $PIECE(^(1),U,4)'=""
QUIT
+1 IF $PIECE(T(LRSAMP,T,LRPSN),U,2)'=$PIECE(T(LRSAMP,J,LRSN),U,2)
DO URGENCY
SET $PIECE(^LRO(69,DT,1,LRPSN,2,+T(LRSAMP,T,LRPSN),0),U,2)=LRURG
+2 SET $PIECE(^LRO(69,DT,1,LRPSN,2,+T(LRSAMP,T,LRPSN),0),"^",14)=DT_";"_LRSN_";"_+T(LRSAMP,J,LRSN)
+3 NEW X,XI,X1,I,TST
+4 SET X1=^LRO(69,DT,1,LRPSN,.1)
SET TST=^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0)
SET $PIECE(^(0),U,6)=X1
SET $PIECE(^LRO(69,DT,1,LRSN,1),U,4)="M"
SET XI=$PIECE(^(1),U,7)
SET XI=XI_X1_"/"
SET $PIECE(^(1),U,7)=XI
+5 DO OERR(TST)
+6 KILL T(LRSAMP,J,LRSN)
+7 QUIT
+8 ;
MERG SET LRSN=0
FOR
SET LRSN=$ORDER(T(LRSAMP,J,LRSN))
if LRSN<1
QUIT
if LRPSN>LRSN
DO SWAP
DO SWAP1
IF LRSN'=LRPSN
DO M1
+1 QUIT
+2 ;
M1 if $PIECE(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0),U,6)'=""
QUIT
+1 SET X=$PIECE(^LRO(69,DT,1,LRPSN,2,0),"^",3)
LP SET X=X+1
+1 IF $DATA(^LRO(69,DT,1,LRPSN,2,X))
GOTO LP
+2 ;
+3 ;Some merging scenarios were causing file 69 to be set incorrectly.
+4 ;Changes were made by LR*5.2*492 so that file 69 is set correctly
+5 ;for all merging scenarios.
+6 ;
+7 ;Also, a new Order (#100) entry is created when necessary during the
+8 ;merging process.
+9 ;
+10 SET ^LRO(69,DT,1,LRPSN,2,X,0)=^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0)
SET ^LRO(69,DT,1,LRPSN,2,"B",J,X)=""
SET $PIECE(^LRO(69,DT,1,LRPSN,2,0),"^",3,4)=X_"^"_X
+11 IF $GET(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),.3))
Begin DoDot:1
+12 SET ^LRO(69,DT,1,LRPSN,2,X,.3)=$GET(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),.3))
+13 DO MER1
End DoDot:1
+14 DO OEADD
+15 SET $PIECE(^LRO(69,DT,1,LRPSN,2,X,0),"^",14)=DT_";"_LRSN_";"_+T(LRSAMP,J,LRSN)
+16 NEW I,XI,X1,TST
+17 SET X1=^LRO(69,DT,1,LRPSN,.1)
SET $PIECE(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0),"^",6)=X1
+18 SET TST=^LRO(69,DT,1,LRPSN,2,X,0)
SET LRURG=$PIECE(TST,"^",2)
SET T(LRSAMP,J,LRPSN)=T(LRSAMP,J,LRSN)
SET $PIECE(T(LRSAMP,J,LRPSN),"^")=X
+19 SET $PIECE(^LRO(69,DT,1,LRSN,1),U,4)="M"
SET XI=$PIECE(^(1),U,7)
SET XI=XI_X1_"/"
SET $PIECE(^LRO(69,DT,1,LRSN,1),U,7)=XI
+20 IF '$GET(MFLG)
DO OERR(TST)
+21 KILL T(LRSAMP,J,LRSN)
+22 QUIT
+23 ;
MER1 ;Merge if later order was on earlier collection list
+1 NEW SAVX,SAVJ
+2 SET SAVX=X
SET SAVJ=J
+3 IF $DATA(T(LRSAMP,J,LRSN))
Begin DoDot:1
+4 SET X1=^LRO(69,DT,1,LRSN,.1)
+5 DO OERR(J)
End DoDot:1
+6 SET LRSWAP=LRSN
SET LRSN=LRPSN
+7 SET T(LRSAMP,J,LRSN)=""
+8 SET LRTJ=$PIECE(^LRO(69,DT,1,LRPSN,0),U,3,4)_"^"_DT
+9 SET LRCOUNT=$GET(LRCOUNT)+1
+10 ;
+11 ;MFLG = tell LRTSTSET to not add "Added by" comments
+12 ; and REUP1^LRPHSET2 whether previous entry should be killed
+13 ; in collection list file 69.1
+14 SET MFLG=1
+15 DO REUP
+16 SET LRSN=LRSWAP
+17 SET X=SAVX
SET J=SAVJ
+18 NEW XSEQ
+19 SET XSEQ=1+$SELECT($DATA(^LRO(69,LRODT,1,LRPSN,2,X,1,0)):$PIECE(^(0),"^",3),1:0)
SET ^(0)="^^"_X_"^"_DT
SET ^(X,0)=" Added by "_$GET(DUZ)_" on "_$$HTE^XLFDT($HOROLOG,"M")
+20 SET ^LRO(69,"AA",+$GET(^LRO(69,LRODT,1,LRSN,.1)),LRODT_"|"_LRSN)=""
+21 QUIT
+22 ;
OEADD ;add test to previous order
+1 NEW LRADD,J
+2 SET LRADD=$PIECE(^LRO(69,DT,1,LRPSN,2,X,0),"^")
+3 SET LRADD(LRADD)=""
+4 SET DFN=$PIECE(^LR(LRDFN,0),"^",3)
+5 SET $PIECE(^LRO(69,DT,1,LRPSN,2,X,0),"^",7)=""
+6 SET $PIECE(^LRO(69,DT,1,LRPSN,2,X,0),"^",14)=""
+7 NEW X
+8 SET LRNATURE="^^^6^SERVICE CORRECTION^99ORR"
+9 DO NEW^LR7OB1(DT,LRPSN,"SN",LRNATURE,.LRADD,6)
+10 QUIT
+11 ;
SWAP SET LRSWAP=LRSN
SET LRSN=LRPSN
SET LRPSN=LRSWAP
KILL LRSWAP
+1 QUIT
+2 ;
SWAP1 SET LRSWAP=J
SET J=T
SET T=LRSWAP
+1 QUIT
+2 ;
URGENCY SET LRURG1=$PIECE(T(LRSAMP,T,LRPSN),U,2)
SET LRURG2=$PIECE(T(LRSAMP,J,LRSN),U,2)
SET LRURG=$SELECT(LRURG1<LRURG2:LRURG1,1:LRURG2)
+1 KILL LRURG1,LRURG2
+2 QUIT
+3 ;
OERR(TSTNODE) ;OE/RR - CPRS calls
+1 ;OE/RR 3.0
NEW X,TTT,LRNATURE,LRSJ
+2 SET LRSJ=J
SET X=$ORDER(^ORD(100.03,"C","LRDUP",0))
SET LRNATURE=$$DC1^LROR6(X,"Combined with LB #"_X1)
+3 SET TTT(+TSTNODE)=""
SET DIE="^LRO(69,DT,1,LRSN,2,"
SET DA=+T(LRSAMP,LRSJ,LRSN)
SET DA(1)=LRSN
SET DA(2)=DT
SET DR="99.1///DUPLICATE TEST: "_$SELECT($PIECE($GET(LRNATURE),"^",5)'="":$PIECE(LRNATURE,"^",5),1:"")
+4 DO ^DIE
+5 DO NEW^LR7OB1(DT,LRSN,"OC",$GET(LRNATURE),.TTT)
+6 SET $PIECE(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,LRSJ,LRSN),0),"^",3,5)="^^"
SET $PIECE(^(0),"^",9,11)="CA^L^"_DUZ
SET J=LRSJ
+7 IF $DATA(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,LRSJ,LRSN),.3))
Begin DoDot:1
+8 SET $PIECE(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,LRSJ,LRSN),.3),"^")=""
End DoDot:1
+9 QUIT
