BLRMLTL1 ; IHS/DIR/FJE - SET IHS LAB TRANSACTION LOG - MICRO ; [ 04/13/98 1:11 PM ]
;;5.2T9;LR;**1018**;Nov 17, 2004
;;5.2;BLR;**1001**;Jun 16, 1998
;
S BLRODT=LRODT,BLRSEQ=LRSN
S BLRVAL=^LRO(69,BLRODT,1,BLRSEQ,0),BLRLRDFN=$P(BLRVAL,U,1),BLRODTM=$P(BLRVAL,U,5)
S BLRDUZ=$P(BLRVAL,U,2),BLRDUZ2=DUZ(2)
S BLRDUZN=$S($D(^VA(200,BLRDUZ,0)):$P(^(0),U,1),1:"UNK"_BLRDUZ)
S BLRDTC=$P($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:+BLRPROV>0 BLRPROVN=$P(^VA(200,$P(BLRVAL,U,6),0),U,1) S:BLRPROVN="" BLRPROVN="Unknown Provider"
S BLRDFN=$P(^LR(BLRLRDFN,0),U,3),BLRFILE=$P(^LR(BLRLRDFN,0),U,2),BLRODTM=$G(BLRODTM)
S BLRSTR="SEQUENCE NUMBER_$$GETIEN(BLRODTM,BLRSEQ,BLRTEST1)~STATUS FLAG_BLRPHASE~LAB MODULE_""MI""~"
S BLRSTR=BLRSTR_"LRFILE_BLRFILE~LRDFN_BLRLRDFN~PATIENT POINTER VALUE_BLRDFN~ORDERING PROVIDER POINTER_BLRPROV~VERIFIER POINTER_BLRDUZ~"
S BLRSTR=BLRSTR_"ORDER DATE_$P(BLRVAL,U,5)~ORDER SEQ. NUMBER_BLRSEQ~ORDERING PROVIDER NAME_BLRPROVN~ORDER NUMBER_^LRO(69,BLRODT,1,BLRSEQ,.1)~"
S BLRSTR=BLRSTR_"COLLECTION DATE/TIME_BLRDTC~VERIFIER NAME_BLRDUZN~ORDERING LOCATION NAME_BLRLOCN~ENTRY DATE/TIME_BLR(""ORDER DATE"")~CLINIC STOP CODE POINTER_BLRCLNC~"
;S BLRSTR=BLRSTR_"ORDERING LOCATION POINTER_BLRLOC~DUZ(2)_BLRDUZ2~I/O CATEGORY_BLRCAT~ACCESSION NUMBER_BLRACCN~"
S BLRSTR=BLRSTR_"ORDERING LOCATION POINTER_BLRLOC~DUZ(2)_BLRDUZ2~I/O CATEGORY_BLRCAT~ACCESSION NUMBER_BLRACCN~COLLECTION SAMPLE POINTER_BLRCOLSP~" ;IHS/DIR TUC/AAB 04/09/98
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 BLRLEV I BLR60F,'BLRSETP K BLRPAR
Q
;
SET2 ;
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 ;
I BLR60F S BLRL60=^LAB(60,BLRTEST1,0),BLRCST=$P(BLRL60,U,11)
;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^BLRSLTL1
S BLRSTR1=""
S BLRSPEC=$G(LRSPEC) D:BLRSPEC'="" SET4
D:BLR60F
.S BLRSTR1=BLRSTR1_"CPT LAB CODE POINTER_BLRCPTP~CPT CODE_BLRCPTS~PANEL/TEST POINTER_BLRTEST1~PANEL/TEST NAME_BLRTESTN~LAB TEST LIST COST_BLRCST~RESULT_BLRRES" S:BLRCMTS'="" BLRSTR1=BLRSTR1_"~COMMENTS_BLRCMTS"
I 'BLR60F D
.S BLRSTR1=BLRSTR1_"PARENT POINTER_BLRPAR~CPT LAB CODE POINTER_BLRCPTP~CPT CODE_BLRCPTS~RESULT_BLRRES~ORGANISM_BLRORG~PANEL/TEST POINTER_BLRCULT"
.I BLRSPT'=6,BLRANTP'="" S BLRSTR1=BLRSTR1_"~ANTIBIOTIC_BLRANTP~ANTIBIOTIC NAME_BLRANTN~PCC ERROR FLAG_BLRERFS" Q
.S:BLRSTGN'="" BLRSTR1=BLRSTR1_"~STAGE NAME_BLRSTGN"
.S:BLRSTG'="" BLRSTR1=BLRSTR1_"~STAGE COUNTER_BLRSTG" Q
I BLR60F S:BLRLEV(BLRLEV,1)'="" BLRPAR=BLRLEV(BLRLEV,1) S:BLRPAR'="" BLRSTR1=BLRSTR1_"~PARENT POINTER_BLRPAR" S:'BLRATOM BLRSTR1=BLRSTR1_"~@BLRPAR_BLR(""SEQUENCE NUMBER"")"
S:+BLRCMPD BLRSTR1=BLRSTR1_"~COMPLETE DATE_BLRCMPD"
D ^BLRFLTL("C",BLRSTR_BLRSTR1)
I 'BLRATOM S BLRLEV(BLRLEV+1,1)=BLRPAR
S BLRCMTS=""
Q
;
SET4 ;
S BLRZ=$G(^LAB(60,BLRTEST1,1,BLRSPEC,0)),BLRUNITS=$P($P(BLRZ,U,7)," ",1)
S BLRSTR1="UNITS_BLRUNITS~SITE/SPECIMEN POINTER_BLRSPEC~"
Q
;
GETCPT ;
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
BLRMLTL1 ; IHS/DIR/FJE - SET IHS LAB TRANSACTION LOG - MICRO ; [ 04/13/98 1:11 PM ]
+1 ;;5.2T9;LR;**1018**;Nov 17, 2004
+2 ;;5.2;BLR;**1001**;Jun 16, 1998
+3 ;
+4 SET BLRODT=LRODT
SET BLRSEQ=LRSN
+5 SET BLRVAL=^LRO(69,BLRODT,1,BLRSEQ,0)
SET BLRLRDFN=$PIECE(BLRVAL,U,1)
SET BLRODTM=$PIECE(BLRVAL,U,5)
+6 SET BLRDUZ=$PIECE(BLRVAL,U,2)
SET BLRDUZ2=DUZ(2)
+7 SET BLRDUZN=$SELECT($DATA(^VA(200,BLRDUZ,0)):$PIECE(^(0),U,1),1:"UNK"_BLRDUZ)
+8 SET BLRDTC=$PIECE($PIECE(BLRVAL,U,8),".")
SET BLRLOCN=$PIECE(BLRVAL,U,7)
+9 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=""
+10 SET BLRCLNC=""
IF BLRLOC'=""
SET BLRCLNC=$PIECE(^SC(BLRLOC,0),U,7)
+11 ;S BLRCAT="A" I $L($G(^DPT(BLRLRDFN,.1))) S BLRCAT="I"
+12 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+13 SET BLRCAT="A"
SET X=$$GET1^DIQ(2,BLRLRDFN,.103)
IF X]""
IF X'["OBSERVATION"
SET BLRCAT="I"
+14 ;----- END IHS MODIFICATIONS MOD SUGGESTED BY LINDA FELS
+15 SET BLRPROV=$PIECE(BLRVAL,U,6)
IF +BLRPROV>0
SET BLRPROVN=$PIECE(^VA(200,$PIECE(BLRVAL,U,6),0),U,1)
IF BLRPROVN=""
SET BLRPROVN="Unknown Provider"
+16 SET BLRDFN=$PIECE(^LR(BLRLRDFN,0),U,3)
SET BLRFILE=$PIECE(^LR(BLRLRDFN,0),U,2)
SET BLRODTM=$GET(BLRODTM)
+17 SET BLRSTR="SEQUENCE NUMBER_$$GETIEN(BLRODTM,BLRSEQ,BLRTEST1)~STATUS FLAG_BLRPHASE~LAB MODULE_""MI""~"
+18 SET BLRSTR=BLRSTR_"LRFILE_BLRFILE~LRDFN_BLRLRDFN~PATIENT POINTER VALUE_BLRDFN~ORDERING PROVIDER POINTER_BLRPROV~VERIFIER POINTER_BLRDUZ~"
+19 SET BLRSTR=BLRSTR_"ORDER DATE_$P(BLRVAL,U,5)~ORDER SEQ. NUMBER_BLRSEQ~ORDERING PROVIDER NAME_BLRPROVN~ORDER NUMBER_^LRO(69,BLRODT,1,BLRSEQ,.1)~"
+20 SET BLRSTR=BLRSTR_"COLLECTION DATE/TIME_BLRDTC~VERIFIER NAME_BLRDUZN~ORDERING LOCATION NAME_BLRLOCN~ENTRY DATE/TIME_BLR(""ORDER DATE"")~CLINIC STOP CODE POINTER_BLRCLNC~"
+21 ;S BLRSTR=BLRSTR_"ORDERING LOCATION POINTER_BLRLOC~DUZ(2)_BLRDUZ2~I/O CATEGORY_BLRCAT~ACCESSION NUMBER_BLRACCN~"
+22 ;IHS/DIR TUC/AAB 04/09/98
SET BLRSTR=BLRSTR_"ORDERING LOCATION POINTER_BLRLOC~DUZ(2)_BLRDUZ2~I/O CATEGORY_BLRCAT~ACCESSION NUMBER_BLRACCN~COLLECTION SAMPLE POINTER_BLRCOLSP~"
+23 SET BLRLEV=1
SET BLRTEST1=BLRTEST
SET BLRLEV(1)=BLRTEST
SET BLRLEV(1,1)=""
SET BLRATOM=1
+24 IF BLR60F
IF 'BLRSETP
SET BLRPAR=""
+25 DO SET3
IF BLR60F
FOR
DO SET2
IF 'BLRLEV
QUIT
+26 KILL BLRLEV
IF BLR60F
IF 'BLRSETP
KILL BLRPAR
+27 QUIT
+28 ;
SET2 ;
+1 SET BLRATOM=$ORDER(^LAB(60,BLRLEV(BLRLEV),2,0))=""
IF BLRATOM
IF BLRLEV=1
SET BLRLEV=0
QUIT
+2 IF 'BLRATOM
SET BLRLEV=BLRLEV+1
SET BLRLEV(BLRLEV,0)=$ORDER(^LAB(60,BLRLEV(BLRLEV-1),2,$GET(BLRLEV(BLRLEV,0),0)))
+3 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
+4 SET BLRLEV(BLRLEV,0)=0
SET BLRLEV=BLRLEV-2
+5 QUIT
+6 ;
SET3 ;
+1 IF BLR60F
SET BLRL60=^LAB(60,BLRTEST1,0)
SET BLRCST=$PIECE(BLRL60,U,11)
+2 ;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
+3 IF BLRLEV=1
DO CPTCODE^BLRSLTL1
+4 SET BLRSTR1=""
+5 SET BLRSPEC=$GET(LRSPEC)
IF BLRSPEC'=""
DO SET4
+6 IF BLR60F
Begin DoDot:1
+7 SET BLRSTR1=BLRSTR1_"CPT LAB CODE POINTER_BLRCPTP~CPT CODE_BLRCPTS~PANEL/TEST POINTER_BLRTEST1~PANEL/TEST NAME_BLRTESTN~LAB TEST LIST COST_BLRCST~RESULT_BLRRES"
IF BLRCMTS'=""
SET BLRSTR1=BLRSTR1_"~COMMENTS_BLRCMTS"
End DoDot:1
+8 IF 'BLR60F
Begin DoDot:1
+9 SET BLRSTR1=BLRSTR1_"PARENT POINTER_BLRPAR~CPT LAB CODE POINTER_BLRCPTP~CPT CODE_BLRCPTS~RESULT_BLRRES~ORGANISM_BLRORG~PANEL/TEST POINTER_BLRCULT"
+10 IF BLRSPT'=6
IF BLRANTP'=""
SET BLRSTR1=BLRSTR1_"~ANTIBIOTIC_BLRANTP~ANTIBIOTIC NAME_BLRANTN~PCC ERROR FLAG_BLRERFS"
QUIT
+11 IF BLRSTGN'=""
SET BLRSTR1=BLRSTR1_"~STAGE NAME_BLRSTGN"
+12 IF BLRSTG'=""
SET BLRSTR1=BLRSTR1_"~STAGE COUNTER_BLRSTG"
QUIT
End DoDot:1
+13 IF BLR60F
IF BLRLEV(BLRLEV,1)'=""
SET BLRPAR=BLRLEV(BLRLEV,1)
IF BLRPAR'=""
SET BLRSTR1=BLRSTR1_"~PARENT POINTER_BLRPAR"
IF 'BLRATOM
SET BLRSTR1=BLRSTR1_"~@BLRPAR_BLR(""SEQUENCE NUMBER"")"
+14 IF +BLRCMPD
SET BLRSTR1=BLRSTR1_"~COMPLETE DATE_BLRCMPD"
+15 DO ^BLRFLTL("C",BLRSTR_BLRSTR1)
+16 IF 'BLRATOM
SET BLRLEV(BLRLEV+1,1)=BLRPAR
+17 SET BLRCMTS=""
+18 QUIT
+19 ;
SET4 ;
+1 SET BLRZ=$GET(^LAB(60,BLRTEST1,1,BLRSPEC,0))
SET BLRUNITS=$PIECE($PIECE(BLRZ,U,7)," ",1)
+2 SET BLRSTR1="UNITS_BLRUNITS~SITE/SPECIMEN POINTER_BLRSPEC~"
+3 QUIT
+4 ;
GETCPT ;
+1 SET BLRFOUND=1
+2 SET BLRCPTP=BLRXII
+3 SET (BLRCPTS,BLRCPTC)=""
FOR
SET BLRCPTC=$ORDER(^BLRCPT(BLRXII,11,"B",BLRCPTC))
IF BLRCPTC=""
QUIT
SET BLRCPTS=BLRCPTS_BLRCPTC_";"
+4 IF $LENGTH(BLRCPTS,";")=2
SET BLRCPTS=$PIECE(BLRCPTS,";",1)
+5 IF $EXTRACT(BLRCPTS,$LENGTH(BLRCPTS))=";"
SET BLRCPTS=$EXTRACT(BLRCPTS,$LENGTH(BLRCPTS))
+6 QUIT
