BGP0GU ; IHS/CMI/LAB - BGP Gui Utilities 10/29/2004 3:28:39 PM 19 Sep 2005 5:28 PM 27 Apr 2009 10:28 PM ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
;
DEBUG(RETVAL,BGPSTR) ;run the debugger
D DEBUG^%Serenji("UPL^BGP0GU(.RETVAL,.BGPSTR)")
Q
;
KEYS(RETVAL,BGPSTR) ;-- return keys for user
S X="MERR^BGP0GU",@^%ZOSF("TRAP") ; m error trap
N BGPDA,BGPNS,P,BGPDATA,BGPKEYI,BGPKEY,BGPI
S BGPI=0
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S ^BGPTMP($J,BGPI)="T00030KEYS"_$C(30)
S P="|"
S BGPNS=$P(BGPSTR,P)
S BGPDA=0 F S BGPDA=$O(^VA(200,DUZ,51,BGPDA)) Q:'BGPDA D
. S BGPDATA=$G(^VA(200,DUZ,51,BGPDA,0))
. S BGPKEYI=$P(BGPDATA,U)
. S BGPKEY=$P($G(^DIC(19.1,BGPKEYI,0)),U)
. I BGPNS'="*" Q:$E(BGPKEY,1,$L(BGPNS))'[BGPNS
. S BGPI=BGPI+1
. S ^BGPTMP($J,BGPI)=BGPKEY_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)_$G(BGPERR)
Q
;
SP(RETVAL,BGPSTR) ;-- get the site parameter entry
N BGPDA,BGPI,P
S P="|"
S BGPSE=$P(BGPSTR,P)
I BGPSE="" S BGPSE=DUZ(2)
I BGPSE'?.N S BGPSE=$O(^DIC(4,"B",BGPSE,0))
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S BGPI=0
S ^BGPTMP($J,BGPI)="T00010BMXIEN^T00050Location^T00050Home Location^T00050Community Taxonomy^T00001EISS"_$C(30)
S BGPDA=0 F S BGPDA=$O(^BGPSITE("B",BGPSE,BGPDA)) Q:'BGPDA D
. N BGPDATA,BGPLI,BGPL,BGPLA,BGPHI,BGPH,BGPHA,BGPTX,BGPTXI,BGPEISS
. S BGPDATA=$G(^BGPSITE(BGPDA,0))
. S BGPLI=$P(BGPDATA,U)
. S BGPL=$P($G(^DIC(4,BGPLI,0)),U)
. S BGPLA=$P($G(^AUTTLOC(BGPLI,0)),U,10)
. S BGPHI=$P(BGPDATA,U,2)
. S BGPH=$S($G(BGPHI):$P($G(^DIC(4,BGPHI,0)),U),1:"")
. S BGPHA=$S($G(BGPHI):$P($G(^AUTTLOC(BGPHI,0)),U,10),1:"")
. S BGPTXI=$P(BGPDATA,U,5)
. S BGPTX=$S($P(BGPDATA,U,5):$P($G(^ATXAX($P(BGPDATA,U,5),0)),U),1:"")
. S BGPEISS=$S($P(BGPDATA,U,8):1,1:0)
. S BGPI=BGPI+1
. S ^BGPTMP($J,BGPI)=BGPDA_U_$S($G(BGPLI):BGPLI_"~"_BGPL,1:"")_U_$S($G(BGPHI):BGPHI_"~"_BGPH,1:"")_U_$S($G(BGPTXI):BGPTXI_"~"_$G(BGPTX),1:"")_U_$G(BGPEISS)_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)_$G(BGPERR)
Q
;
TAXCHK(RETVAL,BGPSTR) ;-- check taxonomies for National GPRA Report
S X="MERR^BGP0GU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPJ,BGPDATA,BGPDA,BGPRTN,P,BGPCALL
S P="|"
S BGPI=0
S BGPERR=""
S BGPRTN=$P(BGPSTR,P)
S BGPCALL=$P(BGPSTR,P,2)
I BGPCALL="GPU" S BGP0GPU=1
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S ^BGPTMP($J,BGPI)="T00250DATA"_$C(30)
S BGPJ=0
S IOM=80
D GUIR^XBLM("GUICHK^"_BGPRTN,"^XTMP(""BGPTAX"",$J)")
S BGPDA=.5 F S BGPDA=$O(^XTMP("BGPTAX",$J,BGPDA)) Q:'BGPDA D
. N BGPDATA
. S BGPI=BGPI+1
. S BGPDATA=$G(^XTMP("BGPTAX",$J,BGPDA))
. S ^BGPTMP($J,BGPI)=BGPDATA_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)_BGPERR
K ^XTMP("BGPTAX",$J)
Q
;
CATSTR(BGPSRET,STR) ;EP -- concatenate a long string in
N BGPDA
S BGPSRET=""
S BGPDA=0 F S BGPDA=$O(STR(BGPDA)) Q:'BGPDA D
. S BGPSRET=BGPSRET_$G(STR(BGPDA))
Q
;
MERR ; MUMPS ERROR TRAP
N BGPX
X ("S BGPX=$"_"ZE")
S BGPX="MUMPS error: """_BGPX_""""
D ^%ZTER
D ERR(BGPX)
Q
;
ERR(ERR) ; BMX ADO SCHEMA ERROR PROCESSOR
N BGPXA
S BGPXA="0|"_ERR_$C(31) ;cmi/maw changed to end of table marker crs 8.0 p2
S @RETVAL@(1)=BGPXA
Q
;
FAC(RETVAL,BGPSTR) ;-- return facilities based on parameters passed
S X="MERR^BGP0GU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPCT,BGPYN,BGPOT,BGPOPT,BGPRT
N BGPQTR,BGPRE,BGPBAS,BGPBEN,BGPFAC
S P="|"
S BGPI=0
S BGPERR=""
S BGPRT=$P(BGPSTR,P)
S BGPPER=$P(BGPSTR,P,2)
S BGPQTR=$P(BGPSTR,P,3)
S BGPBAS=$P(BGPSTR,P,4)
S BGPBEN=$P(BGPSTR,P,5)
S BGPNGR09=$P(BGPSTR,P,6) ;crs 8.0 p3 for area 09 report
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S ^BGPTMP($J,BGPI)="T00007BMXIEN^T00030Service Unit^T00030Facility^T00020Begin Date^T00020End Date^T00020Base Beg^T00020Base End^T00020Date Run"_$C(30)
D GET^BGP0ASL(.BGPFAC,.BGPFILE,BGPRT,BGPPER,BGPQTR,BGPBAS,BGPBEN)
N BGPDA S BGPDA=0 F S BGPDA=$O(BGPFAC(BGPDA)) Q:'BGPDA D
. S BGPI=BGPI+1
. S ^BGPTMP($J,BGPI)=BGPDA_U_$G(BGPFAC(BGPDA))_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)_BGPERR
D EN^XBVK("BGP")
Q
;
SITE(RETVAL,BGPSTR) ;-- save the site parameters
S X="MERR^BGP0GU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPFAC,BGPTAX,BGPHLOC,R,BGPEISS
S P="|",R="~"
S BGPI=0
S BGPERR=""
S BGPFAC=$P($P(BGPSTR,P),R)
S BGPTAX=$P($P(BGPSTR,P,2),R)
S BGPHLOC=$P($P(BGPSTR,P,3),R)
S BGPHLOCI=$O(^AUTTLOC("B",BGPHLOC,0))
S BGPEISS=$P(BGPSTR,P,4)
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S ^BGPTMP($J,BGPI)="T00007BMXIEN^T00030Error"_$C(30)
N BGPFDA,BGPIENS,BGPERR
I $O(^BGPSITE("B",BGPFAC,0)) D
. S BGPIENS=$O(^BGPSITE("B",BGPFAC,0))_","
. S BGPFDA(90241.02,BGPIENS,.05)=BGPTAX
. S BGPFDA(90241.02,BGPIENS,.02)=BGPHLOC
. S BGPFDA(90241.02,BGPIENS,.04)=BGPEISS
. D FILE^DIE("K","BGPFDA","BGPERR(1)")
. I $G(BGPERR(1)) D Q
.. S BGPI=BGPI+1
.. S ^BGPTMP($J,BGPI)="1^Error Saving Site Parameters"
. S BGPI=BGPI+1
. S ^BGPTMP($J,BGPI)="0^Site Parameters Saved"
I '$O(^BGPSITE("B",BGPFAC,0)) D
. S BGPIENS=""
. S BGPIENS(1)=BGPFAC
. S BGPFDA(90241.02,"+1,",.01)=BGPFAC
. S BGPFDA(90241.02,"+1,",.02)=BGPHLOC
. S BGPFDA(90241.02,"+1,",.04)=BGPEISS
. S BGPFDA(90241.02,"+1,",.05)=BGPTAX
. D UPDATE^DIE("","BGPFDA","BGPIENS","BGPERR(1)")
. I $G(BGPERR(1)) D Q
.. S BGPI=BGPI+1
.. S ^BGPTMP($J,BGPI)="1^Error Saving Site Parameters"
. S BGPI=BGPI+1
. S ^BGPTMP($J,BGPI)="0^Site Parameters Saved"
S ^BGPTMP($J,BGPI+1)=$C(31)_BGPERR
D EN^XBVK("BGP")
Q
;
LST(RETVAL,BGPSTR) ;-- list files
S X="MERR^BGP0GU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPCT,BGPYN,BGPOT,BGPOPT,BGPRT
S P="|"
S BGPI=0
S BGPERR=""
S BGPCT=$P(BGPSTR,P)
S BGPCT=$O(^ATXAX("B",BGPCT,0))
S BGPYN=$P(BGPSTR,P,2)
S BGPOT=$P(BGPSTR,P,3)
S BGPOPT=$P(BGPSTR,P,4)
S BGPRT=$P(BGPSTR,P,5)
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S ^BGPTMP($J,BGPI)="T00250DATA"_$C(30)
D EP^BGP0GLST(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPCT,BGPYN,BGPOT,BGPRT)
S BGPI=BGPI+1
S ^BGPTMP($J,BGPI)=$G(BGPERR)_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)_BGPERR
D EN^XBVK("BGP")
Q
;
DELRPT(RETVAL,BGPSTR) ;-- delete a report out of the BGP 10 GUI REPORT file
S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap
N P,R,I
S P="|",R="~"
S BGPERR=""
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
F I=2:1 D Q:$P(BGPSTR,R,I)=""
. N BGPI
. Q:$P(BGPSTR,R,I)=""
. S BGPI=$P(BGPSTR,R,I)
. S DIK="^BGPGUIT(",DA=BGPI D ^DIK
S ^BGPTMP($J,0)="T00250DATA"_$C(30)
S ^BGPTMP($J,1)=$G(BGPERR)_$C(30)
S ^BGPTMP($J,2)=$C(31)_BGPERR
Q
;
ST(RETVAL,BGPSTR) ;-- return search templates by file
S X="MERR^BGP0GU",@^%ZOSF("TRAP") ; m error trap
N P,BGPI,R,BGPFLS
S P="|",R="~"
S BGPFLS=$P(BGPSTR,P)
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S BGPI=0
S ^BGPTMP($J,BGPI)="T00007BMXIEN^T00050Search Template"_$C(30)
N I
F I=1:1 D Q:$P(BGPFLS,R,I)=""
. Q:$P(BGPFLS,R,I)=""
. S BGPFLS($P(BGPFLS,R,I))=$P(BGPFLS,R,I)
N BGPDA
S BGPDA=0 F S BGPDA=$O(^DIBT(BGPDA)) Q:'BGPDA D
. N BGPFL
. S BGPFL=$P($G(^DIBT(BGPDA,0)),U,4)
. Q:'BGPFL
. Q:'$D(BGPFLS(BGPFL))
. S BGPI=BGPI+1
. S ^BGPTMP($J,BGPI)=BGPDA_U_$P($G(^DIBT(BGPDA,0)),U)_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
D EN^XBVK("BGP")
Q
;
UPL(RETVAL,BGPSTR) ;-- upload a file
S X="MERR^BGP0GU",@^%ZOSF("TRAP") ; m error trap
N BGPOPT
S BGPP="|",BGPR="~"
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S BGPI=0
I $G(BGPSTR)="" D CATSTR(.BGPSTR,.BGPSTR)
S BGPOPT="BGP 10 UPLOAD FILES"
F BGPII=2:1 D Q:$P(BGPSTR,BGPP,BGPII)=""
. Q:$P(BGPSTR,BGPP,BGPII)=""
. N BGPFD,BGPDIR,BGPFL
. S BGPFD=$P(BGPSTR,BGPP,BGPII)
. S BGPDIR=$P(BGPFD,BGPR,1)
. S BGPFL=$P(BGPFD,BGPR,2)
. D EP^BGP0GUPL(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPDIR,BGPFL,DT)
S ^BGPTMP($J,BGPI)="T00001Error^T00080ErrorMessage"_$C(30)
S BGPI=BGPI+1
S ^BGPTMP($J,BGPI)=$G(BGPERR)_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
D EN^XBVK("BGP")
Q
;
LSTF(RETVAL,BGPSTR) ;-- list files
S X="MERR^BGP0GU",@^%ZOSF("TRAP") ; m error trap
N P,BGPDIR,BGPFL,BGPOPT,BGPI
S P="|"
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S BGPI=0
S BGPDIR=$P(BGPSTR,P)
K BGPLIST S BGPLIST="",X=$$LIST^%ZISH(BGPDIR,"BG10*",.BGPLIST)
S BGPOPT="BGP 10 UPLOAD FILES"
S ^BGPTMP($J,BGPI)="T00080Directory^T00080File Name"_$C(30)
N BGPDA
S BGPDA=0 F S BGPDA=$O(BGPLIST(BGPDA)) Q:'BGPDA D
. N BGPFL
. S BGPFL=$G(BGPLIST(BGPDA))
. S BGPI=BGPI+1
. S ^BGPTMP($J,BGPI)=BGPDIR_U_BGPFL_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
D EN^XBVK("BGP")
Q
;
CHK(BGPRET,BGPSTR) ;check report status
S X="MERR^BGP0GU",@^%ZOSF("TRAP") ; m error trap
N P,BGPDUZ2,BGPI
S P="|"
S BGPDUZ=$P(BGPSTR,P)
K ^BGPTMP($J)
S BGPRET="^BGPTMP("_$J_")"
S BGPI=0
S ^BGPTMP($J,BGPI)="T00007BMXIEN^T00030Name^T00030User^T00020Start Time^T00020End Time^T00030Type of Report^T00020Report Status^T00020Type of Output^T00250Export File(s)"_$C(30)
N BGPDA
S BGPDA=0 F S BGPDA=$O(^BGPGUIT("AUSR",BGPDUZ,BGPDA)) Q:'BGPDA D
. N BGPIEN
. S BGPIEN=0 F S BGPIEN=$O(^BGPGUIT("AUSR",BGPDUZ,BGPDA,BGPIEN)) Q:'BGPIEN D
.. N BGPDATA,BGPNM,BGPUSER,BGPST,BGPET,BGPTOR,BGPRS,BGPTOO,BGPFLS
.. S BGPDATA=$G(^BGPGUIT(BGPIEN,0))
.. S BGPNM=$P(BGPDATA,U)
.. S BGPUSER=$P($G(^VA(200,$P(BGPDATA,U,2),0)),U)
.. S BGPST=$$FMTE^XLFDT($P(BGPDATA,U,3))
.. S BGPET=$$FMTE^XLFDT($P(BGPDATA,U,4))
.. I $P(BGPDATA,U,4)="",$$SEVEN($P($P(BGPDATA,U,3),".")) D Q
... S DIK="^BGPGUIT(",DA=BGPIEN D ^DIK
.. S BGPTOR=$P(BGPDATA,U,5)
.. S BGPRS=$$GET1^DIQ(90378.08,BGPIEN,.06)
.. S BGPTOO=$$GET1^DIQ(90378.08,BGPIEN,.07)
.. S BGPFLS=$$GET1^DIQ(90378.08,BGPIEN,1)
.. S BGPI=BGPI+1
.. S ^BGPTMP($J,BGPI)=BGPIEN_U_BGPNM_U_BGPUSER_U_BGPST_U_BGPET_U_BGPTOR_U_BGPRS_U_BGPTOO_U_BGPFLS_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
Q
;
SEVEN(ST) ;EP -- check to see if the start date is over 7 days ago
I $$FMDIFF^XLFDT(DT,ST)>7 Q 1
;S X1=ST,X2=7 D C^%DTC
;I X<DT Q 1
Q 0
;
LABTAXC(RETVAL,BGPSTR) ;EP - from remote procedure
S X="MERR^BGP0GU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPJ,BGPDATA,BGPDA,BGPRT,P,BGPOPT,BGPR,BGPFN
S P="|"
S BGPI=0
S BGPERR=""
S BGPOPT=$P(BGPSTR,P)
S BGPOPT="CRS 10 LAB TAXONOMY REPORT" ;8.0 p2
S BGPRT=$P(BGPSTR,P,2)
S BGPR=$P(BGPSTR,P,3)
S BGPFN=$P(BGPSTR,P,4)
S BGPJ=0
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S ^BGPTMP($J,BGPI)="T00250DATA"_$C(30)
D EP^BGP0GLTX(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPRT,BGPR,BGPFN)
S BGPI=BGPI+1
S ^BGPTMP($J,BGPI)=+$G(BGPERR)_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
D EN^XBVK("BGP")
Q
MEDTAXC(RETVAL,BGPSTR) ;EP - from remote procedure
S X="MERR^BGP0GU",@^%ZOSF("TRAP") ; m error trap
N BGPI,BGPJ,BGPDATA,BGPDA,BGPRT,P,BGPOPT,BGPR,BGPFN
S P="|"
S BGPI=0
S BGPERR=""
S BGPOPT=$P(BGPSTR,P)
S BGPOPT="CRS 10 MEDICATION TAXONOMY REPORT" ;8.0 p2
S BGPRT=$P(BGPSTR,P,2)
S BGPR=$P(BGPSTR,P,3)
S BGPFN=$P(BGPSTR,P,4)
S BGPJ=0
K ^BGPTMP($J)
S RETVAL="^BGPTMP("_$J_")"
S ^BGPTMP($J,BGPI)="T00250DATA"_$C(30)
D EP^BGP0GMTX(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPRT,BGPR,BGPFN)
S BGPI=BGPI+1
S ^BGPTMP($J,BGPI)=+$G(BGPERR)_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
D EN^XBVK("BGP")
Q
;
UPDTAX(BGPRET,BGPSTR) ;update taxonomies based on option selected
S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap
N P,BGPOPT,BGPI
S P="|"
S BGPI=0
K ^BGPTMP($J)
S BGPRET="^BGPTMP("_$J_")"
S ^BGPTMP($J,BGPI)="T00080TAXONOMY NAME"_$C(30)
S BGPRPTT1=1
S BGPOPT=$P(BGPSTR,P)
I BGPOPT="TAXNTL" D
. S BGPRPTT1=1
I BGPOPT="TAXCMS" D
. S BGPRPTT1=5
I BGPOPT="TAXCRS" D
. S BGPRPTT1=9
I BGPOPT="TAXONM" D
. S BGPRPTT1=7
I BGPOPT="TAXEO" D
. S BGPRPTT1=8
D INIT^BGP0CTS
I BGPOPT="TAXALL" D
. D INIT^BGP0XTV
N BGPDA,BGPT
S BGPDA=0 F S BGPDA=$O(BGPTAX("IDX",BGPDA)) Q:'BGPDA D
. N BGPN,BGPFL,BGPRO,BGPFLT
. S BGPI=BGPI+1
. S BGPT=$P($G(BGPTAX("IDX",BGPDA,BGPDA)),U)
. S BGPTT=$P($G(BGPTAX("IDX",BGPDA,BGPDA)),U,2)
. I BGPTT="T" D
.. S BGPN=$P($G(^ATXAX(BGPT,0)),U)
.. S BGPRO=$S($P($G(^ATXAX(BGPT,0)),U,22):"Read Only",1:"Editable")
.. S BGPFL=$P($G(^ATXAX(BGPT,0)),U,15)
.. S BGPFLT=$S(BGPFL=50:"Med",1:"Tax")
. I BGPTT="L" D
.. S BGPN=$P($G(^ATXLAB(BGPT,0)),U)
.. S BGPRO=$S($P($G(^ATXLAB(BGPT,0)),U,22):"Read Only",1:"Editable")
.. S BGPFL=$P($G(^ATXLAB(BGPT,0)),U,9)
.. S BGPFLT="Lab"
. S ^BGPTMP($J,BGPI)=BGPN_"("_BGPRO_"/"_BGPFLT_"/"_BGPFL_")"_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
Q
;
COMCHK(BGPRET,BGPSTR) ;EP
S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap
N P,BGPOPT,BGPI,T
S P="|"
S BGPI=0
K ^BGPTMP($J)
S BGPRET="^BGPTMP("_$J_")"
S ^BGPTMP($J,BGPI)="T00200COMMUNITIES"_$C(30)
S BGPI=0
S T=$P(BGPSTR,P)
K BGPC
I '$G(T) Q 0
I '$D(^ATXAX(T)) Q 0
S X=0,G=0
F S X=$O(^ATXAX(T,21,X)) Q:'X D
.S C=$P(^ATXAX(T,21,X,0),U)
.S BGPI=BGPI+1
.I '$D(^AUTTCOM("B",C)) S ^BGPTMP($J,BGPI)="Warning "_C_" is in the taxonomy but not in the standard community table."_$C(30)
S ^BGPTMP($J,BGPI+1)=$C(31)
Q
;
MFI(BGPRET,BGPSTR) ;-- check to see if this is an mfi site
S X="MERR^BGPGU",@^%ZOSF("TRAP") ; m error trap
N P,BGPOPT,BGPI,BGPDUZ2
S P="|"
S BGPI=0
K ^BGPTMP($J)
S BGPRET="^BGPTMP("_$J_")"
S ^BGPTMP($J,BGPI)="T00001MFI"_$C(30)
S BGPI=0
S BGPDUZ2=$P(BGPSTR,P)
S ^BGPTMP($J,1)=$S($E($P($G(^AUTTLOC(BGPDUZ2,0)),U,10),1,1)=3:1,1:0)_$C(30)
S ^BGPTMP($J,2)=$C(31)
Q
;
BGP0GU ; IHS/CMI/LAB - BGP Gui Utilities 10/29/2004 3:28:39 PM 19 Sep 2005 5:28 PM 27 Apr 2009 10:28 PM ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+2 ;
+3 ;
DEBUG(RETVAL,BGPSTR) ;run the debugger
+1 DO DEBUG^%Serenji("UPL^BGP0GU(.RETVAL,.BGPSTR)")
+2 QUIT
+3 ;
KEYS(RETVAL,BGPSTR) ;-- return keys for user
+1 ; m error trap
SET X="MERR^BGP0GU"
SET @^%ZOSF("TRAP")
+2 NEW BGPDA,BGPNS,P,BGPDATA,BGPKEYI,BGPKEY,BGPI
+3 SET BGPI=0
+4 KILL ^BGPTMP($JOB)
+5 SET RETVAL="^BGPTMP("_$JOB_")"
+6 SET ^BGPTMP($JOB,BGPI)="T00030KEYS"_$CHAR(30)
+7 SET P="|"
+8 SET BGPNS=$PIECE(BGPSTR,P)
+9 SET BGPDA=0
FOR
SET BGPDA=$ORDER(^VA(200,DUZ,51,BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+10 SET BGPDATA=$GET(^VA(200,DUZ,51,BGPDA,0))
+11 SET BGPKEYI=$PIECE(BGPDATA,U)
+12 SET BGPKEY=$PIECE($GET(^DIC(19.1,BGPKEYI,0)),U)
+13 IF BGPNS'="*"
IF $EXTRACT(BGPKEY,1,$LENGTH(BGPNS))'[BGPNS
QUIT
+14 SET BGPI=BGPI+1
+15 SET ^BGPTMP($JOB,BGPI)=BGPKEY_$CHAR(30)
End DoDot:1
+16 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)_$GET(BGPERR)
+17 QUIT
+18 ;
SP(RETVAL,BGPSTR) ;-- get the site parameter entry
+1 NEW BGPDA,BGPI,P
+2 SET P="|"
+3 SET BGPSE=$PIECE(BGPSTR,P)
+4 IF BGPSE=""
SET BGPSE=DUZ(2)
+5 IF BGPSE'?.N
SET BGPSE=$ORDER(^DIC(4,"B",BGPSE,0))
+6 KILL ^BGPTMP($JOB)
+7 SET RETVAL="^BGPTMP("_$JOB_")"
+8 SET BGPI=0
+9 SET ^BGPTMP($JOB,BGPI)="T00010BMXIEN^T00050Location^T00050Home Location^T00050Community Taxonomy^T00001EISS"_$CHAR(30)
+10 SET BGPDA=0
FOR
SET BGPDA=$ORDER(^BGPSITE("B",BGPSE,BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+11 NEW BGPDATA,BGPLI,BGPL,BGPLA,BGPHI,BGPH,BGPHA,BGPTX,BGPTXI,BGPEISS
+12 SET BGPDATA=$GET(^BGPSITE(BGPDA,0))
+13 SET BGPLI=$PIECE(BGPDATA,U)
+14 SET BGPL=$PIECE($GET(^DIC(4,BGPLI,0)),U)
+15 SET BGPLA=$PIECE($GET(^AUTTLOC(BGPLI,0)),U,10)
+16 SET BGPHI=$PIECE(BGPDATA,U,2)
+17 SET BGPH=$SELECT($GET(BGPHI):$PIECE($GET(^DIC(4,BGPHI,0)),U),1:"")
+18 SET BGPHA=$SELECT($GET(BGPHI):$PIECE($GET(^AUTTLOC(BGPHI,0)),U,10),1:"")
+19 SET BGPTXI=$PIECE(BGPDATA,U,5)
+20 SET BGPTX=$SELECT($PIECE(BGPDATA,U,5):$PIECE($GET(^ATXAX($PIECE(BGPDATA,U,5),0)),U),1:"")
+21 SET BGPEISS=$SELECT($PIECE(BGPDATA,U,8):1,1:0)
+22 SET BGPI=BGPI+1
+23 SET ^BGPTMP($JOB,BGPI)=BGPDA_U_$SELECT($GET(BGPLI):BGPLI_"~"_BGPL,1:"")_U_$SELECT($GET(BGPHI):BGPHI_"~"_BGPH,1:"")_U_$SELECT($GET(BGPTXI):BGPTXI_"~"_$GET(BGPTX),1:"")_U_$GET(BGPEISS)_$CHAR(30)
End DoDot:1
+24 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)_$GET(BGPERR)
+25 QUIT
+26 ;
TAXCHK(RETVAL,BGPSTR) ;-- check taxonomies for National GPRA Report
+1 ; m error trap
SET X="MERR^BGP0GU"
SET @^%ZOSF("TRAP")
+2 NEW BGPI,BGPJ,BGPDATA,BGPDA,BGPRTN,P,BGPCALL
+3 SET P="|"
+4 SET BGPI=0
+5 SET BGPERR=""
+6 SET BGPRTN=$PIECE(BGPSTR,P)
+7 SET BGPCALL=$PIECE(BGPSTR,P,2)
+8 IF BGPCALL="GPU"
SET BGP0GPU=1
+9 KILL ^BGPTMP($JOB)
+10 SET RETVAL="^BGPTMP("_$JOB_")"
+11 SET ^BGPTMP($JOB,BGPI)="T00250DATA"_$CHAR(30)
+12 SET BGPJ=0
+13 SET IOM=80
+14 DO GUIR^XBLM("GUICHK^"_BGPRTN,"^XTMP(""BGPTAX"",$J)")
+15 SET BGPDA=.5
FOR
SET BGPDA=$ORDER(^XTMP("BGPTAX",$JOB,BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+16 NEW BGPDATA
+17 SET BGPI=BGPI+1
+18 SET BGPDATA=$GET(^XTMP("BGPTAX",$JOB,BGPDA))
+19 SET ^BGPTMP($JOB,BGPI)=BGPDATA_$CHAR(30)
End DoDot:1
+20 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)_BGPERR
+21 KILL ^XTMP("BGPTAX",$JOB)
+22 QUIT
+23 ;
CATSTR(BGPSRET,STR) ;EP -- concatenate a long string in
+1 NEW BGPDA
+2 SET BGPSRET=""
+3 SET BGPDA=0
FOR
SET BGPDA=$ORDER(STR(BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+4 SET BGPSRET=BGPSRET_$GET(STR(BGPDA))
End DoDot:1
+5 QUIT
+6 ;
MERR ; MUMPS ERROR TRAP
+1 NEW BGPX
+2 XECUTE ("S BGPX=$"_"ZE")
+3 SET BGPX="MUMPS error: """_BGPX_""""
+4 DO ^%ZTER
+5 DO ERR(BGPX)
+6 QUIT
+7 ;
ERR(ERR) ; BMX ADO SCHEMA ERROR PROCESSOR
+1 NEW BGPXA
+2 ;cmi/maw changed to end of table marker crs 8.0 p2
SET BGPXA="0|"_ERR_$CHAR(31)
+3 SET @RETVAL@(1)=BGPXA
+4 QUIT
+5 ;
FAC(RETVAL,BGPSTR) ;-- return facilities based on parameters passed
+1 ; m error trap
SET X="MERR^BGP0GU"
SET @^%ZOSF("TRAP")
+2 NEW BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPCT,BGPYN,BGPOT,BGPOPT,BGPRT
+3 NEW BGPQTR,BGPRE,BGPBAS,BGPBEN,BGPFAC
+4 SET P="|"
+5 SET BGPI=0
+6 SET BGPERR=""
+7 SET BGPRT=$PIECE(BGPSTR,P)
+8 SET BGPPER=$PIECE(BGPSTR,P,2)
+9 SET BGPQTR=$PIECE(BGPSTR,P,3)
+10 SET BGPBAS=$PIECE(BGPSTR,P,4)
+11 SET BGPBEN=$PIECE(BGPSTR,P,5)
+12 ;crs 8.0 p3 for area 09 report
SET BGPNGR09=$PIECE(BGPSTR,P,6)
+13 KILL ^BGPTMP($JOB)
+14 SET RETVAL="^BGPTMP("_$JOB_")"
+15 SET ^BGPTMP($JOB,BGPI)="T00007BMXIEN^T00030Service Unit^T00030Facility^T00020Begin Date^T00020End Date^T00020Base Beg^T00020Base End^T00020Date Run"_$CHAR(30)
+16 DO GET^BGP0ASL(.BGPFAC,.BGPFILE,BGPRT,BGPPER,BGPQTR,BGPBAS,BGPBEN)
+17 NEW BGPDA
SET BGPDA=0
FOR
SET BGPDA=$ORDER(BGPFAC(BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+18 SET BGPI=BGPI+1
+19 SET ^BGPTMP($JOB,BGPI)=BGPDA_U_$GET(BGPFAC(BGPDA))_$CHAR(30)
End DoDot:1
+20 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)_BGPERR
+21 DO EN^XBVK("BGP")
+22 QUIT
+23 ;
SITE(RETVAL,BGPSTR) ;-- save the site parameters
+1 ; m error trap
SET X="MERR^BGP0GU"
SET @^%ZOSF("TRAP")
+2 NEW BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPFAC,BGPTAX,BGPHLOC,R,BGPEISS
+3 SET P="|"
SET R="~"
+4 SET BGPI=0
+5 SET BGPERR=""
+6 SET BGPFAC=$PIECE($PIECE(BGPSTR,P),R)
+7 SET BGPTAX=$PIECE($PIECE(BGPSTR,P,2),R)
+8 SET BGPHLOC=$PIECE($PIECE(BGPSTR,P,3),R)
+9 SET BGPHLOCI=$ORDER(^AUTTLOC("B",BGPHLOC,0))
+10 SET BGPEISS=$PIECE(BGPSTR,P,4)
+11 KILL ^BGPTMP($JOB)
+12 SET RETVAL="^BGPTMP("_$JOB_")"
+13 SET ^BGPTMP($JOB,BGPI)="T00007BMXIEN^T00030Error"_$CHAR(30)
+14 NEW BGPFDA,BGPIENS,BGPERR
+15 IF $ORDER(^BGPSITE("B",BGPFAC,0))
Begin DoDot:1
+16 SET BGPIENS=$ORDER(^BGPSITE("B",BGPFAC,0))_","
+17 SET BGPFDA(90241.02,BGPIENS,.05)=BGPTAX
+18 SET BGPFDA(90241.02,BGPIENS,.02)=BGPHLOC
+19 SET BGPFDA(90241.02,BGPIENS,.04)=BGPEISS
+20 DO FILE^DIE("K","BGPFDA","BGPERR(1)")
+21 IF $GET(BGPERR(1))
Begin DoDot:2
+22 SET BGPI=BGPI+1
+23 SET ^BGPTMP($JOB,BGPI)="1^Error Saving Site Parameters"
End DoDot:2
QUIT
+24 SET BGPI=BGPI+1
+25 SET ^BGPTMP($JOB,BGPI)="0^Site Parameters Saved"
End DoDot:1
+26 IF '$ORDER(^BGPSITE("B",BGPFAC,0))
Begin DoDot:1
+27 SET BGPIENS=""
+28 SET BGPIENS(1)=BGPFAC
+29 SET BGPFDA(90241.02,"+1,",.01)=BGPFAC
+30 SET BGPFDA(90241.02,"+1,",.02)=BGPHLOC
+31 SET BGPFDA(90241.02,"+1,",.04)=BGPEISS
+32 SET BGPFDA(90241.02,"+1,",.05)=BGPTAX
+33 DO UPDATE^DIE("","BGPFDA","BGPIENS","BGPERR(1)")
+34 IF $GET(BGPERR(1))
Begin DoDot:2
+35 SET BGPI=BGPI+1
+36 SET ^BGPTMP($JOB,BGPI)="1^Error Saving Site Parameters"
End DoDot:2
QUIT
+37 SET BGPI=BGPI+1
+38 SET ^BGPTMP($JOB,BGPI)="0^Site Parameters Saved"
End DoDot:1
+39 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)_BGPERR
+40 DO EN^XBVK("BGP")
+41 QUIT
+42 ;
LST(RETVAL,BGPSTR) ;-- list files
+1 ; m error trap
SET X="MERR^BGP0GU"
SET @^%ZOSF("TRAP")
+2 NEW BGPI,BGPJ,BGPDATA,BGPDA,P,BGPERR,BGPCT,BGPYN,BGPOT,BGPOPT,BGPRT
+3 SET P="|"
+4 SET BGPI=0
+5 SET BGPERR=""
+6 SET BGPCT=$PIECE(BGPSTR,P)
+7 SET BGPCT=$ORDER(^ATXAX("B",BGPCT,0))
+8 SET BGPYN=$PIECE(BGPSTR,P,2)
+9 SET BGPOT=$PIECE(BGPSTR,P,3)
+10 SET BGPOPT=$PIECE(BGPSTR,P,4)
+11 SET BGPRT=$PIECE(BGPSTR,P,5)
+12 KILL ^BGPTMP($JOB)
+13 SET RETVAL="^BGPTMP("_$JOB_")"
+14 SET ^BGPTMP($JOB,BGPI)="T00250DATA"_$CHAR(30)
+15 DO EP^BGP0GLST(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPCT,BGPYN,BGPOT,BGPRT)
+16 SET BGPI=BGPI+1
+17 SET ^BGPTMP($JOB,BGPI)=$GET(BGPERR)_$CHAR(30)
+18 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)_BGPERR
+19 DO EN^XBVK("BGP")
+20 QUIT
+21 ;
DELRPT(RETVAL,BGPSTR) ;-- delete a report out of the BGP 10 GUI REPORT file
+1 ; m error trap
SET X="MERR^BGPGU"
SET @^%ZOSF("TRAP")
+2 NEW P,R,I
+3 SET P="|"
SET R="~"
+4 SET BGPERR=""
+5 KILL ^BGPTMP($JOB)
+6 SET RETVAL="^BGPTMP("_$JOB_")"
+7 FOR I=2:1
Begin DoDot:1
+8 NEW BGPI
+9 IF $PIECE(BGPSTR,R,I)=""
QUIT
+10 SET BGPI=$PIECE(BGPSTR,R,I)
+11 SET DIK="^BGPGUIT("
SET DA=BGPI
DO ^DIK
End DoDot:1
IF $PIECE(BGPSTR,R,I)=""
QUIT
+12 SET ^BGPTMP($JOB,0)="T00250DATA"_$CHAR(30)
+13 SET ^BGPTMP($JOB,1)=$GET(BGPERR)_$CHAR(30)
+14 SET ^BGPTMP($JOB,2)=$CHAR(31)_BGPERR
+15 QUIT
+16 ;
ST(RETVAL,BGPSTR) ;-- return search templates by file
+1 ; m error trap
SET X="MERR^BGP0GU"
SET @^%ZOSF("TRAP")
+2 NEW P,BGPI,R,BGPFLS
+3 SET P="|"
SET R="~"
+4 SET BGPFLS=$PIECE(BGPSTR,P)
+5 KILL ^BGPTMP($JOB)
+6 SET RETVAL="^BGPTMP("_$JOB_")"
+7 SET BGPI=0
+8 SET ^BGPTMP($JOB,BGPI)="T00007BMXIEN^T00050Search Template"_$CHAR(30)
+9 NEW I
+10 FOR I=1:1
Begin DoDot:1
+11 IF $PIECE(BGPFLS,R,I)=""
QUIT
+12 SET BGPFLS($PIECE(BGPFLS,R,I))=$PIECE(BGPFLS,R,I)
End DoDot:1
IF $PIECE(BGPFLS,R,I)=""
QUIT
+13 NEW BGPDA
+14 SET BGPDA=0
FOR
SET BGPDA=$ORDER(^DIBT(BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+15 NEW BGPFL
+16 SET BGPFL=$PIECE($GET(^DIBT(BGPDA,0)),U,4)
+17 IF 'BGPFL
QUIT
+18 IF '$DATA(BGPFLS(BGPFL))
QUIT
+19 SET BGPI=BGPI+1
+20 SET ^BGPTMP($JOB,BGPI)=BGPDA_U_$PIECE($GET(^DIBT(BGPDA,0)),U)_$CHAR(30)
End DoDot:1
+21 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+22 DO EN^XBVK("BGP")
+23 QUIT
+24 ;
UPL(RETVAL,BGPSTR) ;-- upload a file
+1 ; m error trap
SET X="MERR^BGP0GU"
SET @^%ZOSF("TRAP")
+2 NEW BGPOPT
+3 SET BGPP="|"
SET BGPR="~"
+4 KILL ^BGPTMP($JOB)
+5 SET RETVAL="^BGPTMP("_$JOB_")"
+6 SET BGPI=0
+7 IF $GET(BGPSTR)=""
DO CATSTR(.BGPSTR,.BGPSTR)
+8 SET BGPOPT="BGP 10 UPLOAD FILES"
+9 FOR BGPII=2:1
Begin DoDot:1
+10 IF $PIECE(BGPSTR,BGPP,BGPII)=""
QUIT
+11 NEW BGPFD,BGPDIR,BGPFL
+12 SET BGPFD=$PIECE(BGPSTR,BGPP,BGPII)
+13 SET BGPDIR=$PIECE(BGPFD,BGPR,1)
+14 SET BGPFL=$PIECE(BGPFD,BGPR,2)
+15 DO EP^BGP0GUPL(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPDIR,BGPFL,DT)
End DoDot:1
IF $PIECE(BGPSTR,BGPP,BGPII)=""
QUIT
+16 SET ^BGPTMP($JOB,BGPI)="T00001Error^T00080ErrorMessage"_$CHAR(30)
+17 SET BGPI=BGPI+1
+18 SET ^BGPTMP($JOB,BGPI)=$GET(BGPERR)_$CHAR(30)
+19 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+20 DO EN^XBVK("BGP")
+21 QUIT
+22 ;
LSTF(RETVAL,BGPSTR) ;-- list files
+1 ; m error trap
SET X="MERR^BGP0GU"
SET @^%ZOSF("TRAP")
+2 NEW P,BGPDIR,BGPFL,BGPOPT,BGPI
+3 SET P="|"
+4 KILL ^BGPTMP($JOB)
+5 SET RETVAL="^BGPTMP("_$JOB_")"
+6 SET BGPI=0
+7 SET BGPDIR=$PIECE(BGPSTR,P)
+8 KILL BGPLIST
SET BGPLIST=""
SET X=$$LIST^%ZISH(BGPDIR,"BG10*",.BGPLIST)
+9 SET BGPOPT="BGP 10 UPLOAD FILES"
+10 SET ^BGPTMP($JOB,BGPI)="T00080Directory^T00080File Name"_$CHAR(30)
+11 NEW BGPDA
+12 SET BGPDA=0
FOR
SET BGPDA=$ORDER(BGPLIST(BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+13 NEW BGPFL
+14 SET BGPFL=$GET(BGPLIST(BGPDA))
+15 SET BGPI=BGPI+1
+16 SET ^BGPTMP($JOB,BGPI)=BGPDIR_U_BGPFL_$CHAR(30)
End DoDot:1
+17 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+18 DO EN^XBVK("BGP")
+19 QUIT
+20 ;
CHK(BGPRET,BGPSTR) ;check report status
+1 ; m error trap
SET X="MERR^BGP0GU"
SET @^%ZOSF("TRAP")
+2 NEW P,BGPDUZ2,BGPI
+3 SET P="|"
+4 SET BGPDUZ=$PIECE(BGPSTR,P)
+5 KILL ^BGPTMP($JOB)
+6 SET BGPRET="^BGPTMP("_$JOB_")"
+7 SET BGPI=0
+8 SET ^BGPTMP($JOB,BGPI)="T00007BMXIEN^T00030Name^T00030User^T00020Start Time^T00020End Time^T00030Type of Report^T00020Report Status^T00020Type of Output^T00250Export File(s)"_$CHAR(30)
+9 NEW BGPDA
+10 SET BGPDA=0
FOR
SET BGPDA=$ORDER(^BGPGUIT("AUSR",BGPDUZ,BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+11 NEW BGPIEN
+12 SET BGPIEN=0
FOR
SET BGPIEN=$ORDER(^BGPGUIT("AUSR",BGPDUZ,BGPDA,BGPIEN))
IF 'BGPIEN
QUIT
Begin DoDot:2
+13 NEW BGPDATA,BGPNM,BGPUSER,BGPST,BGPET,BGPTOR,BGPRS,BGPTOO,BGPFLS
+14 SET BGPDATA=$GET(^BGPGUIT(BGPIEN,0))
+15 SET BGPNM=$PIECE(BGPDATA,U)
+16 SET BGPUSER=$PIECE($GET(^VA(200,$PIECE(BGPDATA,U,2),0)),U)
+17 SET BGPST=$$FMTE^XLFDT($PIECE(BGPDATA,U,3))
+18 SET BGPET=$$FMTE^XLFDT($PIECE(BGPDATA,U,4))
+19 IF $PIECE(BGPDATA,U,4)=""
IF $$SEVEN($PIECE($PIECE(BGPDATA,U,3),"."))
Begin DoDot:3
+20 SET DIK="^BGPGUIT("
SET DA=BGPIEN
DO ^DIK
End DoDot:3
QUIT
+21 SET BGPTOR=$PIECE(BGPDATA,U,5)
+22 SET BGPRS=$$GET1^DIQ(90378.08,BGPIEN,.06)
+23 SET BGPTOO=$$GET1^DIQ(90378.08,BGPIEN,.07)
+24 SET BGPFLS=$$GET1^DIQ(90378.08,BGPIEN,1)
+25 SET BGPI=BGPI+1
+26 SET ^BGPTMP($JOB,BGPI)=BGPIEN_U_BGPNM_U_BGPUSER_U_BGPST_U_BGPET_U_BGPTOR_U_BGPRS_U_BGPTOO_U_BGPFLS_$CHAR(30)
End DoDot:2
End DoDot:1
+27 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+28 QUIT
+29 ;
SEVEN(ST) ;EP -- check to see if the start date is over 7 days ago
+1 IF $$FMDIFF^XLFDT(DT,ST)>7
QUIT 1
+2 ;S X1=ST,X2=7 D C^%DTC
+3 ;I X<DT Q 1
+4 QUIT 0
+5 ;
LABTAXC(RETVAL,BGPSTR) ;EP - from remote procedure
+1 ; m error trap
SET X="MERR^BGP0GU"
SET @^%ZOSF("TRAP")
+2 NEW BGPI,BGPJ,BGPDATA,BGPDA,BGPRT,P,BGPOPT,BGPR,BGPFN
+3 SET P="|"
+4 SET BGPI=0
+5 SET BGPERR=""
+6 SET BGPOPT=$PIECE(BGPSTR,P)
+7 ;8.0 p2
SET BGPOPT="CRS 10 LAB TAXONOMY REPORT"
+8 SET BGPRT=$PIECE(BGPSTR,P,2)
+9 SET BGPR=$PIECE(BGPSTR,P,3)
+10 SET BGPFN=$PIECE(BGPSTR,P,4)
+11 SET BGPJ=0
+12 KILL ^BGPTMP($JOB)
+13 SET RETVAL="^BGPTMP("_$JOB_")"
+14 SET ^BGPTMP($JOB,BGPI)="T00250DATA"_$CHAR(30)
+15 DO EP^BGP0GLTX(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPRT,BGPR,BGPFN)
+16 SET BGPI=BGPI+1
+17 SET ^BGPTMP($JOB,BGPI)=+$GET(BGPERR)_$CHAR(30)
+18 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+19 DO EN^XBVK("BGP")
+20 QUIT
MEDTAXC(RETVAL,BGPSTR) ;EP - from remote procedure
+1 ; m error trap
SET X="MERR^BGP0GU"
SET @^%ZOSF("TRAP")
+2 NEW BGPI,BGPJ,BGPDATA,BGPDA,BGPRT,P,BGPOPT,BGPR,BGPFN
+3 SET P="|"
+4 SET BGPI=0
+5 SET BGPERR=""
+6 SET BGPOPT=$PIECE(BGPSTR,P)
+7 ;8.0 p2
SET BGPOPT="CRS 10 MEDICATION TAXONOMY REPORT"
+8 SET BGPRT=$PIECE(BGPSTR,P,2)
+9 SET BGPR=$PIECE(BGPSTR,P,3)
+10 SET BGPFN=$PIECE(BGPSTR,P,4)
+11 SET BGPJ=0
+12 KILL ^BGPTMP($JOB)
+13 SET RETVAL="^BGPTMP("_$JOB_")"
+14 SET ^BGPTMP($JOB,BGPI)="T00250DATA"_$CHAR(30)
+15 DO EP^BGP0GMTX(.BGPERR,DUZ,DUZ(2),BGPOPT,BGPRT,BGPR,BGPFN)
+16 SET BGPI=BGPI+1
+17 SET ^BGPTMP($JOB,BGPI)=+$GET(BGPERR)_$CHAR(30)
+18 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+19 DO EN^XBVK("BGP")
+20 QUIT
+21 ;
UPDTAX(BGPRET,BGPSTR) ;update taxonomies based on option selected
+1 ; m error trap
SET X="MERR^BGPGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BGPOPT,BGPI
+3 SET P="|"
+4 SET BGPI=0
+5 KILL ^BGPTMP($JOB)
+6 SET BGPRET="^BGPTMP("_$JOB_")"
+7 SET ^BGPTMP($JOB,BGPI)="T00080TAXONOMY NAME"_$CHAR(30)
+8 SET BGPRPTT1=1
+9 SET BGPOPT=$PIECE(BGPSTR,P)
+10 IF BGPOPT="TAXNTL"
Begin DoDot:1
+11 SET BGPRPTT1=1
End DoDot:1
+12 IF BGPOPT="TAXCMS"
Begin DoDot:1
+13 SET BGPRPTT1=5
End DoDot:1
+14 IF BGPOPT="TAXCRS"
Begin DoDot:1
+15 SET BGPRPTT1=9
End DoDot:1
+16 IF BGPOPT="TAXONM"
Begin DoDot:1
+17 SET BGPRPTT1=7
End DoDot:1
+18 IF BGPOPT="TAXEO"
Begin DoDot:1
+19 SET BGPRPTT1=8
End DoDot:1
+20 DO INIT^BGP0CTS
+21 IF BGPOPT="TAXALL"
Begin DoDot:1
+22 DO INIT^BGP0XTV
End DoDot:1
+23 NEW BGPDA,BGPT
+24 SET BGPDA=0
FOR
SET BGPDA=$ORDER(BGPTAX("IDX",BGPDA))
IF 'BGPDA
QUIT
Begin DoDot:1
+25 NEW BGPN,BGPFL,BGPRO,BGPFLT
+26 SET BGPI=BGPI+1
+27 SET BGPT=$PIECE($GET(BGPTAX("IDX",BGPDA,BGPDA)),U)
+28 SET BGPTT=$PIECE($GET(BGPTAX("IDX",BGPDA,BGPDA)),U,2)
+29 IF BGPTT="T"
Begin DoDot:2
+30 SET BGPN=$PIECE($GET(^ATXAX(BGPT,0)),U)
+31 SET BGPRO=$SELECT($PIECE($GET(^ATXAX(BGPT,0)),U,22):"Read Only",1:"Editable")
+32 SET BGPFL=$PIECE($GET(^ATXAX(BGPT,0)),U,15)
+33 SET BGPFLT=$SELECT(BGPFL=50:"Med",1:"Tax")
End DoDot:2
+34 IF BGPTT="L"
Begin DoDot:2
+35 SET BGPN=$PIECE($GET(^ATXLAB(BGPT,0)),U)
+36 SET BGPRO=$SELECT($PIECE($GET(^ATXLAB(BGPT,0)),U,22):"Read Only",1:"Editable")
+37 SET BGPFL=$PIECE($GET(^ATXLAB(BGPT,0)),U,9)
+38 SET BGPFLT="Lab"
End DoDot:2
+39 SET ^BGPTMP($JOB,BGPI)=BGPN_"("_BGPRO_"/"_BGPFLT_"/"_BGPFL_")"_$CHAR(30)
End DoDot:1
+40 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+41 QUIT
+42 ;
COMCHK(BGPRET,BGPSTR) ;EP
+1 ; m error trap
SET X="MERR^BGPGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BGPOPT,BGPI,T
+3 SET P="|"
+4 SET BGPI=0
+5 KILL ^BGPTMP($JOB)
+6 SET BGPRET="^BGPTMP("_$JOB_")"
+7 SET ^BGPTMP($JOB,BGPI)="T00200COMMUNITIES"_$CHAR(30)
+8 SET BGPI=0
+9 SET T=$PIECE(BGPSTR,P)
+10 KILL BGPC
+11 IF '$GET(T)
QUIT 0
+12 IF '$DATA(^ATXAX(T))
QUIT 0
+13 SET X=0
SET G=0
+14 FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF 'X
QUIT
Begin DoDot:1
+15 SET C=$PIECE(^ATXAX(T,21,X,0),U)
+16 SET BGPI=BGPI+1
+17 IF '$DATA(^AUTTCOM("B",C))
SET ^BGPTMP($JOB,BGPI)="Warning "_C_" is in the taxonomy but not in the standard community table."_$CHAR(30)
End DoDot:1
+18 SET ^BGPTMP($JOB,BGPI+1)=$CHAR(31)
+19 QUIT
+20 ;
MFI(BGPRET,BGPSTR) ;-- check to see if this is an mfi site
+1 ; m error trap
SET X="MERR^BGPGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BGPOPT,BGPI,BGPDUZ2
+3 SET P="|"
+4 SET BGPI=0
+5 KILL ^BGPTMP($JOB)
+6 SET BGPRET="^BGPTMP("_$JOB_")"
+7 SET ^BGPTMP($JOB,BGPI)="T00001MFI"_$CHAR(30)
+8 SET BGPI=0
+9 SET BGPDUZ2=$PIECE(BGPSTR,P)
+10 SET ^BGPTMP($JOB,1)=$SELECT($EXTRACT($PIECE($GET(^AUTTLOC(BGPDUZ2,0)),U,10),1,1)=3:1,1:0)_$CHAR(30)
+11 SET ^BGPTMP($JOB,2)=$CHAR(31)
+12 QUIT
+13 ;
