BPCSC1.m

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