AMHSC1 ; IHS/CMI/LAB - SPECIAL X-REF ROUTINES - ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
; 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^AMHSC1",BGUCRFS="",AMHPIEN=BGUBEGIN
.S AMHSDATE=$P(BGUEND,"`",1),AMHEDATE=$P(BGUEND,"`",2)
.S AMHVWNO=$P(BGUEND,"`",3),AMHLBONL=$P(BGUEND,"`",4)
.S AMHVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('AMHVWOPT:AMHVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:AMHPIEN=""
S AMHVWOPT="2"
D MED1
Q
;
MED1 ;
S:'(+AMHVWNO) AMHVWNO=10 S:AMHSDATE="" AMHSDATE="1/1/1980"
S:AMHEDATE="" AMHEDATE="T" S:AMHVWOPT="" AMHVWOPT="0"
S:AMHLBONL="" AMHLBONL="1"
D DT^DILF("",AMHSDATE,.AMHSDAT)
I AMHSDAT=-1 D
.S AMHSDATE="1/1/1980"
.D DT^DILF("",AMHSDATE,.AMHSDAT)
D DT^DILF("",AMHEDATE,.AMHEDAT)
I AMHEDAT=-1 D
.S AMHEDATE="T"
.D DT^DILF("",AMHEDATE,.AMHEDAT)
S AMHC=0,AMHX=0,AMHLIM=$S(AMHVWOPT="0":AMHVWNO,1:99999)
F S AMHX=$O(^AUPNVSIT("AA",AMHPIEN,AMHX)) Q:AMHX="" D Q:AMHC=AMHLIM
.S AMHVIEN=""
.F S AMHVIEN=$O(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN)) Q:AMHVIEN="" D Q:AMHC=AMHLIM
..S AMHDTA=^AUPNVSIT(AMHVIEN,0),AMHCKD=$P($P(AMHDTA,U,1),".",1)
..Q:AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
..S AMHC=AMHC+1,AMHPMIEN=0
..F S AMHPMIEN=$O(^AUPNVMED("AD",AMHVIEN,AMHPMIEN)) Q:AMHPMIEN="" D
...S AMHSTAT=-1
...I $D(^PSRX("APCC",AMHPMIEN)) D
....S AMHRXIEN=$O(^PSRX("APCC",AMHPMIEN,"")) Q:AMHRXIEN=""
....S AMHCK=$O(^PSRX("APCC",AMHPMIEN,AMHRXIEN,""))
....I AMHCK'="" S AMHSTAT=-1 Q
....S AMHSTAT=$P(^PSRX(AMHRXIEN,0),"^",15) S:AMHSTAT="" AMHSTAT=-1
....;I AMHSTAT=0 D MED2
...I AMHSTAT=0 S BGUSUB(1)=AMHPMIEN D FIELDS^BGULIST
Q
MED2 ;
N DYS,RFLS,ISUDAT,CKDT
S AMHSTAT=-1,AMHRX0=$G(^PSRX(AMHRXIEN,0)) Q:AMHRX0=""
S AMHRX2=$G(^PSRX(AMHRXIEN,2))
S DYS=$P(AMHRX0,U,8),RFLS=$P(AMHRX0,U,9),ISUDAT=$P(AMHRX0,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 AMHSTAT=0
Q
POV ; Get purpose of visits
;
I '$D(BGUDRIVR) D Q
.S BGUDRIVR="POV^AMHSC1",BGUCRFS="",AMHPIEN=BGUBEGIN
.S AMHSDATE=$P(BGUEND,"`",1),AMHEDATE=$P(BGUEND,"`",2)
.S AMHVWNO=$P(BGUEND,"`",3),AMHLBONL=$P(BGUEND,"`",4)
.S AMHVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('AMHVWOPT:AMHVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:AMHPIEN=""
S AMHVWOPT="2"
D POV1
Q
POV1 ;
S:'(+AMHVWNO) AMHVWNO=10 S:AMHSDATE="" AMHSDATE="1/1/1980"
S:AMHEDATE="" AMHEDATE="T" S:AMHVWOPT="" AMHVWOPT="0"
S:AMHLBONL="" AMHLBONL="1"
D DT^DILF("",AMHSDATE,.AMHSDAT)
I AMHSDAT=-1 D
.S AMHSDATE="1/1/1980"
.D DT^DILF("",AMHSDATE,.AMHSDAT)
D DT^DILF("",AMHEDATE,.AMHEDAT)
I AMHEDAT=-1 D
.S AMHEDATE="T"
.D DT^DILF("",AMHEDATE,.AMHEDAT)
S AMHC=0,AMHX=0,AMHLIM=$S(AMHVWOPT="0":AMHVWNO,1:99999)
F S AMHX=$O(^AUPNVSIT("AA",AMHPIEN,AMHX)) Q:AMHX="" D Q:AMHC=AMHLIM
.S AMHVIEN=""
.F S AMHVIEN=$O(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN)) Q:AMHVIEN="" D Q:AMHC=AMHLIM
..S AMHDTA=^AUPNVSIT(AMHVIEN,0),AMHCKD=$P($P(AMHDTA,U,1),".",1)
..Q:AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
..S AMHC=AMHC+1,AMHPVIEN=0
..F S AMHPVIEN=$O(^AUPNVPOV("AD",AMHVIEN,AMHPVIEN)) Q:AMHPVIEN="" D
...S BGUSUB(1)=AMHPVIEN D FIELDS^BGULIST
Q
MEAS ;
I '$D(BGUDRIVR) D Q
.S BGUDRIVR="MEAS^AMHSC1",BGUCRFS="",AMHPIEN=BGUBEGIN
.S AMHSDATE=$P(BGUEND,"`",1),AMHEDATE=$P(BGUEND,"`",2)
.S AMHVWNO=$P(BGUEND,"`",3),AMHLBONL=$P(BGUEND,"`",4)
.S AMHVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('AMHVWOPT:AMHVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:AMHPIEN=""
S AMHVWOPT="2"
D MEAS1
Q
MEAS1 ;
S:'(+AMHVWNO) AMHVWNO=10 S:AMHSDATE="" AMHSDATE="1/1/1980"
S:AMHEDATE="" AMHEDATE="T" S:AMHVWOPT="" AMHVWOPT="0"
S:AMHLBONL="" AMHLBONL="1"
D DT^DILF("",AMHSDATE,.AMHSDAT)
I AMHSDAT=-1 D
.S AMHSDATE="1/1/1980"
.D DT^DILF("",AMHSDATE,.AMHSDAT)
D DT^DILF("",AMHEDATE,.AMHEDAT)
I AMHEDAT=-1 D
.S AMHEDATE="T"
.D DT^DILF("",AMHEDATE,.AMHEDAT)
S AMHC=0,AMHX=0,AMHLIM=$S(AMHVWOPT="0":AMHVWNO,1:99999)
F S AMHX=$O(^AUPNVSIT("AA",AMHPIEN,AMHX)) Q:AMHX="" D Q:AMHC=AMHLIM
.S AMHVIEN=""
.F S AMHVIEN=$O(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN)) Q:AMHVIEN="" D Q:AMHC=AMHLIM
..S AMHDTA=^AUPNVSIT(AMHVIEN,0),AMHCKD=$P($P(AMHDTA,U,1),".",1)
..Q:AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
..;Q:'$D(^AUPNVMSR("AD",AMHVIEN))
..S AMHC=AMHC+1,AMHMVIEN=0
..F S AMHMVIEN=$O(^AUPNVMSR("AD",AMHVIEN,AMHMVIEN)) Q:AMHMVIEN="" D
...S BGUSUB(1)=AMHMVIEN D FIELDS^BGULIST
Q
EDP ; Get EDUCATION PROTOCOLS
;
I '$D(BGUDRIVR) D Q
.S BGUDRIVR="EDP^AMHSC1",BGUCRFS="",AMHPIEN=BGUBEGIN
.S AMHSDATE=$P(BGUEND,"`",1),AMHEDATE=$P(BGUEND,"`",2)
.S AMHVWNO=$P(BGUEND,"`",3),AMHLBONL=$P(BGUEND,"`",4)
.S AMHVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('AMHVWOPT:AMHVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:AMHPIEN=""
S AMHVWOPT="2"
D EDP1
Q
EDP1 ;
S:'(+AMHVWNO) AMHVWNO=10 S:AMHSDATE="" AMHSDATE="1/1/1980"
S:AMHEDATE="" AMHEDATE="T" S:AMHVWOPT="" AMHVWOPT="0"
S:AMHLBONL="" AMHLBONL="1"
D DT^DILF("",AMHSDATE,.AMHSDAT)
I AMHSDAT=-1 D
.S AMHSDATE="1/1/1980"
.D DT^DILF("",AMHSDATE,.AMHSDAT)
D DT^DILF("",AMHEDATE,.AMHEDAT)
I AMHEDAT=-1 D
.S AMHEDATE="T"
.D DT^DILF("",AMHEDATE,.AMHEDAT)
S AMHC=0,AMHX=0,AMHLIM=$S(AMHVWOPT="0":AMHVWNO,1:99999)
F S AMHX=$O(^AUPNVSIT("AA",AMHPIEN,AMHX)) Q:'AMHX D Q:AMHC=AMHLIM
.S AMHVIEN=""
.F S AMHVIEN=$O(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN)) Q:'AMHVIEN D Q:AMHC=AMHLIM
..S AMHDTA=^AUPNVSIT(AMHVIEN,0),AMHCKD=$P($P(AMHDTA,U,1),".",1)
..Q:AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
..S AMHC=AMHC+1,AMHPVIEN=0
..F S AMHPVIEN=$O(^AUPNVPED("AD",AMHVIEN,AMHPVIEN)) Q:'AMHPVIEN D
...S BGUSUB(1)=AMHPVIEN D FIELDS^BGULIST
Q
RAD ; Get RADIOLOGY PCC data
;
I '$D(BGUDRIVR) D Q
.S BGUDRIVR="RAD^AMHSC1",BGUCRFS="",AMHPIEN=BGUBEGIN
.S AMHSDATE=$P(BGUEND,"`",1),AMHEDATE=$P(BGUEND,"`",2)
.S AMHVWNO=$P(BGUEND,"`",3),AMHLBONL=$P(BGUEND,"`",4)
.S AMHVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('AMHVWOPT:AMHVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:AMHPIEN=""
S AMHVWOPT="2"
D RAD1
Q
RAD1 ;
S:'(+AMHVWNO) AMHVWNO=10 S:AMHSDATE="" AMHSDATE="1/1/1980"
S:AMHEDATE="" AMHEDATE="T" S:AMHVWOPT="" AMHVWOPT="0"
S:AMHLBONL="" AMHLBONL="1"
D DT^DILF("",AMHSDATE,.AMHSDAT)
I AMHSDAT=-1 D
.S AMHSDATE="1/1/1980"
.D DT^DILF("",AMHSDATE,.AMHSDAT)
D DT^DILF("",AMHEDATE,.AMHEDAT)
I AMHEDAT=-1 D
.S AMHEDATE="T"
.D DT^DILF("",AMHEDATE,.AMHEDAT)
S AMHC=0,AMHX=0,AMHLIM=$S(AMHVWOPT="0":AMHVWNO,1:99999)
F S AMHX=$O(^AUPNVSIT("AA",AMHPIEN,AMHX)) Q:'AMHX D Q:AMHC=AMHLIM
.S AMHVIEN=""
.F S AMHVIEN=$O(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN)) Q:'AMHVIEN D Q:AMHC=AMHLIM
..S AMHDTA=^AUPNVSIT(AMHVIEN,0),AMHCKD=$P($P(AMHDTA,U,1),".",1)
..Q:AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
..S AMHC=AMHC+1,AMHPVIEN=0
..F S AMHPVIEN=$O(^AUPNVRAD("AD",AMHVIEN,AMHPVIEN)) Q:'AMHPVIEN D
...S BGUSUB(1)=AMHPVIEN D FIELDS^BGULIST
Q
MIC ; Get V MICROBIOLOGY data
;
K ^TMP($J)
I '$D(BGUDRIVR) D Q
.S BGUDRIVR="MIC^AMHSC1",BGUCRFS="",AMHPIEN=BGUBEGIN
.S AMHSDATE=$P(BGUEND,"`",1),AMHEDATE=$P(BGUEND,"`",2)
.S AMHVWNO=$P(BGUEND,"`",3),AMHLBONL=$P(BGUEND,"`",4)
.S AMHVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('AMHVWOPT:AMHVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:AMHPIEN=""
S AMHVWOPT="2"
D MIC1
Q
MIC1 ;
S:'(+AMHVWNO) AMHVWNO=10 S:AMHSDATE="" AMHSDATE="1/1/1980"
S:AMHEDATE="" AMHEDATE="T" S:AMHVWOPT="" AMHVWOPT="0"
S:AMHLBONL="" AMHLBONL="1"
D DT^DILF("",AMHSDATE,.AMHSDAT)
I AMHSDAT=-1 D
.S AMHSDATE="1/1/1980"
.D DT^DILF("",AMHSDATE,.AMHSDAT)
D DT^DILF("",AMHEDATE,.AMHEDAT)
I AMHEDAT=-1 D
.S AMHEDATE="T"
.D DT^DILF("",AMHEDATE,.AMHEDAT)
S AMHC=0,AMHX=0,AMHLIM=$S(AMHVWOPT="0":AMHVWNO,1:99999)
F S AMHX=$O(^AUPNVSIT("AA",AMHPIEN,AMHX)) Q:'AMHX D Q:AMHC=AMHLIM
.S AMHVIEN=""
.F S AMHVIEN=$O(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN)) Q:'AMHVIEN D Q:AMHC=AMHLIM
..S AMHDTA=^AUPNVSIT(AMHVIEN,0),AMHCKD=$P($P(AMHDTA,U,1),".",1)
..Q:AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
..S AMHC=AMHC+1,AMHPVIEN=0
..F S AMHPVIEN=$O(^AUPNVMIC("AD",AMHVIEN,AMHPVIEN)) Q:'AMHPVIEN D
...D MIC2
S AMHJ=$J,AMHMI="MICRO",AMHU=",",AMHZ=")",AMHQ=$C(34) S AMHX="^TMP("_AMHJ_AMHU_AMHQ_AMHMI_AMHQ_AMHZ
F S AMHX=$Q(@AMHX) Q:AMHX'[("^TMP("_AMHJ_AMHU_AMHQ_AMHMI_AMHQ_AMHU) S AMHPVIEN=@AMHX S BGUSUB(1)=AMHPVIEN D FIELDS^BGULIST
Q
MIC2 ;SORT BY PARENT
S AMHPARNT=$S($P($G(^AUPNVMIC(AMHPVIEN,12)),U,8)>0:$P($G(^AUPNVMIC(AMHPVIEN,12)),U,8),1:0)
S AMHACCN=$S($L($P($G(^AUPNVMIC(AMHPVIEN,0)),U,6))>0:$P($G(^AUPNVMIC(AMHPVIEN,0)),U,6),1:0)
S AMHORGSM=$S($P($G(^AUPNVMIC(AMHPVIEN,0)),U,4)>0:$P($G(^AUPNVMIC(AMHPVIEN,0)),U,4),1:0) S:AMHORGSM AMHORGSM=$P($G(^LAB(61.2,AMHORGSM,0)),U,1)
S AMHANTIB=$S($P($G(^AUPNVMIC(AMHPVIEN,0)),U,5)>0:$P($G(^AUPNVMIC(AMHPVIEN,0)),U,5),1:0) S:AMHANTIB AMHANTIB=$P($G(^LAB(62.06,AMHANTIB,0)),U,1)
S ^TMP($J,"MICRO",AMHVIEN,AMHACCN,AMHPARNT,AMHORGSM,AMHANTIB,AMHPVIEN)=AMHPVIEN
Q
PCCMED ; Get PRESCRIPTION PCC DATA
;
K ^TMP($J)
I '$D(BGUDRIVR) D Q
.S BGUDRIVR="PCCMED^AMHSC1",BGUCRFS="",AMHPIEN=BGUBEGIN
.S AMHSDATE=$P(BGUEND,"`",1),AMHEDATE=$P(BGUEND,"`",2)
.S AMHVWNO=$P(BGUEND,"`",3),AMHLBONL=$P(BGUEND,"`",4)
.S AMHVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('AMHVWOPT:AMHVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:AMHPIEN=""
S AMHVWOPT="2"
D PCCMED1
Q
PCCMED1 ;
S:'(+AMHVWNO) AMHVWNO=10 S:AMHSDATE="" AMHSDATE="1/1/1980"
S:AMHEDATE="" AMHEDATE="T" S:AMHVWOPT="" AMHVWOPT="0"
S:AMHLBONL="" AMHLBONL="1"
D DT^DILF("",AMHSDATE,.AMHSDAT)
I AMHSDAT=-1 D
.S AMHSDATE="1/1/1980"
.D DT^DILF("",AMHSDATE,.AMHSDAT)
D DT^DILF("",AMHEDATE,.AMHEDAT)
I AMHEDAT=-1 D
.S AMHEDATE="T"
.D DT^DILF("",AMHEDATE,.AMHEDAT)
S AMHC=0,AMHX=0,AMHLIM=$S(AMHVWOPT="0":AMHVWNO,1:99999)
F S AMHX=$O(^AUPNVSIT("AA",AMHPIEN,AMHX)) Q:'AMHX D Q:AMHC=AMHLIM
.S AMHVIEN=""
.F S AMHVIEN=$O(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN)) Q:'AMHVIEN D Q:AMHC=AMHLIM
..S AMHDTA=^AUPNVSIT(AMHVIEN,0),AMHCKD=$P($P(AMHDTA,U,1),".",1)
..Q:AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
..S AMHC=AMHC+1,AMHPVIEN=0
..F S AMHPVIEN=$O(^AUPNVMED("AD",AMHVIEN,AMHPVIEN)) Q:'AMHPVIEN D
...D PCCMED2
S AMHJ=$J,AMHPMED="PCCMED",AMHU=",",AMHZ=")",AMHQ=$C(34) S AMHX="^TMP("_AMHJ_AMHU_AMHQ_AMHPMED_AMHQ_AMHZ
F S AMHX=$Q(@AMHX) Q:AMHX'[("^TMP("_AMHJ_AMHU_AMHQ_AMHPMED_AMHQ_AMHU) S AMHPVIEN=@AMHX S BGUSUB(1)=AMHPVIEN D FIELDS^BGULIST
Q
PCCMED2 ;SORT BY INVERSE VISIT DATE
S AMHIDT=$S(AMHCKD>2700000:9999999-AMHCKD,1:9999999)
S AMHMED=$S($P($G(^AUPNVMED(AMHPVIEN,0)),U,1)>0:$P($G(^AUPNVMED(AMHPVIEN,0)),U,1),1:0) S:+AMHMED AMHMED=$P($G(^PSDRUG(AMHMED,0)),U,1) S:'AMHMED AMHMED=0
S ^TMP($J,"PCCMED",AMHIDT,AMHVIEN,AMHMED,AMHPVIEN)=AMHPVIEN
Q
MEDP I '$D(BGUDRIVR) D Q
.S BGUDRIVR="MEDP^AMHSC1",BGUCRFS="",AMHPIEN=BGUBEGIN
.S AMHSDATE=$P(BGUEND,"`",1),AMHEDATE=$P(BGUEND,"`",2)
.S AMHVWNO=$P(BGUEND,"`",3),AMHLBONL=$P(BGUEND,"`",4)
.S AMHVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('AMHVWOPT:AMHVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:AMHPIEN=""
S AMHVWOPT="2"
D MEDP1
Q
;
MEDP1 ;
S:'(+AMHVWNO) AMHVWNO=10 S:AMHSDATE="" AMHSDATE="1/1/1980"
S:AMHEDATE="" AMHEDATE="T" S:AMHVWOPT="" AMHVWOPT="0"
S:AMHLBONL="" AMHLBONL="1"
D DT^DILF("",AMHSDATE,.AMHSDAT)
I AMHSDAT=-1 D
.S AMHSDATE="1/1/1980"
.D DT^DILF("",AMHSDATE,.AMHSDAT)
D DT^DILF("",AMHEDATE,.AMHEDAT)
I AMHEDAT=-1 D
.S AMHEDATE="T"
.D DT^DILF("",AMHEDATE,.AMHEDAT)
S AMHC=0,AMHX=0,AMHLIM=$S(AMHVWOPT="0":AMHVWNO,1:99999)
F S AMHX=$O(^AUPNVSIT("AA",AMHPIEN,AMHX)) Q:AMHX="" D Q:AMHC=AMHLIM
.S AMHVIEN=""
.F S AMHVIEN=$O(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN)) Q:AMHVIEN="" D Q:AMHC=AMHLIM
..S AMHDTA=^AUPNVSIT(AMHVIEN,0),AMHCKD=$P($P(AMHDTA,U,1),".",1)
..Q:AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
..S AMHC=AMHC+1,AMHPMIEN=0
..F S AMHPMIEN=$O(^AUPNVMED("AD",AMHVIEN,AMHPMIEN)) Q:AMHPMIEN="" D
...S AMHSTAT=-1
...I $D(^PSRX("APCC",AMHPMIEN)) D
....S AMHRXIEN=$O(^PSRX("APCC",AMHPMIEN,"")) Q:AMHRXIEN=""
....S AMHCK=$O(^PSRX("APCC",AMHPMIEN,AMHRXIEN,""))
....I AMHCK'="" S AMHSTAT=-1 Q
....S AMHSTAT=$P(^PSRX(AMHRXIEN,0),"^",15) S:AMHSTAT="" AMHSTAT=-1
....;I AMHSTAT=0 D MEDP2
...I AMHSTAT=0 S BGUSUB(1)=AMHPMIEN D FIELDS^BGULIST
Q
MEDP2 ;
N DYS,RFLS,ISUDAT,CKDT
S AMHSTAT=-1,AMHRX0=$G(^PSRX(AMHRXIEN,0)) Q:AMHRX0=""
S AMHRX2=$G(^PSRX(AMHRXIEN,2))
S DYS=$P(AMHRX0,U,8),RFLS=$P(AMHRX0,U,9),ISUDAT=$P(AMHRX0,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 AMHSTAT=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 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^AMHSC1",BGUCRFS="",AMHPIEN=BGUBEGIN
.S AMHSDATE=$P(BGUEND,"`",1),AMHEDATE=$P(BGUEND,"`",2)
.S AMHVWNO=$P(BGUEND,"`",3),AMHLBONL=$P(BGUEND,"`",4)
.S AMHVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('AMHVWOPT:AMHVWNO,1:32000)
.S (BGUBEGIN,BGUEND)=""
Q:AMHPIEN=""
S AMHVWOPT="2"
D RXMED1
Q
RXMED1 ;
S:'(+AMHVWNO) AMHVWNO=10 S:AMHSDATE="" AMHSDATE="1/1/1980"
S:AMHEDATE="" AMHEDATE="T" S:AMHVWOPT="" AMHVWOPT="0"
S:AMHLBONL="" AMHLBONL="1"
D DT^DILF("",AMHSDATE,.AMHSDAT)
I AMHSDAT=-1 D
.S AMHSDATE="1/1/1980"
.D DT^DILF("",AMHSDATE,.AMHSDAT)
D DT^DILF("",AMHEDATE,.AMHEDAT)
I AMHEDAT=-1 D
.S AMHEDATE="T"
.D DT^DILF("",AMHEDATE,.AMHEDAT)
S AMHC=0,AMHX=0,AMHLIM=$S(AMHVWOPT="0":AMHVWNO,1:99999)
S ^FJBGU(1)=AMHPIEN
F S AMHX=$O(^PS(55,AMHPIEN,"P",AMHX)) Q:'AMHX D Q:AMHC=AMHLIM
.S AMHVIEN=$P($G(^PS(55,AMHPIEN,"P",AMHX,0)),U,1) Q:+AMHVIEN=0
.S ^FJBGU(1,AMHX)=AMHVIEN
.S AMHRX0=$G(^PSRX(AMHVIEN,0))
.S AMHRX2=$G(^PSRX(AMHVIEN,2))
.S ^FJBGU(AMHVIEN)=AMHRX2
.S AMHCKD=$P($P(AMHRX2,U,1),".",1)
.Q:AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
.S BGUSUB(1)=AMHVIEN D FIELDS^BGULIST
Q
AMHSC1 ; IHS/CMI/LAB - SPECIAL X-REF ROUTINES - ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+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^AMHSC1"
SET BGUCRFS=""
SET AMHPIEN=BGUBEGIN
+2 SET AMHSDATE=$PIECE(BGUEND,"`",1)
SET AMHEDATE=$PIECE(BGUEND,"`",2)
+3 SET AMHVWNO=$PIECE(BGUEND,"`",3)
SET AMHLBONL=$PIECE(BGUEND,"`",4)
+4 SET AMHVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('AMHVWOPT:AMHVWNO,1:32000)
+5 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+6 IF AMHPIEN=""
QUIT
+7 SET AMHVWOPT="2"
+8 DO MED1
+9 QUIT
+10 ;
MED1 ;
+1 IF '(+AMHVWNO)
SET AMHVWNO=10
IF AMHSDATE=""
SET AMHSDATE="1/1/1980"
+2 IF AMHEDATE=""
SET AMHEDATE="T"
IF AMHVWOPT=""
SET AMHVWOPT="0"
+3 IF AMHLBONL=""
SET AMHLBONL="1"
+4 DO DT^DILF("",AMHSDATE,.AMHSDAT)
+5 IF AMHSDAT=-1
Begin DoDot:1
+6 SET AMHSDATE="1/1/1980"
+7 DO DT^DILF("",AMHSDATE,.AMHSDAT)
End DoDot:1
+8 DO DT^DILF("",AMHEDATE,.AMHEDAT)
+9 IF AMHEDAT=-1
Begin DoDot:1
+10 SET AMHEDATE="T"
+11 DO DT^DILF("",AMHEDATE,.AMHEDAT)
End DoDot:1
+12 SET AMHC=0
SET AMHX=0
SET AMHLIM=$SELECT(AMHVWOPT="0":AMHVWNO,1:99999)
+13 FOR
SET AMHX=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX))
IF AMHX=""
QUIT
Begin DoDot:1
+14 SET AMHVIEN=""
+15 FOR
SET AMHVIEN=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN))
IF AMHVIEN=""
QUIT
Begin DoDot:2
+16 SET AMHDTA=^AUPNVSIT(AMHVIEN,0)
SET AMHCKD=$PIECE($PIECE(AMHDTA,U,1),".",1)
+17 IF AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
QUIT
+18 SET AMHC=AMHC+1
SET AMHPMIEN=0
+19 FOR
SET AMHPMIEN=$ORDER(^AUPNVMED("AD",AMHVIEN,AMHPMIEN))
IF AMHPMIEN=""
QUIT
Begin DoDot:3
+20 SET AMHSTAT=-1
+21 IF $DATA(^PSRX("APCC",AMHPMIEN))
Begin DoDot:4
+22 SET AMHRXIEN=$ORDER(^PSRX("APCC",AMHPMIEN,""))
IF AMHRXIEN=""
QUIT
+23 SET AMHCK=$ORDER(^PSRX("APCC",AMHPMIEN,AMHRXIEN,""))
+24 IF AMHCK'=""
SET AMHSTAT=-1
QUIT
+25 SET AMHSTAT=$PIECE(^PSRX(AMHRXIEN,0),"^",15)
IF AMHSTAT=""
SET AMHSTAT=-1
+26 ;I AMHSTAT=0 D MED2
End DoDot:4
+27 IF AMHSTAT=0
SET BGUSUB(1)=AMHPMIEN
DO FIELDS^BGULIST
End DoDot:3
End DoDot:2
IF AMHC=AMHLIM
QUIT
End DoDot:1
IF AMHC=AMHLIM
QUIT
+28 QUIT
MED2 ;
+1 NEW DYS,RFLS,ISUDAT,CKDT
+2 SET AMHSTAT=-1
SET AMHRX0=$GET(^PSRX(AMHRXIEN,0))
IF AMHRX0=""
QUIT
+3 SET AMHRX2=$GET(^PSRX(AMHRXIEN,2))
+4 SET DYS=$PIECE(AMHRX0,U,8)
SET RFLS=$PIECE(AMHRX0,U,9)
SET ISUDAT=$PIECE(AMHRX0,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 AMHSTAT=0
End DoDot:1
+9 QUIT
POV ; Get purpose of visits
+1 ;
+2 IF '$DATA(BGUDRIVR)
Begin DoDot:1
+3 SET BGUDRIVR="POV^AMHSC1"
SET BGUCRFS=""
SET AMHPIEN=BGUBEGIN
+4 SET AMHSDATE=$PIECE(BGUEND,"`",1)
SET AMHEDATE=$PIECE(BGUEND,"`",2)
+5 SET AMHVWNO=$PIECE(BGUEND,"`",3)
SET AMHLBONL=$PIECE(BGUEND,"`",4)
+6 SET AMHVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('AMHVWOPT:AMHVWNO,1:32000)
+7 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+8 IF AMHPIEN=""
QUIT
+9 SET AMHVWOPT="2"
+10 DO POV1
+11 QUIT
POV1 ;
+1 IF '(+AMHVWNO)
SET AMHVWNO=10
IF AMHSDATE=""
SET AMHSDATE="1/1/1980"
+2 IF AMHEDATE=""
SET AMHEDATE="T"
IF AMHVWOPT=""
SET AMHVWOPT="0"
+3 IF AMHLBONL=""
SET AMHLBONL="1"
+4 DO DT^DILF("",AMHSDATE,.AMHSDAT)
+5 IF AMHSDAT=-1
Begin DoDot:1
+6 SET AMHSDATE="1/1/1980"
+7 DO DT^DILF("",AMHSDATE,.AMHSDAT)
End DoDot:1
+8 DO DT^DILF("",AMHEDATE,.AMHEDAT)
+9 IF AMHEDAT=-1
Begin DoDot:1
+10 SET AMHEDATE="T"
+11 DO DT^DILF("",AMHEDATE,.AMHEDAT)
End DoDot:1
+12 SET AMHC=0
SET AMHX=0
SET AMHLIM=$SELECT(AMHVWOPT="0":AMHVWNO,1:99999)
+13 FOR
SET AMHX=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX))
IF AMHX=""
QUIT
Begin DoDot:1
+14 SET AMHVIEN=""
+15 FOR
SET AMHVIEN=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN))
IF AMHVIEN=""
QUIT
Begin DoDot:2
+16 SET AMHDTA=^AUPNVSIT(AMHVIEN,0)
SET AMHCKD=$PIECE($PIECE(AMHDTA,U,1),".",1)
+17 IF AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
QUIT
+18 SET AMHC=AMHC+1
SET AMHPVIEN=0
+19 FOR
SET AMHPVIEN=$ORDER(^AUPNVPOV("AD",AMHVIEN,AMHPVIEN))
IF AMHPVIEN=""
QUIT
Begin DoDot:3
+20 SET BGUSUB(1)=AMHPVIEN
DO FIELDS^BGULIST
End DoDot:3
End DoDot:2
IF AMHC=AMHLIM
QUIT
End DoDot:1
IF AMHC=AMHLIM
QUIT
+21 QUIT
MEAS ;
+1 IF '$DATA(BGUDRIVR)
Begin DoDot:1
+2 SET BGUDRIVR="MEAS^AMHSC1"
SET BGUCRFS=""
SET AMHPIEN=BGUBEGIN
+3 SET AMHSDATE=$PIECE(BGUEND,"`",1)
SET AMHEDATE=$PIECE(BGUEND,"`",2)
+4 SET AMHVWNO=$PIECE(BGUEND,"`",3)
SET AMHLBONL=$PIECE(BGUEND,"`",4)
+5 SET AMHVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('AMHVWOPT:AMHVWNO,1:32000)
+6 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+7 IF AMHPIEN=""
QUIT
+8 SET AMHVWOPT="2"
+9 DO MEAS1
+10 QUIT
MEAS1 ;
+1 IF '(+AMHVWNO)
SET AMHVWNO=10
IF AMHSDATE=""
SET AMHSDATE="1/1/1980"
+2 IF AMHEDATE=""
SET AMHEDATE="T"
IF AMHVWOPT=""
SET AMHVWOPT="0"
+3 IF AMHLBONL=""
SET AMHLBONL="1"
+4 DO DT^DILF("",AMHSDATE,.AMHSDAT)
+5 IF AMHSDAT=-1
Begin DoDot:1
+6 SET AMHSDATE="1/1/1980"
+7 DO DT^DILF("",AMHSDATE,.AMHSDAT)
End DoDot:1
+8 DO DT^DILF("",AMHEDATE,.AMHEDAT)
+9 IF AMHEDAT=-1
Begin DoDot:1
+10 SET AMHEDATE="T"
+11 DO DT^DILF("",AMHEDATE,.AMHEDAT)
End DoDot:1
+12 SET AMHC=0
SET AMHX=0
SET AMHLIM=$SELECT(AMHVWOPT="0":AMHVWNO,1:99999)
+13 FOR
SET AMHX=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX))
IF AMHX=""
QUIT
Begin DoDot:1
+14 SET AMHVIEN=""
+15 FOR
SET AMHVIEN=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN))
IF AMHVIEN=""
QUIT
Begin DoDot:2
+16 SET AMHDTA=^AUPNVSIT(AMHVIEN,0)
SET AMHCKD=$PIECE($PIECE(AMHDTA,U,1),".",1)
+17 IF AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
QUIT
+18 ;Q:'$D(^AUPNVMSR("AD",AMHVIEN))
+19 SET AMHC=AMHC+1
SET AMHMVIEN=0
+20 FOR
SET AMHMVIEN=$ORDER(^AUPNVMSR("AD",AMHVIEN,AMHMVIEN))
IF AMHMVIEN=""
QUIT
Begin DoDot:3
+21 SET BGUSUB(1)=AMHMVIEN
DO FIELDS^BGULIST
End DoDot:3
End DoDot:2
IF AMHC=AMHLIM
QUIT
End DoDot:1
IF AMHC=AMHLIM
QUIT
+22 QUIT
EDP ; Get EDUCATION PROTOCOLS
+1 ;
+2 IF '$DATA(BGUDRIVR)
Begin DoDot:1
+3 SET BGUDRIVR="EDP^AMHSC1"
SET BGUCRFS=""
SET AMHPIEN=BGUBEGIN
+4 SET AMHSDATE=$PIECE(BGUEND,"`",1)
SET AMHEDATE=$PIECE(BGUEND,"`",2)
+5 SET AMHVWNO=$PIECE(BGUEND,"`",3)
SET AMHLBONL=$PIECE(BGUEND,"`",4)
+6 SET AMHVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('AMHVWOPT:AMHVWNO,1:32000)
+7 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+8 IF AMHPIEN=""
QUIT
+9 SET AMHVWOPT="2"
+10 DO EDP1
+11 QUIT
EDP1 ;
+1 IF '(+AMHVWNO)
SET AMHVWNO=10
IF AMHSDATE=""
SET AMHSDATE="1/1/1980"
+2 IF AMHEDATE=""
SET AMHEDATE="T"
IF AMHVWOPT=""
SET AMHVWOPT="0"
+3 IF AMHLBONL=""
SET AMHLBONL="1"
+4 DO DT^DILF("",AMHSDATE,.AMHSDAT)
+5 IF AMHSDAT=-1
Begin DoDot:1
+6 SET AMHSDATE="1/1/1980"
+7 DO DT^DILF("",AMHSDATE,.AMHSDAT)
End DoDot:1
+8 DO DT^DILF("",AMHEDATE,.AMHEDAT)
+9 IF AMHEDAT=-1
Begin DoDot:1
+10 SET AMHEDATE="T"
+11 DO DT^DILF("",AMHEDATE,.AMHEDAT)
End DoDot:1
+12 SET AMHC=0
SET AMHX=0
SET AMHLIM=$SELECT(AMHVWOPT="0":AMHVWNO,1:99999)
+13 FOR
SET AMHX=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX))
IF 'AMHX
QUIT
Begin DoDot:1
+14 SET AMHVIEN=""
+15 FOR
SET AMHVIEN=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN))
IF 'AMHVIEN
QUIT
Begin DoDot:2
+16 SET AMHDTA=^AUPNVSIT(AMHVIEN,0)
SET AMHCKD=$PIECE($PIECE(AMHDTA,U,1),".",1)
+17 IF AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
QUIT
+18 SET AMHC=AMHC+1
SET AMHPVIEN=0
+19 FOR
SET AMHPVIEN=$ORDER(^AUPNVPED("AD",AMHVIEN,AMHPVIEN))
IF 'AMHPVIEN
QUIT
Begin DoDot:3
+20 SET BGUSUB(1)=AMHPVIEN
DO FIELDS^BGULIST
End DoDot:3
End DoDot:2
IF AMHC=AMHLIM
QUIT
End DoDot:1
IF AMHC=AMHLIM
QUIT
+21 QUIT
RAD ; Get RADIOLOGY PCC data
+1 ;
+2 IF '$DATA(BGUDRIVR)
Begin DoDot:1
+3 SET BGUDRIVR="RAD^AMHSC1"
SET BGUCRFS=""
SET AMHPIEN=BGUBEGIN
+4 SET AMHSDATE=$PIECE(BGUEND,"`",1)
SET AMHEDATE=$PIECE(BGUEND,"`",2)
+5 SET AMHVWNO=$PIECE(BGUEND,"`",3)
SET AMHLBONL=$PIECE(BGUEND,"`",4)
+6 SET AMHVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('AMHVWOPT:AMHVWNO,1:32000)
+7 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+8 IF AMHPIEN=""
QUIT
+9 SET AMHVWOPT="2"
+10 DO RAD1
+11 QUIT
RAD1 ;
+1 IF '(+AMHVWNO)
SET AMHVWNO=10
IF AMHSDATE=""
SET AMHSDATE="1/1/1980"
+2 IF AMHEDATE=""
SET AMHEDATE="T"
IF AMHVWOPT=""
SET AMHVWOPT="0"
+3 IF AMHLBONL=""
SET AMHLBONL="1"
+4 DO DT^DILF("",AMHSDATE,.AMHSDAT)
+5 IF AMHSDAT=-1
Begin DoDot:1
+6 SET AMHSDATE="1/1/1980"
+7 DO DT^DILF("",AMHSDATE,.AMHSDAT)
End DoDot:1
+8 DO DT^DILF("",AMHEDATE,.AMHEDAT)
+9 IF AMHEDAT=-1
Begin DoDot:1
+10 SET AMHEDATE="T"
+11 DO DT^DILF("",AMHEDATE,.AMHEDAT)
End DoDot:1
+12 SET AMHC=0
SET AMHX=0
SET AMHLIM=$SELECT(AMHVWOPT="0":AMHVWNO,1:99999)
+13 FOR
SET AMHX=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX))
IF 'AMHX
QUIT
Begin DoDot:1
+14 SET AMHVIEN=""
+15 FOR
SET AMHVIEN=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN))
IF 'AMHVIEN
QUIT
Begin DoDot:2
+16 SET AMHDTA=^AUPNVSIT(AMHVIEN,0)
SET AMHCKD=$PIECE($PIECE(AMHDTA,U,1),".",1)
+17 IF AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
QUIT
+18 SET AMHC=AMHC+1
SET AMHPVIEN=0
+19 FOR
SET AMHPVIEN=$ORDER(^AUPNVRAD("AD",AMHVIEN,AMHPVIEN))
IF 'AMHPVIEN
QUIT
Begin DoDot:3
+20 SET BGUSUB(1)=AMHPVIEN
DO FIELDS^BGULIST
End DoDot:3
End DoDot:2
IF AMHC=AMHLIM
QUIT
End DoDot:1
IF AMHC=AMHLIM
QUIT
+21 QUIT
MIC ; Get V MICROBIOLOGY data
+1 ;
+2 KILL ^TMP($JOB)
+3 IF '$DATA(BGUDRIVR)
Begin DoDot:1
+4 SET BGUDRIVR="MIC^AMHSC1"
SET BGUCRFS=""
SET AMHPIEN=BGUBEGIN
+5 SET AMHSDATE=$PIECE(BGUEND,"`",1)
SET AMHEDATE=$PIECE(BGUEND,"`",2)
+6 SET AMHVWNO=$PIECE(BGUEND,"`",3)
SET AMHLBONL=$PIECE(BGUEND,"`",4)
+7 SET AMHVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('AMHVWOPT:AMHVWNO,1:32000)
+8 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+9 IF AMHPIEN=""
QUIT
+10 SET AMHVWOPT="2"
+11 DO MIC1
+12 QUIT
MIC1 ;
+1 IF '(+AMHVWNO)
SET AMHVWNO=10
IF AMHSDATE=""
SET AMHSDATE="1/1/1980"
+2 IF AMHEDATE=""
SET AMHEDATE="T"
IF AMHVWOPT=""
SET AMHVWOPT="0"
+3 IF AMHLBONL=""
SET AMHLBONL="1"
+4 DO DT^DILF("",AMHSDATE,.AMHSDAT)
+5 IF AMHSDAT=-1
Begin DoDot:1
+6 SET AMHSDATE="1/1/1980"
+7 DO DT^DILF("",AMHSDATE,.AMHSDAT)
End DoDot:1
+8 DO DT^DILF("",AMHEDATE,.AMHEDAT)
+9 IF AMHEDAT=-1
Begin DoDot:1
+10 SET AMHEDATE="T"
+11 DO DT^DILF("",AMHEDATE,.AMHEDAT)
End DoDot:1
+12 SET AMHC=0
SET AMHX=0
SET AMHLIM=$SELECT(AMHVWOPT="0":AMHVWNO,1:99999)
+13 FOR
SET AMHX=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX))
IF 'AMHX
QUIT
Begin DoDot:1
+14 SET AMHVIEN=""
+15 FOR
SET AMHVIEN=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN))
IF 'AMHVIEN
QUIT
Begin DoDot:2
+16 SET AMHDTA=^AUPNVSIT(AMHVIEN,0)
SET AMHCKD=$PIECE($PIECE(AMHDTA,U,1),".",1)
+17 IF AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
QUIT
+18 SET AMHC=AMHC+1
SET AMHPVIEN=0
+19 FOR
SET AMHPVIEN=$ORDER(^AUPNVMIC("AD",AMHVIEN,AMHPVIEN))
IF 'AMHPVIEN
QUIT
Begin DoDot:3
+20 DO MIC2
End DoDot:3
End DoDot:2
IF AMHC=AMHLIM
QUIT
End DoDot:1
IF AMHC=AMHLIM
QUIT
+21 SET AMHJ=$JOB
SET AMHMI="MICRO"
SET AMHU=","
SET AMHZ=")"
SET AMHQ=$CHAR(34)
SET AMHX="^TMP("_AMHJ_AMHU_AMHQ_AMHMI_AMHQ_AMHZ
+22 FOR
SET AMHX=$QUERY(@AMHX)
IF AMHX'[("^TMP("_AMHJ_AMHU_AMHQ_AMHMI_AMHQ_AMHU)
QUIT
SET AMHPVIEN=@AMHX
SET BGUSUB(1)=AMHPVIEN
DO FIELDS^BGULIST
+23 QUIT
MIC2 ;SORT BY PARENT
+1 SET AMHPARNT=$SELECT($PIECE($GET(^AUPNVMIC(AMHPVIEN,12)),U,8)>0:$PIECE($GET(^AUPNVMIC(AMHPVIEN,12)),U,8),1:0)
+2 SET AMHACCN=$SELECT($LENGTH($PIECE($GET(^AUPNVMIC(AMHPVIEN,0)),U,6))>0:$PIECE($GET(^AUPNVMIC(AMHPVIEN,0)),U,6),1:0)
+3 SET AMHORGSM=$SELECT($PIECE($GET(^AUPNVMIC(AMHPVIEN,0)),U,4)>0:$PIECE($GET(^AUPNVMIC(AMHPVIEN,0)),U,4),1:0)
IF AMHORGSM
SET AMHORGSM=$PIECE($GET(^LAB(61.2,AMHORGSM,0)),U,1)
+4 SET AMHANTIB=$SELECT($PIECE($GET(^AUPNVMIC(AMHPVIEN,0)),U,5)>0:$PIECE($GET(^AUPNVMIC(AMHPVIEN,0)),U,5),1:0)
IF AMHANTIB
SET AMHANTIB=$PIECE($GET(^LAB(62.06,AMHANTIB,0)),U,1)
+5 SET ^TMP($JOB,"MICRO",AMHVIEN,AMHACCN,AMHPARNT,AMHORGSM,AMHANTIB,AMHPVIEN)=AMHPVIEN
+6 QUIT
PCCMED ; Get PRESCRIPTION PCC DATA
+1 ;
+2 KILL ^TMP($JOB)
+3 IF '$DATA(BGUDRIVR)
Begin DoDot:1
+4 SET BGUDRIVR="PCCMED^AMHSC1"
SET BGUCRFS=""
SET AMHPIEN=BGUBEGIN
+5 SET AMHSDATE=$PIECE(BGUEND,"`",1)
SET AMHEDATE=$PIECE(BGUEND,"`",2)
+6 SET AMHVWNO=$PIECE(BGUEND,"`",3)
SET AMHLBONL=$PIECE(BGUEND,"`",4)
+7 SET AMHVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('AMHVWOPT:AMHVWNO,1:32000)
+8 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+9 IF AMHPIEN=""
QUIT
+10 SET AMHVWOPT="2"
+11 DO PCCMED1
+12 QUIT
PCCMED1 ;
+1 IF '(+AMHVWNO)
SET AMHVWNO=10
IF AMHSDATE=""
SET AMHSDATE="1/1/1980"
+2 IF AMHEDATE=""
SET AMHEDATE="T"
IF AMHVWOPT=""
SET AMHVWOPT="0"
+3 IF AMHLBONL=""
SET AMHLBONL="1"
+4 DO DT^DILF("",AMHSDATE,.AMHSDAT)
+5 IF AMHSDAT=-1
Begin DoDot:1
+6 SET AMHSDATE="1/1/1980"
+7 DO DT^DILF("",AMHSDATE,.AMHSDAT)
End DoDot:1
+8 DO DT^DILF("",AMHEDATE,.AMHEDAT)
+9 IF AMHEDAT=-1
Begin DoDot:1
+10 SET AMHEDATE="T"
+11 DO DT^DILF("",AMHEDATE,.AMHEDAT)
End DoDot:1
+12 SET AMHC=0
SET AMHX=0
SET AMHLIM=$SELECT(AMHVWOPT="0":AMHVWNO,1:99999)
+13 FOR
SET AMHX=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX))
IF 'AMHX
QUIT
Begin DoDot:1
+14 SET AMHVIEN=""
+15 FOR
SET AMHVIEN=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN))
IF 'AMHVIEN
QUIT
Begin DoDot:2
+16 SET AMHDTA=^AUPNVSIT(AMHVIEN,0)
SET AMHCKD=$PIECE($PIECE(AMHDTA,U,1),".",1)
+17 IF AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
QUIT
+18 SET AMHC=AMHC+1
SET AMHPVIEN=0
+19 FOR
SET AMHPVIEN=$ORDER(^AUPNVMED("AD",AMHVIEN,AMHPVIEN))
IF 'AMHPVIEN
QUIT
Begin DoDot:3
+20 DO PCCMED2
End DoDot:3
End DoDot:2
IF AMHC=AMHLIM
QUIT
End DoDot:1
IF AMHC=AMHLIM
QUIT
+21 SET AMHJ=$JOB
SET AMHPMED="PCCMED"
SET AMHU=","
SET AMHZ=")"
SET AMHQ=$CHAR(34)
SET AMHX="^TMP("_AMHJ_AMHU_AMHQ_AMHPMED_AMHQ_AMHZ
+22 FOR
SET AMHX=$QUERY(@AMHX)
IF AMHX'[("^TMP("_AMHJ_AMHU_AMHQ_AMHPMED_AMHQ_AMHU)
QUIT
SET AMHPVIEN=@AMHX
SET BGUSUB(1)=AMHPVIEN
DO FIELDS^BGULIST
+23 QUIT
PCCMED2 ;SORT BY INVERSE VISIT DATE
+1 SET AMHIDT=$SELECT(AMHCKD>2700000:9999999-AMHCKD,1:9999999)
+2 SET AMHMED=$SELECT($PIECE($GET(^AUPNVMED(AMHPVIEN,0)),U,1)>0:$PIECE($GET(^AUPNVMED(AMHPVIEN,0)),U,1),1:0)
IF +AMHMED
SET AMHMED=$PIECE($GET(^PSDRUG(AMHMED,0)),U,1)
IF 'AMHMED
SET AMHMED=0
+3 SET ^TMP($JOB,"PCCMED",AMHIDT,AMHVIEN,AMHMED,AMHPVIEN)=AMHPVIEN
+4 QUIT
MEDP IF '$DATA(BGUDRIVR)
Begin DoDot:1
+1 SET BGUDRIVR="MEDP^AMHSC1"
SET BGUCRFS=""
SET AMHPIEN=BGUBEGIN
+2 SET AMHSDATE=$PIECE(BGUEND,"`",1)
SET AMHEDATE=$PIECE(BGUEND,"`",2)
+3 SET AMHVWNO=$PIECE(BGUEND,"`",3)
SET AMHLBONL=$PIECE(BGUEND,"`",4)
+4 SET AMHVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('AMHVWOPT:AMHVWNO,1:32000)
+5 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+6 IF AMHPIEN=""
QUIT
+7 SET AMHVWOPT="2"
+8 DO MEDP1
+9 QUIT
+10 ;
MEDP1 ;
+1 IF '(+AMHVWNO)
SET AMHVWNO=10
IF AMHSDATE=""
SET AMHSDATE="1/1/1980"
+2 IF AMHEDATE=""
SET AMHEDATE="T"
IF AMHVWOPT=""
SET AMHVWOPT="0"
+3 IF AMHLBONL=""
SET AMHLBONL="1"
+4 DO DT^DILF("",AMHSDATE,.AMHSDAT)
+5 IF AMHSDAT=-1
Begin DoDot:1
+6 SET AMHSDATE="1/1/1980"
+7 DO DT^DILF("",AMHSDATE,.AMHSDAT)
End DoDot:1
+8 DO DT^DILF("",AMHEDATE,.AMHEDAT)
+9 IF AMHEDAT=-1
Begin DoDot:1
+10 SET AMHEDATE="T"
+11 DO DT^DILF("",AMHEDATE,.AMHEDAT)
End DoDot:1
+12 SET AMHC=0
SET AMHX=0
SET AMHLIM=$SELECT(AMHVWOPT="0":AMHVWNO,1:99999)
+13 FOR
SET AMHX=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX))
IF AMHX=""
QUIT
Begin DoDot:1
+14 SET AMHVIEN=""
+15 FOR
SET AMHVIEN=$ORDER(^AUPNVSIT("AA",AMHPIEN,AMHX,AMHVIEN))
IF AMHVIEN=""
QUIT
Begin DoDot:2
+16 SET AMHDTA=^AUPNVSIT(AMHVIEN,0)
SET AMHCKD=$PIECE($PIECE(AMHDTA,U,1),".",1)
+17 IF AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
QUIT
+18 SET AMHC=AMHC+1
SET AMHPMIEN=0
+19 FOR
SET AMHPMIEN=$ORDER(^AUPNVMED("AD",AMHVIEN,AMHPMIEN))
IF AMHPMIEN=""
QUIT
Begin DoDot:3
+20 SET AMHSTAT=-1
+21 IF $DATA(^PSRX("APCC",AMHPMIEN))
Begin DoDot:4
+22 SET AMHRXIEN=$ORDER(^PSRX("APCC",AMHPMIEN,""))
IF AMHRXIEN=""
QUIT
+23 SET AMHCK=$ORDER(^PSRX("APCC",AMHPMIEN,AMHRXIEN,""))
+24 IF AMHCK'=""
SET AMHSTAT=-1
QUIT
+25 SET AMHSTAT=$PIECE(^PSRX(AMHRXIEN,0),"^",15)
IF AMHSTAT=""
SET AMHSTAT=-1
+26 ;I AMHSTAT=0 D MEDP2
End DoDot:4
+27 IF AMHSTAT=0
SET BGUSUB(1)=AMHPMIEN
DO FIELDS^BGULIST
End DoDot:3
End DoDot:2
IF AMHC=AMHLIM
QUIT
End DoDot:1
IF AMHC=AMHLIM
QUIT
+28 QUIT
MEDP2 ;
+1 NEW DYS,RFLS,ISUDAT,CKDT
+2 SET AMHSTAT=-1
SET AMHRX0=$GET(^PSRX(AMHRXIEN,0))
IF AMHRX0=""
QUIT
+3 SET AMHRX2=$GET(^PSRX(AMHRXIEN,2))
+4 SET DYS=$PIECE(AMHRX0,U,8)
SET RFLS=$PIECE(AMHRX0,U,9)
SET ISUDAT=$PIECE(AMHRX0,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 AMHSTAT=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 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^AMHSC1"
SET BGUCRFS=""
SET AMHPIEN=BGUBEGIN
+5 SET AMHSDATE=$PIECE(BGUEND,"`",1)
SET AMHEDATE=$PIECE(BGUEND,"`",2)
+6 SET AMHVWNO=$PIECE(BGUEND,"`",3)
SET AMHLBONL=$PIECE(BGUEND,"`",4)
+7 SET AMHVWOPT=$PIECE(BGUEND,"`",5)
SET BGUMAX=$SELECT('AMHVWOPT:AMHVWNO,1:32000)
+8 SET (BGUBEGIN,BGUEND)=""
End DoDot:1
QUIT
+9 IF AMHPIEN=""
QUIT
+10 SET AMHVWOPT="2"
+11 DO RXMED1
+12 QUIT
RXMED1 ;
+1 IF '(+AMHVWNO)
SET AMHVWNO=10
IF AMHSDATE=""
SET AMHSDATE="1/1/1980"
+2 IF AMHEDATE=""
SET AMHEDATE="T"
IF AMHVWOPT=""
SET AMHVWOPT="0"
+3 IF AMHLBONL=""
SET AMHLBONL="1"
+4 DO DT^DILF("",AMHSDATE,.AMHSDAT)
+5 IF AMHSDAT=-1
Begin DoDot:1
+6 SET AMHSDATE="1/1/1980"
+7 DO DT^DILF("",AMHSDATE,.AMHSDAT)
End DoDot:1
+8 DO DT^DILF("",AMHEDATE,.AMHEDAT)
+9 IF AMHEDAT=-1
Begin DoDot:1
+10 SET AMHEDATE="T"
+11 DO DT^DILF("",AMHEDATE,.AMHEDAT)
End DoDot:1
+12 SET AMHC=0
SET AMHX=0
SET AMHLIM=$SELECT(AMHVWOPT="0":AMHVWNO,1:99999)
+13 SET ^FJBGU(1)=AMHPIEN
+14 FOR
SET AMHX=$ORDER(^PS(55,AMHPIEN,"P",AMHX))
IF 'AMHX
QUIT
Begin DoDot:1
+15 SET AMHVIEN=$PIECE($GET(^PS(55,AMHPIEN,"P",AMHX,0)),U,1)
IF +AMHVIEN=0
QUIT
+16 SET ^FJBGU(1,AMHX)=AMHVIEN
+17 SET AMHRX0=$GET(^PSRX(AMHVIEN,0))
+18 SET AMHRX2=$GET(^PSRX(AMHVIEN,2))
+19 SET ^FJBGU(AMHVIEN)=AMHRX2
+20 SET AMHCKD=$PIECE($PIECE(AMHRX2,U,1),".",1)
+21 IF AMHCKD=""!(AMHCKD<AMHSDAT)!(AMHCKD>AMHEDAT)
QUIT
+22 SET BGUSUB(1)=AMHVIEN
DO FIELDS^BGULIST
End DoDot:1
IF AMHC=AMHLIM
QUIT
+23 QUIT
