- LRPHSET2 ;VA/SLC/RWA - COLLECTION LIST TO ACCESSIONS CONT ;JUL 06, 2010 3:14 PM
- ;;5.2;LAB SERVICE;**1018,1027**;NOV 01, 1997
- ;;5.2;LAB SERVICE;**121,202**;Sep 27, 1994
- REUP ;FROM LRPHSET1 - ADD TO OR REBUILD TO COLLECTION LIST
- S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRRB=$S(LRDPF=2&$D(^DPT(DFN,.101)):^(.101),1:0),LRRB=$S($L(LRRB):LRRB,1:"")
- S I=0 F S I=$O(^LRO(69,DT,1,LRSN,2,I)) Q:I<1 S X=^(I,0) I $L($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 '$L($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) 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
- 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 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)
- 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
- 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 $L($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)),$L($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:$L($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
- S ^LRO(69,DT,1,LRPSN,2,X,0)=^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0),$P(^(0),"^",14)=DT_";"_LRSN_";"_+T(LRSAMP,J,LRSN),^LRO(69,DT,1,LRPSN,2,"B",J,X)="",$P(^LRO(69,DT,1,LRPSN,2,0),"^",3,4)=X_"^"_X
- ;----- BEGIN IHS MODIFICATION LR*5.2*1018
- ;IHS/ITSC/TPF 11/15/2002 BRING 'SIGN OR SYMPTOM' LAB POV INTO MERGE **1015**
- ; S ^LRO(69,DT,1,LRPSN,2,X,9999999)=^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),9999999)
- S:$D(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),9999999)) ^LRO(69,DT,1,LRPSN,2,X,9999999)=^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),9999999) ; IHS/OIT/MKK - LR*5.2*1027
- ;END **1015**
- ;END IHS MODIFICATION
- 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
- ;----- BEGIN IHS MODIFICATION LR*5.2*1018
- D:BLRLOG ^BLREVTQ("M","O",$G(BLROPT),,DT_","_LRSN) ;IHS/DIR TUC/AAB 03/27/98
- ;-----END IHS MODIFICATION
- D OERR(TST)
- K T(LRSAMP,J,LRSN)
- 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
- I $$VER^LR7OU1<3 D Q ;OE/RR 2.5
- . N I,ORIFN,OREASON,ORSTS
- . S ORIFN=$P(TSTNODE,U,7)
- . I ORIFN S ORSTS=1,OREASON="D" D ST^ORX
- 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($L($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
- Q
- LRPHSET2 ;VA/SLC/RWA - COLLECTION LIST TO ACCESSIONS CONT ;JUL 06, 2010 3:14 PM
- +1 ;;5.2;LAB SERVICE;**1018,1027**;NOV 01, 1997
- +2 ;;5.2;LAB SERVICE;**121,202**;Sep 27, 1994
- REUP ;FROM LRPHSET1 - ADD TO OR REBUILD TO COLLECTION LIST
- +1 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- SET LRRB=$SELECT(LRDPF=2&$DATA(^DPT(DFN,.101)):^(.101),1:0)
- SET LRRB=$SELECT($LENGTH(LRRB):LRRB,1:"")
- +2 SET I=0
- FOR
- SET I=$ORDER(^LRO(69,DT,1,LRSN,2,I))
- IF I<1
- QUIT
- SET X=^(I,0)
- IF $LENGTH($PIECE(X,U,3))
- SET LRAA($PIECE(X,U,4))=$PIECE(X,U,3)_"^"_$PIECE(X,U,4)_"^"_$PIECE(X,U,5)
- +3 SET LRK=0
- FOR
- SET LRK=$ORDER(^LRO(69,DT,1,LRSN,2,LRK))
- IF LRK<1
- QUIT
- SET X=^(LRK,0)
- IF '$LENGTH($PIECE(X,U,3))
- IF '$PIECE(X,"^",11)
- Begin DoDot:1
- +4 SET LRTS=+X
- SET LRAA=$SELECT($DATA(^LAB(60,LRTS,8,DUZ(2),0)):$PIECE(^(0),U,2),1:"")
- +5 IF LRAA'=""
- IF $DATA(LRAA(LRAA))
- IF $PIECE(^LAB(60,LRTS,0),U,7)'=1
- DO JAM
- End DoDot:1
- +6 SET LRI=0
- 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)
- SET LRTSTN=+X
- SET LRAD=$PIECE(X,U,3)
- SET LRAA=$PIECE(X,U,4)
- SET LRAN=$PIECE(X,U,5)
- IF '$DATA(^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN,+LRTSTN))
- DO REUP1
- +7 IF $DATA(REUP)
- SET LRCOUNT=LRCOUNT+1
- SET ^LRO(69,DT,1,LRSN,3)=LRDTI
- +8 IF '$DATA(REUP)
- SET $PIECE(^LRO(69,DT,1,LRSN,1),U)=$PIECE(^LRO(69,DT,1,LRSN,3),U)
- +9 KILL LRAD,LRI,LRAN,LRAA,LRDPF,DFN,LRZ3,LRZB,LRZ1,LRTSTN,LRRB,LRURG,REUP,I,J,LRK,F,LRAODT
- QUIT
- 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 IF '$DATA(^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN,LRAA,LRAN))
- SET REUP=1
- 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
- JAM 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)
- +1 DO EN^LRTSTSET
- +2 QUIT
- S7 ;FROM LRPHSET1 - COMBINE OR MERGE TESTS ON ORDERS
- +1 SET T=0
- FOR
- SET T=$ORDER(T(LRSAMP,T))
- IF T<1
- QUIT
- DO S7A
- +2 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 $LENGTH($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 $LENGTH($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
- 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
- M1 IF $LENGTH($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 SET ^LRO(69,DT,1,LRPSN,2,X,0)=^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0)
- SET $PIECE(^(0),"^",14)=DT_";"_LRSN_";"_+T(LRSAMP,J,LRSN)
- SET ^LRO(69,DT,1,LRPSN,2,"B",J,X)=""
- SET $PIECE(^LRO(69,DT,1,LRPSN,2,0),"^",3,4)=X_"^"_X
- +3 ;----- BEGIN IHS MODIFICATION LR*5.2*1018
- +4 ;IHS/ITSC/TPF 11/15/2002 BRING 'SIGN OR SYMPTOM' LAB POV INTO MERGE **1015**
- +5 ; S ^LRO(69,DT,1,LRPSN,2,X,9999999)=^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),9999999)
- +6 ; IHS/OIT/MKK - LR*5.2*1027
- IF $DATA(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),9999999))
- SET ^LRO(69,DT,1,LRPSN,2,X,9999999)=^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),9999999)
- +7 ;END **1015**
- +8 ;END IHS MODIFICATION
- +9 NEW I,XI,X1,TST
- +10 SET X1=^LRO(69,DT,1,LRPSN,.1)
- SET $PIECE(^LRO(69,DT,1,LRSN,2,+T(LRSAMP,J,LRSN),0),"^",6)=X1
- +11 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
- +12 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
- +13 ;----- BEGIN IHS MODIFICATION LR*5.2*1018
- +14 ;IHS/DIR TUC/AAB 03/27/98
- IF BLRLOG
- DO ^BLREVTQ("M","O",$GET(BLROPT),,DT_","_LRSN)
- +15 ;-----END IHS MODIFICATION
- +16 DO OERR(TST)
- +17 KILL T(LRSAMP,J,LRSN)
- +18 QUIT
- SWAP SET LRSWAP=LRSN
- SET LRSN=LRPSN
- SET LRPSN=LRSWAP
- KILL LRSWAP
- +1 QUIT
- SWAP1 SET LRSWAP=J
- SET J=T
- SET T=LRSWAP
- +1 QUIT
- 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
- OERR(TSTNODE) ;OE/RR - CPRS calls
- +1 ;OE/RR 2.5
- IF $$VER^LR7OU1<3
- Begin DoDot:1
- +2 NEW I,ORIFN,OREASON,ORSTS
- +3 SET ORIFN=$PIECE(TSTNODE,U,7)
- +4 IF ORIFN
- SET ORSTS=1
- SET OREASON="D"
- DO ST^ORX
- End DoDot:1
- QUIT
- +5 ;OE/RR 3.0
- NEW X,TTT,LRNATURE,LRSJ
- +6 SET LRSJ=J
- SET X=$ORDER(^ORD(100.03,"C","LRDUP",0))
- SET LRNATURE=$$DC1^LROR6(X,"Combined with LB #"_X1)
- +7 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($LENGTH($PIECE($GET(LRNATURE),"^",5)):$PIECE(LRNATURE,"^",5),1:"")
- +8 DO ^DIE
- +9 DO NEW^LR7OB1(DT,LRSN,"OC",$GET(LRNATURE),.TTT)
- +10 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
- +11 QUIT
