BLRTNM1 ; IHS/HQT/MJL - SET IHS LAB TRANSACTION LOG - MICRO ; 14 Jun 2010 9:55 AM
;;5.2;IHS LABORATORY;**1010,1018,1028,1030**;NOV 01, 1997
;;
;
D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER ^BLRTNM1")
S BLRCMF="C"
Q:$D(^LRO(69,BLRODT,1,BLRSEQ,0))<1 ; IHS/OIT/MKK - LR*5.2*1028 -- If no Data, skip. PIMC correction.
; S BLRVAL=^LRO(69,BLRODT,1,BLRSEQ,0),BLRLRDFN=$P(BLRVAL,U,1),BLRODTM=$P(BLRVAL,U,5)
; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030 -- Naked Reference Issue
S BLRVAL=$G(^LRO(69,BLRODT,1,BLRSEQ,0))
S BLRLRDFN=$P(BLRVAL,U,1)
S BLRODTM=$P(BLRVAL,U,5)
; ----- END IHS/OIT/MKK -- LR*5.2*1030
S BLRDUZ=$P(BLRVAL,U,2),BLRDUZ2=DUZ(2)
S BLRDTC=$P(BLRVAL,U,8),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 BLRCLNC="" I BLRLOC'="" S BLRCLNC=$P(^SC(BLRLOC,0),U,7)
;S BLRCAT="A" I $L($G(^DPT(BLRLRDFN,.1))) S BLRCAT="I"
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
S BLRCAT="A" S X=$$GET1^DIQ(2,BLRLRDFN,.103) I X]"",X'["OBSERVATION" S BLRCAT="I"
;----- END IHS MODIFICATIONS MOD SUGGESTED BY LINDA FELS
S BLRPROV=$P(BLRVAL,U,6)
S BLRDFN=$P(^LR(BLRLRDFN,0),U,3),BLRFILE=$P(^LR(BLRLRDFN,0),U,2),BLRODTM=$G(BLRODTM)
S BLR("SEQUENCE NUMBER")=$$GETIEN
S BLR("LRFILE")=BLRFILE,BLR("LRDFN")=BLRLRDFN,BLR("PATIENT POINTER VALUE")=BLRDFN,BLR("ORDERING PROVIDER POINTER")=BLRPROV,BLR("VERIFIER POINTER")=BLRDUZ
S BLR("ORDER DATE")=$P(BLRVAL,U,5),BLR("ORDER SEQ. NUMBER")=BLRSEQ,BLR("ORDER NUMBER")=^LRO(69,BLRODT,1,BLRSEQ,.1)
D NOW^%DTC S BLR("ENTRY DATE/TIME")=%
S BLR("COLLECTION DATE/TIME")=BLRDTC,BLR("CLINIC STOP CODE POINTER")=BLRCLNC
S BLR("ORDERING LOCATION POINTER")=BLRLOC,BLR("DUZ(2)")=BLRDUZ2,BLR("I/O CATEGORY")=BLRCAT,BLR("ACCESSION NUMBER")=BLRACCN,BLR("COLLECTION SAMPLE POINTER")=BLRCOLSP
S BLRLEV=1,BLRTEST1=BLRTEST,BLRLEV(1)=BLRTEST,BLRLEV(1,1)="",BLRATOM=1
I BLR60F,'BLRSETP S BLRPAR=""
D SET3 I BLR60F F D SET2 Q:'BLRLEV
K BLR,BLRLEV I BLR60F,'BLRSETP K BLRPAR
Q
;
SET2 ;
D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER SET2^BLRTNM1")
S BLRATOM=$O(^LAB(60,BLRLEV(BLRLEV),2,0))="" I BLRATOM,BLRLEV=1 S BLRLEV=0 Q
S:'BLRATOM BLRLEV=BLRLEV+1 S BLRLEV(BLRLEV,0)=$O(^LAB(60,BLRLEV(BLRLEV-1),2,$G(BLRLEV(BLRLEV,0),0)))
I BLRLEV(BLRLEV,0) S BLRTEST1=+^LAB(60,BLRLEV(BLRLEV-1),2,$G(BLRLEV(BLRLEV,0),0),0),BLRLEV(BLRLEV)=BLRTEST1 D SET3 Q
S BLRLEV(BLRLEV,0)=0,BLRLEV=BLRLEV-2
Q
;
SET3 ;
D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER SET3^BLRTNM1")
S BLRMOD="MI"
I BLR60F S BLRL60=^LAB(60,BLRTEST1,0),BLRMOD=$P(BLRL60,U,4),BLRCST=$P(BLRL60,U,11)
S BLR("LAB MODULE")=BLRMOD
;S (BLRXII,BLRCPTS,BLRCPTP)="" F S BLRFOUND=0,BLRXII=$O(^BLRCPT("C",BLRTEST1,BLRXII)) Q:(BLRXII=""!(BLRFOUND)) S BLRCPTF=$P(^BLRCPT(BLRXII,1),U,2) Q:BLRCPTF D GETCPT Q
D:BLRLEV=1 CPTCODE^BLRTN
S BLRSPEC=$G(LRSPEC) D:BLRSPEC'="" SET4
D:BLR60F
.S BLR("CPT LAB CODE POINTER")=BLRCPTP,BLR("CPT CODE")=BLRCPTS,BLR("PANEL/TEST POINTER")=BLRTEST1,BLR("PANEL/TEST NAME")=BLRTESTN,BLR("LAB TEST LIST COST")=BLRCST,BLR("RESULT")=BLRRES S:BLRCMTS'="" BLR("COMMENTS")=BLRCMTS
I 'BLR60F D
.S BLR("PARENT POINTER")=BLRPAR,BLR("CPT LAB CODE POINTER")=BLRCPTP,BLR("CPT CODE")=BLRCPTS,BLR("RESULT")=BLRRES,BLR("ORGANISM")=BLRORG,BLR("PANEL/TEST POINTER")=BLRCULT
.I BLRSPT'=6,BLRANTP'="" S BLR("ANTIBIOTIC")=BLRANTP,BLR("ANTIBIOTIC NAME")=BLRANTN,BLR("PCC ERROR FLAG")=BLRERFS
.S:BLRSTGN'="" BLR("STAGE NAME")=BLRSTGN
.S:BLRSTG'="" BLR("STAGE COUNTER")=BLRSTG Q
I BLR60F S BLR("PARENT POINTER")=BLRLEV(BLRLEV,1) S:'BLRATOM BLRPAR=BLR("SEQUENCE NUMBER")
S:+BLRCMPD BLR("COMPLETE DATE")=BLRCMPD
D ^BLRNFLTL
I 'BLRATOM S BLRLEV(BLRLEV+1,1)=BLRPAR
S BLRCMTS=""
Q
;
SET4 ;
D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER SET4^BLRTNM1")
S BLRZ=$G(^LAB(60,BLRTEST1,1,BLRSPEC,0)),BLRUNITS=$P($P(BLRZ,U,7)," ",1)
;[LR*5.2*1028;08/20/10;IHS/OIT/MPW]Added next 1 line
I BLRUNITS?1N.N,$D(^BLRUCUM(BLRUNITS,0)) S BLRUNITS=$P($G(^BLRUCUM(BLRUNITS,0)),U,1)
S BLR("UNITS")=BLRUNITS,BLR("SITE/SPECIMEN POINTER")=BLRSPEC
Q
;
GETIEN() ;
D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER GETIEN^BLRTNM1")
I BLRCMF="C" D GETNEW Q BLRENT
D
.S BLRCRGL="^BLRTXLOG("_BLRCRSBS_")",BLRENT=$O(@BLRCRGL@(""),BLRDIR)
.S:'BLRENT BLRERR=1
.I BLRENT,BLROKCK'="" D @BLROKCK
.I 'BLRERR,BLRBADCK'="" D @BLRBADCK
.I BLRERR D EMSG Q
.S BLRIEN=BLRENT_"," Q
Q BLRENT
;
GETNEW ;
D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER GETNEW^BLRTNM1")
S BLRENT=$G(^BLRTXLOG("SEQ"))
I 'BLRENT S BLRENT=$O(^BLRTXLOG("@"),-1) I BLRENT,'$D(^BLRTXLOG(1)) S BLRENT=0
F BLRENT=BLRENT+1:1 Q:'$D(^BLRTXLOG(BLRENT))
S BLRENTS="BLRENTS",BLRENTS(1)=BLRENT,^BLRTXLOG("SEQ")=BLRENT,BLRIEN="+1,"
Q
;
CHKDT ;
D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER CHKDT^BLRTNM1")
S BLRCDT=$P(^BLRTXLOG(BLRENT,12),U)
Q:$E(BLRCDT,1,3)=$E(DT,1,3)
I ($E(BLRCDT,1,3)+1)'=$E(DT,1,3) S BLRERR=1,BLRDTER=1 Q ;MORE THAN 1 YEAR AHEAD
I $E(BLRCDT,4,5)<11 S BLRERR=1,BLRDTER=1 Q
Q
;
EMSG ;
; Log an error because the crossreference isn't set.
I 'BLRENT D
.S BLRERR=1,BLRERROR(1)="Something wrong -- problem with IHS Lab Transaction Log Cross Reference: "_BLRCRGL
Q
;
;
GETCPT ;
D:$G(SNAPSHOT) ENTRYAUD^BLRUTIL("ENTER GETCPT^BLRTNM1")
S BLRFOUND=1
S BLRCPTP=BLRXII
S (BLRCPTS,BLRCPTC)="" F S BLRCPTC=$O(^BLRCPT(BLRXII,11,"B",BLRCPTC)) Q:BLRCPTC="" S BLRCPTS=BLRCPTS_BLRCPTC_";"
I $L(BLRCPTS,";")=2 S BLRCPTS=$P(BLRCPTS,";",1)
I $E(BLRCPTS,$L(BLRCPTS))=";" S BLRCPTS=$E(BLRCPTS,$L(BLRCPTS))
Q
;
BLRTNM1 ; IHS/HQT/MJL - SET IHS LAB TRANSACTION LOG - MICRO ; 14 Jun 2010 9:55 AM
+1 ;;5.2;IHS LABORATORY;**1010,1018,1028,1030**;NOV 01, 1997
+2 ;;
+3 ;
+4 IF $GET(SNAPSHOT)
DO ENTRYAUD^BLRUTIL("ENTER ^BLRTNM1")
+5 SET BLRCMF="C"
+6 ; IHS/OIT/MKK - LR*5.2*1028 -- If no Data, skip. PIMC correction.
IF $DATA(^LRO(69,BLRODT,1,BLRSEQ,0))<1
QUIT
+7 ; S BLRVAL=^LRO(69,BLRODT,1,BLRSEQ,0),BLRLRDFN=$P(BLRVAL,U,1),BLRODTM=$P(BLRVAL,U,5)
+8 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030 -- Naked Reference Issue
+9 SET BLRVAL=$GET(^LRO(69,BLRODT,1,BLRSEQ,0))
+10 SET BLRLRDFN=$PIECE(BLRVAL,U,1)
+11 SET BLRODTM=$PIECE(BLRVAL,U,5)
+12 ; ----- END IHS/OIT/MKK -- LR*5.2*1030
+13 SET BLRDUZ=$PIECE(BLRVAL,U,2)
SET BLRDUZ2=DUZ(2)
+14 SET BLRDTC=$PIECE(BLRVAL,U,8)
SET BLRLOCN=$PIECE(BLRVAL,U,7)
+15 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=""
+16 SET BLRCLNC=""
IF BLRLOC'=""
SET BLRCLNC=$PIECE(^SC(BLRLOC,0),U,7)
+17 ;S BLRCAT="A" I $L($G(^DPT(BLRLRDFN,.1))) S BLRCAT="I"
+18 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+19 SET BLRCAT="A"
SET X=$$GET1^DIQ(2,BLRLRDFN,.103)
IF X]""
IF X'["OBSERVATION"
SET BLRCAT="I"
+20 ;----- END IHS MODIFICATIONS MOD SUGGESTED BY LINDA FELS
+21 SET BLRPROV=$PIECE(BLRVAL,U,6)
+22 SET BLRDFN=$PIECE(^LR(BLRLRDFN,0),U,3)
SET BLRFILE=$PIECE(^LR(BLRLRDFN,0),U,2)
SET BLRODTM=$GET(BLRODTM)
+23 SET BLR("SEQUENCE NUMBER")=$$GETIEN
+24 SET BLR("LRFILE")=BLRFILE
SET BLR("LRDFN")=BLRLRDFN
SET BLR("PATIENT POINTER VALUE")=BLRDFN
SET BLR("ORDERING PROVIDER POINTER")=BLRPROV
SET BLR("VERIFIER POINTER")=BLRDUZ
+25 SET BLR("ORDER DATE")=$PIECE(BLRVAL,U,5)
SET BLR("ORDER SEQ. NUMBER")=BLRSEQ
SET BLR("ORDER NUMBER")=^LRO(69,BLRODT,1,BLRSEQ,.1)
+26 DO NOW^%DTC
SET BLR("ENTRY DATE/TIME")=%
+27 SET BLR("COLLECTION DATE/TIME")=BLRDTC
SET BLR("CLINIC STOP CODE POINTER")=BLRCLNC
+28 SET BLR("ORDERING LOCATION POINTER")=BLRLOC
SET BLR("DUZ(2)")=BLRDUZ2
SET BLR("I/O CATEGORY")=BLRCAT
SET BLR("ACCESSION NUMBER")=BLRACCN
SET BLR("COLLECTION SAMPLE POINTER")=BLRCOLSP
+29 SET BLRLEV=1
SET BLRTEST1=BLRTEST
SET BLRLEV(1)=BLRTEST
SET BLRLEV(1,1)=""
SET BLRATOM=1
+30 IF BLR60F
IF 'BLRSETP
SET BLRPAR=""
+31 DO SET3
IF BLR60F
FOR
DO SET2
IF 'BLRLEV
QUIT
+32 KILL BLR,BLRLEV
IF BLR60F
IF 'BLRSETP
KILL BLRPAR
+33 QUIT
+34 ;
SET2 ;
+1 IF $GET(SNAPSHOT)
DO ENTRYAUD^BLRUTIL("ENTER SET2^BLRTNM1")
+2 SET BLRATOM=$ORDER(^LAB(60,BLRLEV(BLRLEV),2,0))=""
IF BLRATOM
IF BLRLEV=1
SET BLRLEV=0
QUIT
+3 IF 'BLRATOM
SET BLRLEV=BLRLEV+1
SET BLRLEV(BLRLEV,0)=$ORDER(^LAB(60,BLRLEV(BLRLEV-1),2,$GET(BLRLEV(BLRLEV,0),0)))
+4 IF BLRLEV(BLRLEV,0)
SET BLRTEST1=+^LAB(60,BLRLEV(BLRLEV-1),2,$GET(BLRLEV(BLRLEV,0),0),0)
SET BLRLEV(BLRLEV)=BLRTEST1
DO SET3
QUIT
+5 SET BLRLEV(BLRLEV,0)=0
SET BLRLEV=BLRLEV-2
+6 QUIT
+7 ;
SET3 ;
+1 IF $GET(SNAPSHOT)
DO ENTRYAUD^BLRUTIL("ENTER SET3^BLRTNM1")
+2 SET BLRMOD="MI"
+3 IF BLR60F
SET BLRL60=^LAB(60,BLRTEST1,0)
SET BLRMOD=$PIECE(BLRL60,U,4)
SET BLRCST=$PIECE(BLRL60,U,11)
+4 SET BLR("LAB MODULE")=BLRMOD
+5 ;S (BLRXII,BLRCPTS,BLRCPTP)="" F S BLRFOUND=0,BLRXII=$O(^BLRCPT("C",BLRTEST1,BLRXII)) Q:(BLRXII=""!(BLRFOUND)) S BLRCPTF=$P(^BLRCPT(BLRXII,1),U,2) Q:BLRCPTF D GETCPT Q
+6 IF BLRLEV=1
DO CPTCODE^BLRTN
+7 SET BLRSPEC=$GET(LRSPEC)
IF BLRSPEC'=""
DO SET4
+8 IF BLR60F
Begin DoDot:1
+9 SET BLR("CPT LAB CODE POINTER")=BLRCPTP
SET BLR("CPT CODE")=BLRCPTS
SET BLR("PANEL/TEST POINTER")=BLRTEST1
SET BLR("PANEL/TEST NAME")=BLRTESTN
SET BLR("LAB TEST LIST COST")=BLRCST
SET BLR("RESULT")=BLRRES
IF BLRCMTS'=""
SET BLR("COMMENTS")=BLRCMTS
End DoDot:1
+10 IF 'BLR60F
Begin DoDot:1
+11 SET BLR("PARENT POINTER")=BLRPAR
SET BLR("CPT LAB CODE POINTER")=BLRCPTP
SET BLR("CPT CODE")=BLRCPTS
SET BLR("RESULT")=BLRRES
SET BLR("ORGANISM")=BLRORG
SET BLR("PANEL/TEST POINTER")=BLRCULT
+12 IF BLRSPT'=6
IF BLRANTP'=""
SET BLR("ANTIBIOTIC")=BLRANTP
SET BLR("ANTIBIOTIC NAME")=BLRANTN
SET BLR("PCC ERROR FLAG")=BLRERFS
+13 IF BLRSTGN'=""
SET BLR("STAGE NAME")=BLRSTGN
+14 IF BLRSTG'=""
SET BLR("STAGE COUNTER")=BLRSTG
QUIT
End DoDot:1
+15 IF BLR60F
SET BLR("PARENT POINTER")=BLRLEV(BLRLEV,1)
IF 'BLRATOM
SET BLRPAR=BLR("SEQUENCE NUMBER")
+16 IF +BLRCMPD
SET BLR("COMPLETE DATE")=BLRCMPD
+17 DO ^BLRNFLTL
+18 IF 'BLRATOM
SET BLRLEV(BLRLEV+1,1)=BLRPAR
+19 SET BLRCMTS=""
+20 QUIT
+21 ;
SET4 ;
+1 IF $GET(SNAPSHOT)
DO ENTRYAUD^BLRUTIL("ENTER SET4^BLRTNM1")
+2 SET BLRZ=$GET(^LAB(60,BLRTEST1,1,BLRSPEC,0))
SET BLRUNITS=$PIECE($PIECE(BLRZ,U,7)," ",1)
+3 ;[LR*5.2*1028;08/20/10;IHS/OIT/MPW]Added next 1 line
+4 IF BLRUNITS?1N.N
IF $DATA(^BLRUCUM(BLRUNITS,0))
SET BLRUNITS=$PIECE($GET(^BLRUCUM(BLRUNITS,0)),U,1)
+5 SET BLR("UNITS")=BLRUNITS
SET BLR("SITE/SPECIMEN POINTER")=BLRSPEC
+6 QUIT
+7 ;
GETIEN() ;
+1 IF $GET(SNAPSHOT)
DO ENTRYAUD^BLRUTIL("ENTER GETIEN^BLRTNM1")
+2 IF BLRCMF="C"
DO GETNEW
QUIT BLRENT
+3 Begin DoDot:1
+4 SET BLRCRGL="^BLRTXLOG("_BLRCRSBS_")"
SET BLRENT=$ORDER(@BLRCRGL@(""),BLRDIR)
+5 IF 'BLRENT
SET BLRERR=1
+6 IF BLRENT
IF BLROKCK'=""
DO @BLROKCK
+7 IF 'BLRERR
IF BLRBADCK'=""
DO @BLRBADCK
+8 IF BLRERR
DO EMSG
QUIT
+9 SET BLRIEN=BLRENT_","
QUIT
End DoDot:1
+10 QUIT BLRENT
+11 ;
GETNEW ;
+1 IF $GET(SNAPSHOT)
DO ENTRYAUD^BLRUTIL("ENTER GETNEW^BLRTNM1")
+2 SET BLRENT=$GET(^BLRTXLOG("SEQ"))
+3 IF 'BLRENT
SET BLRENT=$ORDER(^BLRTXLOG("@"),-1)
IF BLRENT
IF '$DATA(^BLRTXLOG(1))
SET BLRENT=0
+4 FOR BLRENT=BLRENT+1:1
IF '$DATA(^BLRTXLOG(BLRENT))
QUIT
+5 SET BLRENTS="BLRENTS"
SET BLRENTS(1)=BLRENT
SET ^BLRTXLOG("SEQ")=BLRENT
SET BLRIEN="+1,"
+6 QUIT
+7 ;
CHKDT ;
+1 IF $GET(SNAPSHOT)
DO ENTRYAUD^BLRUTIL("ENTER CHKDT^BLRTNM1")
+2 SET BLRCDT=$PIECE(^BLRTXLOG(BLRENT,12),U)
+3 IF $EXTRACT(BLRCDT,1,3)=$EXTRACT(DT,1,3)
QUIT
+4 ;MORE THAN 1 YEAR AHEAD
IF ($EXTRACT(BLRCDT,1,3)+1)'=$EXTRACT(DT,1,3)
SET BLRERR=1
SET BLRDTER=1
QUIT
+5 IF $EXTRACT(BLRCDT,4,5)<11
SET BLRERR=1
SET BLRDTER=1
QUIT
+6 QUIT
+7 ;
EMSG ;
+1 ; Log an error because the crossreference isn't set.
+2 IF 'BLRENT
Begin DoDot:1
+3 SET BLRERR=1
SET BLRERROR(1)="Something wrong -- problem with IHS Lab Transaction Log Cross Reference: "_BLRCRGL
End DoDot:1
+4 QUIT
+5 ;
+6 ;
GETCPT ;
+1 IF $GET(SNAPSHOT)
DO ENTRYAUD^BLRUTIL("ENTER GETCPT^BLRTNM1")
+2 SET BLRFOUND=1
+3 SET BLRCPTP=BLRXII
+4 SET (BLRCPTS,BLRCPTC)=""
FOR
SET BLRCPTC=$ORDER(^BLRCPT(BLRXII,11,"B",BLRCPTC))
IF BLRCPTC=""
QUIT
SET BLRCPTS=BLRCPTS_BLRCPTC_";"
+5 IF $LENGTH(BLRCPTS,";")=2
SET BLRCPTS=$PIECE(BLRCPTS,";",1)
+6 IF $EXTRACT(BLRCPTS,$LENGTH(BLRCPTS))=";"
SET BLRCPTS=$EXTRACT(BLRCPTS,$LENGTH(BLRCPTS))
+7 QUIT
+8 ;
