BPCRC8 ; IHS/OIT/MJL - REFERRED CARE GUI RPC ROUTINES ;
;;1.5;BPC;;MAY 26, 2005
;
GETFACE(BPCRES,BPCPIEN,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETFACEDATA
;
EN ;
S U="^",XWBWRAP=1,BPCCTR=0,BPCPIEN=$G(BPCPIEN),BPCPARAM=$G(BPCPARAM)
S BPCS1="`",BPCS2="~"
K BPCRES,BPCTMP
I BPCPIEN="" S BPCRES(1)=-1,BPCRES(2)="PATIENT IEN NOT SENT!" D KILL Q
I '$D(^AUPNPAT(BPCPIEN,0)) S BPCRES(1)=-1,BPCRES(2)="PATIENT IEN IS NOT DEFINED!" D KILL Q
;I BPCPARAM="JASPER" D EN^BPCFACE Q
D GETAUPN,GETDPT,BUILD,KILL
Q
GETAUPN ;
S BPCDTA=$G(^AUPNPAT(BPCPIEN,0)),BPCEDTE=$P(BPCDTA,U,2),BPCLDTE=$P(BPCDTA,U,3),BPCSSNS=$P(BPCDTA,U,23),BPCTREN=$P(BPCDTA,U,7),BPCEMP=$P(BPCDTA,U,19)
S:BPCSSNS'="" BPCSSNS=$P($G(^AUTTSSN(BPCSSNS,0)),U,2) S:BPCSSNS="" BPCSSNS="UNKNOWN"
I BPCEMP'="" S BPCEMP=$P($G(^AUTNEMPL(BPCEMP,0)),U,1)
S BPCDTA=$G(^AUPNPAT(BPCPIEN,11)),BPCCLS=$P(BPCDTA,U,11),BPCCOM=$P(BPCDTA,U,18),BPCTRIB=$P(BPCDTA,U,8),BPCTQT=$P(BPCDTA,U,9),BPCIQT=$P(BPCDTA,U,10),BPCESTAT=$P(BPCDTA,U,12)
I BPCCLS'="" S BPCCLS=$P($G(^AUTTBEN(BPCCLS,0)),U,1)
I BPCTRIB'="" S BPCTRIB=$P($G(^AUTTTRI(BPCTRIB,0)),U,1)
I BPCESTAT'="" S BPCESTAT=$S(BPCESTAT="I":"INELIGIBLE",BPCESTAT="D":"DIRECT ONLY",BPCESTAT="C":"CHS & DIRECT",1:"PENDING VERIFICATION")
S BPCDTA=$G(^AUPNPAT(BPCPIEN,26)),BPCFCTY=$P(BPCDTA,U,2),BPCFST=$P(BPCDTA,U,3),BPCMCTY=$P(BPCDTA,U,5),BPCMST=$P(BPCDTA,U,6)
I BPCFST'="" S BPCFST=$P($G(^DIC(5,BPCFST,0)),U,1)
I BPCMST'="" S BPCMST=$P($G(^DIC(5,BPCMST,0)),U,1)
Q
GETDPT ;
S BPCDTA=$G(^DPT(BPCPIEN,0)),BPCNAM=$P(BPCDTA,U,1),BPCSSN=$P(BPCDTA,U,9),BPCSEX=$P(BPCDTA,U,2),BPCDOB=$P(BPCDTA,U,3),BPCBCITY=$P(BPCDTA,U,11),BPCBSTA=$P(BPCDTA,U,12),BPCREL=$P(BPCDTA,U,8)
S:BPCBSTA'="" BPCBSTA=$P($G(^DIC(5,BPCBSTA,0)),U,1) S:BPCREL'="" BPCREL=$P($G(^DIC(13,BPCREL,0)),U,1)
S BPCSEX=$S(BPCSEX="M":"MALE",BPCSEX="F":"FEMALE",1:""),BPCAGE="",BPCAUN=""
D:BPCDOB'="" GETAGE
S BPCDTA=$G(^DPT(BPCPIEN,".11")),BPCSTIEN=$P(BPCDTA,U,5),BPCCTY=$P(BPCDTA,U,7),BPCADDR1=$P(BPCDTA,U,1),BPCADDR2=$P(BPCDTA,U,2),BPCADDR3=$P(BPCDTA,U,3),BPCCITY=$P(BPCDTA,U,4),BPCZIP=$P(BPCDTA,U,6)
S BPCSTATE="" I BPCSTIEN'="" S BPCSTATE=$P($G(^DIC(5,BPCSTIEN,0)),U,1) S:BPCCTY'="" BPCCTY=$P($G(^DIC(5,BPCSTIEN,1,BPCCTY,0)),U,1)
S BPCDTA=$G(^DPT(BPCPIEN,".13")),BPCHPH=$P(BPCDTA,U,1),BPCOPH=$P(BPCDTA,U,2)
S BPCDTA=$G(^DPT(BPCPIEN,".24")),BPCFNAM=$P(BPCDTA,U,1),BPCMNAM=$P(BPCDTA,U,3)
S BPCDTA=$G(^DPT(BPCPIEN,".33")),BPCEC=$P(BPCDTA,U,1),BPCECAD1=$P(BPCDTA,U,3),BPCECAD2=$P(BPCDTA,U,4),BPCECAD3=$P(BPCDTA,U,5),BPCECCTY=$P(BPCDTA,U,6),BPCECSTA=$P(BPCDTA,U,7),BPCECZIP=$P(BPCDTA,U,8),BPCECPNE=$P(BPCDTA,U,9)
S:BPCECSTA'="" BPCECSTA=$P($G(^DIC(5,BPCECSTA,0)),U,1)
S BPCVET=$G(^DPT(BPCPIEN,"VET"))
S (BPCSRVC,BPCSRVDT,BPCSRVSD,BPCCLAIM)=""
I BPCVET="Y" D
.S BPCDTA=$G(^DPT(BPCPIEN,".32")),BPCSRVC=$P(BPCDTA,U,5),BPCSRVDT=$P(BPCDTA,U,6),BPCSRVSD=$P(BPCDTA,U,7) S:BPCSRVC'="" BPCSRVC=$P($G(^DIC(23,BPCSRVC,0)),U,1)
. S BPCCLAIM=$P($G(^DPT(BPCPIEN,".31")),U,3)
S BPCSCON=$P($G(^DPT(BPCPIEN,".3")),U,1)
Q
BUILD ;
S BPCDTA="DATA"_BPCS1_BPCNAM_BPCS1_BPCEDTE_BPCS1_BPCLDTE_BPCS1_BPCSSN_BPCS1_BPCSSNS_BPCS1_BPCSEX_BPCS1_BPCDOB_BPCS1_BPCAGE_BPCS1_BPCAUN_BPCS1_BPCCLS_BPCS1_BPCCOM
S BPCDTA=BPCDTA_BPCS1_BPCCTY_BPCS1_BPCADDR1_BPCS1_BPCADDR2_BPCS1_BPCADDR3_BPCS1_BPCCITY_BPCS1_BPCSTATE_BPCS1_BPCZIP_BPCS1_BPCHPH_BPCS1_BPCOPH_BPCS1_BPCTRIB_BPCS1_BPCTQT
S BPCDTA=BPCDTA_BPCS1_BPCIQT_BPCS1_BPCTREN_BPCS1_BPCBCITY_BPCS1_BPCBSTA_BPCS1_BPCREL_BPCS1_BPCFNAM_BPCS1_BPCFCTY_BPCS1_BPCFST_BPCS1_BPCMNAM_BPCS1_BPCMCTY_BPCS1_BPCMST
S BPCDTA=BPCDTA_BPCS1_BPCEC_BPCS1_BPCECAD1_BPCS1_BPCECAD2_BPCS1_BPCECAD3_BPCS1_BPCECCTY_BPCS1_BPCECSTA_BPCS1_BPCECZIP_BPCS1_BPCECPNE_BPCS1_BPCEMP_BPCS1_BPCESTAT
S BPCDTA=BPCDTA_BPCS1_BPCVET_BPCS1_BPCSRVC_BPCS1_BPCSRVDT_BPCS1_BPCSRVSD_BPCS1_BPCSCON_BPCS1_BPCCLAIM
S BPCCTR=BPCCTR+1,BPCRES(BPCCTR)=BPCDTA
D BUILD1,BUILD2,BUILD3,BUILD4,BUILD5,BUILD6,BUILD7,BUILD8
S BPCRES(0)=BPCCTR
Q
BUILD1 ;
S BPCX=0,BPCD="",BPCC=0 F S BPCX=$O(^AUPNPAT(BPCPIEN,43,BPCX)) Q:BPCX=""!(BPCX'?1.N) S BPCDTA=^(BPCX,0),BPCY=$P(BPCDTA,U,1),BPCQ=$P(BPCDTA,U,2) S:BPCY'="" BPCY=$P($G(^AUTTTRI(BPCY,0)),U,1) I BPCY'=BPCTRIB D
. S BPCC=BPCC+1
. S:BPCD'="" BPCD=BPCD_BPCS2_BPCY_U_BPCQ S:BPCD="" BPCD=BPCY_U_BPCQ
S:BPCC>0 BPCCTR=BPCCTR+1,BPCRES(BPCCTR)="TRIBES"_BPCS1_BPCC_BPCS1_BPCD
Q
BUILD2 ;
Q:'$D(^AUPNMCR("B",BPCPIEN))
S BPCX="",BPCD="",BPCC=0 F S BPCX=$O(^AUPNMCR("B",BPCPIEN,BPCX)) Q:BPCX=""!(BPCX'?1.N) S BPCDTA=$G(^AUPNMCR(BPCX,0)) D
. S BPCN=$P(BPCDTA,U,3),BPCSUF=$P(BPCDTA,U,4)
. S:BPCSUF'="" BPCSUF=$P($G(^AUTTMCS(BPCSUF,0)),U,1)
. S BPCY=0 F S BPCY=$O(^AUPNMCR(BPCX,11,BPCY)) Q:BPCY=""!(BPCY'?1.N) D
.. S BPCDTA=^AUPNMCR(BPCX,11,BPCY,0),BPCC=BPCC+1
.. S:BPCD'="" BPCD=BPCD_BPCS2_BPCDTA
.. S:BPCD="" BPCD=BPCDTA
S:BPCC>0 BPCCTR=BPCCTR+1,BPCRES(BPCCTR)="MCR"_BPCS1_BPCN_BPCSUF_BPCS1_BPCC_BPCS1_BPCD
Q
BUILD3 ;
Q:'$D(^AUPNMCD("B",BPCPIEN))
S BPCX="",BPCD="",BPCC=0
F S BPCX=$O(^AUPNMCD("B",BPCPIEN,BPCX)) Q:BPCX=""!(BPCX'?1.N) D
. S BPCDTA=$G(^AUPNMCD(BPCX,0)),BPCN=$P(BPCDTA,U,3),BPCP=$P(BPCDTA,U,10)
. S:BPCP'="" BPCP=$P($G(^AUTNINS(BPCP,0)),U,1)
. S BPCY=0 F S BPCY=$O(^AUPNMCD(BPCX,11,BPCY)) Q:BPCY=""!(BPCY'?1.N) D
.. S BPCDTA=^AUPNMCD(BPCX,11,BPCY,0),BPCC=BPCC+1
.. S:BPCD'="" BPCD=BPCD_BPCS2_BPCDTA
.. S:BPCD="" BPCD=BPCDTA
S:BPCC>0 BPCCTR=BPCCTR+1,BPCRES(BPCCTR)="MCD"_BPCS1_BPCN_BPCS1_BPCC_BPCS1_BPCD_BPCS1_BPCP
Q
BUILD4 ;
Q:'$D(^AUPNPRVT("B",BPCPIEN))
S BPCX="",BPCD="",BPCC=0 F S BPCX=$O(^AUPNPRVT("B",BPCPIEN,BPCX)) Q:BPCX=""!(BPCX'?1.N) S BPCY=0 F S BPCY=$O(^AUPNPRVT(BPCX,11,BPCY)) Q:BPCY=""!(BPCY'?1.N) D
. S BPCDTA=^AUPNPRVT(BPCX,11,BPCY,0),BPCC=BPCC+1,BPCN=$P(BPCDTA,U,1) S:BPCN'="" BPCN=$G(^AUTNINS(BPCN,4))
. S:BPCD'="" BPCD=BPCD_BPCS2_BPCN_U_$P(BPCDTA,U,2)_U_$P(BPCDTA,U,6)_U_$P(BPCDTA,U,7)
. S:BPCD="" BPCD=BPCN_U_$P(BPCDTA,U,2)_U_$P(BPCDTA,U,6)_U_$P(BPCDTA,U,7)
S:BPCC>0 BPCCTR=BPCCTR+1,BPCRES(BPCCTR)="PI"_BPCS1_BPCC_BPCS1_BPCD
Q
BUILD5 ;
Q:'$D(^DPT(BPCPIEN,".01"))
S BPCX=0,BPCD="",BPCC=0 F S BPCX=$O(^DPT(BPCPIEN,".01",BPCX)) Q:BPCX=""!(BPCX'?1.N) D
. S BPCDTA=^DPT(BPCPIEN,".01",BPCX,0),BPCC=BPCC+1,BPCN=$P(BPCDTA,U,1)
. S:BPCD'="" BPCD=BPCD_U_BPCN
. S:BPCD="" BPCD=BPCN
S:BPCC>0 BPCCTR=BPCCTR+1,BPCRES(BPCCTR)="NAMES"_BPCS1_BPCC_BPCS1_BPCD
Q
BUILD6 ;
Q:'$D(^AUPNPAT(BPCPIEN,41,0))
S BPCX=0,BPCD="",BPCC=0 F S BPCX=$O(^AUPNPAT(BPCPIEN,41,BPCX)) Q:BPCX=""!(BPCX'?1.N) I BPCX'=$G(DUZ(2)) D
. S BPCDTA=^(BPCX,0),BPCC=BPCC+1,BPCN=$P(BPCDTA,U,2),BPCY=$P($G(^DIC(4,BPCX,0)),U,1)
. S:BPCD'="" BPCD=BPCD_BPCS2_BPCY_U_BPCN
. S:BPCD="" BPCD=BPCY_U_BPCN
S:BPCC>0 BPCCTR=BPCCTR+1,BPCRES(BPCCTR)="REGS"_BPCS1_BPCC_BPCS1_BPCD
Q
BUILD7 ;
Q:'$D(^AUPNPAT(BPCPIEN,12,0))
S BPCX=0,BPCD="",BPCC=0 F S BPCX=$O(^AUPNPAT(BPCPIEN,12,BPCX)) Q:BPCX=""!(BPCX'?1.N) D
. S BPCDTA=^AUPNPAT(BPCPIEN,12,BPCX,0),BPCC=BPCC+1,BPCN=$P(BPCDTA,U,1)
. S:BPCD'="" BPCD=BPCD_U_BPCN
. S:BPCD="" BPCD=BPCN
S:BPCC>0 BPCCTR=BPCCTR+1,BPCRES(BPCCTR)="HOME"_BPCS1_BPCC_BPCS1_BPCD
Q
BUILD8 ;
Q:'$D(^AUPNPAT(BPCPIEN,13,0))
S BPCX=0,BPCD="",BPCC=0 F S BPCX=$O(^AUPNPAT(BPCPIEN,13,BPCX)) Q:BPCX=""!(BPCX'?1.N) D
. S BPCDTA=^AUPNPAT(BPCPIEN,13,BPCX,0),BPCC=BPCC+1,BPCN=$P(BPCDTA,U,1)
. S:BPCD'="" BPCD=BPCD_U_BPCN
. S:BPCD="" BPCD=BPCN
S:BPCC>0 BPCCTR=BPCCTR+1,BPCRES(BPCCTR)="ADD"_BPCS1_BPCC_BPCS1_BPCD
Q
GETAGE ;
S %H=+$H D YMD^%DTC S BPCNOW=X
S X1=BPCNOW,X2=BPCDOB D ^%DTC S BPCAGE=X\365.25
I BPCAGE S BPCAUN="YRS" Q
I X#(365.25)>30.5 S BPCAGE=X#(365.25)\30.5,BPCAUN="MONTHS" Q
S BPCAGE=X,BPCAUN="DAYS"
K BPCNOW
Q
;
KILL ;
K BPCNAM,BPCEDTE,BPCLDTE,BPCSSN,BPCSEX,BPCDOB,BPCAGE,BPCAUN,BPCCLS,BPCCOM,BPCCTY,BPCADDR1,BPCADDR2,BPCADDR3,BPCCITY,BPCSTAT,BPCZIP,BPCHPH,BPCOPH
K BPCTRIB,BPCTQT,BPCIQT,BPCTREN,BPCBCITY,BPCBSTA,BPCREL,BPCFNAM,BPCFCTY,BPCFST,BPCMNAM,BPCMCTY,BPCMST,BPCEC,BPCECAD1,BPCECAD2,BPCECAD3
K BPCECCTY,BPCECSTA,BPCECZIP,BPCECPNE,BPCEMP,BPCESTAT,BPCVET,BPCSRVC,BPCSAVDT,BPCSRVSD,BPCSCON,BPCCLAIM
K BPCC,BPCCTR,BPCD,BPCDTA,BPCN,BPCNOW,BPCQ,BPCS1,BPCS2,BPCSRVDT,BPCSSNS,BPCSTATE,BPCSTIEN,BPCSUF,BPCX,BPCY
Q
BPCRC8 ; IHS/OIT/MJL - REFERRED CARE GUI RPC ROUTINES ;
+1 ;;1.5;BPC;;MAY 26, 2005
+2 ;
GETFACE(BPCRES,BPCPIEN,BPCPARAM) ;EP CALL FROM REMOTE PROC: BPC GETFACEDATA
+1 ;
EN ;
+1 SET U="^"
SET XWBWRAP=1
SET BPCCTR=0
SET BPCPIEN=$GET(BPCPIEN)
SET BPCPARAM=$GET(BPCPARAM)
+2 SET BPCS1="`"
SET BPCS2="~"
+3 KILL BPCRES,BPCTMP
+4 IF BPCPIEN=""
SET BPCRES(1)=-1
SET BPCRES(2)="PATIENT IEN NOT SENT!"
DO KILL
QUIT
+5 IF '$DATA(^AUPNPAT(BPCPIEN,0))
SET BPCRES(1)=-1
SET BPCRES(2)="PATIENT IEN IS NOT DEFINED!"
DO KILL
QUIT
+6 ;I BPCPARAM="JASPER" D EN^BPCFACE Q
+7 DO GETAUPN
DO GETDPT
DO BUILD
DO KILL
+8 QUIT
GETAUPN ;
+1 SET BPCDTA=$GET(^AUPNPAT(BPCPIEN,0))
SET BPCEDTE=$PIECE(BPCDTA,U,2)
SET BPCLDTE=$PIECE(BPCDTA,U,3)
SET BPCSSNS=$PIECE(BPCDTA,U,23)
SET BPCTREN=$PIECE(BPCDTA,U,7)
SET BPCEMP=$PIECE(BPCDTA,U,19)
+2 IF BPCSSNS'=""
SET BPCSSNS=$PIECE($GET(^AUTTSSN(BPCSSNS,0)),U,2)
IF BPCSSNS=""
SET BPCSSNS="UNKNOWN"
+3 IF BPCEMP'=""
SET BPCEMP=$PIECE($GET(^AUTNEMPL(BPCEMP,0)),U,1)
+4 SET BPCDTA=$GET(^AUPNPAT(BPCPIEN,11))
SET BPCCLS=$PIECE(BPCDTA,U,11)
SET BPCCOM=$PIECE(BPCDTA,U,18)
SET BPCTRIB=$PIECE(BPCDTA,U,8)
SET BPCTQT=$PIECE(BPCDTA,U,9)
SET BPCIQT=$PIECE(BPCDTA,U,10)
SET BPCESTAT=$PIECE(BPCDTA,U,12)
+5 IF BPCCLS'=""
SET BPCCLS=$PIECE($GET(^AUTTBEN(BPCCLS,0)),U,1)
+6 IF BPCTRIB'=""
SET BPCTRIB=$PIECE($GET(^AUTTTRI(BPCTRIB,0)),U,1)
+7 IF BPCESTAT'=""
SET BPCESTAT=$SELECT(BPCESTAT="I":"INELIGIBLE",BPCESTAT="D":"DIRECT ONLY",BPCESTAT="C":"CHS & DIRECT",1:"PENDING VERIFICATION")
+8 SET BPCDTA=$GET(^AUPNPAT(BPCPIEN,26))
SET BPCFCTY=$PIECE(BPCDTA,U,2)
SET BPCFST=$PIECE(BPCDTA,U,3)
SET BPCMCTY=$PIECE(BPCDTA,U,5)
SET BPCMST=$PIECE(BPCDTA,U,6)
+9 IF BPCFST'=""
SET BPCFST=$PIECE($GET(^DIC(5,BPCFST,0)),U,1)
+10 IF BPCMST'=""
SET BPCMST=$PIECE($GET(^DIC(5,BPCMST,0)),U,1)
+11 QUIT
GETDPT ;
+1 SET BPCDTA=$GET(^DPT(BPCPIEN,0))
SET BPCNAM=$PIECE(BPCDTA,U,1)
SET BPCSSN=$PIECE(BPCDTA,U,9)
SET BPCSEX=$PIECE(BPCDTA,U,2)
SET BPCDOB=$PIECE(BPCDTA,U,3)
SET BPCBCITY=$PIECE(BPCDTA,U,11)
SET BPCBSTA=$PIECE(BPCDTA,U,12)
SET BPCREL=$PIECE(BPCDTA,U,8)
+2 IF BPCBSTA'=""
SET BPCBSTA=$PIECE($GET(^DIC(5,BPCBSTA,0)),U,1)
IF BPCREL'=""
SET BPCREL=$PIECE($GET(^DIC(13,BPCREL,0)),U,1)
+3 SET BPCSEX=$SELECT(BPCSEX="M":"MALE",BPCSEX="F":"FEMALE",1:"")
SET BPCAGE=""
SET BPCAUN=""
+4 IF BPCDOB'=""
DO GETAGE
+5 SET BPCDTA=$GET(^DPT(BPCPIEN,".11"))
SET BPCSTIEN=$PIECE(BPCDTA,U,5)
SET BPCCTY=$PIECE(BPCDTA,U,7)
SET BPCADDR1=$PIECE(BPCDTA,U,1)
SET BPCADDR2=$PIECE(BPCDTA,U,2)
SET BPCADDR3=$PIECE(BPCDTA,U,3)
SET BPCCITY=$PIECE(BPCDTA,U,4)
SET BPCZIP=$PIECE(BPCDTA,U,6)
+6 SET BPCSTATE=""
IF BPCSTIEN'=""
SET BPCSTATE=$PIECE($GET(^DIC(5,BPCSTIEN,0)),U,1)
IF BPCCTY'=""
SET BPCCTY=$PIECE($GET(^DIC(5,BPCSTIEN,1,BPCCTY,0)),U,1)
+7 SET BPCDTA=$GET(^DPT(BPCPIEN,".13"))
SET BPCHPH=$PIECE(BPCDTA,U,1)
SET BPCOPH=$PIECE(BPCDTA,U,2)
+8 SET BPCDTA=$GET(^DPT(BPCPIEN,".24"))
SET BPCFNAM=$PIECE(BPCDTA,U,1)
SET BPCMNAM=$PIECE(BPCDTA,U,3)
+9 SET BPCDTA=$GET(^DPT(BPCPIEN,".33"))
SET BPCEC=$PIECE(BPCDTA,U,1)
SET BPCECAD1=$PIECE(BPCDTA,U,3)
SET BPCECAD2=$PIECE(BPCDTA,U,4)
SET BPCECAD3=$PIECE(BPCDTA,U,5)
SET BPCECCTY=$PIECE(BPCDTA,U,6)
SET BPCECSTA=$PIECE(BPCDTA,U,7)
SET BPCECZIP=$PIECE(BPCDTA,U,8)
SET BPCECPNE=$PIECE(BPCDTA,U,9)
+10 IF BPCECSTA'=""
SET BPCECSTA=$PIECE($GET(^DIC(5,BPCECSTA,0)),U,1)
+11 SET BPCVET=$GET(^DPT(BPCPIEN,"VET"))
+12 SET (BPCSRVC,BPCSRVDT,BPCSRVSD,BPCCLAIM)=""
+13 IF BPCVET="Y"
Begin DoDot:1
+14 SET BPCDTA=$GET(^DPT(BPCPIEN,".32"))
SET BPCSRVC=$PIECE(BPCDTA,U,5)
SET BPCSRVDT=$PIECE(BPCDTA,U,6)
SET BPCSRVSD=$PIECE(BPCDTA,U,7)
IF BPCSRVC'=""
SET BPCSRVC=$PIECE($GET(^DIC(23,BPCSRVC,0)),U,1)
+15 SET BPCCLAIM=$PIECE($GET(^DPT(BPCPIEN,".31")),U,3)
End DoDot:1
+16 SET BPCSCON=$PIECE($GET(^DPT(BPCPIEN,".3")),U,1)
+17 QUIT
BUILD ;
+1 SET BPCDTA="DATA"_BPCS1_BPCNAM_BPCS1_BPCEDTE_BPCS1_BPCLDTE_BPCS1_BPCSSN_BPCS1_BPCSSNS_BPCS1_BPCSEX_BPCS1_BPCDOB_BPCS1_BPCAGE_BPCS1_BPCAUN_BPCS1_BPCCLS_BPCS1_BPCCOM
+2 SET BPCDTA=BPCDTA_BPCS1_BPCCTY_BPCS1_BPCADDR1_BPCS1_BPCADDR2_BPCS1_BPCADDR3_BPCS1_BPCCITY_BPCS1_BPCSTATE_BPCS1_BPCZIP_BPCS1_BPCHPH_BPCS1_BPCOPH_BPCS1_BPCTRIB_BPCS1_BPCTQT
+3 SET BPCDTA=BPCDTA_BPCS1_BPCIQT_BPCS1_BPCTREN_BPCS1_BPCBCITY_BPCS1_BPCBSTA_BPCS1_BPCREL_BPCS1_BPCFNAM_BPCS1_BPCFCTY_BPCS1_BPCFST_BPCS1_BPCMNAM_BPCS1_BPCMCTY_BPCS1_BPCMST
+4 SET BPCDTA=BPCDTA_BPCS1_BPCEC_BPCS1_BPCECAD1_BPCS1_BPCECAD2_BPCS1_BPCECAD3_BPCS1_BPCECCTY_BPCS1_BPCECSTA_BPCS1_BPCECZIP_BPCS1_BPCECPNE_BPCS1_BPCEMP_BPCS1_BPCESTAT
+5 SET BPCDTA=BPCDTA_BPCS1_BPCVET_BPCS1_BPCSRVC_BPCS1_BPCSRVDT_BPCS1_BPCSRVSD_BPCS1_BPCSCON_BPCS1_BPCCLAIM
+6 SET BPCCTR=BPCCTR+1
SET BPCRES(BPCCTR)=BPCDTA
+7 DO BUILD1
DO BUILD2
DO BUILD3
DO BUILD4
DO BUILD5
DO BUILD6
DO BUILD7
DO BUILD8
+8 SET BPCRES(0)=BPCCTR
+9 QUIT
BUILD1 ;
+1 SET BPCX=0
SET BPCD=""
SET BPCC=0
FOR
SET BPCX=$ORDER(^AUPNPAT(BPCPIEN,43,BPCX))
IF BPCX=""!(BPCX'?1.N)
QUIT
SET BPCDTA=^(BPCX,0)
SET BPCY=$PIECE(BPCDTA,U,1)
SET BPCQ=$PIECE(BPCDTA,U,2)
IF BPCY'=""
SET BPCY=$PIECE($GET(^AUTTTRI(BPCY,0)),U,1)
IF BPCY'=BPCTRIB
Begin DoDot:1
+2 SET BPCC=BPCC+1
+3 IF BPCD'=""
SET BPCD=BPCD_BPCS2_BPCY_U_BPCQ
IF BPCD=""
SET BPCD=BPCY_U_BPCQ
End DoDot:1
+4 IF BPCC>0
SET BPCCTR=BPCCTR+1
SET BPCRES(BPCCTR)="TRIBES"_BPCS1_BPCC_BPCS1_BPCD
+5 QUIT
BUILD2 ;
+1 IF '$DATA(^AUPNMCR("B",BPCPIEN))
QUIT
+2 SET BPCX=""
SET BPCD=""
SET BPCC=0
FOR
SET BPCX=$ORDER(^AUPNMCR("B",BPCPIEN,BPCX))
IF BPCX=""!(BPCX'?1.N)
QUIT
SET BPCDTA=$GET(^AUPNMCR(BPCX,0))
Begin DoDot:1
+3 SET BPCN=$PIECE(BPCDTA,U,3)
SET BPCSUF=$PIECE(BPCDTA,U,4)
+4 IF BPCSUF'=""
SET BPCSUF=$PIECE($GET(^AUTTMCS(BPCSUF,0)),U,1)
+5 SET BPCY=0
FOR
SET BPCY=$ORDER(^AUPNMCR(BPCX,11,BPCY))
IF BPCY=""!(BPCY'?1.N)
QUIT
Begin DoDot:2
+6 SET BPCDTA=^AUPNMCR(BPCX,11,BPCY,0)
SET BPCC=BPCC+1
+7 IF BPCD'=""
SET BPCD=BPCD_BPCS2_BPCDTA
+8 IF BPCD=""
SET BPCD=BPCDTA
End DoDot:2
End DoDot:1
+9 IF BPCC>0
SET BPCCTR=BPCCTR+1
SET BPCRES(BPCCTR)="MCR"_BPCS1_BPCN_BPCSUF_BPCS1_BPCC_BPCS1_BPCD
+10 QUIT
BUILD3 ;
+1 IF '$DATA(^AUPNMCD("B",BPCPIEN))
QUIT
+2 SET BPCX=""
SET BPCD=""
SET BPCC=0
+3 FOR
SET BPCX=$ORDER(^AUPNMCD("B",BPCPIEN,BPCX))
IF BPCX=""!(BPCX'?1.N)
QUIT
Begin DoDot:1
+4 SET BPCDTA=$GET(^AUPNMCD(BPCX,0))
SET BPCN=$PIECE(BPCDTA,U,3)
SET BPCP=$PIECE(BPCDTA,U,10)
+5 IF BPCP'=""
SET BPCP=$PIECE($GET(^AUTNINS(BPCP,0)),U,1)
+6 SET BPCY=0
FOR
SET BPCY=$ORDER(^AUPNMCD(BPCX,11,BPCY))
IF BPCY=""!(BPCY'?1.N)
QUIT
Begin DoDot:2
+7 SET BPCDTA=^AUPNMCD(BPCX,11,BPCY,0)
SET BPCC=BPCC+1
+8 IF BPCD'=""
SET BPCD=BPCD_BPCS2_BPCDTA
+9 IF BPCD=""
SET BPCD=BPCDTA
End DoDot:2
End DoDot:1
+10 IF BPCC>0
SET BPCCTR=BPCCTR+1
SET BPCRES(BPCCTR)="MCD"_BPCS1_BPCN_BPCS1_BPCC_BPCS1_BPCD_BPCS1_BPCP
+11 QUIT
BUILD4 ;
+1 IF '$DATA(^AUPNPRVT("B",BPCPIEN))
QUIT
+2 SET BPCX=""
SET BPCD=""
SET BPCC=0
FOR
SET BPCX=$ORDER(^AUPNPRVT("B",BPCPIEN,BPCX))
IF BPCX=""!(BPCX'?1.N)
QUIT
SET BPCY=0
FOR
SET BPCY=$ORDER(^AUPNPRVT(BPCX,11,BPCY))
IF BPCY=""!(BPCY'?1.N)
QUIT
Begin DoDot:1
+3 SET BPCDTA=^AUPNPRVT(BPCX,11,BPCY,0)
SET BPCC=BPCC+1
SET BPCN=$PIECE(BPCDTA,U,1)
IF BPCN'=""
SET BPCN=$GET(^AUTNINS(BPCN,4))
+4 IF BPCD'=""
SET BPCD=BPCD_BPCS2_BPCN_U_$PIECE(BPCDTA,U,2)_U_$PIECE(BPCDTA,U,6)_U_$PIECE(BPCDTA,U,7)
+5 IF BPCD=""
SET BPCD=BPCN_U_$PIECE(BPCDTA,U,2)_U_$PIECE(BPCDTA,U,6)_U_$PIECE(BPCDTA,U,7)
End DoDot:1
+6 IF BPCC>0
SET BPCCTR=BPCCTR+1
SET BPCRES(BPCCTR)="PI"_BPCS1_BPCC_BPCS1_BPCD
+7 QUIT
BUILD5 ;
+1 IF '$DATA(^DPT(BPCPIEN,".01"))
QUIT
+2 SET BPCX=0
SET BPCD=""
SET BPCC=0
FOR
SET BPCX=$ORDER(^DPT(BPCPIEN,".01",BPCX))
IF BPCX=""!(BPCX'?1.N)
QUIT
Begin DoDot:1
+3 SET BPCDTA=^DPT(BPCPIEN,".01",BPCX,0)
SET BPCC=BPCC+1
SET BPCN=$PIECE(BPCDTA,U,1)
+4 IF BPCD'=""
SET BPCD=BPCD_U_BPCN
+5 IF BPCD=""
SET BPCD=BPCN
End DoDot:1
+6 IF BPCC>0
SET BPCCTR=BPCCTR+1
SET BPCRES(BPCCTR)="NAMES"_BPCS1_BPCC_BPCS1_BPCD
+7 QUIT
BUILD6 ;
+1 IF '$DATA(^AUPNPAT(BPCPIEN,41,0))
QUIT
+2 SET BPCX=0
SET BPCD=""
SET BPCC=0
FOR
SET BPCX=$ORDER(^AUPNPAT(BPCPIEN,41,BPCX))
IF BPCX=""!(BPCX'?1.N)
QUIT
IF BPCX'=$GET(DUZ(2))
Begin DoDot:1
+3 SET BPCDTA=^(BPCX,0)
SET BPCC=BPCC+1
SET BPCN=$PIECE(BPCDTA,U,2)
SET BPCY=$PIECE($GET(^DIC(4,BPCX,0)),U,1)
+4 IF BPCD'=""
SET BPCD=BPCD_BPCS2_BPCY_U_BPCN
+5 IF BPCD=""
SET BPCD=BPCY_U_BPCN
End DoDot:1
+6 IF BPCC>0
SET BPCCTR=BPCCTR+1
SET BPCRES(BPCCTR)="REGS"_BPCS1_BPCC_BPCS1_BPCD
+7 QUIT
BUILD7 ;
+1 IF '$DATA(^AUPNPAT(BPCPIEN,12,0))
QUIT
+2 SET BPCX=0
SET BPCD=""
SET BPCC=0
FOR
SET BPCX=$ORDER(^AUPNPAT(BPCPIEN,12,BPCX))
IF BPCX=""!(BPCX'?1.N)
QUIT
Begin DoDot:1
+3 SET BPCDTA=^AUPNPAT(BPCPIEN,12,BPCX,0)
SET BPCC=BPCC+1
SET BPCN=$PIECE(BPCDTA,U,1)
+4 IF BPCD'=""
SET BPCD=BPCD_U_BPCN
+5 IF BPCD=""
SET BPCD=BPCN
End DoDot:1
+6 IF BPCC>0
SET BPCCTR=BPCCTR+1
SET BPCRES(BPCCTR)="HOME"_BPCS1_BPCC_BPCS1_BPCD
+7 QUIT
BUILD8 ;
+1 IF '$DATA(^AUPNPAT(BPCPIEN,13,0))
QUIT
+2 SET BPCX=0
SET BPCD=""
SET BPCC=0
FOR
SET BPCX=$ORDER(^AUPNPAT(BPCPIEN,13,BPCX))
IF BPCX=""!(BPCX'?1.N)
QUIT
Begin DoDot:1
+3 SET BPCDTA=^AUPNPAT(BPCPIEN,13,BPCX,0)
SET BPCC=BPCC+1
SET BPCN=$PIECE(BPCDTA,U,1)
+4 IF BPCD'=""
SET BPCD=BPCD_U_BPCN
+5 IF BPCD=""
SET BPCD=BPCN
End DoDot:1
+6 IF BPCC>0
SET BPCCTR=BPCCTR+1
SET BPCRES(BPCCTR)="ADD"_BPCS1_BPCC_BPCS1_BPCD
+7 QUIT
GETAGE ;
+1 SET %H=+$HOROLOG
DO YMD^%DTC
SET BPCNOW=X
+2 SET X1=BPCNOW
SET X2=BPCDOB
DO ^%DTC
SET BPCAGE=X\365.25
+3 IF BPCAGE
SET BPCAUN="YRS"
QUIT
+4 IF X#(365.25)>30.5
SET BPCAGE=X#(365.25)\30.5
SET BPCAUN="MONTHS"
QUIT
+5 SET BPCAGE=X
SET BPCAUN="DAYS"
+6 KILL BPCNOW
+7 QUIT
+8 ;
KILL ;
+1 KILL BPCNAM,BPCEDTE,BPCLDTE,BPCSSN,BPCSEX,BPCDOB,BPCAGE,BPCAUN,BPCCLS,BPCCOM,BPCCTY,BPCADDR1,BPCADDR2,BPCADDR3,BPCCITY,BPCSTAT,BPCZIP,BPCHPH,BPCOPH
+2 KILL BPCTRIB,BPCTQT,BPCIQT,BPCTREN,BPCBCITY,BPCBSTA,BPCREL,BPCFNAM,BPCFCTY,BPCFST,BPCMNAM,BPCMCTY,BPCMST,BPCEC,BPCECAD1,BPCECAD2,BPCECAD3
+3 KILL BPCECCTY,BPCECSTA,BPCECZIP,BPCECPNE,BPCEMP,BPCESTAT,BPCVET,BPCSRVC,BPCSAVDT,BPCSRVSD,BPCSCON,BPCCLAIM
+4 KILL BPCC,BPCCTR,BPCD,BPCDTA,BPCN,BPCNOW,BPCQ,BPCS1,BPCS2,BPCSRVDT,BPCSSNS,BPCSTATE,BPCSTIEN,BPCSUF,BPCX,BPCY
+5 QUIT
