BLRTNDEL ; IHS/HQT/MJL - CREATE/EDIT TRANSACTIONS (CONTINUED) DELETION ;MAY 06, 2009 9:58 AM
;;5.2T1;IHS LABORATORY;**1026**;NOV 01, 1997
;
; Code removed from BLRTN routine due to BLRTN becoming too large
DELETE ;
D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER DELETE^BLRTN")
I BLROPT="DELORD" D Q
. S BLRODTM=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRODTM"))
. I BLRPARAM["TESTS" D Q
.. S BLRCRSBS="""AOT"",BLRODTM,BLRSEQ,BLRTEST1"
.. S BLRDIR=1
.. S BLROKCK="CKORD"
.. S BLRBADCK=""
.. S BLRTEST=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRTEST"))
.. S BLRSEQ=$G(^("LRSN")) D SET1^BLRTN
. M BLRT=^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"T")
. ;
. S BLRII=""
. F S BLRII=$O(BLRT(BLRII)) Q:'BLRII D
.. S BLRLRSN=BLRT(BLRII)
.. S BLRTEST=$P(BLRLRSN,U,3)
.. S BLRLRSN=+BLRLRSN
.. S BLRTN=0
.. F S BLRTN=$O(^BLRTXLOG("AOT",BLRODTM,BLRLRSN,BLRTEST,BLRTN)) Q:'BLRTN S BLRTN(BLRTN)=""
. ;
. S BLRLRSN=0
. F S BLRLRSN=$O(^BLRTXLOG("AOT",BLRODTM,BLRLRSN)) Q:'BLRLRSN D
.. S BLRTEST=0
.. F S BLRTEST=$O(^BLRTXLOG("AOT",BLRODTM,BLRLRSN,BLRTEST)) Q:'BLRTEST D
... S BLRTN=0
... F S BLRTN=$O(^BLRTXLOG("AOT",BLRODTM,BLRLRSN,BLRTEST,BLRTN)) Q:'BLRTN S BLRTNS(BLRTN)=""
. ;
. S BLRTN=0
. F S BLRTN=$O(BLRTNS(BLRTN)) Q:'BLRTN D
.. S BLRPAR=+$P($G(^BLRTXLOG(BLRTN,1)),U)
.. I $D(BLRTN(BLRTN))!$D(BLRTN(BLRPAR)) D
... S BLRTN(BLRTN)=""
... S BLR("SEQUENCE NUMBER")=BLRTN
... S BLRENT=BLRTN
... S BLRIEN=BLRTN_","
... D ^BLRNFLTL
. K BLRT,BLRTN,BLRTNS
;
S BLRACCN=""
I BLRIDS,BLRIDS["," S BLRAA=$P(BLRIDS,","),BLRAD=$P(BLRIDS,",",2),BLRAN=$P(BLRIDS,",",3),BLRACCN=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRACCN"))
S:BLRACCN="" BLRACCN=BLRIDS
;
I BLROPT="DELACC" D DELACC Q
;
I BLROPT="REMACC" D Q
. S BLRTEST=0
. F S BLRTEST=$O(^BLRTXLOG("AAT",BLRACCN,BLRTEST)) Q:'BLRTEST D
.. S BLRENT=$O(^BLRTXLOG("AAT",BLRACCN,BLRTEST," "),-1)
.. I BLRENT S BLR("SEQUENCE NUMBER")=BLRENT,BLRIEN=BLRENT_"," D ^BLRNFLTL
Q
;
DELACC ; EP
K BLRTN,BLRTNS
S BLRTEST=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRTEST"))
M ^BLRTEST=^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRTEST")
;
;GET TEST IEN BEING DELETED
S BLRTN=$O(^BLRTXLOG("AAT",BLRACCN,BLRTEST," "),-1) I 'BLRTN K BLRTN Q
S BLRTN(BLRTN)="" ; TEST BEING DELETED
S DELSEQ=BLRTN ; SAVE SEQ BEING DELETED
S COMP=1 ; FIX PARENT NOT UPDATING WHEN DELETING A TEST ;ASSUME ITS COMPLETE
S ALLDEL=1 ; IF ALL TESTS ARE DELETED THE DELETE PARENT TO ASSUME ALL ARE DELETED. IF ANY ARE NOT DELETED S ALLDEL=0
K PARENT
;
;GET LIST OF ALL TESTS BELONGING TO THIS ACCESSION
S (COUNT,BLRTEST)=0
F S BLRTEST=$O(^BLRTXLOG("AAT",BLRACCN,BLRTEST)) Q:'BLRTEST D
. S BLRTN=$O(^BLRTXLOG("AAT",BLRACCN,BLRTEST," "),-1)
. I BLRTN S BLRTNS(BLRTN)="",COUNT=COUNT+1 ;IF COUNT = 1 THEN WE HAVE A LONE PARENT SINGLE TEST
;
S (COUNT,BLRTEST)=0
F S BLRTEST=$O(^BLRTXLOG("AAT",BLRACCN,BLRTEST)) Q:'BLRTEST D
. S BLRTN=$O(^BLRTXLOG("AAT",BLRACCN,BLRTEST," "),-1) Q:BLRTN=""
. S BLRTEMP(BLRTN)=$P($G(^BLRTXLOG(BLRTN,1)),U)
;
S P=""
F S P=$O(BLRTEMP(P)) Q:P="" D
. I $G(BLRTEMP(P)) S BLRTEMP(BLRTEMP(P),P)="" K BLRTEMP(P)
;
; IF SEQ BEING DELETED IS THE PARENT AND THERE ARE NO CHILDREN DELETE IT
I $D(BLRTEMP(DELSEQ))=1 D DELPAR(DELSEQ) Q
;
S PARENT=$O(BLRTNS("")) ;PARENT ALWAYS FIRST IN THIS ARRAY
;
;SKIP THE PARENT WE'LL DEAL WITH IT LATER
S BLRTN=0 S BLRTN=$O(BLRTNS(BLRTN)) F S BLRTN=$O(BLRTNS(BLRTN)) Q:'BLRTN S BLRPAR=+$P($G(^BLRTXLOG(BLRTN,1)),U) I $D(BLRTN(BLRTN))!$D(BLRTN(BLRPAR)) S BLRTN(BLRTN)="",BLR("SEQUENCE NUMBER")=BLRTN,BLRENT=BLRTN,BLRIEN=BLRTN_"," D ^BLRNFLTL
S BLRTEST=0 F S BLRTEST=$O(^BLRTXLOG("AAT",BLRACCN,BLRTEST)) Q:'BLRTEST S BLRTN=$O(^BLRTXLOG("AAT",BLRACCN,BLRTEST," "),-1) D UPDTPAR(BLRTEST,BLRTN) S:BLRTN BLRTNS(BLRTN)="" ;IHS/ITSC/TPF 03/15/02
D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("BEFORE CHECK COMP")
;
I COMP D
. D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER COMP")
. I COUNT=1 S $P(^BLRTXLOG(PARENT,1),U,2)="D",BLR("STATUS FLAG")="D"
. E S $P(^BLRTXLOG(PARENT,1),U,2)="R",BLR("STATUS FLAG")="R"
. S BLR("SEQUENCE NUMBER")=PARENT
. S BLRENT=PARENT
. S BLRIEN=PARENT_","
. D ^BLRNFLTL ;IHS/ITSC/TPF 03/15/02 UPDATE PCC WITH PARENT STATUS
;
K BLRTN,BLRTNS
;
;NEW TO DELETE PARENT IF ALL TESTS ARE DELETED
I ALLDEL D
. D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER ALLDEL")
. Q:COUNT=1
. S $P(^BLRTXLOG(PARENT,1),U,2)="D",BLR("STATUS FLAG")="D"
. S BLR("SEQUENCE NUMBER")=PARENT
. S BLRENT=PARENT
. S BLRIEN=PARENT_","
. D ^BLRNFLTL
Q
;
; AFTER DELETING A TEST UPDATE PARENT FOR RESULT STATUS IF ALL REQUIRED
; TESTS ARE RESULTED
UPDTPAR(TST,SEQ) ; EP
;IS STATUS FLAG "A" AND ITS REQUIRED THEN PARENT STAYS ACCESSIONED
Q:SEQ=PARENT
;
I $P($G(^BLRTXLOG(SEQ,1)),U,2)'="D" S ALLDEL=0 ;IF ANY ARE NOT DELETED
;
; DON'T DELETE PARENT
; TEST ACCESSIONED AND REQUIRED TEST COMPLETE IS FALSE
I ($P($G(^BLRTXLOG(SEQ,1)),U,2)="A"),$P($G(^LAB(60,TST,0)),U,17) S COMP=0
Q
;
; DELETE THE LONE PARENT
DELPAR(P) ; EP
D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER DELPAR^BLRTN")
;
S $P(^BLRTXLOG(P,1),U,2)="D",BLR("STATUS FLAG")="D"
S BLR("SEQUENCE NUMBER")=P
S BLRENT=P
S BLRIEN=P_","
D ^BLRNFLTL
Q
BLRTNDEL ; IHS/HQT/MJL - CREATE/EDIT TRANSACTIONS (CONTINUED) DELETION ;MAY 06, 2009 9:58 AM
+1 ;;5.2T1;IHS LABORATORY;**1026**;NOV 01, 1997
+2 ;
+3 ; Code removed from BLRTN routine due to BLRTN becoming too large
DELETE ;
+1 IF $GET(SNAPSHOT)
DO ENTRYAUD^BLRUTIL("ENTER DELETE^BLRTN")
+2 IF BLROPT="DELORD"
Begin DoDot:1
+3 SET BLRODTM=$GET(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRODTM"))
+4 IF BLRPARAM["TESTS"
Begin DoDot:2
+5 SET BLRCRSBS="""AOT"",BLRODTM,BLRSEQ,BLRTEST1"
+6 SET BLRDIR=1
+7 SET BLROKCK="CKORD"
+8 SET BLRBADCK=""
+9 SET BLRTEST=$GET(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRTEST"))
+10 SET BLRSEQ=$GET(^("LRSN"))
DO SET1^BLRTN
End DoDot:2
QUIT
+11 MERGE BLRT=^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"T")
+12 ;
+13 SET BLRII=""
+14 FOR
SET BLRII=$ORDER(BLRT(BLRII))
IF 'BLRII
QUIT
Begin DoDot:2
+15 SET BLRLRSN=BLRT(BLRII)
+16 SET BLRTEST=$PIECE(BLRLRSN,U,3)
+17 SET BLRLRSN=+BLRLRSN
+18 SET BLRTN=0
+19 FOR
SET BLRTN=$ORDER(^BLRTXLOG("AOT",BLRODTM,BLRLRSN,BLRTEST,BLRTN))
IF 'BLRTN
QUIT
SET BLRTN(BLRTN)=""
End DoDot:2
+20 ;
+21 SET BLRLRSN=0
+22 FOR
SET BLRLRSN=$ORDER(^BLRTXLOG("AOT",BLRODTM,BLRLRSN))
IF 'BLRLRSN
QUIT
Begin DoDot:2
+23 SET BLRTEST=0
+24 FOR
SET BLRTEST=$ORDER(^BLRTXLOG("AOT",BLRODTM,BLRLRSN,BLRTEST))
IF 'BLRTEST
QUIT
Begin DoDot:3
+25 SET BLRTN=0
+26 FOR
SET BLRTN=$ORDER(^BLRTXLOG("AOT",BLRODTM,BLRLRSN,BLRTEST,BLRTN))
IF 'BLRTN
QUIT
SET BLRTNS(BLRTN)=""
End DoDot:3
End DoDot:2
+27 ;
+28 SET BLRTN=0
+29 FOR
SET BLRTN=$ORDER(BLRTNS(BLRTN))
IF 'BLRTN
QUIT
Begin DoDot:2
+30 SET BLRPAR=+$PIECE($GET(^BLRTXLOG(BLRTN,1)),U)
+31 IF $DATA(BLRTN(BLRTN))!$DATA(BLRTN(BLRPAR))
Begin DoDot:3
+32 SET BLRTN(BLRTN)=""
+33 SET BLR("SEQUENCE NUMBER")=BLRTN
+34 SET BLRENT=BLRTN
+35 SET BLRIEN=BLRTN_","
+36 DO ^BLRNFLTL
End DoDot:3
End DoDot:2
+37 KILL BLRT,BLRTN,BLRTNS
End DoDot:1
QUIT
+38 ;
+39 SET BLRACCN=""
+40 IF BLRIDS
IF BLRIDS[","
SET BLRAA=$PIECE(BLRIDS,",")
SET BLRAD=$PIECE(BLRIDS,",",2)
SET BLRAN=$PIECE(BLRIDS,",",3)
SET BLRACCN=$GET(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRACCN"))
+41 IF BLRACCN=""
SET BLRACCN=BLRIDS
+42 ;
+43 IF BLROPT="DELACC"
DO DELACC
QUIT
+44 ;
+45 IF BLROPT="REMACC"
Begin DoDot:1
+46 SET BLRTEST=0
+47 FOR
SET BLRTEST=$ORDER(^BLRTXLOG("AAT",BLRACCN,BLRTEST))
IF 'BLRTEST
QUIT
Begin DoDot:2
+48 SET BLRENT=$ORDER(^BLRTXLOG("AAT",BLRACCN,BLRTEST," "),-1)
+49 IF BLRENT
SET BLR("SEQUENCE NUMBER")=BLRENT
SET BLRIEN=BLRENT_","
DO ^BLRNFLTL
End DoDot:2
End DoDot:1
QUIT
+50 QUIT
+51 ;
DELACC ; EP
+1 KILL BLRTN,BLRTNS
+2 SET BLRTEST=$GET(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRTEST"))
+3 MERGE ^BLRTEST=^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRTEST")
+4 ;
+5 ;GET TEST IEN BEING DELETED
+6 SET BLRTN=$ORDER(^BLRTXLOG("AAT",BLRACCN,BLRTEST," "),-1)
IF 'BLRTN
KILL BLRTN
QUIT
+7 ; TEST BEING DELETED
SET BLRTN(BLRTN)=""
+8 ; SAVE SEQ BEING DELETED
SET DELSEQ=BLRTN
+9 ; FIX PARENT NOT UPDATING WHEN DELETING A TEST ;ASSUME ITS COMPLETE
SET COMP=1
+10 ; IF ALL TESTS ARE DELETED THE DELETE PARENT TO ASSUME ALL ARE DELETED. IF ANY ARE NOT DELETED S ALLDEL=0
SET ALLDEL=1
+11 KILL PARENT
+12 ;
+13 ;GET LIST OF ALL TESTS BELONGING TO THIS ACCESSION
+14 SET (COUNT,BLRTEST)=0
+15 FOR
SET BLRTEST=$ORDER(^BLRTXLOG("AAT",BLRACCN,BLRTEST))
IF 'BLRTEST
QUIT
Begin DoDot:1
+16 SET BLRTN=$ORDER(^BLRTXLOG("AAT",BLRACCN,BLRTEST," "),-1)
+17 ;IF COUNT = 1 THEN WE HAVE A LONE PARENT SINGLE TEST
IF BLRTN
SET BLRTNS(BLRTN)=""
SET COUNT=COUNT+1
End DoDot:1
+18 ;
+19 SET (COUNT,BLRTEST)=0
+20 FOR
SET BLRTEST=$ORDER(^BLRTXLOG("AAT",BLRACCN,BLRTEST))
IF 'BLRTEST
QUIT
Begin DoDot:1
+21 SET BLRTN=$ORDER(^BLRTXLOG("AAT",BLRACCN,BLRTEST," "),-1)
IF BLRTN=""
QUIT
+22 SET BLRTEMP(BLRTN)=$PIECE($GET(^BLRTXLOG(BLRTN,1)),U)
End DoDot:1
+23 ;
+24 SET P=""
+25 FOR
SET P=$ORDER(BLRTEMP(P))
IF P=""
QUIT
Begin DoDot:1
+26 IF $GET(BLRTEMP(P))
SET BLRTEMP(BLRTEMP(P),P)=""
KILL BLRTEMP(P)
End DoDot:1
+27 ;
+28 ; IF SEQ BEING DELETED IS THE PARENT AND THERE ARE NO CHILDREN DELETE IT
+29 IF $DATA(BLRTEMP(DELSEQ))=1
DO DELPAR(DELSEQ)
QUIT
+30 ;
+31 ;PARENT ALWAYS FIRST IN THIS ARRAY
SET PARENT=$ORDER(BLRTNS(""))
+32 ;
+33 ;SKIP THE PARENT WE'LL DEAL WITH IT LATER
+34 SET BLRTN=0
SET BLRTN=$ORDER(BLRTNS(BLRTN))
FOR
SET BLRTN=$ORDER(BLRTNS(BLRTN))
IF 'BLRTN
QUIT
SET BLRPAR=+$PIECE($GET(^BLRTXLOG(BLRTN,1)),U)
IF $DATA(BLRTN(BLRTN))!$DATA(BLRTN(BLRPAR))
SET BLRTN(BLRTN)=""
SET BLR("SEQUENCE NUMBER")=BLRTN
SET BLRENT=BLRTN
SET BLRIEN=BLRTN_","
DO ^BLRNFLTL
+35 ;IHS/ITSC/TPF 03/15/02
SET BLRTEST=0
FOR
SET BLRTEST=$ORDER(^BLRTXLOG("AAT",BLRACCN,BLRTEST))
IF 'BLRTEST
QUIT
SET BLRTN=$ORDER(^BLRTXLOG("AAT",BLRACCN,BLRTEST," "),-1)
DO UPDTPAR(BLRTEST,BLRTN)
IF BLRTN
SET BLRTNS(BLRTN)=""
+36 IF $GET(SNAPSHOT)
DO ENTRYAUD^BLRUTIL("BEFORE CHECK COMP")
+37 ;
+38 IF COMP
Begin DoDot:1
+39 IF $GET(SNAPSHOT)
DO ENTRYAUD^BLRUTIL("ENTER COMP")
+40 IF COUNT=1
SET $PIECE(^BLRTXLOG(PARENT,1),U,2)="D"
SET BLR("STATUS FLAG")="D"
+41 IF '$TEST
SET $PIECE(^BLRTXLOG(PARENT,1),U,2)="R"
SET BLR("STATUS FLAG")="R"
+42 SET BLR("SEQUENCE NUMBER")=PARENT
+43 SET BLRENT=PARENT
+44 SET BLRIEN=PARENT_","
+45 ;IHS/ITSC/TPF 03/15/02 UPDATE PCC WITH PARENT STATUS
DO ^BLRNFLTL
End DoDot:1
+46 ;
+47 KILL BLRTN,BLRTNS
+48 ;
+49 ;NEW TO DELETE PARENT IF ALL TESTS ARE DELETED
+50 IF ALLDEL
Begin DoDot:1
+51 IF $GET(SNAPSHOT)
DO ENTRYAUD^BLRUTIL("ENTER ALLDEL")
+52 IF COUNT=1
QUIT
+53 SET $PIECE(^BLRTXLOG(PARENT,1),U,2)="D"
SET BLR("STATUS FLAG")="D"
+54 SET BLR("SEQUENCE NUMBER")=PARENT
+55 SET BLRENT=PARENT
+56 SET BLRIEN=PARENT_","
+57 DO ^BLRNFLTL
End DoDot:1
+58 QUIT
+59 ;
+60 ; AFTER DELETING A TEST UPDATE PARENT FOR RESULT STATUS IF ALL REQUIRED
+61 ; TESTS ARE RESULTED
UPDTPAR(TST,SEQ) ; EP
+1 ;IS STATUS FLAG "A" AND ITS REQUIRED THEN PARENT STAYS ACCESSIONED
+2 IF SEQ=PARENT
QUIT
+3 ;
+4 ;IF ANY ARE NOT DELETED
IF $PIECE($GET(^BLRTXLOG(SEQ,1)),U,2)'="D"
SET ALLDEL=0
+5 ;
+6 ; DON'T DELETE PARENT
+7 ; TEST ACCESSIONED AND REQUIRED TEST COMPLETE IS FALSE
+8 IF ($PIECE($GET(^BLRTXLOG(SEQ,1)),U,2)="A")
IF $PIECE($GET(^LAB(60,TST,0)),U,17)
SET COMP=0
+9 QUIT
+10 ;
+11 ; DELETE THE LONE PARENT
DELPAR(P) ; EP
+1 IF $GET(SNAPSHOT)
DO ENTRYAUD^BLRUTIL("ENTER DELPAR^BLRTN")
+2 ;
+3 SET $PIECE(^BLRTXLOG(P,1),U,2)="D"
SET BLR("STATUS FLAG")="D"
+4 SET BLR("SEQUENCE NUMBER")=P
+5 SET BLRENT=P
+6 SET BLRIEN=P_","
+7 DO ^BLRNFLTL
+8 QUIT
