Routine: BLRTNRES

BLRTNRES ; IHS/HQT/MJL - CREATE/EDIT TRANSACTIONS (CONTINUED) RESULT ;MAY 06, 2009 9:58 AM

 ;;5.2T1;IHS LABORATORY;**1026**;NOV 01, 1997

 ; Code removed from BLRTN due to BLRTN becoming too large

RESULT ;

 D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER RESULT^BLRTN")

 I BLROPT="MICRO" D ^BLRTNM,^BLRTN1:$G(BLRACCN)'=""  Q

 I BLROPT="BBANK" D ^BLRTNB,^BLRTN1:$G(BLRACCN)'=""  Q

 S BLRACCN=$P(BLRIDS,","),BLR("ACCESSION NUMBER")=BLRACCN,BLRTEST=$P(BLRIDS,",",2),BLRRSTAG="RESVRS"

 S:BLROPT="BYPASS" BLRCMF="C",BLR("STATUS FLAG")="A"

 S BLRAA=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRAA")),BLRAD=$G(^("LRAD")),BLRAN=$G(^("LRAN")),BLRSS=$G(^("LRSS")),BLRODT=$G(^("LRODT")),BLRSEQ=$G(^("LRSN")),BLRSPEC=$G(^("LRSPEC")),BLRCMP=$P($G(^LRO(68,BLRAA,1,BLRAD,1,BLRAN,3)),U,4)'=""

 S BLRCRSBS="""AAT"",BLRACCN,BLRTEST1",BLRDIR=-1,BLROKCK="",BLRBADCK=""

 M BLRRVS=^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRSB")

 ;CLEAR OUT PENDING OR UNRESULTED TESTS

 S BLRDN=""

 F  S BLRDN=$O(BLRRVS(BLRDN)) Q:BLRDN=""  D

 . I BLRRVS(BLRDN)=""!(BLRRVS(BLRDN)[("pending")) K BLRRVS(BLRDN)  ;IHS/ITSC/TPF  TREAT pending AS NOT A RESULT

 I $G(BLRCMF)="C" D ORDVRS,ACCVRS^BLRTN  Q:BLRACCN=""

 S BLRTEST=$G(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRTEST"))

 S:BLRTEST=0 BLRTEST=""

 ;GET THE COMMENTS  ;IGNORE 0 NODES AND B X-REFS

 K ^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRCOM",0)

 K ^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRCOM","B")

 S COMIEN=0

 F  S COMIEN=$O(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRCOM",COMIEN)) Q:+COMIEN=0  D

 . S BLR("COMMENTS")=$G(BLR("COMMENTS"))_$G(^(COMIEN,0))_$C(20)

 . I BLRTEST'="",'$D(BLRRVS)!(BLRCMF="C") D SET1^BLRTN Q

. ;

 . D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("BEFORE BLRRVS LOOP")

 . S BLRDN=""

 . F  S BLRDN=$O(BLRRVS(BLRDN)) Q:BLRDN=""  D

 .. S BLRCREF=BLRSS_";"_BLRDN_";1"

 .. S BLRTEST=$O(^LAB(60,"C",BLRCREF,""))

 .. I BLRTEST'="",$D(^BLRTXLOG("AAT",BLRACCN,BLRTEST)) D

 ... D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("BEFORE SEQUENCE NUMBER GET")

 ... S BLRTEST1=BLRTEST,BLR("SEQUENCE NUMBER")=$$GETIEN^BLRTN()  Q:BLRERR

 ... D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("IN RESULT BEFORE UPDATE")

 ... S BLRRES=$P(BLRRVS(BLRDN),U)

 ... S BLRNAF=$P(BLRRVS(BLRDN),U,2)

 ... D RES1^BLRTN

 ... D ^BLRNFLTL

 ... D LOINC^BLRTN

 ... D CRSFLDS^BLRTN

 K BLR("COMMENTS")

 D ^BLRTN1

 K BLRRVS

 D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("EXIT RESULT^BLRTN")

 ; Set the BLR array using the field name or number, e.g.,

 ; S BLR("ORDER NUMBER")=X or S BLR(1103)=X

ORDVRS ;

 D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER ORDVRS^BLRTNRES")

 S BLRVAL=$G(^LRO(69,BLRODT,1,BLRSEQ,0))

 S BLRODTM=$P(BLRVAL,U,5)  ;'DATE/TIME ORDERED'

 S BLRDTC=$P($G(^LRO(69,BLRODT,1,BLRSEQ,1)),U)  ;'DATE/TIME OF COLLECTION'

 S:BLRDTC="" BLRDTC=$P(BLRVAL,U,8)  ;'EST. DATE/TIME OF COLLECTION'

 S BLR("COLLECTION DATE/TIME")=BLRDTC

 I BLRCMF'="C" Q

 S BLRLRDFN=$P(BLRVAL,U)  ;'LRDFN'

 S BLRFILE=$G(^LR(BLRLRDFN,0))

 S BLRDFN=$P(BLRFILE,U,3)

 S BLR("PATIENT POINTER VALUE")=BLRDFN

 S BLRFILE=$P(BLRFILE,U,2)

 S BLR("LRFILE")=BLRFILE

 S BLR("ORDER DATE")=BLRODTM

 S BLR("ORDER NUMBER")=$G(^LRO(69,BLRODT,1,BLRSEQ,.1))

 S BLR("ORDER SEQUENCE NUMBER")=BLRSEQ

 S BLRLOCN=$P(BLRVAL,U,7)

 S BLRLOC="" I BLRLOCN'="" S BLRLOC=$O(^SC("B",BLRLOCN,"")) S:BLRLOC="" BLRLOC=$O(^SC("C",BLRLOCN,"")) I BLRLOC="" S X=BLRLOCN,DIC=44,DIC(0)="MX" D ^DIC S BLRLOC=+Y I Y=-1 S BLRLOC=""

 S BLRCAT="A" I $L($G(^DPT(BLRDFN,.1))) S BLRCAT="I"

 S BLRCLNC="",BLRPCC1=0

 I BLRLOC'="" S BLRCLNC=$G(^SC(BLRLOC,0)),BLRIST=$P(BLRCLNC,U,4),BLRCLNC=$P(BLRCLNC,U,7) S:BLRIST="" BLRIST=$G(BLRDUZ2) I BLRXPCC S BLRPCCC=$P($G(^APCCCTRL(BLRIST,11,BLRLPKG,0)),U,3) I BLRPCCC'="" S BLRPCC1=$S(BLRPCCC:1,1:BLRCAT'="I")

 S BLRPROV=$P(BLRVAL,U,6),BLR("ORDERING PROVIDER POINTER")=BLRPROV

 D NOW^%DTC S BLR("ENTRY DATE/TIME")=%

 S BLR("CLINIC STOP CODE POINTER")=BLRCLNC

 S BLR("ORDERING LOCATION POINTER")=BLRLOC

 S BLR("DUZ(2)")=BLRDUZ2

 S BLR("I/O CATEGORY")=BLRCAT

 D LOINC^BLRTN

BLRTNRES  ; IHS/HQT/MJL - CREATE/EDIT TRANSACTIONS (CONTINUED) RESULT ;MAY 06, 2009 9:58 AM

 +1       ;;5.2T1;IHS LABORATORY;**1026**;NOV 01, 1997

 +2       ;

 +3       ; Code removed from BLRTN due to BLRTN becoming too large

RESULT    ;

 +1        IF $GET(SNAPSHOT)

               DO ENTRYAUD^BLRUTIL("ENTER RESULT^BLRTN")

 +2       ;

 +3        IF BLROPT="MICRO"

               DO ^BLRTNM

               IF $GET(BLRACCN)'=""

                   DO ^BLRTN1

               QUIT

 +4        IF BLROPT="BBANK"

               DO ^BLRTNB

               IF $GET(BLRACCN)'=""

                   DO ^BLRTN1

               QUIT

 +5       ;

 +6        SET BLRACCN=$PIECE(BLRIDS,",")

           SET BLR("ACCESSION NUMBER")=BLRACCN

           SET BLRTEST=$PIECE(BLRIDS,",",2)

           SET BLRRSTAG="RESVRS"

 +7        IF BLROPT="BYPASS"

               SET BLRCMF="C"

               SET BLR("STATUS FLAG")="A"

 +8       ;

 +9        SET BLRAA=$GET(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRAA"))

           SET BLRAD=$GET(^("LRAD"))

           SET BLRAN=$GET(^("LRAN"))

           SET BLRSS=$GET(^("LRSS"))

           SET BLRODT=$GET(^("LRODT"))

           SET BLRSEQ=$GET(^("LRSN"))

           SET BLRSPEC=$GET(^("LRSPEC"))

           SET BLRCMP=$PIECE($GET(^LRO(68,BLRAA,1,BLRAD,1,BLRAN,3)),U,4)'=""

 +10       SET BLRCRSBS="""AAT"",BLRACCN,BLRTEST1"

           SET BLRDIR=-1

           SET BLROKCK=""

           SET BLRBADCK=""

 +11      ;

 +12       MERGE BLRRVS=^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRSB")

 +13      ;

 +14      ;CLEAR OUT PENDING OR UNRESULTED TESTS

 +15       SET BLRDN=""

 +16       FOR

               SET BLRDN=$ORDER(BLRRVS(BLRDN))

               IF BLRDN=""

                   QUIT

               Begin DoDot:1

 +17      ;IHS/ITSC/TPF  TREAT pending AS NOT A RESULT

                   IF BLRRVS(BLRDN)=""!(BLRRVS(BLRDN)[("pending"))

                       KILL BLRRVS(BLRDN)

               End DoDot:1

 +18      ;

 +19       IF $GET(BLRCMF)="C"

               DO ORDVRS

               DO ACCVRS^BLRTN

               IF BLRACCN=""

                   QUIT

 +20      ;

 +21       SET BLRTEST=$GET(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"BLRTEST"))

 +22       IF BLRTEST=0

               SET BLRTEST=""

 +23      ;

 +24      ;GET THE COMMENTS  ;IGNORE 0 NODES AND B X-REFS

 +25       KILL ^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRCOM",0)

 +26       KILL ^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRCOM","B")

 +27       SET COMIEN=0

 +28       FOR

               SET COMIEN=$ORDER(^BLRSITE(BLRQSITE,20,BLRQDH,1,BLRLTP,"LRCOM",COMIEN))

               IF +COMIEN=0

                   QUIT

               Begin DoDot:1

 +29               SET BLR("COMMENTS")=$GET(BLR("COMMENTS"))_$GET(^(COMIEN,0))_$CHAR(20)

               End DoDot:1

 +30      ;

 +31       Begin DoDot:1

 +32           IF BLRTEST'=""

                   IF '$DATA(BLRRVS)!(BLRCMF="C")

                       DO SET1^BLRTN

                       QUIT

 +33      ;

 +34           IF $GET(SNAPSHOT)

                   DO ENTRYAUD^BLRUTIL("BEFORE BLRRVS LOOP")

 +35           SET BLRDN=""

 +36           FOR

                   SET BLRDN=$ORDER(BLRRVS(BLRDN))

                   IF BLRDN=""

                       QUIT

                   Begin DoDot:2

 +37                   SET BLRCREF=BLRSS_";"_BLRDN_";1"

 +38                   SET BLRTEST=$ORDER(^LAB(60,"C",BLRCREF,""))

 +39                   IF BLRTEST'=""

                           IF $DATA(^BLRTXLOG("AAT",BLRACCN,BLRTEST))

                               Begin DoDot:3

 +40                               IF $GET(SNAPSHOT)

                                       DO ENTRYAUD^BLRUTIL("BEFORE SEQUENCE NUMBER GET")

 +41                               SET BLRTEST1=BLRTEST

                                   SET BLR("SEQUENCE NUMBER")=$$GETIEN^BLRTN()

                                   IF BLRERR

                                       QUIT

 +42                               IF $GET(SNAPSHOT)

                                       DO ENTRYAUD^BLRUTIL("IN RESULT BEFORE UPDATE")

 +43                               SET BLRRES=$PIECE(BLRRVS(BLRDN),U)

 +44                               SET BLRNAF=$PIECE(BLRRVS(BLRDN),U,2)

 +45                               DO RES1^BLRTN

 +46                               DO ^BLRNFLTL

 +47                               DO LOINC^BLRTN

 +48                               DO CRSFLDS^BLRTN

                               End DoDot:3

                   End DoDot:2

           End DoDot:1

 +49      ;

 +50       KILL BLR("COMMENTS")

 +51       DO ^BLRTN1

 +52       KILL BLRRVS

 +53       IF $GET(SNAPSHOT)

               DO ENTRYAUD^BLRUTIL("EXIT RESULT^BLRTN")

 +54       QUIT

 +55      ;

 +56      ; Set the BLR array using the field name or number, e.g.,

 +57      ; S BLR("ORDER NUMBER")=X or S BLR(1103)=X

ORDVRS    ;

 +1        IF $GET(SNAPSHOT)

               DO ENTRYAUD^BLRUTIL("ENTER ORDVRS^BLRTNRES")

 +2        SET BLRVAL=$GET(^LRO(69,BLRODT,1,BLRSEQ,0))

 +3       ;'DATE/TIME ORDERED'

           SET BLRODTM=$PIECE(BLRVAL,U,5)

 +4       ;'DATE/TIME OF COLLECTION'

           SET BLRDTC=$PIECE($GET(^LRO(69,BLRODT,1,BLRSEQ,1)),U)

 +5       ;'EST. DATE/TIME OF COLLECTION'

           IF BLRDTC=""

               SET BLRDTC=$PIECE(BLRVAL,U,8)

 +6        SET BLR("COLLECTION DATE/TIME")=BLRDTC

 +7       ;

 +8        IF BLRCMF'="C"

               QUIT

 +9       ;

 +10      ;'LRDFN'

           SET BLRLRDFN=$PIECE(BLRVAL,U)

 +11       SET BLRFILE=$GET(^LR(BLRLRDFN,0))

 +12       SET BLRDFN=$PIECE(BLRFILE,U,3)

 +13       SET BLR("PATIENT POINTER VALUE")=BLRDFN

 +14       SET BLRFILE=$PIECE(BLRFILE,U,2)

 +15       SET BLR("LRFILE")=BLRFILE

 +16       SET BLR("ORDER DATE")=BLRODTM

 +17       SET BLR("ORDER NUMBER")=$GET(^LRO(69,BLRODT,1,BLRSEQ,.1))

 +18       SET BLR("ORDER SEQUENCE NUMBER")=BLRSEQ

 +19       SET BLRLOCN=$PIECE(BLRVAL,U,7)

 +20      ;

 +21       SET BLRLOC=""

           IF BLRLOCN'=""

               SET BLRLOC=$ORDER(^SC("B",BLRLOCN,""))

               IF BLRLOC=""

                   SET BLRLOC=$ORDER(^SC("C",BLRLOCN,""))

               IF BLRLOC=""

                   SET X=BLRLOCN

                   SET DIC=44

                   SET DIC(0)="MX"

                   DO ^DIC

                   SET BLRLOC=+Y

                   IF Y=-1

                       SET BLRLOC=""

 +22       SET BLRCAT="A"

           IF $LENGTH($GET(^DPT(BLRDFN,.1)))

               SET BLRCAT="I"

 +23       SET BLRCLNC=""

           SET BLRPCC1=0

 +24       IF BLRLOC'=""

               SET BLRCLNC=$GET(^SC(BLRLOC,0))

               SET BLRIST=$PIECE(BLRCLNC,U,4)

               SET BLRCLNC=$PIECE(BLRCLNC,U,7)

               IF BLRIST=""

                   SET BLRIST=$GET(BLRDUZ2)

               IF BLRXPCC

                   SET BLRPCCC=$PIECE($GET(^APCCCTRL(BLRIST,11,BLRLPKG,0)),U,3)

                   IF BLRPCCC'=""

                       SET BLRPCC1=$SELECT(BLRPCCC:1,1:BLRCAT'="I")

 +25       SET BLRPROV=$PIECE(BLRVAL,U,6)

           SET BLR("ORDERING PROVIDER POINTER")=BLRPROV

 +26       DO NOW^%DTC

           SET BLR("ENTRY DATE/TIME")=%

 +27       SET BLR("CLINIC STOP CODE POINTER")=BLRCLNC

 +28       SET BLR("ORDERING LOCATION POINTER")=BLRLOC

 +29       SET BLR("DUZ(2)")=BLRDUZ2

 +30       SET BLR("I/O CATEGORY")=BLRCAT

 +31       DO LOINC^BLRTN

 +32       QUIT

BLRTNRES.m