BPCSC1 ; IHS/OIT/MJL - SPECIAL X-REF ROUTINES - ; [ 04/14/2008 4:14 PM ]
;;1.5;BPC;**5**;FEB 16, 2005
;
; BGUBEGIN contains the Patient IEN
; BGUEND contains the following separated by "`"
; 1. Start Date (External format)
; 2. End Date (External format)
; 3. No of visits to view (ignored if View Option = 1)
; 4. Visits with labs only flag (0=No,1=Yes)
; 5. View Option (0=Last # of visits in dt rng,1=all visits in dt rng)
;
MED I '$D(BGUDRIVR) D Q
.S BGUDRIVR="MED^BPCSC1",BGUCRFS="",BPCPIEN=BGUBEGIN
.S BPCSDATE=$P(BGUEND,"`",1),BPCEDATE=$P(BGUEND,"`",2)
.S BPCVWNO=$P(BGUEND,"`",3),BPCLBONL=$P(BGUEND,"`",4)
.S BPCVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('BPCVWOPT:BPCVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:BPCPIEN=""
S BPCVWOPT="2"
D MED1
Q
;
MED1 ;
S:'(+BPCVWNO) BPCVWNO=10 S:BPCSDATE="" BPCSDATE="1/1/1980"
S:BPCEDATE="" BPCEDATE="T" S:BPCVWOPT="" BPCVWOPT="0"
S:BPCLBONL="" BPCLBONL="1"
D DT^DILF("",BPCSDATE,.BPCSDAT)
I BPCSDAT=-1 D
.S BPCSDATE="1/1/1980"
.D DT^DILF("",BPCSDATE,.BPCSDAT)
D DT^DILF("",BPCEDATE,.BPCEDAT)
I BPCEDAT=-1 D
.S BPCEDATE="T"
.D DT^DILF("",BPCEDATE,.BPCEDAT)
S BPCC=0,BPCX=0,BPCLIM=$S(BPCVWOPT="0":BPCVWNO,1:99999)
F S BPCX=$O(^AUPNVSIT("AA",BPCPIEN,BPCX)) Q:BPCX="" D Q:BPCC=BPCLIM
.S BPCVIEN=""
.F S BPCVIEN=$O(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN)) Q:BPCVIEN="" D Q:BPCC=BPCLIM
..S BPCDTA=^AUPNVSIT(BPCVIEN,0),BPCCKD=$P($P(BPCDTA,U,1),".",1)
..Q:BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
..S BPCC=BPCC+1,BPCPMIEN=0
..F S BPCPMIEN=$O(^AUPNVMED("AD",BPCVIEN,BPCPMIEN)) Q:BPCPMIEN="" D
...S BPCSTAT=-1
...I $D(^PSRX("APCC",BPCPMIEN)) D
....S BPCRXIEN=$O(^PSRX("APCC",BPCPMIEN,"")) Q:BPCRXIEN=""
....S BPCCK=$O(^PSRX("APCC",BPCPMIEN,BPCRXIEN,""))
....I BPCCK'="" S BPCSTAT=-1 Q
....S BPCSTAT=$P(^PSRX(BPCRXIEN,0),"^",15) S:BPCSTAT="" BPCSTAT=-1
....;I BPCSTAT=0 D MED2
...I BPCSTAT=0 S BGUSUB(1)=BPCPMIEN D FIELDS^BGULIST
Q
MED2 ;
N DYS,RFLS,ISUDAT,CKDT
S BPCSTAT=-1,BPCRX0=$G(^PSRX(BPCRXIEN,0)) Q:BPCRX0=""
S BPCRX2=$G(^PSRX(BPCRXIEN,2))
S DYS=$P(BPCRX0,U,8),RFLS=$P(BPCRX0,U,9),ISUDAT=$P(BPCRX0,U,13)
S X2=DYS*RFLS,X2=$S(DYS=X2:X2,X2<181:184,X2=360:366,1:X2)
D:ISUDAT'=""
.S X1=ISUDAT D C^%DTC S CKDT=$P(X,".",1)
.S X="T" D ^%DT I CKDT'<Y S BPCSTAT=0
Q
POV ; Get purpose of visits
;
I '$D(BGUDRIVR) D Q
.S BGUDRIVR="POV^BPCSC1",BGUCRFS="",BPCPIEN=BGUBEGIN
.S BPCSDATE=$P(BGUEND,"`",1),BPCEDATE=$P(BGUEND,"`",2)
.S BPCVWNO=$P(BGUEND,"`",3),BPCLBONL=$P(BGUEND,"`",4)
.S BPCVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('BPCVWOPT:BPCVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:BPCPIEN=""
S BPCVWOPT="2"
D POV1
Q
POV1 ;
S:'(+BPCVWNO) BPCVWNO=10 S:BPCSDATE="" BPCSDATE="1/1/1980"
S:BPCEDATE="" BPCEDATE="T" S:BPCVWOPT="" BPCVWOPT="0"
S:BPCLBONL="" BPCLBONL="1"
D DT^DILF("",BPCSDATE,.BPCSDAT)
I BPCSDAT=-1 D
.S BPCSDATE="1/1/1980"
.D DT^DILF("",BPCSDATE,.BPCSDAT)
D DT^DILF("",BPCEDATE,.BPCEDAT)
I BPCEDAT=-1 D
.S BPCEDATE="T"
.D DT^DILF("",BPCEDATE,.BPCEDAT)
S BPCC=0,BPCX=0,BPCLIM=$S(BPCVWOPT="0":BPCVWNO,1:99999)
F S BPCX=$O(^AUPNVSIT("AA",BPCPIEN,BPCX)) Q:BPCX="" D Q:BPCC=BPCLIM
.S BPCVIEN=""
.F S BPCVIEN=$O(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN)) Q:BPCVIEN="" D Q:BPCC=BPCLIM
..S BPCDTA=^AUPNVSIT(BPCVIEN,0),BPCCKD=$P($P(BPCDTA,U,1),".",1)
..Q:BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
..S BPCC=BPCC+1,BPCPVIEN=0
..F S BPCPVIEN=$O(^AUPNVPOV("AD",BPCVIEN,BPCPVIEN)) Q:BPCPVIEN="" D
...S BGUSUB(1)=BPCPVIEN D FIELDS^BGULIST
Q
MEAS ;
I '$D(BGUDRIVR) D Q
.S BGUDRIVR="MEAS^BPCSC1",BGUCRFS="",BPCPIEN=BGUBEGIN
.S BPCSDATE=$P(BGUEND,"`",1),BPCEDATE=$P(BGUEND,"`",2)
.S BPCVWNO=$P(BGUEND,"`",3),BPCLBONL=$P(BGUEND,"`",4)
.S BPCVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('BPCVWOPT:BPCVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:BPCPIEN=""
S BPCVWOPT="2"
D MEAS1
Q
MEAS1 ;
S:'(+BPCVWNO) BPCVWNO=10 S:BPCSDATE="" BPCSDATE="1/1/1980"
S:BPCEDATE="" BPCEDATE="T" S:BPCVWOPT="" BPCVWOPT="0"
S:BPCLBONL="" BPCLBONL="1"
D DT^DILF("",BPCSDATE,.BPCSDAT)
I BPCSDAT=-1 D
.S BPCSDATE="1/1/1980"
.D DT^DILF("",BPCSDATE,.BPCSDAT)
D DT^DILF("",BPCEDATE,.BPCEDAT)
I BPCEDAT=-1 D
.S BPCEDATE="T"
.D DT^DILF("",BPCEDATE,.BPCEDAT)
S BPCC=0,BPCX=0,BPCLIM=$S(BPCVWOPT="0":BPCVWNO,1:99999)
F S BPCX=$O(^AUPNVSIT("AA",BPCPIEN,BPCX)) Q:BPCX="" D Q:BPCC=BPCLIM
.S BPCVIEN=""
.F S BPCVIEN=$O(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN)) Q:BPCVIEN="" D Q:BPCC=BPCLIM
..S BPCDTA=^AUPNVSIT(BPCVIEN,0),BPCCKD=$P($P(BPCDTA,U,1),".",1)
..Q:BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
..;Q:'$D(^AUPNVMSR("AD",BPCVIEN))
..S BPCC=BPCC+1,BPCMVIEN=0
..F S BPCMVIEN=$O(^AUPNVMSR("AD",BPCVIEN,BPCMVIEN)) Q:BPCMVIEN="" D
...S BGUSUB(1)=BPCMVIEN D FIELDS^BGULIST
Q
EDP ; Get EDUCATION PROTOCOLS
;
I '$D(BGUDRIVR) D Q
.S BGUDRIVR="EDP^BPCSC1",BGUCRFS="",BPCPIEN=BGUBEGIN
.S BPCSDATE=$P(BGUEND,"`",1),BPCEDATE=$P(BGUEND,"`",2)
.S BPCVWNO=$P(BGUEND,"`",3),BPCLBONL=$P(BGUEND,"`",4)
.S BPCVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('BPCVWOPT:BPCVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:BPCPIEN=""
S BPCVWOPT="2"
D EDP1
Q
EDP1 ;
S:'(+BPCVWNO) BPCVWNO=10 S:BPCSDATE="" BPCSDATE="1/1/1980"
S:BPCEDATE="" BPCEDATE="T" S:BPCVWOPT="" BPCVWOPT="0"
S:BPCLBONL="" BPCLBONL="1"
D DT^DILF("",BPCSDATE,.BPCSDAT)
I BPCSDAT=-1 D
.S BPCSDATE="1/1/1980"
.D DT^DILF("",BPCSDATE,.BPCSDAT)
D DT^DILF("",BPCEDATE,.BPCEDAT)
I BPCEDAT=-1 D
.S BPCEDATE="T"
.D DT^DILF("",BPCEDATE,.BPCEDAT)
S BPCC=0,BPCX=0,BPCLIM=$S(BPCVWOPT="0":BPCVWNO,1:99999)
F S BPCX=$O(^AUPNVSIT("AA",BPCPIEN,BPCX)) Q:'BPCX D Q:BPCC=BPCLIM
.S BPCVIEN=""
.F S BPCVIEN=$O(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN)) Q:'BPCVIEN D Q:BPCC=BPCLIM
..S BPCDTA=^AUPNVSIT(BPCVIEN,0),BPCCKD=$P($P(BPCDTA,U,1),".",1)
..Q:BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
..S BPCC=BPCC+1,BPCPVIEN=0
..F S BPCPVIEN=$O(^AUPNVPED("AD",BPCVIEN,BPCPVIEN)) Q:'BPCPVIEN D
...S BGUSUB(1)=BPCPVIEN D FIELDS^BGULIST
Q
RAD ; Get RADIOLOGY PCC data
;
I '$D(BGUDRIVR) D Q
.S BGUDRIVR="RAD^BPCSC1",BGUCRFS="",BPCPIEN=BGUBEGIN
.S BPCSDATE=$P(BGUEND,"`",1),BPCEDATE=$P(BGUEND,"`",2)
.S BPCVWNO=$P(BGUEND,"`",3),BPCLBONL=$P(BGUEND,"`",4)
.S BPCVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('BPCVWOPT:BPCVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:BPCPIEN=""
S BPCVWOPT="2"
D RAD1
Q
RAD1 ;
S:'(+BPCVWNO) BPCVWNO=10 S:BPCSDATE="" BPCSDATE="1/1/1980"
S:BPCEDATE="" BPCEDATE="T" S:BPCVWOPT="" BPCVWOPT="0"
S:BPCLBONL="" BPCLBONL="1"
D DT^DILF("",BPCSDATE,.BPCSDAT)
I BPCSDAT=-1 D
.S BPCSDATE="1/1/1980"
.D DT^DILF("",BPCSDATE,.BPCSDAT)
D DT^DILF("",BPCEDATE,.BPCEDAT)
I BPCEDAT=-1 D
.S BPCEDATE="T"
.D DT^DILF("",BPCEDATE,.BPCEDAT)
S BPCC=0,BPCX=0,BPCLIM=$S(BPCVWOPT="0":BPCVWNO,1:99999)
F S BPCX=$O(^AUPNVSIT("AA",BPCPIEN,BPCX)) Q:'BPCX D Q:BPCC=BPCLIM
.S BPCVIEN=""
.F S BPCVIEN=$O(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN)) Q:'BPCVIEN D Q:BPCC=BPCLIM
..S BPCDTA=^AUPNVSIT(BPCVIEN,0),BPCCKD=$P($P(BPCDTA,U,1),".",1)
..Q:BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
..S BPCC=BPCC+1,BPCPVIEN=0
..F S BPCPVIEN=$O(^AUPNVRAD("AD",BPCVIEN,BPCPVIEN)) Q:'BPCPVIEN D
...S BGUSUB(1)=BPCPVIEN D FIELDS^BGULIST
Q
MIC ; Get V MICROBIOLOGY data
;
K ^TMP($J)
I '$D(BGUDRIVR) D Q
.S BGUDRIVR="MIC^BPCSC1",BGUCRFS="",BPCPIEN=BGUBEGIN
.S BPCSDATE=$P(BGUEND,"`",1),BPCEDATE=$P(BGUEND,"`",2)
.S BPCVWNO=$P(BGUEND,"`",3),BPCLBONL=$P(BGUEND,"`",4)
.S BPCVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('BPCVWOPT:BPCVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:BPCPIEN=""
S BPCVWOPT="2"
D MIC1
Q
MIC1 ;
S:'(+BPCVWNO) BPCVWNO=10 S:BPCSDATE="" BPCSDATE="1/1/1980"
S:BPCEDATE="" BPCEDATE="T" S:BPCVWOPT="" BPCVWOPT="0"
S:BPCLBONL="" BPCLBONL="1"
D DT^DILF("",BPCSDATE,.BPCSDAT)
I BPCSDAT=-1 D
.S BPCSDATE="1/1/1980"
.D DT^DILF("",BPCSDATE,.BPCSDAT)
D DT^DILF("",BPCEDATE,.BPCEDAT)
I BPCEDAT=-1 D
.S BPCEDATE="T"
.D DT^DILF("",BPCEDATE,.BPCEDAT)
S BPCC=0,BPCX=0,BPCLIM=$S(BPCVWOPT="0":BPCVWNO,1:99999)
F S BPCX=$O(^AUPNVSIT("AA",BPCPIEN,BPCX)) Q:'BPCX D Q:BPCC=BPCLIM
.S BPCVIEN=""
.F S BPCVIEN=$O(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN)) Q:'BPCVIEN D Q:BPCC=BPCLIM
..S BPCDTA=^AUPNVSIT(BPCVIEN,0),BPCCKD=$P($P(BPCDTA,U,1),".",1)
..Q:BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
..S BPCC=BPCC+1,BPCPVIEN=0
..F S BPCPVIEN=$O(^AUPNVMIC("AD",BPCVIEN,BPCPVIEN)) Q:'BPCPVIEN D
...D MIC2
S BPCJ=$J,BPCMI="MICRO",BPCU=",",BPCZ=")",BPCQ=$C(34) S BPCX="^TMP("_BPCJ_BPCU_BPCQ_BPCMI_BPCQ_BPCZ
F S BPCX=$Q(@BPCX) Q:BPCX'[("^TMP("_BPCJ_BPCU_BPCQ_BPCMI_BPCQ_BPCU) S BPCPVIEN=@BPCX S BGUSUB(1)=BPCPVIEN D FIELDS^BGULIST
Q
MIC2 ;SORT BY PARENT
S BPCPARNT=$S($P($G(^AUPNVMIC(BPCPVIEN,12)),U,8)>0:$P($G(^AUPNVMIC(BPCPVIEN,12)),U,8),1:0)
S BPCACCN=$S($L($P($G(^AUPNVMIC(BPCPVIEN,0)),U,6))>0:$P($G(^AUPNVMIC(BPCPVIEN,0)),U,6),1:0)
S BPCORGSM=$S($P($G(^AUPNVMIC(BPCPVIEN,0)),U,4)>0:$P($G(^AUPNVMIC(BPCPVIEN,0)),U,4),1:0) S:BPCORGSM BPCORGSM=$P($G(^LAB(61.2,BPCORGSM,0)),U,1)
S BPCANTIB=$S($P($G(^AUPNVMIC(BPCPVIEN,0)),U,5)>0:$P($G(^AUPNVMIC(BPCPVIEN,0)),U,5),1:0) S:BPCANTIB BPCANTIB=$P($G(^LAB(62.06,BPCANTIB,0)),U,1)
S ^TMP($J,"MICRO",BPCVIEN,BPCACCN,BPCPARNT,BPCORGSM,BPCANTIB,BPCPVIEN)=BPCPVIEN
Q
PCCMED ; Get PRESCRIPTION PCC DATA
;
K ^TMP($J)
I '$D(BGUDRIVR) D Q
.S BGUDRIVR="PCCMED^BPCSC1",BGUCRFS="",BPCPIEN=BGUBEGIN
.S BPCSDATE=$P(BGUEND,"`",1),BPCEDATE=$P(BGUEND,"`",2)
.S BPCVWNO=$P(BGUEND,"`",3),BPCLBONL=$P(BGUEND,"`",4)
.S BPCVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('BPCVWOPT:BPCVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:BPCPIEN=""
S BPCVWOPT="2"
D PCCMED1
Q
PCCMED1 ;
S:'(+BPCVWNO) BPCVWNO=10 S:BPCSDATE="" BPCSDATE="1/1/1980"
S:BPCEDATE="" BPCEDATE="T" S:BPCVWOPT="" BPCVWOPT="0"
S:BPCLBONL="" BPCLBONL="1"
D DT^DILF("",BPCSDATE,.BPCSDAT)
I BPCSDAT=-1 D
.S BPCSDATE="1/1/1980"
.D DT^DILF("",BPCSDATE,.BPCSDAT)
D DT^DILF("",BPCEDATE,.BPCEDAT)
I BPCEDAT=-1 D
.S BPCEDATE="T"
.D DT^DILF("",BPCEDATE,.BPCEDAT)
S BPCC=0,BPCX=0,BPCLIM=$S(BPCVWOPT="0":BPCVWNO,1:99999)
F S BPCX=$O(^AUPNVSIT("AA",BPCPIEN,BPCX)) Q:'BPCX D Q:BPCC=BPCLIM
.S BPCVIEN=""
.F S BPCVIEN=$O(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN)) Q:'BPCVIEN D Q:BPCC=BPCLIM
..S BPCDTA=^AUPNVSIT(BPCVIEN,0),BPCCKD=$P($P(BPCDTA,U,1),".",1)
..Q:BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
..S BPCC=BPCC+1,BPCPVIEN=0
..F S BPCPVIEN=$O(^AUPNVMED("AD",BPCVIEN,BPCPVIEN)) Q:'BPCPVIEN D
...D PCCMED2
S BPCJ=$J,BPCPMED="PCCMED",BPCU=",",BPCZ=")",BPCQ=$C(34) S BPCX="^TMP("_BPCJ_BPCU_BPCQ_BPCPMED_BPCQ_BPCZ
F S BPCX=$Q(@BPCX) Q:BPCX'[("^TMP("_BPCJ_BPCU_BPCQ_BPCPMED_BPCQ_BPCU) S BPCPVIEN=@BPCX S BGUSUB(1)=BPCPVIEN D FIELDS^BGULIST
Q
PCCMED2 ;SORT BY INVERSE VISIT DATE
S BPCIDT=$S(BPCCKD>2700000:9999999-BPCCKD,1:9999999)
S BPCMED=$S($P($G(^AUPNVMED(BPCPVIEN,0)),U,1)>0:$P($G(^AUPNVMED(BPCPVIEN,0)),U,1),1:0) S:+BPCMED BPCMED=$P($G(^PSDRUG(BPCMED,0)),U,1) S:'BPCMED BPCMED=0
S ^TMP($J,"PCCMED",BPCIDT,BPCVIEN,BPCMED,BPCPVIEN)=BPCPVIEN
Q
MEDP I '$D(BGUDRIVR) D Q
.S BGUDRIVR="MEDP^BPCSC1",BGUCRFS="",BPCPIEN=BGUBEGIN
.S BPCSDATE=$P(BGUEND,"`",1),BPCEDATE=$P(BGUEND,"`",2)
.S BPCVWNO=$P(BGUEND,"`",3),BPCLBONL=$P(BGUEND,"`",4)
.S BPCVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('BPCVWOPT:BPCVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:BPCPIEN=""
S BPCVWOPT="2"
D MEDP1
Q
;
MEDP1 ;
S:'(+BPCVWNO) BPCVWNO=10 S:BPCSDATE="" BPCSDATE="1/1/1980"
S:BPCEDATE="" BPCEDATE="T" S:BPCVWOPT="" BPCVWOPT="0"
S:BPCLBONL="" BPCLBONL="1"
D DT^DILF("",BPCSDATE,.BPCSDAT)
I BPCSDAT=-1 D
.S BPCSDATE="1/1/1980"
.D DT^DILF("",BPCSDATE,.BPCSDAT)
D DT^DILF("",BPCEDATE,.BPCEDAT)
I BPCEDAT=-1 D
.S BPCEDATE="T"
.D DT^DILF("",BPCEDATE,.BPCEDAT)
S BPCC=0,BPCX=0,BPCLIM=$S(BPCVWOPT="0":BPCVWNO,1:99999)
F S BPCX=$O(^AUPNVSIT("AA",BPCPIEN,BPCX)) Q:BPCX="" D Q:BPCC=BPCLIM
.S BPCVIEN=""
.F S BPCVIEN=$O(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN)) Q:BPCVIEN="" D Q:BPCC=BPCLIM
..S BPCDTA=^AUPNVSIT(BPCVIEN,0),BPCCKD=$P($P(BPCDTA,U,1),".",1)
..Q:BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
..S BPCC=BPCC+1,BPCPMIEN=0
..F S BPCPMIEN=$O(^AUPNVMED("AD",BPCVIEN,BPCPMIEN)) Q:BPCPMIEN="" D
...S BPCSTAT=-1
...I $D(^PSRX("APCC",BPCPMIEN)) D
....S BPCRXIEN=$O(^PSRX("APCC",BPCPMIEN,"")) Q:BPCRXIEN=""
....S BPCCK=$O(^PSRX("APCC",BPCPMIEN,BPCRXIEN,""))
....I BPCCK'="" S BPCSTAT=-1 Q
....S BPCSTAT=$P(^PSRX(BPCRXIEN,0),"^",15) S:BPCSTAT="" BPCSTAT=-1
....;I BPCSTAT=0 D MEDP2
...I BPCSTAT=0 S BGUSUB(1)=BPCPMIEN D FIELDS^BGULIST
Q
MEDP2 ;
N DYS,RFLS,ISUDAT,CKDT
S BPCSTAT=-1,BPCRX0=$G(^PSRX(BPCRXIEN,0)) Q:BPCRX0=""
S BPCRX2=$G(^PSRX(BPCRXIEN,2))
S DYS=$P(BPCRX0,U,8),RFLS=$P(BPCRX0,U,9),ISUDAT=$P(BPCRX0,U,13)
S X2=DYS*RFLS,X2=$S(DYS=X2:X2,X2<181:184,X2=360:366,1:X2)
D:ISUDAT'=""
.S X1=ISUDAT D C^%DTC S CKDT=$P(X,".",1)
.S X="T" D ^%DT I CKDT'<Y S BPCSTAT=0
Q
PAT ; Get PATIENT Data
; Set BGUCRFS1 to the cross-reference to be used for lookup.
; If the file is not the same as the primary file, prefix BGUCRFS1
; with the file number or name followed by a semicolan and then the
; cross-reference node.
;
S BPCDUZ2=DUZ(2),BGUCRFS1="B"
I BGUBEGIN?9N S BGUCRFS1="VA PATIENT;SSN" Q
I BGUBEGIN?1.6N S BGUCRFS1="PATIENT;D" Q
I BGUBEGIN?1A4N S BGUCRFS1="VA PATIENT;BS5" Q
I BGUBEGIN?1.2N1"/"1.2N1"/"2.4N S X=BGUBEGIN D ^%DT S (BGUBEGIN,BGUEND)=Y,BGUCRFS1="VA PATIENT;ADOB" Q
Q
RXMED ; Get PRESCRIPTION RX DATA
;
K ^TMP($J)
I '$D(BGUDRIVR) D Q
.S BGUDRIVR="RXMED^BPCSC1",BGUCRFS="",BPCPIEN=BGUBEGIN
.S BPCSDATE=$P(BGUEND,"`",1),BPCEDATE=$P(BGUEND,"`",2)
.S BPCVWNO=$P(BGUEND,"`",3),BPCLBONL=$P(BGUEND,"`",4)
.S BPCVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('BPCVWOPT:BPCVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:BPCPIEN=""
S BPCVWOPT="2"
D RXMED1
Q
RXMED1 ;
S:'(+BPCVWNO) BPCVWNO=10 S:BPCSDATE="" BPCSDATE="1/1/1980"
S:BPCEDATE="" BPCEDATE="T" S:BPCVWOPT="" BPCVWOPT="0"
S:BPCLBONL="" BPCLBONL="1"
D DT^DILF("",BPCSDATE,.BPCSDAT)
I BPCSDAT=-1 D
.S BPCSDATE="1/1/1980"
.D DT^DILF("",BPCSDATE,.BPCSDAT)
D DT^DILF("",BPCEDATE,.BPCEDAT)
I BPCEDAT=-1 D
.S BPCEDATE="T"
.D DT^DILF("",BPCEDATE,.BPCEDAT)
S BPCC=0,BPCX=0,BPCLIM=$S(BPCVWOPT="0":BPCVWNO,1:99999)
S ^FJBGU(1)=BPCPIEN
F S BPCX=$O(^PS(55,BPCPIEN,"P",BPCX)) Q:'BPCX D Q:BPCC=BPCLIM
.S BPCVIEN=$P($G(^PS(55,BPCPIEN,"P",BPCX,0)),U,1) Q:+BPCVIEN=0
.S ^FJBGU(1,BPCX)=BPCVIEN
.S BPCRX0=$G(^PSRX(BPCVIEN,0))
.S BPCRX2=$G(^PSRX(BPCVIEN,2))
.S ^FJBGU(BPCVIEN)=BPCRX2
.S BPCCKD=$P($P(BPCRX2,U,1),".",1)
.Q:BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
.S BGUSUB(1)=BPCVIEN D FIELDS^BGULIST
Q
BPCSC1 ; IHS/OIT/MJL - SPECIAL X-REF ROUTINES - ; [ 04/14/2008 4:14 PM ]
+1 ;;1.5;BPC;**5**;FEB 16, 2005
+2 ;
+3 ; BGUBEGIN contains the Patient IEN
+4 ; BGUEND contains the following separated by "`"
+5 ; 1. Start Date (External format)
+6 ; 2. End Date (External format)
+7 ; 3. No of visits to view (ignored if View Option = 1)
+8 ; 4. Visits with labs only flag (0=No,1=Yes)
+9 ; 5. View Option (0=Last # of visits in dt rng,1=all visits in dt rng)
+10 ;
MED IF '$DATA(BGUDRIVR)
Begin DoDot:1
+1 SET BGUDRIVR="MED^BPCSC1"
SET BGUCRFS=""
SET BPCPIEN=BGUBEGIN
+2 SET BPCSDATE=$PIECE(BGUEND,"`",1)
SET BPCEDATE=$PIECE(BGUEND,"`",2)
+3 SET BPCVWNO=$PIECE(BGUEND,"`",3)
SET BPCLBONL=$PIECE(BGUEND,"`",4)
+4 SET BPCVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('BPCVWOPT:BPCVWNO,1:32000)
+5 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+6 IF BPCPIEN=""
QUIT
+7 SET BPCVWOPT="2"
+8 DO MED1
+9 QUIT
+10 ;
MED1 ;
+1 IF '(+BPCVWNO)
SET BPCVWNO=10
IF BPCSDATE=""
SET BPCSDATE="1/1/1980"
+2 IF BPCEDATE=""
SET BPCEDATE="T"
IF BPCVWOPT=""
SET BPCVWOPT="0"
+3 IF BPCLBONL=""
SET BPCLBONL="1"
+4 DO DT^DILF("",BPCSDATE,.BPCSDAT)
+5 IF BPCSDAT=-1
Begin DoDot:1
+6 SET BPCSDATE="1/1/1980"
+7 DO DT^DILF("",BPCSDATE,.BPCSDAT)
End DoDot:1
+8 DO DT^DILF("",BPCEDATE,.BPCEDAT)
+9 IF BPCEDAT=-1
Begin DoDot:1
+10 SET BPCEDATE="T"
+11 DO DT^DILF("",BPCEDATE,.BPCEDAT)
End DoDot:1
+12 SET BPCC=0
SET BPCX=0
SET BPCLIM=$SELECT(BPCVWOPT="0":BPCVWNO,1:99999)
+13 FOR
SET BPCX=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX))
IF BPCX=""
QUIT
Begin DoDot:1
+14 SET BPCVIEN=""
+15 FOR
SET BPCVIEN=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN))
IF BPCVIEN=""
QUIT
Begin DoDot:2
+16 SET BPCDTA=^AUPNVSIT(BPCVIEN,0)
SET BPCCKD=$PIECE($PIECE(BPCDTA,U,1),".",1)
+17 IF BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
QUIT
+18 SET BPCC=BPCC+1
SET BPCPMIEN=0
+19 FOR
SET BPCPMIEN=$ORDER(^AUPNVMED("AD",BPCVIEN,BPCPMIEN))
IF BPCPMIEN=""
QUIT
Begin DoDot:3
+20 SET BPCSTAT=-1
+21 IF $DATA(^PSRX("APCC",BPCPMIEN))
Begin DoDot:4
+22 SET BPCRXIEN=$ORDER(^PSRX("APCC",BPCPMIEN,""))
IF BPCRXIEN=""
QUIT
+23 SET BPCCK=$ORDER(^PSRX("APCC",BPCPMIEN,BPCRXIEN,""))
+24 IF BPCCK'=""
SET BPCSTAT=-1
QUIT
+25 SET BPCSTAT=$PIECE(^PSRX(BPCRXIEN,0),"^",15)
IF BPCSTAT=""
SET BPCSTAT=-1
+26 ;I BPCSTAT=0 D MED2
End DoDot:4
+27 IF BPCSTAT=0
SET BGUSUB(1)=BPCPMIEN
DO FIELDS^BGULIST
End DoDot:3
End DoDot:2
IF BPCC=BPCLIM
QUIT
End DoDot:1
IF BPCC=BPCLIM
QUIT
+28 QUIT
MED2 ;
+1 NEW DYS,RFLS,ISUDAT,CKDT
+2 SET BPCSTAT=-1
SET BPCRX0=$GET(^PSRX(BPCRXIEN,0))
IF BPCRX0=""
QUIT
+3 SET BPCRX2=$GET(^PSRX(BPCRXIEN,2))
+4 SET DYS=$PIECE(BPCRX0,U,8)
SET RFLS=$PIECE(BPCRX0,U,9)
SET ISUDAT=$PIECE(BPCRX0,U,13)
+5 SET X2=DYS*RFLS
SET X2=$SELECT(DYS=X2:X2,X2<181:184,X2=360:366,1:X2)
+6 IF ISUDAT'=""
Begin DoDot:1
+7 SET X1=ISUDAT
DO C^%DTC
SET CKDT=$PIECE(X,".",1)
+8 SET X="T"
DO ^%DT
IF CKDT'<Y
SET BPCSTAT=0
End DoDot:1
+9 QUIT
POV ; Get purpose of visits
+1 ;
+2 IF '$DATA(BGUDRIVR)
Begin DoDot:1
+3 SET BGUDRIVR="POV^BPCSC1"
SET BGUCRFS=""
SET BPCPIEN=BGUBEGIN
+4 SET BPCSDATE=$PIECE(BGUEND,"`",1)
SET BPCEDATE=$PIECE(BGUEND,"`",2)
+5 SET BPCVWNO=$PIECE(BGUEND,"`",3)
SET BPCLBONL=$PIECE(BGUEND,"`",4)
+6 SET BPCVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('BPCVWOPT:BPCVWNO,1:32000)
+7 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+8 IF BPCPIEN=""
QUIT
+9 SET BPCVWOPT="2"
+10 DO POV1
+11 QUIT
POV1 ;
+1 IF '(+BPCVWNO)
SET BPCVWNO=10
IF BPCSDATE=""
SET BPCSDATE="1/1/1980"
+2 IF BPCEDATE=""
SET BPCEDATE="T"
IF BPCVWOPT=""
SET BPCVWOPT="0"
+3 IF BPCLBONL=""
SET BPCLBONL="1"
+4 DO DT^DILF("",BPCSDATE,.BPCSDAT)
+5 IF BPCSDAT=-1
Begin DoDot:1
+6 SET BPCSDATE="1/1/1980"
+7 DO DT^DILF("",BPCSDATE,.BPCSDAT)
End DoDot:1
+8 DO DT^DILF("",BPCEDATE,.BPCEDAT)
+9 IF BPCEDAT=-1
Begin DoDot:1
+10 SET BPCEDATE="T"
+11 DO DT^DILF("",BPCEDATE,.BPCEDAT)
End DoDot:1
+12 SET BPCC=0
SET BPCX=0
SET BPCLIM=$SELECT(BPCVWOPT="0":BPCVWNO,1:99999)
+13 FOR
SET BPCX=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX))
IF BPCX=""
QUIT
Begin DoDot:1
+14 SET BPCVIEN=""
+15 FOR
SET BPCVIEN=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN))
IF BPCVIEN=""
QUIT
Begin DoDot:2
+16 SET BPCDTA=^AUPNVSIT(BPCVIEN,0)
SET BPCCKD=$PIECE($PIECE(BPCDTA,U,1),".",1)
+17 IF BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
QUIT
+18 SET BPCC=BPCC+1
SET BPCPVIEN=0
+19 FOR
SET BPCPVIEN=$ORDER(^AUPNVPOV("AD",BPCVIEN,BPCPVIEN))
IF BPCPVIEN=""
QUIT
Begin DoDot:3
+20 SET BGUSUB(1)=BPCPVIEN
DO FIELDS^BGULIST
End DoDot:3
End DoDot:2
IF BPCC=BPCLIM
QUIT
End DoDot:1
IF BPCC=BPCLIM
QUIT
+21 QUIT
MEAS ;
+1 IF '$DATA(BGUDRIVR)
Begin DoDot:1
+2 SET BGUDRIVR="MEAS^BPCSC1"
SET BGUCRFS=""
SET BPCPIEN=BGUBEGIN
+3 SET BPCSDATE=$PIECE(BGUEND,"`",1)
SET BPCEDATE=$PIECE(BGUEND,"`",2)
+4 SET BPCVWNO=$PIECE(BGUEND,"`",3)
SET BPCLBONL=$PIECE(BGUEND,"`",4)
+5 SET BPCVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('BPCVWOPT:BPCVWNO,1:32000)
+6 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+7 IF BPCPIEN=""
QUIT
+8 SET BPCVWOPT="2"
+9 DO MEAS1
+10 QUIT
MEAS1 ;
+1 IF '(+BPCVWNO)
SET BPCVWNO=10
IF BPCSDATE=""
SET BPCSDATE="1/1/1980"
+2 IF BPCEDATE=""
SET BPCEDATE="T"
IF BPCVWOPT=""
SET BPCVWOPT="0"
+3 IF BPCLBONL=""
SET BPCLBONL="1"
+4 DO DT^DILF("",BPCSDATE,.BPCSDAT)
+5 IF BPCSDAT=-1
Begin DoDot:1
+6 SET BPCSDATE="1/1/1980"
+7 DO DT^DILF("",BPCSDATE,.BPCSDAT)
End DoDot:1
+8 DO DT^DILF("",BPCEDATE,.BPCEDAT)
+9 IF BPCEDAT=-1
Begin DoDot:1
+10 SET BPCEDATE="T"
+11 DO DT^DILF("",BPCEDATE,.BPCEDAT)
End DoDot:1
+12 SET BPCC=0
SET BPCX=0
SET BPCLIM=$SELECT(BPCVWOPT="0":BPCVWNO,1:99999)
+13 FOR
SET BPCX=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX))
IF BPCX=""
QUIT
Begin DoDot:1
+14 SET BPCVIEN=""
+15 FOR
SET BPCVIEN=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN))
IF BPCVIEN=""
QUIT
Begin DoDot:2
+16 SET BPCDTA=^AUPNVSIT(BPCVIEN,0)
SET BPCCKD=$PIECE($PIECE(BPCDTA,U,1),".",1)
+17 IF BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
QUIT
+18 ;Q:'$D(^AUPNVMSR("AD",BPCVIEN))
+19 SET BPCC=BPCC+1
SET BPCMVIEN=0
+20 FOR
SET BPCMVIEN=$ORDER(^AUPNVMSR("AD",BPCVIEN,BPCMVIEN))
IF BPCMVIEN=""
QUIT
Begin DoDot:3
+21 SET BGUSUB(1)=BPCMVIEN
DO FIELDS^BGULIST
End DoDot:3
End DoDot:2
IF BPCC=BPCLIM
QUIT
End DoDot:1
IF BPCC=BPCLIM
QUIT
+22 QUIT
EDP ; Get EDUCATION PROTOCOLS
+1 ;
+2 IF '$DATA(BGUDRIVR)
Begin DoDot:1
+3 SET BGUDRIVR="EDP^BPCSC1"
SET BGUCRFS=""
SET BPCPIEN=BGUBEGIN
+4 SET BPCSDATE=$PIECE(BGUEND,"`",1)
SET BPCEDATE=$PIECE(BGUEND,"`",2)
+5 SET BPCVWNO=$PIECE(BGUEND,"`",3)
SET BPCLBONL=$PIECE(BGUEND,"`",4)
+6 SET BPCVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('BPCVWOPT:BPCVWNO,1:32000)
+7 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+8 IF BPCPIEN=""
QUIT
+9 SET BPCVWOPT="2"
+10 DO EDP1
+11 QUIT
EDP1 ;
+1 IF '(+BPCVWNO)
SET BPCVWNO=10
IF BPCSDATE=""
SET BPCSDATE="1/1/1980"
+2 IF BPCEDATE=""
SET BPCEDATE="T"
IF BPCVWOPT=""
SET BPCVWOPT="0"
+3 IF BPCLBONL=""
SET BPCLBONL="1"
+4 DO DT^DILF("",BPCSDATE,.BPCSDAT)
+5 IF BPCSDAT=-1
Begin DoDot:1
+6 SET BPCSDATE="1/1/1980"
+7 DO DT^DILF("",BPCSDATE,.BPCSDAT)
End DoDot:1
+8 DO DT^DILF("",BPCEDATE,.BPCEDAT)
+9 IF BPCEDAT=-1
Begin DoDot:1
+10 SET BPCEDATE="T"
+11 DO DT^DILF("",BPCEDATE,.BPCEDAT)
End DoDot:1
+12 SET BPCC=0
SET BPCX=0
SET BPCLIM=$SELECT(BPCVWOPT="0":BPCVWNO,1:99999)
+13 FOR
SET BPCX=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX))
IF 'BPCX
QUIT
Begin DoDot:1
+14 SET BPCVIEN=""
+15 FOR
SET BPCVIEN=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN))
IF 'BPCVIEN
QUIT
Begin DoDot:2
+16 SET BPCDTA=^AUPNVSIT(BPCVIEN,0)
SET BPCCKD=$PIECE($PIECE(BPCDTA,U,1),".",1)
+17 IF BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
QUIT
+18 SET BPCC=BPCC+1
SET BPCPVIEN=0
+19 FOR
SET BPCPVIEN=$ORDER(^AUPNVPED("AD",BPCVIEN,BPCPVIEN))
IF 'BPCPVIEN
QUIT
Begin DoDot:3
+20 SET BGUSUB(1)=BPCPVIEN
DO FIELDS^BGULIST
End DoDot:3
End DoDot:2
IF BPCC=BPCLIM
QUIT
End DoDot:1
IF BPCC=BPCLIM
QUIT
+21 QUIT
RAD ; Get RADIOLOGY PCC data
+1 ;
+2 IF '$DATA(BGUDRIVR)
Begin DoDot:1
+3 SET BGUDRIVR="RAD^BPCSC1"
SET BGUCRFS=""
SET BPCPIEN=BGUBEGIN
+4 SET BPCSDATE=$PIECE(BGUEND,"`",1)
SET BPCEDATE=$PIECE(BGUEND,"`",2)
+5 SET BPCVWNO=$PIECE(BGUEND,"`",3)
SET BPCLBONL=$PIECE(BGUEND,"`",4)
+6 SET BPCVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('BPCVWOPT:BPCVWNO,1:32000)
+7 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+8 IF BPCPIEN=""
QUIT
+9 SET BPCVWOPT="2"
+10 DO RAD1
+11 QUIT
RAD1 ;
+1 IF '(+BPCVWNO)
SET BPCVWNO=10
IF BPCSDATE=""
SET BPCSDATE="1/1/1980"
+2 IF BPCEDATE=""
SET BPCEDATE="T"
IF BPCVWOPT=""
SET BPCVWOPT="0"
+3 IF BPCLBONL=""
SET BPCLBONL="1"
+4 DO DT^DILF("",BPCSDATE,.BPCSDAT)
+5 IF BPCSDAT=-1
Begin DoDot:1
+6 SET BPCSDATE="1/1/1980"
+7 DO DT^DILF("",BPCSDATE,.BPCSDAT)
End DoDot:1
+8 DO DT^DILF("",BPCEDATE,.BPCEDAT)
+9 IF BPCEDAT=-1
Begin DoDot:1
+10 SET BPCEDATE="T"
+11 DO DT^DILF("",BPCEDATE,.BPCEDAT)
End DoDot:1
+12 SET BPCC=0
SET BPCX=0
SET BPCLIM=$SELECT(BPCVWOPT="0":BPCVWNO,1:99999)
+13 FOR
SET BPCX=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX))
IF 'BPCX
QUIT
Begin DoDot:1
+14 SET BPCVIEN=""
+15 FOR
SET BPCVIEN=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN))
IF 'BPCVIEN
QUIT
Begin DoDot:2
+16 SET BPCDTA=^AUPNVSIT(BPCVIEN,0)
SET BPCCKD=$PIECE($PIECE(BPCDTA,U,1),".",1)
+17 IF BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
QUIT
+18 SET BPCC=BPCC+1
SET BPCPVIEN=0
+19 FOR
SET BPCPVIEN=$ORDER(^AUPNVRAD("AD",BPCVIEN,BPCPVIEN))
IF 'BPCPVIEN
QUIT
Begin DoDot:3
+20 SET BGUSUB(1)=BPCPVIEN
DO FIELDS^BGULIST
End DoDot:3
End DoDot:2
IF BPCC=BPCLIM
QUIT
End DoDot:1
IF BPCC=BPCLIM
QUIT
+21 QUIT
MIC ; Get V MICROBIOLOGY data
+1 ;
+2 KILL ^TMP($JOB)
+3 IF '$DATA(BGUDRIVR)
Begin DoDot:1
+4 SET BGUDRIVR="MIC^BPCSC1"
SET BGUCRFS=""
SET BPCPIEN=BGUBEGIN
+5 SET BPCSDATE=$PIECE(BGUEND,"`",1)
SET BPCEDATE=$PIECE(BGUEND,"`",2)
+6 SET BPCVWNO=$PIECE(BGUEND,"`",3)
SET BPCLBONL=$PIECE(BGUEND,"`",4)
+7 SET BPCVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('BPCVWOPT:BPCVWNO,1:32000)
+8 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+9 IF BPCPIEN=""
QUIT
+10 SET BPCVWOPT="2"
+11 DO MIC1
+12 QUIT
MIC1 ;
+1 IF '(+BPCVWNO)
SET BPCVWNO=10
IF BPCSDATE=""
SET BPCSDATE="1/1/1980"
+2 IF BPCEDATE=""
SET BPCEDATE="T"
IF BPCVWOPT=""
SET BPCVWOPT="0"
+3 IF BPCLBONL=""
SET BPCLBONL="1"
+4 DO DT^DILF("",BPCSDATE,.BPCSDAT)
+5 IF BPCSDAT=-1
Begin DoDot:1
+6 SET BPCSDATE="1/1/1980"
+7 DO DT^DILF("",BPCSDATE,.BPCSDAT)
End DoDot:1
+8 DO DT^DILF("",BPCEDATE,.BPCEDAT)
+9 IF BPCEDAT=-1
Begin DoDot:1
+10 SET BPCEDATE="T"
+11 DO DT^DILF("",BPCEDATE,.BPCEDAT)
End DoDot:1
+12 SET BPCC=0
SET BPCX=0
SET BPCLIM=$SELECT(BPCVWOPT="0":BPCVWNO,1:99999)
+13 FOR
SET BPCX=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX))
IF 'BPCX
QUIT
Begin DoDot:1
+14 SET BPCVIEN=""
+15 FOR
SET BPCVIEN=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN))
IF 'BPCVIEN
QUIT
Begin DoDot:2
+16 SET BPCDTA=^AUPNVSIT(BPCVIEN,0)
SET BPCCKD=$PIECE($PIECE(BPCDTA,U,1),".",1)
+17 IF BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
QUIT
+18 SET BPCC=BPCC+1
SET BPCPVIEN=0
+19 FOR
SET BPCPVIEN=$ORDER(^AUPNVMIC("AD",BPCVIEN,BPCPVIEN))
IF 'BPCPVIEN
QUIT
Begin DoDot:3
+20 DO MIC2
End DoDot:3
End DoDot:2
IF BPCC=BPCLIM
QUIT
End DoDot:1
IF BPCC=BPCLIM
QUIT
+21 SET BPCJ=$JOB
SET BPCMI="MICRO"
SET BPCU=","
SET BPCZ=")"
SET BPCQ=$CHAR(34)
SET BPCX="^TMP("_BPCJ_BPCU_BPCQ_BPCMI_BPCQ_BPCZ
+22 FOR
SET BPCX=$QUERY(@BPCX)
IF BPCX'[("^TMP("_BPCJ_BPCU_BPCQ_BPCMI_BPCQ_BPCU)
QUIT
SET BPCPVIEN=@BPCX
SET BGUSUB(1)=BPCPVIEN
DO FIELDS^BGULIST
+23 QUIT
MIC2 ;SORT BY PARENT
+1 SET BPCPARNT=$SELECT($PIECE($GET(^AUPNVMIC(BPCPVIEN,12)),U,8)>0:$PIECE($GET(^AUPNVMIC(BPCPVIEN,12)),U,8),1:0)
+2 SET BPCACCN=$SELECT($LENGTH($PIECE($GET(^AUPNVMIC(BPCPVIEN,0)),U,6))>0:$PIECE($GET(^AUPNVMIC(BPCPVIEN,0)),U,6),1:0)
+3 SET BPCORGSM=$SELECT($PIECE($GET(^AUPNVMIC(BPCPVIEN,0)),U,4)>0:$PIECE($GET(^AUPNVMIC(BPCPVIEN,0)),U,4),1:0)
IF BPCORGSM
SET BPCORGSM=$PIECE($GET(^LAB(61.2,BPCORGSM,0)),U,1)
+4 SET BPCANTIB=$SELECT($PIECE($GET(^AUPNVMIC(BPCPVIEN,0)),U,5)>0:$PIECE($GET(^AUPNVMIC(BPCPVIEN,0)),U,5),1:0)
IF BPCANTIB
SET BPCANTIB=$PIECE($GET(^LAB(62.06,BPCANTIB,0)),U,1)
+5 SET ^TMP($JOB,"MICRO",BPCVIEN,BPCACCN,BPCPARNT,BPCORGSM,BPCANTIB,BPCPVIEN)=BPCPVIEN
+6 QUIT
PCCMED ; Get PRESCRIPTION PCC DATA
+1 ;
+2 KILL ^TMP($JOB)
+3 IF '$DATA(BGUDRIVR)
Begin DoDot:1
+4 SET BGUDRIVR="PCCMED^BPCSC1"
SET BGUCRFS=""
SET BPCPIEN=BGUBEGIN
+5 SET BPCSDATE=$PIECE(BGUEND,"`",1)
SET BPCEDATE=$PIECE(BGUEND,"`",2)
+6 SET BPCVWNO=$PIECE(BGUEND,"`",3)
SET BPCLBONL=$PIECE(BGUEND,"`",4)
+7 SET BPCVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('BPCVWOPT:BPCVWNO,1:32000)
+8 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+9 IF BPCPIEN=""
QUIT
+10 SET BPCVWOPT="2"
+11 DO PCCMED1
+12 QUIT
PCCMED1 ;
+1 IF '(+BPCVWNO)
SET BPCVWNO=10
IF BPCSDATE=""
SET BPCSDATE="1/1/1980"
+2 IF BPCEDATE=""
SET BPCEDATE="T"
IF BPCVWOPT=""
SET BPCVWOPT="0"
+3 IF BPCLBONL=""
SET BPCLBONL="1"
+4 DO DT^DILF("",BPCSDATE,.BPCSDAT)
+5 IF BPCSDAT=-1
Begin DoDot:1
+6 SET BPCSDATE="1/1/1980"
+7 DO DT^DILF("",BPCSDATE,.BPCSDAT)
End DoDot:1
+8 DO DT^DILF("",BPCEDATE,.BPCEDAT)
+9 IF BPCEDAT=-1
Begin DoDot:1
+10 SET BPCEDATE="T"
+11 DO DT^DILF("",BPCEDATE,.BPCEDAT)
End DoDot:1
+12 SET BPCC=0
SET BPCX=0
SET BPCLIM=$SELECT(BPCVWOPT="0":BPCVWNO,1:99999)
+13 FOR
SET BPCX=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX))
IF 'BPCX
QUIT
Begin DoDot:1
+14 SET BPCVIEN=""
+15 FOR
SET BPCVIEN=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN))
IF 'BPCVIEN
QUIT
Begin DoDot:2
+16 SET BPCDTA=^AUPNVSIT(BPCVIEN,0)
SET BPCCKD=$PIECE($PIECE(BPCDTA,U,1),".",1)
+17 IF BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
QUIT
+18 SET BPCC=BPCC+1
SET BPCPVIEN=0
+19 FOR
SET BPCPVIEN=$ORDER(^AUPNVMED("AD",BPCVIEN,BPCPVIEN))
IF 'BPCPVIEN
QUIT
Begin DoDot:3
+20 DO PCCMED2
End DoDot:3
End DoDot:2
IF BPCC=BPCLIM
QUIT
End DoDot:1
IF BPCC=BPCLIM
QUIT
+21 SET BPCJ=$JOB
SET BPCPMED="PCCMED"
SET BPCU=","
SET BPCZ=")"
SET BPCQ=$CHAR(34)
SET BPCX="^TMP("_BPCJ_BPCU_BPCQ_BPCPMED_BPCQ_BPCZ
+22 FOR
SET BPCX=$QUERY(@BPCX)
IF BPCX'[("^TMP("_BPCJ_BPCU_BPCQ_BPCPMED_BPCQ_BPCU)
QUIT
SET BPCPVIEN=@BPCX
SET BGUSUB(1)=BPCPVIEN
DO FIELDS^BGULIST
+23 QUIT
PCCMED2 ;SORT BY INVERSE VISIT DATE
+1 SET BPCIDT=$SELECT(BPCCKD>2700000:9999999-BPCCKD,1:9999999)
+2 SET BPCMED=$SELECT($PIECE($GET(^AUPNVMED(BPCPVIEN,0)),U,1)>0:$PIECE($GET(^AUPNVMED(BPCPVIEN,0)),U,1),1:0)
IF +BPCMED
SET BPCMED=$PIECE($GET(^PSDRUG(BPCMED,0)),U,1)
IF 'BPCMED
SET BPCMED=0
+3 SET ^TMP($JOB,"PCCMED",BPCIDT,BPCVIEN,BPCMED,BPCPVIEN)=BPCPVIEN
+4 QUIT
MEDP IF '$DATA(BGUDRIVR)
Begin DoDot:1
+1 SET BGUDRIVR="MEDP^BPCSC1"
SET BGUCRFS=""
SET BPCPIEN=BGUBEGIN
+2 SET BPCSDATE=$PIECE(BGUEND,"`",1)
SET BPCEDATE=$PIECE(BGUEND,"`",2)
+3 SET BPCVWNO=$PIECE(BGUEND,"`",3)
SET BPCLBONL=$PIECE(BGUEND,"`",4)
+4 SET BPCVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('BPCVWOPT:BPCVWNO,1:32000)
+5 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+6 IF BPCPIEN=""
QUIT
+7 SET BPCVWOPT="2"
+8 DO MEDP1
+9 QUIT
+10 ;
MEDP1 ;
+1 IF '(+BPCVWNO)
SET BPCVWNO=10
IF BPCSDATE=""
SET BPCSDATE="1/1/1980"
+2 IF BPCEDATE=""
SET BPCEDATE="T"
IF BPCVWOPT=""
SET BPCVWOPT="0"
+3 IF BPCLBONL=""
SET BPCLBONL="1"
+4 DO DT^DILF("",BPCSDATE,.BPCSDAT)
+5 IF BPCSDAT=-1
Begin DoDot:1
+6 SET BPCSDATE="1/1/1980"
+7 DO DT^DILF("",BPCSDATE,.BPCSDAT)
End DoDot:1
+8 DO DT^DILF("",BPCEDATE,.BPCEDAT)
+9 IF BPCEDAT=-1
Begin DoDot:1
+10 SET BPCEDATE="T"
+11 DO DT^DILF("",BPCEDATE,.BPCEDAT)
End DoDot:1
+12 SET BPCC=0
SET BPCX=0
SET BPCLIM=$SELECT(BPCVWOPT="0":BPCVWNO,1:99999)
+13 FOR
SET BPCX=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX))
IF BPCX=""
QUIT
Begin DoDot:1
+14 SET BPCVIEN=""
+15 FOR
SET BPCVIEN=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN))
IF BPCVIEN=""
QUIT
Begin DoDot:2
+16 SET BPCDTA=^AUPNVSIT(BPCVIEN,0)
SET BPCCKD=$PIECE($PIECE(BPCDTA,U,1),".",1)
+17 IF BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
QUIT
+18 SET BPCC=BPCC+1
SET BPCPMIEN=0
+19 FOR
SET BPCPMIEN=$ORDER(^AUPNVMED("AD",BPCVIEN,BPCPMIEN))
IF BPCPMIEN=""
QUIT
Begin DoDot:3
+20 SET BPCSTAT=-1
+21 IF $DATA(^PSRX("APCC",BPCPMIEN))
Begin DoDot:4
+22 SET BPCRXIEN=$ORDER(^PSRX("APCC",BPCPMIEN,""))
IF BPCRXIEN=""
QUIT
+23 SET BPCCK=$ORDER(^PSRX("APCC",BPCPMIEN,BPCRXIEN,""))
+24 IF BPCCK'=""
SET BPCSTAT=-1
QUIT
+25 SET BPCSTAT=$PIECE(^PSRX(BPCRXIEN,0),"^",15)
IF BPCSTAT=""
SET BPCSTAT=-1
+26 ;I BPCSTAT=0 D MEDP2
End DoDot:4
+27 IF BPCSTAT=0
SET BGUSUB(1)=BPCPMIEN
DO FIELDS^BGULIST
End DoDot:3
End DoDot:2
IF BPCC=BPCLIM
QUIT
End DoDot:1
IF BPCC=BPCLIM
QUIT
+28 QUIT
MEDP2 ;
+1 NEW DYS,RFLS,ISUDAT,CKDT
+2 SET BPCSTAT=-1
SET BPCRX0=$GET(^PSRX(BPCRXIEN,0))
IF BPCRX0=""
QUIT
+3 SET BPCRX2=$GET(^PSRX(BPCRXIEN,2))
+4 SET DYS=$PIECE(BPCRX0,U,8)
SET RFLS=$PIECE(BPCRX0,U,9)
SET ISUDAT=$PIECE(BPCRX0,U,13)
+5 SET X2=DYS*RFLS
SET X2=$SELECT(DYS=X2:X2,X2<181:184,X2=360:366,1:X2)
+6 IF ISUDAT'=""
Begin DoDot:1
+7 SET X1=ISUDAT
DO C^%DTC
SET CKDT=$PIECE(X,".",1)
+8 SET X="T"
DO ^%DT
IF CKDT'<Y
SET BPCSTAT=0
End DoDot:1
+9 QUIT
PAT ; Get PATIENT Data
+1 ; Set BGUCRFS1 to the cross-reference to be used for lookup.
+2 ; If the file is not the same as the primary file, prefix BGUCRFS1
+3 ; with the file number or name followed by a semicolan and then the
+4 ; cross-reference node.
+5 ;
+6 SET BPCDUZ2=DUZ(2)
SET BGUCRFS1="B"
+7 IF BGUBEGIN?9N
SET BGUCRFS1="VA PATIENT;SSN"
QUIT
+8 IF BGUBEGIN?1.6N
SET BGUCRFS1="PATIENT;D"
QUIT
+9 IF BGUBEGIN?1A4N
SET BGUCRFS1="VA PATIENT;BS5"
QUIT
+10 IF BGUBEGIN?1.2N1"/"1.2N1"/"2.4N
SET X=BGUBEGIN
DO ^%DT
SET (BGUBEGIN,BGUEND)=Y
SET BGUCRFS1="VA PATIENT;ADOB"
QUIT
+11 QUIT
RXMED ; Get PRESCRIPTION RX DATA
+1 ;
+2 KILL ^TMP($JOB)
+3 IF '$DATA(BGUDRIVR)
Begin DoDot:1
+4 SET BGUDRIVR="RXMED^BPCSC1"
SET BGUCRFS=""
SET BPCPIEN=BGUBEGIN
+5 SET BPCSDATE=$PIECE(BGUEND,"`",1)
SET BPCEDATE=$PIECE(BGUEND,"`",2)
+6 SET BPCVWNO=$PIECE(BGUEND,"`",3)
SET BPCLBONL=$PIECE(BGUEND,"`",4)
+7 SET BPCVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('BPCVWOPT:BPCVWNO,1:32000)
+8 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+9 IF BPCPIEN=""
QUIT
+10 SET BPCVWOPT="2"
+11 DO RXMED1
+12 QUIT
RXMED1 ;
+1 IF '(+BPCVWNO)
SET BPCVWNO=10
IF BPCSDATE=""
SET BPCSDATE="1/1/1980"
+2 IF BPCEDATE=""
SET BPCEDATE="T"
IF BPCVWOPT=""
SET BPCVWOPT="0"
+3 IF BPCLBONL=""
SET BPCLBONL="1"
+4 DO DT^DILF("",BPCSDATE,.BPCSDAT)
+5 IF BPCSDAT=-1
Begin DoDot:1
+6 SET BPCSDATE="1/1/1980"
+7 DO DT^DILF("",BPCSDATE,.BPCSDAT)
End DoDot:1
+8 DO DT^DILF("",BPCEDATE,.BPCEDAT)
+9 IF BPCEDAT=-1
Begin DoDot:1
+10 SET BPCEDATE="T"
+11 DO DT^DILF("",BPCEDATE,.BPCEDAT)
End DoDot:1
+12 SET BPCC=0
SET BPCX=0
SET BPCLIM=$SELECT(BPCVWOPT="0":BPCVWNO,1:99999)
+13 SET ^FJBGU(1)=BPCPIEN
+14 FOR
SET BPCX=$ORDER(^PS(55,BPCPIEN,"P",BPCX))
IF 'BPCX
QUIT
Begin DoDot:1
+15 SET BPCVIEN=$PIECE($GET(^PS(55,BPCPIEN,"P",BPCX,0)),U,1)
IF +BPCVIEN=0
QUIT
+16 SET ^FJBGU(1,BPCX)=BPCVIEN
+17 SET BPCRX0=$GET(^PSRX(BPCVIEN,0))
+18 SET BPCRX2=$GET(^PSRX(BPCVIEN,2))
+19 SET ^FJBGU(BPCVIEN)=BPCRX2
+20 SET BPCCKD=$PIECE($PIECE(BPCRX2,U,1),".",1)
+21 IF BPCCKD=""!(BPCCKD<BPCSDAT)!(BPCCKD>BPCEDAT)
QUIT
+22 SET BGUSUB(1)=BPCVIEN
DO FIELDS^BGULIST
End DoDot:1
IF BPCC=BPCLIM
QUIT
+23 QUIT
