Routine: BPCLIPL

BPCLIPL ; IHS/OIT/MJL - GUI PROVIDER PAT LIST FOR LAB DATA ;

 ;;1.5;BPC;;MAY 26, 2005

 ;GETS LIST OF INITIAL PATIENTS FROM LAB OPT

 ;    EDIT/DISP....LAB LISTS MENU

 ;    ADDS TODAY'S PATIENTS WHO HAVE LABS

 ;GETS TODAYS LABS FOR PROVIDER DUZ

TAG(BPCRES) ;EP REMOTE PROC: BPC GET INITIAL LAB LIST

STRT S U="^",XWBWRAP=1,BPCCTR=2,BPCSTAR="" K ^BGUTMP($J),^TMP($J) S BPCRES="^TMP("_$J_")"

 I '$D(DUZ) S ^TMP($J,1)=-1,^TMP($J,2)="NO USER (DUZ) DEFINED" D KILL Q

 D CLIN

 S BPCX="",BPCSTAR="  *L*" F  S BPCX=$O(^BGUTMP($J,"CLIN",BPCX)) Q:BPCX=""  D GETPDAT

 S BPCSTAR="" I $D(^LRO(69.2,1,7,DUZ,1,"C")) S BPCX=0 F  S BPCX=$O(^LRO(69.2,1,7,DUZ,1,"C",BPCX)) Q:BPCX=""  D GETPDAT

 S BPCX="" F  S BPCX=$O(^BGUTMP($J,"NAME",BPCX)) Q:BPCX=""  S ^TMP($J,BPCCTR)=^(BPCX),BPCCTR=BPCCTR+1

 S ^TMP($J,1)=$S(BPCCTR=2:0,1:BPCCTR-1)

 D KILL

KILL ;

 K BGUDOB,BPCCTR,BPCDAT,BPCDFN,BPCDOB,BPCEDT,BPCHRCN,BPCIDT,BPCIEN,BPCL0,BPCLOC,BPCNA,BPCP,BPCDFN,BPCPDT,BPCPNM,BPCPRVN,BPCPRVNA,BPCR1,BPCRANGE,BPCRHIGH,BPCRL0W,BPCRLOW,BPCSDT,BPCSEX,BPCSPEC,BPCSR,BPCSSN

 K BPCSTAR,BPCT,BPCTIME,BPCTX,BPCUNITS,BPCX,BPCY,BPCDFN,BPCI,BPCLRDFN,BPCLRDPF,Y

GETPDAT ;

 S BPCIEN=$O(^DPT("B",BPCX,"")),BGUDOB="",BPCSSN="" Q:'$L(BPCIEN)

 S BPCDAT=^DPT(BPCIEN,0),BGUDOB=$P(BPCDAT,U,3),BPCSSN=$P(BPCDAT,U,9),BPCSEX=$P(BPCDAT,U,2)

 S Y=BGUDOB D DD^%DT S BGUDOB=Y

 S BPCHRCN=$P($G(^AUPNPAT(BPCIEN,41,DUZ(2),0)),U,2)

 I $L(BPCSTAR),$D(^BGUTMP($J,"CLIN",BPCX)) S ^BGUTMP($J,"NAME",BPCX)="IPL"_U_BPCX_BPCSTAR_U_BPCIEN_U_BGUDOB_U_BPCSSN_U_BPCHRCN_U_U_BPCSEX

 I '$D(^BGUTMP($J,"NAME",BPCX)) S ^BGUTMP($J,"NAME",BPCX)="IPL"_U_BPCX_BPCSTAR_U_BPCIEN_U_BGUDOB_U_BPCSSN_U_BPCHRCN_U_U_BPCSEX

 K BPCIEN,BGUDOB,BPCSSN,BPCDAT

CLIN ;GETS TODAYS LAB DATA FOR DUZ

 I '$P($G(^VA(200,DUZ,0)),U,16) Q

 S BPCNA=$P(^VA(200,DUZ,0),U,1)

 S BPCDFN=DUZ

 S BPCSDT=DT,BPCEDT=DT

 F BPCPDT=BPCEDT-.01:0 S BPCPDT=$O(^LRO(69,BPCPDT)) Q:BPCPDT<BPCEDT!(BPCPDT>BPCSDT)  D LOC

LOC S BPCLOC="" F  S BPCLOC=$O(^LRO(69,BPCPDT,1,"AN",BPCLOC)) Q:BPCLOC=""  D PT

PT S BPCP="" F BPCLRDFN=0:0 S BPCLRDFN=$O(^LRO(69,BPCPDT,1,"AN",BPCLOC,BPCLRDFN)) Q:BPCLRDFN<1  D SETPRV D:(BPCDFN=BPCPRVN) IDT

IDT F BPCIDT=0:0 S BPCIDT=$O(^LRO(69,BPCPDT,1,"AN",BPCLOC,BPCLRDFN,BPCIDT)) Q:BPCIDT<1  D LOOK

LOOK K BPCT S BPCL0=$S($D(^LR(BPCLRDFN,"CH",BPCIDT,0)):^(0),1:"") Q:BPCL0=""

 S BPCT=0 F BPCI=1:0 S BPCI=$O(^LR(BPCLRDFN,"CH",BPCIDT,BPCI)) Q:BPCI<1  S BPCT=BPCT+1,BPCT(BPCI)=^(BPCI) ;FOR ABN PUT I $P(^(BPCI),U,2)'="" BEFORE S BPCT=BPCT+1

 D GUI:BPCT

SETPRV S BPCPRVN=""

 F  S BPCP=$O(^LRO(69,BPCPDT,1,"AA",BPCLRDFN,BPCP)) Q:BPCP=""  D C1

C1 S BPCPRVN=$P(^LRO(69,BPCPDT,1,BPCP,0),"^",6)

 S BPCPRVNA=$P($G(^VA(200,BPCPRVN,0)),"^",1)

SETUPDT I '$D(BPCL0) S BPCY="" Q

 S Y=$P(BPCL0,"^",1)

 I '$D(Y)!(Y="") S BPCY="" Q

 S BPCY=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_" "

 X ^DD("DD")

 S BPCTIME=$P(Y,"@",2),BPCY=BPCY_$E(BPCTIME,1,2)_":"_$E(BPCTIME,4,5)

SETRANGE S BPCRL0W="",BPCRHIGH="" I '$D(BPCL0) Q

 I '$D(BPCTX) Q

 S BPCR1=$P(BPCL0,"^",5)

 I '$D(^LAB(60,BPCTX,1,BPCR1,0)) Q

 S BPCRANGE=^LAB(60,BPCTX,1,BPCR1,0)

 ; NEED TO PICK UP TEST UNITS AND SPECIMEN.

 S BPCUNITS=$P(BPCRANGE,U,7),BPCSR=$S(BPCR1=72:70,BPCR1=73:70,1:BPCR1),BPCSPEC=$P(^LAB(61,BPCSR,0),U,1)

 I BPCRANGE["$S" S BPCX="S BPCRLOW="_$P(BPCRANGE,"^",2) X BPCX S BPCX="S BPCRHIGH="_$P(BPCRANGE,"^",3) X BPCX Q

 S BPCRLOW=$P(BPCRANGE,"^",2),BPCRHIGH=$P(BPCRANGE,"^",3)

GUI D SETUPDT S LRDFN=BPCLRDFN,BPCX=^LR(BPCLRDFN,0),BPCLRDPF=$P(BPCX,U,2),BPCDFN=$P(BPCX,U,3) D PT^LRX S BPCHRCN=$G(HRCN),BPCPNM=$G(PNM) Q:'$L(BPCPNM)

 S BPCX=^DPT(BPCDFN,0),BPCDOB=$P(BPCX,U,3),BPCSSN=$P(BPCX,U,9)

 S (^TMP($J,BPCCTR),^BGUTMP($J,"CLIN",BPCPNM))="CLIN"_U_"NAME"_U_BPCPNM_U_BPCHRCN_U_$S($D(^DPT(BPCDFN,.1)):^(.1),1:BPCLOC)_U_$P(BPCL0,U,6)_U_BPCY_U_BPCDOB_U_BPCSSN,BPCCTR=BPCCTR+1

 S BPCI=0 F  S BPCI=$O(BPCT(BPCI)) Q:BPCI<1  S BPCTX=$O(^LAB(60,"C","CH;"_BPCI_";1",0)) I BPCTX>0 S ^TMP($J,BPCCTR)="CLIN"_U_"TEST"_U_$P(^LAB(60,BPCTX,0),U,1)_U_$P(BPCT(BPCI),U,1)_U_$P(BPCT(BPCI),U,2) D

 .D SETRANGE S ^TMP($J,BPCCTR)=^TMP($J,BPCCTR)_U_BPCRLOW_U_BPCRHIGH_U_BPCUNITS_U_BPCSPEC S BPCCTR=BPCCTR+1

 K BGUDOB,BGUSSN

BPCLIPL   ; IHS/OIT/MJL - GUI PROVIDER PAT LIST FOR LAB DATA ;

 +1       ;;1.5;BPC;;MAY 26, 2005

 +2       ;GETS LIST OF INITIAL PATIENTS FROM LAB OPT

 +3       ;    EDIT/DISP....LAB LISTS MENU

 +4       ;    ADDS TODAY'S PATIENTS WHO HAVE LABS

 +5       ;GETS TODAYS LABS FOR PROVIDER DUZ

TAG(BPCRES) ;EP REMOTE PROC: BPC GET INITIAL LAB LIST

STRT       SET U="^"

           SET XWBWRAP=1

           SET BPCCTR=2

           SET BPCSTAR=""

           KILL ^BGUTMP($JOB),^TMP($JOB)

           SET BPCRES="^TMP("_$JOB_")"

 +1        IF '$DATA(DUZ)

               SET ^TMP($JOB,1)=-1

               SET ^TMP($JOB,2)="NO USER (DUZ) DEFINED"

               DO KILL

               QUIT

 +2        DO CLIN

 +3        SET BPCX=""

           SET BPCSTAR="  *L*"

FOR

               SET BPCX=$ORDER(^BGUTMP($JOB,"CLIN",BPCX))

               IF BPCX=""

                   QUIT

               DO GETPDAT

 +4        SET BPCSTAR=""

           IF $DATA(^LRO(69.2,1,7,DUZ,1,"C"))

               SET BPCX=0

FOR

                   SET BPCX=$ORDER(^LRO(69.2,1,7,DUZ,1,"C",BPCX))

                   IF BPCX=""

                       QUIT

                   DO GETPDAT

 +5        SET BPCX=""

FOR

               SET BPCX=$ORDER(^BGUTMP($JOB,"NAME",BPCX))

               IF BPCX=""

                   QUIT

               SET ^TMP($JOB,BPCCTR)=^(BPCX)

               SET BPCCTR=BPCCTR+1

 +6        SET ^TMP($JOB,1)=$SELECT(BPCCTR=2:0,1:BPCCTR-1)

 +7        DO KILL

 +8        QUIT

 +9       ;

KILL      ;

 +1        KILL BGUDOB,BPCCTR,BPCDAT,BPCDFN,BPCDOB,BPCEDT,BPCHRCN,BPCIDT,BPCIEN,BPCL0,BPCLOC,BPCNA,BPCP,BPCDFN,BPCPDT,BPCPNM,BPCPRVN,BPCPRVNA,BPCR1,BPCRANGE,BPCRHIGH,BPCRL0W,BPCRLOW,BPCSDT,BPCSEX,BPCSPEC,BPCSR,BPCSSN

 +2        KILL BPCSTAR,BPCT,BPCTIME,BPCTX,BPCUNITS,BPCX,BPCY,BPCDFN,BPCI,BPCLRDFN,BPCLRDPF,Y

 +3        QUIT

 +4       ;

GETPDAT   ;

 +1        SET BPCIEN=$ORDER(^DPT("B",BPCX,""))

           SET BGUDOB=""

           SET BPCSSN=""

           IF '$LENGTH(BPCIEN)

               QUIT

 +2        SET BPCDAT=^DPT(BPCIEN,0)

           SET BGUDOB=$PIECE(BPCDAT,U,3)

           SET BPCSSN=$PIECE(BPCDAT,U,9)

           SET BPCSEX=$PIECE(BPCDAT,U,2)

 +3        SET Y=BGUDOB

           DO DD^%DT

           SET BGUDOB=Y

 +4        SET BPCHRCN=$PIECE($GET(^AUPNPAT(BPCIEN,41,DUZ(2),0)),U,2)

 +5        IF $LENGTH(BPCSTAR)

               IF $DATA(^BGUTMP($JOB,"CLIN",BPCX))

                   SET ^BGUTMP($JOB,"NAME",BPCX)="IPL"_U_BPCX_BPCSTAR_U_BPCIEN_U_BGUDOB_U_BPCSSN_U_BPCHRCN_U_U_BPCSEX

 +6        IF '$DATA(^BGUTMP($JOB,"NAME",BPCX))

               SET ^BGUTMP($JOB,"NAME",BPCX)="IPL"_U_BPCX_BPCSTAR_U_BPCIEN_U_BGUDOB_U_BPCSSN_U_BPCHRCN_U_U_BPCSEX

 +7        KILL BPCIEN,BGUDOB,BPCSSN,BPCDAT

 +8        QUIT

 +9       ;

CLIN      ;GETS TODAYS LAB DATA FOR DUZ

 +1        IF '$PIECE($GET(^VA(200,DUZ,0)),U,16)

               QUIT

 +2        SET BPCNA=$PIECE(^VA(200,DUZ,0),U,1)

 +3        SET BPCDFN=DUZ

 +4        SET BPCSDT=DT

           SET BPCEDT=DT

 +5        FOR BPCPDT=BPCEDT-.01:0

               SET BPCPDT=$ORDER(^LRO(69,BPCPDT))

               IF BPCPDT<BPCEDT!(BPCPDT>BPCSDT)

                   QUIT

               DO LOC

 +6        QUIT

 +7       ;

LOC        SET BPCLOC=""

FOR

               SET BPCLOC=$ORDER(^LRO(69,BPCPDT,1,"AN",BPCLOC))

               IF BPCLOC=""

                   QUIT

               DO PT

 +1        QUIT

 +2       ;

PT         SET BPCP=""

           FOR BPCLRDFN=0:0

               SET BPCLRDFN=$ORDER(^LRO(69,BPCPDT,1,"AN",BPCLOC,BPCLRDFN))

               IF BPCLRDFN<1

                   QUIT

               DO SETPRV

               IF (BPCDFN=BPCPRVN)

                   DO IDT

 +1        QUIT

 +2       ;

IDT        FOR BPCIDT=0:0

               SET BPCIDT=$ORDER(^LRO(69,BPCPDT,1,"AN",BPCLOC,BPCLRDFN,BPCIDT))

               IF BPCIDT<1

                   QUIT

               DO LOOK

 +1        QUIT

 +2       ;

LOOK       KILL BPCT

           SET BPCL0=$SELECT($DATA(^LR(BPCLRDFN,"CH",BPCIDT,0)):^(0),1:"")

           IF BPCL0=""

               QUIT

 +1       ;FOR ABN PUT I $P(^(BPCI),U,2)'="" BEFORE S BPCT=BPCT+1

           SET BPCT=0

           FOR BPCI=1:0

               SET BPCI=$ORDER(^LR(BPCLRDFN,"CH",BPCIDT,BPCI))

               IF BPCI<1

                   QUIT

               SET BPCT=BPCT+1

               SET BPCT(BPCI)=^(BPCI)

 +2        IF BPCT

               DO GUI

 +3        QUIT

 +4       ;

SETPRV     SET BPCPRVN=""

 +1        FOR

               SET BPCP=$ORDER(^LRO(69,BPCPDT,1,"AA",BPCLRDFN,BPCP))

               IF BPCP=""

                   QUIT

               DO C1

 +2        QUIT

 +3       ;

C1         SET BPCPRVN=$PIECE(^LRO(69,BPCPDT,1,BPCP,0),"^",6)

 +1        SET BPCPRVNA=$PIECE($GET(^VA(200,BPCPRVN,0)),"^",1)

 +2        QUIT

 +3       ;

SETUPDT    IF '$DATA(BPCL0)

               SET BPCY=""

               QUIT

 +1        SET Y=$PIECE(BPCL0,"^",1)

 +2        IF '$DATA(Y)!(Y="")

               SET BPCY=""

               QUIT

 +3        SET BPCY=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)_" "

 +4        XECUTE ^DD("DD")

 +5        SET BPCTIME=$PIECE(Y,"@",2)

           SET BPCY=BPCY_$EXTRACT(BPCTIME,1,2)_":"_$EXTRACT(BPCTIME,4,5)

 +6        QUIT

 +7       ;

SETRANGE   SET BPCRL0W=""

           SET BPCRHIGH=""

           IF '$DATA(BPCL0)

               QUIT

 +1        IF '$DATA(BPCTX)

               QUIT

 +2        SET BPCR1=$PIECE(BPCL0,"^",5)

 +3        IF '$DATA(^LAB(60,BPCTX,1,BPCR1,0))

               QUIT

 +4        SET BPCRANGE=^LAB(60,BPCTX,1,BPCR1,0)

 +5       ; NEED TO PICK UP TEST UNITS AND SPECIMEN.

 +6        SET BPCUNITS=$PIECE(BPCRANGE,U,7)

           SET BPCSR=$SELECT(BPCR1=72:70,BPCR1=73:70,1:BPCR1)

           SET BPCSPEC=$PIECE(^LAB(61,BPCSR,0),U,1)

 +7        IF BPCRANGE["$S"

               SET BPCX="S BPCRLOW="_$PIECE(BPCRANGE,"^",2)

               XECUTE BPCX

               SET BPCX="S BPCRHIGH="_$PIECE(BPCRANGE,"^",3)

               XECUTE BPCX

               QUIT

 +8        SET BPCRLOW=$PIECE(BPCRANGE,"^",2)

           SET BPCRHIGH=$PIECE(BPCRANGE,"^",3)

 +9        QUIT

 +10      ;

GUI        DO SETUPDT

           SET LRDFN=BPCLRDFN

           SET BPCX=^LR(BPCLRDFN,0)

           SET BPCLRDPF=$PIECE(BPCX,U,2)

           SET BPCDFN=$PIECE(BPCX,U,3)

           DO PT^LRX

           SET BPCHRCN=$GET(HRCN)

           SET BPCPNM=$GET(PNM)

           IF '$LENGTH(BPCPNM)

               QUIT

 +1        SET BPCX=^DPT(BPCDFN,0)

           SET BPCDOB=$PIECE(BPCX,U,3)

           SET BPCSSN=$PIECE(BPCX,U,9)

 +2        SET (^TMP($JOB,BPCCTR),^BGUTMP($JOB,"CLIN",BPCPNM))="CLIN"_U_"NAME"_U_BPCPNM_U_BPCHRCN_U_$SELECT($DATA(^DPT(BPCDFN,.1)):^(.1),1:BPCLOC)_U_$PIECE(BPCL0,U,6)_U_BPCY_U_BPCDOB_U_BPCSSN

           SET BPCCTR=BPCCTR+1

 +3        SET BPCI=0

FOR

               SET BPCI=$ORDER(BPCT(BPCI))

               IF BPCI<1

                   QUIT

               SET BPCTX=$ORDER(^LAB(60,"C","CH;"_BPCI_";1",0))

               IF BPCTX>0

                   SET ^TMP($JOB,BPCCTR)="CLIN"_U_"TEST"_U_$PIECE(^LAB(60,BPCTX,0),U,1)_U_$PIECE(BPCT(BPCI),U,1)_U_$PIECE(BPCT(BPCI),U,2)

                   Begin DoDot:1

 +4                    DO SETRANGE

                       SET ^TMP($JOB,BPCCTR)=^TMP($JOB,BPCCTR)_U_BPCRLOW_U_BPCRHIGH_U_BPCUNITS_U_BPCSPEC

                       SET BPCCTR=BPCCTR+1

                   End DoDot:1

 +5        KILL BGUDOB,BGUSSN

 +6        QUIT

BPCLIPL.m