- BPCSC ; IHS/OIT/MJL - SPECIAL CROSS REFERENCE ROUTINE ;
- ;;1.5;BPC;;MAY 26, 2005
- ;
- DX ;FHL 12/31/99
- S BGUCRFS1="AIHS"
- I BGUBEGIN?.N1".".N!(BGUBEGIN?1"V".N.1".".N)!(BGUBEGIN="") D Q
- .I BGUBEGIN'="",$D(^ICD9("BA",BGUBEGIN)) D Q:BGUIEN'=""
- ..S BGUIEN=$O(^ICD9("BA",BGUBEGIN,""))
- ..I BGUIEN'="" S (BGUBEGIN,BGUEND,BGUCRFS,BGUCRFS1)=""
- .S BGUCRFS1="BA"
- I BGUBEGIN?1N.N D
- .S BGUCRFS1="BA"
- .S BGUBEGIN=BGUBEGIN_"."
- .S BGUEND=BGUBEGIN_"~"
- Q
- INTERACT ;
- I '$D(BGUDRIVR) D Q
- .S BGUDRIVR="INTERACT^BPCSC",BGUCRFS="",BPCDIEN2=BGUBEGIN
- .S BPCDIEN1=BGUEND,BGUMAX=32000
- .S (BGUBEGIN,BGUEND)=""
- Q:BPCDIEN1=""!(BPCDIEN2="")
- I $D(^PSDRUG(BPCDIEN1,"ND")),$D(^PSDRUG(BPCDIEN2,"ND")) D INTACT1
- Q
- INTACT1 ;
- S BPCND=^PSDRUG(BPCDIEN1,"ND"),BPCNDF1=$P(BPCND,"^",1)_"A"_$P(BPCND,"^",3)
- S BPCND=^PSDRUG(BPCDIEN2,"ND"),BPCNDF2=$P(BPCND,"^",1)_"A"_$P(BPCND,"^",3)
- S BPCIEN=$O(^PS(56,"APD",BPCNDF1,BPCNDF2,0)) Q:BPCIEN=""
- S BGUSUB(1)=BPCIEN D FIELDS^BGULIST
- ;F BPCX=1:1:$L(BPCDIENS,"`") D
- .S BPCDRGI=$P(BPCDIENS,"`",BPCX)
- .I $D(^PSDRUG(BPCDRGI,"ND")) D
- ..S BPCND=^PSDRUG(BPCDRGI,"ND")
- ..S BPCNDF1=$P(BPCND,"^",1)_"A"_$P(BPCND,"^",3)
- ..S BPCIEN=$O(^PS(56,"APD",BPCNDF1,BPCNDF2,0)) Q:BPCIEN=""
- ..S BGUSUB(1)=BPCIEN D FIELDS^BGULIST
- Q
- MEDS ;
- I '$D(BGUDRIVR) D Q
- .S BGUDRIVR="MEDS^BPCSC",BGUCRFS="",BPCPIEN=BGUBEGIN
- .S BPCOPT=$P(BGUEND,"`",1),BPCSDATE=$P(BGUEND,"`",2)
- .S BPCEDATE=$P(BGUEND,"`",3),BPCLIM=BGUMAX,BGUMAX=32000
- .S (BGUBEGIN,BGUEND)=""
- Q:BPCPIEN=""
- S:BPCOPT=2 BPCLIM=9999999
- S BPCC=0,BPCX=0 F S BPCX=$O(^AUPNVSIT("AA",BPCPIEN,BPCX)) Q:BPCX=""!(BPCC=BPCLIM) D
- .S BPCVIEN="" F S BPCVIEN=$O(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN)) Q:BPCVIEN=""!(BPCC=BPCLIM) D
- ..I BPCOPT=3,'$D(^AUPNVLAB("AD",BPCVIEN)) Q
- ..S BPCY=^AUPNVSIT(BPCVIEN,0),BPCVDT=$P(BPCY,U,1),BPCCKD=$P(BPCVDT,".",1)
- ..I BPCSDATE'="",BPCEDATE'="",((BPCCKD<BPCSDATE)!(BPCCKD>BPCEDATE)) Q
- ..S BPCVMIEN=0,BPCC=BPCC+1 F S BPCVMIEN=$O(^AUPNVMED("AD",BPCVIEN,BPCVMIEN)) Q:BPCVMIEN="" D
- ...S BPCSTAT=0
- ...I $D(^PSRX("APCC",BPCVMIEN)) D
- ....S BPCRXIEN=$O(^PSRX("APCC",BPCVMIEN,"")) Q:BPCRXIEN=""
- ....S BPCCK=$O(^PSRX("APCC",BPCVMIEN,BPCRXIEN,""))
- ....I BPCCK'="" S BPCSTAT=-1 Q
- ....S BPCSTAT=+$P(^PSRX(BPCRXIEN,0),"^",15)
- ...I BPCSTAT=0 S BGUSUB(1)=BPCVMIEN D FIELDS^BGULIST
- Q
- RAD ;
- I '$D(BGUDRIVR) D Q
- .S BGUDRIVR="RAD^BPCSC",BGUCRFS="",BPCPIEN=BGUBEGIN
- .S BPCOPT=$P(BGUEND,"`",1),BPCSDATE=$P(BGUEND,"`",2)
- .S BPCEDATE=$P(BGUEND,"`",3),BPCLIM=BGUMAX,BGUMAX=32000
- .S (BGUBEGIN,BGUEND)=""
- Q:BPCPIEN=""
- S:BPCOPT=2 BPCLIM=9999999
- S BPCC=0,BPCX=0 F S BPCX=$O(^AUPNVSIT("AA",BPCPIEN,BPCX)) Q:BPCX=""!(BPCC=BPCLIM) D
- .S BPCVIEN="" F S BPCVIEN=$O(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN)) Q:BPCVIEN=""!(BPCC=BPCLIM) D
- ..I BPCOPT=3,'$D(^AUPNVLAB("AD",BPCVIEN)) Q
- ..S BPCY=^AUPNVSIT(BPCVIEN,0),BPCVDT=$P(BPCY,U,1),BPCCKD=$P(BPCVDT,".",1)
- ..I BPCSDATE'="",BPCEDATE'="",((BPCCKD<BPCSDATE)!(BPCCKD>BPCEDATE)) Q
- ..S BPCVMIEN=0,BPCC=BPCC+1 F S BPCVMIEN=$O(^AUPNVRAD("AD",BPCVIEN,BPCVMIEN)) Q:BPCVMIEN="" D
- ...S BPCSTAT=0
- ...I $D(^PSRX("APCC",BPCVMIEN)) D
- ....S BPCRXIEN=$O(^PSRX("APCC",BPCVMIEN,"")) Q:BPCRXIEN=""
- ....S BPCCK=$O(^PSRX("APCC",BPCVMIEN,BPCRXIEN,""))
- ....I BPCCK'="" S BPCSTAT=-1 Q
- ....S BPCSTAT=+$P(^PSRX(BPCRXIEN,0),"^",15)
- ...I BPCSTAT=0 S BGUSUB(1)=BPCVMIEN D FIELDS^BGULIST
- Q
- EDP ;
- I '$D(BGUDRIVR) D Q
- .S BGUDRIVR="MEDS^BPCSC",BGUCRFS="",BPCPIEN=BGUBEGIN
- .S BPCOPT=$P(BGUEND,"`",1),BPCSDATE=$P(BGUEND,"`",2)
- .S BPCEDATE=$P(BGUEND,"`",3),BPCLIM=BGUMAX,BGUMAX=32000
- .S (BGUBEGIN,BGUEND)=""
- Q:BPCPIEN=""
- S:BPCOPT=2 BPCLIM=9999999
- S BPCC=0,BPCX=0 F S BPCX=$O(^AUPNVSIT("AA",BPCPIEN,BPCX)) Q:BPCX=""!(BPCC=BPCLIM) D
- .S BPCVIEN="" F S BPCVIEN=$O(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN)) Q:BPCVIEN=""!(BPCC=BPCLIM) D
- ..I BPCOPT=3,'$D(^AUPNVLAB("AD",BPCVIEN)) Q
- ..S BPCY=^AUPNVSIT(BPCVIEN,0),BPCVDT=$P(BPCY,U,1),BPCCKD=$P(BPCVDT,".",1)
- ..I BPCSDATE'="",BPCEDATE'="",((BPCCKD<BPCSDATE)!(BPCCKD>BPCEDATE)) Q
- ..S BPCVMIEN=0,BPCC=BPCC+1 F S BPCVMIEN=$O(^AUPNVMED("AD",BPCVIEN,BPCVMIEN)) Q:BPCVMIEN="" D
- ...S BPCSTAT=0
- ...I $D(^PSRX("APCC",BPCVMIEN)) D
- ....S BPCRXIEN=$O(^PSRX("APCC",BPCVMIEN,"")) Q:BPCRXIEN=""
- ....S BPCCK=$O(^PSRX("APCC",BPCVMIEN,BPCRXIEN,""))
- ....I BPCCK'="" S BPCSTAT=-1 Q
- ....S BPCSTAT=+$P(^PSRX(BPCRXIEN,0),"^",15)
- ...I BPCSTAT=0 S BGUSUB(1)=BPCVMIEN D FIELDS^BGULIST
- Q
- XXXX ;
- I '$D(BGUDRIVR) D Q
- .S BGUDRIVR="MEDS^BPCSC",BGUCRFS="",BPCPIEN=BGUBEGIN
- .S BPCOPT=$P(BGUEND,"`",1),BPCSDATE=$P(BGUEND,"`",2)
- .S BPCEDATE=$P(BGUEND,"`",3),BPCLIM=BGUMAX,BGUMAX=32000
- .S (BGUBEGIN,BGUEND)=""
- Q:BPCPIEN=""
- S:BPCOPT=2 BPCLIM=9999999
- S BPCC=0,BPCX=0 F S BPCX=$O(^AUPNVSIT("AA",BPCPIEN,BPCX)) Q:BPCX=""!(BPCC=BPCLIM) D
- .S BPCVIEN="" F S BPCVIEN=$O(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN)) Q:BPCVIEN=""!(BPCC=BPCLIM) D
- ..I BPCOPT=3,'$D(^AUPNVLAB("AD",BPCVIEN)) Q
- ..S BPCY=^AUPNVSIT(BPCVIEN,0),BPCVDT=$P(BPCY,U,1),BPCCKD=$P(BPCVDT,".",1)
- ..I BPCSDATE'="",BPCEDATE'="",((BPCCKD<BPCSDATE)!(BPCCKD>BPCEDATE)) Q
- ..S BPCVMIEN=0,BPCC=BPCC+1 F S BPCVMIEN=$O(^AUPNVMED("AD",BPCVIEN,BPCVMIEN)) Q:BPCVMIEN="" D
- ...S BPCSTAT=0
- ...I $D(^PSRX("APCC",BPCVMIEN)) D
- ....S BPCRXIEN=$O(^PSRX("APCC",BPCVMIEN,"")) Q:BPCRXIEN=""
- ....S BPCCK=$O(^PSRX("APCC",BPCVMIEN,BPCRXIEN,""))
- ....I BPCCK'="" S BPCSTAT=-1 Q
- ....S BPCSTAT=+$P(^PSRX(BPCRXIEN,0),"^",15)
- ...I BPCSTAT=0 S BGUSUB(1)=BPCVMIEN D FIELDS^BGULIST
- Q
- BPCSC ; IHS/OIT/MJL - SPECIAL CROSS REFERENCE ROUTINE ;
- +1 ;;1.5;BPC;;MAY 26, 2005
- +2 ;
- DX ;FHL 12/31/99
- +1 SET BGUCRFS1="AIHS"
- +2 IF BGUBEGIN?.N1".".N!(BGUBEGIN?1"V".N.1".".N)!(BGUBEGIN="")
- Begin DoDot:1
- +3 IF BGUBEGIN'=""
- IF $DATA(^ICD9("BA",BGUBEGIN))
- Begin DoDot:2
- +4 SET BGUIEN=$ORDER(^ICD9("BA",BGUBEGIN,""))
- +5 IF BGUIEN'=""
- SET (BGUBEGIN,BGUEND,BGUCRFS,BGUCRFS1)=""
- End DoDot:2
- IF BGUIEN'=""
- QUIT
- +6 SET BGUCRFS1="BA"
- End DoDot:1
- QUIT
- +7 IF BGUBEGIN?1N.N
- Begin DoDot:1
- +8 SET BGUCRFS1="BA"
- +9 SET BGUBEGIN=BGUBEGIN_"."
- +10 SET BGUEND=BGUBEGIN_"~"
- End DoDot:1
- +11 QUIT
- INTERACT ;
- +1 IF '$DATA(BGUDRIVR)
- Begin DoDot:1
- +2 SET BGUDRIVR="INTERACT^BPCSC"
- SET BGUCRFS=""
- SET BPCDIEN2=BGUBEGIN
- +3 SET BPCDIEN1=BGUEND
- SET BGUMAX=32000
- +4 SET (BGUBEGIN,BGUEND)=""
- End DoDot:1
- QUIT
- +5 IF BPCDIEN1=""!(BPCDIEN2="")
- QUIT
- +6 IF $DATA(^PSDRUG(BPCDIEN1,"ND"))
- IF $DATA(^PSDRUG(BPCDIEN2,"ND"))
- DO INTACT1
- +7 QUIT
- INTACT1 ;
- +1 SET BPCND=^PSDRUG(BPCDIEN1,"ND")
- SET BPCNDF1=$PIECE(BPCND,"^",1)_"A"_$PIECE(BPCND,"^",3)
- +2 SET BPCND=^PSDRUG(BPCDIEN2,"ND")
- SET BPCNDF2=$PIECE(BPCND,"^",1)_"A"_$PIECE(BPCND,"^",3)
- +3 SET BPCIEN=$ORDER(^PS(56,"APD",BPCNDF1,BPCNDF2,0))
- IF BPCIEN=""
- QUIT
- +4 SET BGUSUB(1)=BPCIEN
- DO FIELDS^BGULIST
- +5 ;F BPCX=1:1:$L(BPCDIENS,"`") D
- +6
- *** ERROR ***
- +7
- *** ERROR ***
- +8
- *** ERROR ***
- +9
- *** ERROR ***
- +10
- *** ERROR ***
- +11
- *** ERROR ***
- +12 QUIT
- MEDS ;
- +1 IF '$DATA(BGUDRIVR)
- Begin DoDot:1
- +2 SET BGUDRIVR="MEDS^BPCSC"
- SET BGUCRFS=""
- SET BPCPIEN=BGUBEGIN
- +3 SET BPCOPT=$PIECE(BGUEND,"`",1)
- SET BPCSDATE=$PIECE(BGUEND,"`",2)
- +4 SET BPCEDATE=$PIECE(BGUEND,"`",3)
- SET BPCLIM=BGUMAX
- SET BGUMAX=32000
- +5 SET (BGUBEGIN,BGUEND)=""
- End DoDot:1
- QUIT
- +6 IF BPCPIEN=""
- QUIT
- +7 IF BPCOPT=2
- SET BPCLIM=9999999
- +8 SET BPCC=0
- SET BPCX=0
- FOR
- SET BPCX=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX))
- IF BPCX=""!(BPCC=BPCLIM)
- QUIT
- Begin DoDot:1
- +9 SET BPCVIEN=""
- FOR
- SET BPCVIEN=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN))
- IF BPCVIEN=""!(BPCC=BPCLIM)
- QUIT
- Begin DoDot:2
- +10 IF BPCOPT=3
- IF '$DATA(^AUPNVLAB("AD",BPCVIEN))
- QUIT
- +11 SET BPCY=^AUPNVSIT(BPCVIEN,0)
- SET BPCVDT=$PIECE(BPCY,U,1)
- SET BPCCKD=$PIECE(BPCVDT,".",1)
- +12 IF BPCSDATE'=""
- IF BPCEDATE'=""
- IF ((BPCCKD<BPCSDATE)!(BPCCKD>BPCEDATE))
- QUIT
- +13 SET BPCVMIEN=0
- SET BPCC=BPCC+1
- FOR
- SET BPCVMIEN=$ORDER(^AUPNVMED("AD",BPCVIEN,BPCVMIEN))
- IF BPCVMIEN=""
- QUIT
- Begin DoDot:3
- +14 SET BPCSTAT=0
- +15 IF $DATA(^PSRX("APCC",BPCVMIEN))
- Begin DoDot:4
- +16 SET BPCRXIEN=$ORDER(^PSRX("APCC",BPCVMIEN,""))
- IF BPCRXIEN=""
- QUIT
- +17 SET BPCCK=$ORDER(^PSRX("APCC",BPCVMIEN,BPCRXIEN,""))
- +18 IF BPCCK'=""
- SET BPCSTAT=-1
- QUIT
- +19 SET BPCSTAT=+$PIECE(^PSRX(BPCRXIEN,0),"^",15)
- End DoDot:4
- +20 IF BPCSTAT=0
- SET BGUSUB(1)=BPCVMIEN
- DO FIELDS^BGULIST
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +21 QUIT
- RAD ;
- +1 IF '$DATA(BGUDRIVR)
- Begin DoDot:1
- +2 SET BGUDRIVR="RAD^BPCSC"
- SET BGUCRFS=""
- SET BPCPIEN=BGUBEGIN
- +3 SET BPCOPT=$PIECE(BGUEND,"`",1)
- SET BPCSDATE=$PIECE(BGUEND,"`",2)
- +4 SET BPCEDATE=$PIECE(BGUEND,"`",3)
- SET BPCLIM=BGUMAX
- SET BGUMAX=32000
- +5 SET (BGUBEGIN,BGUEND)=""
- End DoDot:1
- QUIT
- +6 IF BPCPIEN=""
- QUIT
- +7 IF BPCOPT=2
- SET BPCLIM=9999999
- +8 SET BPCC=0
- SET BPCX=0
- FOR
- SET BPCX=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX))
- IF BPCX=""!(BPCC=BPCLIM)
- QUIT
- Begin DoDot:1
- +9 SET BPCVIEN=""
- FOR
- SET BPCVIEN=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN))
- IF BPCVIEN=""!(BPCC=BPCLIM)
- QUIT
- Begin DoDot:2
- +10 IF BPCOPT=3
- IF '$DATA(^AUPNVLAB("AD",BPCVIEN))
- QUIT
- +11 SET BPCY=^AUPNVSIT(BPCVIEN,0)
- SET BPCVDT=$PIECE(BPCY,U,1)
- SET BPCCKD=$PIECE(BPCVDT,".",1)
- +12 IF BPCSDATE'=""
- IF BPCEDATE'=""
- IF ((BPCCKD<BPCSDATE)!(BPCCKD>BPCEDATE))
- QUIT
- +13 SET BPCVMIEN=0
- SET BPCC=BPCC+1
- FOR
- SET BPCVMIEN=$ORDER(^AUPNVRAD("AD",BPCVIEN,BPCVMIEN))
- IF BPCVMIEN=""
- QUIT
- Begin DoDot:3
- +14 SET BPCSTAT=0
- +15 IF $DATA(^PSRX("APCC",BPCVMIEN))
- Begin DoDot:4
- +16 SET BPCRXIEN=$ORDER(^PSRX("APCC",BPCVMIEN,""))
- IF BPCRXIEN=""
- QUIT
- +17 SET BPCCK=$ORDER(^PSRX("APCC",BPCVMIEN,BPCRXIEN,""))
- +18 IF BPCCK'=""
- SET BPCSTAT=-1
- QUIT
- +19 SET BPCSTAT=+$PIECE(^PSRX(BPCRXIEN,0),"^",15)
- End DoDot:4
- +20 IF BPCSTAT=0
- SET BGUSUB(1)=BPCVMIEN
- DO FIELDS^BGULIST
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +21 QUIT
- EDP ;
- +1 IF '$DATA(BGUDRIVR)
- Begin DoDot:1
- +2 SET BGUDRIVR="MEDS^BPCSC"
- SET BGUCRFS=""
- SET BPCPIEN=BGUBEGIN
- +3 SET BPCOPT=$PIECE(BGUEND,"`",1)
- SET BPCSDATE=$PIECE(BGUEND,"`",2)
- +4 SET BPCEDATE=$PIECE(BGUEND,"`",3)
- SET BPCLIM=BGUMAX
- SET BGUMAX=32000
- +5 SET (BGUBEGIN,BGUEND)=""
- End DoDot:1
- QUIT
- +6 IF BPCPIEN=""
- QUIT
- +7 IF BPCOPT=2
- SET BPCLIM=9999999
- +8 SET BPCC=0
- SET BPCX=0
- FOR
- SET BPCX=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX))
- IF BPCX=""!(BPCC=BPCLIM)
- QUIT
- Begin DoDot:1
- +9 SET BPCVIEN=""
- FOR
- SET BPCVIEN=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN))
- IF BPCVIEN=""!(BPCC=BPCLIM)
- QUIT
- Begin DoDot:2
- +10 IF BPCOPT=3
- IF '$DATA(^AUPNVLAB("AD",BPCVIEN))
- QUIT
- +11 SET BPCY=^AUPNVSIT(BPCVIEN,0)
- SET BPCVDT=$PIECE(BPCY,U,1)
- SET BPCCKD=$PIECE(BPCVDT,".",1)
- +12 IF BPCSDATE'=""
- IF BPCEDATE'=""
- IF ((BPCCKD<BPCSDATE)!(BPCCKD>BPCEDATE))
- QUIT
- +13 SET BPCVMIEN=0
- SET BPCC=BPCC+1
- FOR
- SET BPCVMIEN=$ORDER(^AUPNVMED("AD",BPCVIEN,BPCVMIEN))
- IF BPCVMIEN=""
- QUIT
- Begin DoDot:3
- +14 SET BPCSTAT=0
- +15 IF $DATA(^PSRX("APCC",BPCVMIEN))
- Begin DoDot:4
- +16 SET BPCRXIEN=$ORDER(^PSRX("APCC",BPCVMIEN,""))
- IF BPCRXIEN=""
- QUIT
- +17 SET BPCCK=$ORDER(^PSRX("APCC",BPCVMIEN,BPCRXIEN,""))
- +18 IF BPCCK'=""
- SET BPCSTAT=-1
- QUIT
- +19 SET BPCSTAT=+$PIECE(^PSRX(BPCRXIEN,0),"^",15)
- End DoDot:4
- +20 IF BPCSTAT=0
- SET BGUSUB(1)=BPCVMIEN
- DO FIELDS^BGULIST
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +21 QUIT
- XXXX ;
- +1 IF '$DATA(BGUDRIVR)
- Begin DoDot:1
- +2 SET BGUDRIVR="MEDS^BPCSC"
- SET BGUCRFS=""
- SET BPCPIEN=BGUBEGIN
- +3 SET BPCOPT=$PIECE(BGUEND,"`",1)
- SET BPCSDATE=$PIECE(BGUEND,"`",2)
- +4 SET BPCEDATE=$PIECE(BGUEND,"`",3)
- SET BPCLIM=BGUMAX
- SET BGUMAX=32000
- +5 SET (BGUBEGIN,BGUEND)=""
- End DoDot:1
- QUIT
- +6 IF BPCPIEN=""
- QUIT
- +7 IF BPCOPT=2
- SET BPCLIM=9999999
- +8 SET BPCC=0
- SET BPCX=0
- FOR
- SET BPCX=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX))
- IF BPCX=""!(BPCC=BPCLIM)
- QUIT
- Begin DoDot:1
- +9 SET BPCVIEN=""
- FOR
- SET BPCVIEN=$ORDER(^AUPNVSIT("AA",BPCPIEN,BPCX,BPCVIEN))
- IF BPCVIEN=""!(BPCC=BPCLIM)
- QUIT
- Begin DoDot:2
- +10 IF BPCOPT=3
- IF '$DATA(^AUPNVLAB("AD",BPCVIEN))
- QUIT
- +11 SET BPCY=^AUPNVSIT(BPCVIEN,0)
- SET BPCVDT=$PIECE(BPCY,U,1)
- SET BPCCKD=$PIECE(BPCVDT,".",1)
- +12 IF BPCSDATE'=""
- IF BPCEDATE'=""
- IF ((BPCCKD<BPCSDATE)!(BPCCKD>BPCEDATE))
- QUIT
- +13 SET BPCVMIEN=0
- SET BPCC=BPCC+1
- FOR
- SET BPCVMIEN=$ORDER(^AUPNVMED("AD",BPCVIEN,BPCVMIEN))
- IF BPCVMIEN=""
- QUIT
- Begin DoDot:3
- +14 SET BPCSTAT=0
- +15 IF $DATA(^PSRX("APCC",BPCVMIEN))
- Begin DoDot:4
- +16 SET BPCRXIEN=$ORDER(^PSRX("APCC",BPCVMIEN,""))
- IF BPCRXIEN=""
- QUIT
- +17 SET BPCCK=$ORDER(^PSRX("APCC",BPCVMIEN,BPCRXIEN,""))
- +18 IF BPCCK'=""
- SET BPCSTAT=-1
- QUIT
- +19 SET BPCSTAT=+$PIECE(^PSRX(BPCRXIEN,0),"^",15)
- End DoDot:4
- +20 IF BPCSTAT=0
- SET BGUSUB(1)=BPCVMIEN
- DO FIELDS^BGULIST
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +21 QUIT
