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
Q
;
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
Q
;
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
Q
;
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
Q
;
LOC S BPCLOC="" F S BPCLOC=$O(^LRO(69,BPCPDT,1,"AN",BPCLOC)) Q:BPCLOC="" D PT
Q
;
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
Q
;
IDT F BPCIDT=0:0 S BPCIDT=$O(^LRO(69,BPCPDT,1,"AN",BPCLOC,BPCLRDFN,BPCIDT)) Q:BPCIDT<1 D LOOK
Q
;
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
Q
;
SETPRV S BPCPRVN=""
F S BPCP=$O(^LRO(69,BPCPDT,1,"AA",BPCLRDFN,BPCP)) Q:BPCP="" D C1
Q
;
C1 S BPCPRVN=$P(^LRO(69,BPCPDT,1,BPCP,0),"^",6)
S BPCPRVNA=$P($G(^VA(200,BPCPRVN,0)),"^",1)
Q
;
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)
Q
;
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)
Q
;
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
Q
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
