Routine: BLRTNDEL

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

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

 ; 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

 ; 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

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

BLRTNDEL.m