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)
;
D
. 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")
Q
;
; 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
Q
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
