Routine: BLRMLTL1

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

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

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=""

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~"

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))

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

BLRMLTL1.m