BDMGUA ; cmi/anch/maw - BDM DMS GUI Utilities ; 11 Feb 2010 7:45 AM
;;2.0;BDM DIABETES MANAGEMENT SYSTEM;**1,3,5,6,7,8,9,10,11,12**;JUN 14, 2007;Build 51
;
;
;
;
DEBUG(BDMRET,BDMSTR) ;-- debug
D DEBUG^%Serenji("TAXCHK^BDMGUA(.BDMRET,.BDMSTR)")
Q
;
DELPT(BDMRET,BDMSTR) ;-- delete a patient/data from dms
S X="MERR^BDMGU",@^%ZOSF("TRAP")
N P,BDMPAT,BDMGREF,BDMI,BDMX
S P="|"
S BDMPAT=$P(BDMSTR,P) ;patient
S BDMREGE=$P(BDMSTR,P,2) ;register
S BDMREG=$O(^ACM(41.1,"B",BDMREGE,0)) ;register ien
S BDMGREF="^ACM(49)"
S BDMX=0 F S BDMX=$O(@BDMGREF@("AC",BDMREG,BDMPAT,BDMX)) Q:'BDMX D
. S DA=0 F S DA=$O(@BDMGREF@("AC",BDMREG,BDMPAT,BDMX,DA)) Q:'DA D
.. S DIK="^ACM(49,"
.. D ^DIK
.. K DIK,DIC
F BDMI=42,43,44,45,46,47,48,51,53,54,41 S BDMGREF="^ACM("_BDMI_")"
S BDMX=0 F S BDMX=$O(@BDMGREF@("AC",BDMREG,BDMPAT,BDMX)) Q:'BDMX S DIK="^ACM("_BDMI_",",DA=^(BDMX) D
. D ^DIK
. K DIK,DIC,DA
S DA=^ACM(41,"AC",BDMPAT,BDMREG),DIK="^ACM(41,"
D ^DIK
K DIK,DIC
S BDMRET=""
Q
;
TAXCHKO(BDMRET) ;-- check taxonomies
S X="MERR^BDMGU",@^%ZOSF("TRAP")
N BDMI,BDMJ,BDMDATA,BDMDA
S BDMI=0
S BDMERR=""
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S ^BDMTMP($J,BDMI)="T00250DATA"_$C(30)
S BDMJ=0
S IOM=80
D GUIR^XBLM("TAXCHK^BDMDA19","^XTMP(""BDMTAX"",$J)")
S BDMDA=.5 F S BDMDA=$O(^XTMP("BDMTAX",$J,BDMDA)) Q:'BDMDA D
. N BDMDATA
. S BDMI=BDMI+1
. S BDMDATA=$G(^XTMP("BDMTAX",$J,BDMDA))
. S ^BDMTMP($J,BDMI)=BDMDATA_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_BDMERR
K ^XTMP("BDMTAX",$J)
Q
;
TAXCHK(RETVAL,BDMSTR) ;-- check taxonomies
S X="MERR^BDMGU",@^%ZOSF("TRAP")
N BDMI,BDMJ,BDMDATA,BDMDA,BDMRTN,P
S P="|"
S BDMI=0
S BDMERR=""
S BDMRTN=$P(BDMSTR,P)
K ^BDMTMP($J)
S RETVAL="^BDMTMP("_$J_")"
S ^BDMTMP($J,BDMI)="T00250DATA"_$C(30)
S BDMJ=0
S IOM=80
D GUIR^XBLM("TAXCHK^"_BDMRTN,"^XTMP(""BDMTAX"",$J)")
S BDMDA=.5 F S BDMDA=$O(^XTMP("BDMTAX",$J,BDMDA)) Q:'BDMDA D
. N BDMDATA
. S BDMI=BDMI+1
. S BDMDATA=$G(^XTMP("BDMTAX",$J,BDMDA))
. S ^BDMTMP($J,BDMI)=BDMDATA_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_BDMERR
K ^XTMP("BDMTAX",$J)
Q
;
UPDTAX(BDMRET,BDMSTR) ;update taxonomies
S X="MERR^BDMGU",@^%ZOSF("TRAP")
N P,BDMOPT,BDMI
S P="|"
S BDMI=0
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S ^BDMTMP($J,BDMI)="T00080TAXONOMY NAME"_$C(30)
S BDMOPT=$P(BDMSTR,P)
I BDMOPT="Upd DM Audit P 05" D
. D INIT^BDMP5TS
I BDMOPT="Upd DM Audit 05" D
. D INIT^BDMD5TS
I BDMOPT="Upd DM Audit P 06" D
. D INIT^BDMP6TS
I BDMOPT="Upd DM Audit 06" D
. D INIT^BDMD6TS
I BDMOPT="Upd DM Audit P 07" D
. D INIT^BDMP7TS
I BDMOPT="Upd DM Audit 07" D
. D INIT^BDMD7TS
I BDMOPT="Upd DM Audit P 08" D
. D INIT^BDMP8TS
I BDMOPT="Upd DM Audit 08" D
. D INIT^BDMD8TS
I BDMOPT="Upd DM Audit P 09" D
. D INIT^BDMP9TS
I BDMOPT="Upd DM Audit 09" D
. D INIT^BDMD9TS
I BDMOPT="Upd DM Audit P 10" D
. D INIT^BDMP0TS
I BDMOPT="Upd DM Audit 10" D
. D INIT^BDMD0TS
I BDMOPT="Upd DM Audit P 11" D
. D INIT^BDMP1TS
I BDMOPT="Upd DM Audit 11" D
. D INIT^BDMD1TS
I BDMOPT="Upd DM Audit P 12" D
. D INIT^BDMP4TS
I BDMOPT="Upd DM Audit 12" D
. D INIT^BDMD4TS
I BDMOPT="Upd DM Audit P 13" D
. D INIT^BDMPATS
I BDMOPT="Upd DM Audit 13" D
. D INIT^BDMDATS
I BDMOPT="Upd DM Audit P 14" D
. D INIT^BDMPBTS
I BDMOPT="Upd DM Audit 14" D
. D INIT^BDMDBTS
I BDMOPT="Upd DM Audit P 15" D
. D INIT^BDMPCTS
I BDMOPT="Upd DM Audit 15" D
. D INIT^BDMDCTS
I BDMOPT="Upd DM Audit P 16" D
. D INIT^BDMPDTS
I BDMOPT="Upd DM Audit 16" D
. D INIT^BDMDDTS
I BDMOPT="Upd DM Audit P 17" D
. D INIT^BDMPETS
I BDMOPT="Upd DM Audit 17" D
. D INIT^BDMDETS
I BDMOPT="Upd DM Audit P 18" D
. D INIT^BDMPFTS
I BDMOPT="Upd DM Audit 18" D
. D INIT^BDMDFTS
I BDMOPT="Upd DM Audit P 19" D
. D INIT^BDMPGTS
I BDMOPT="Upd DM Audit 19" D
. D INIT^BDMDGTS
N BDMDA,BDMT
S BDMDA=0 F S BDMDA=$O(BDMTAX("IDX",BDMDA)) Q:'BDMDA D
. N BDMN,BDMFL,BDMRO,BDMFLT,BDMPAN
. S BDMI=BDMI+1
. S BDMT=$P($G(BDMTAX("IDX",BDMDA,BDMDA)),U)
. S BDMTT=$P($G(BDMTAX("IDX",BDMDA,BDMDA)),U,2)
. I BDMTT="T" D
.. S BDMN=$P($G(^ATXAX(BDMT,0)),U)
.. S BDMRO=$S($P($G(^ATXAX(BDMT,0)),U,22):"Read Only",1:"Editable")
.. S BDMFL=$P($G(^ATXAX(BDMT,0)),U,15)
.. S BDMFLT=$S(BDMFL=50:"Med",1:"Tax")
. I BDMTT="L" D
.. S BDMN=$P($G(^ATXLAB(BDMT,0)),U)
.. S BDMPAN=$P($G(^ATXLAB(BDMT,0)),U,11)
.. S BDMRO=$S($P($G(^ATXLAB(BDMT,0)),U,22):"Read Only",1:"Editable")
.. S BDMFL=$P($G(^ATXLAB(BDMT,0)),U,9)
.. S BDMFLT="Lab"
. S ^BDMTMP($J,BDMI)=BDMN_"("_BDMRO_"/"_BDMFLT_"/"_BDMFL_"/"_$G(BDMPAN)_")"_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)
Q
;
CHTDATA(BDMRET,BDMSTR) ;-- get lab, bp or wt data for chart
S X="MERR^BDMGU",@^%ZOSF("TRAP")
N P,BDMCTP,BDMBD,BDMED,BDMPIEN,BDMI,BDMPAT,BDMCHT,BDMINST,BDMLAB,BDMEL
S P="|"
S BDMCTP=$P(BDMSTR,P)
S BDMBD=$P(BDMSTR,P,2)
S BDMED=$P(BDMSTR,P,3)
S BDMPIEN=$P(BDMSTR,P,4)
S BDMINST=$P(BDMSTR,P,5)-1
S BDMLAB=$P(BDMSTR,P,6)
S BDMEL=$P(BDMSTR,P,7)
S BDMPAT=$P($G(^DPT(BDMPIEN,0)),U)
S BDMCHT=$$HRN^AUPNPAT(BDMPIEN,DUZ(2))
S BDMI=0
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
D @BDMCTP^BDMGUA(BDMBD,BDMED,BDMPIEN,BDMPAT,BDMCHT,BDMINST,BDMLAB,BDMEL)
S ^BDMTMP($J,BDMI+1)=$C(31)
Q
;
WEIGHT(BD,ED,PIEN,PAT,CHT,INST,LAB,EL) ;-- get the chartable wts
S ^BDMTMP($J,BDMI)="T00020Begin Date^T00020End Date^T00020Date^T00004Weight^T00030Patient^T00007Chart"_$C(30)
N BDMDA,BDMEDA,BDMMST,BDMCNT
S BDMCNT=0
S BDMBDA=9999999-BD
S BDMDA=9999999-ED
S BDMMST=$O(^AUTTMSR("B","WT",0))
F S BDMDA=$O(^AUPNVMSR("AA",PIEN,BDMMST,BDMDA)) Q:'BDMDA!(BDMDA>BDMBDA)!(BDMCNT>INST) D
. Q:BDMCNT>INST
. N BDMIEN,BDMVAL,BDMVDT
. S BDMIEN=0 F S BDMIEN=$O(^AUPNVMSR("AA",PIEN,BDMMST,BDMDA,BDMIEN)) Q:'BDMIEN D
.. Q:BDMCNT>INST
.. S BDMCNT=BDMCNT+1
.. S BDMVAL=$P($G(^AUPNVMSR(BDMIEN,0)),U,4)
.. S BDMVDT=9999999-BDMDA
.. I $G(EL)="L" D Q
... S BDMI=BDMI+1
... S ^BDMTMP($J,BDMI)=$$FMTE^XLFDT(BD)_U_$$FMTE^XLFDT(ED)_U_$$FMTE^XLFDT(BDMVDT)_U_BDMVAL_U_PAT_U_CHT_$C(30)
.. S ^TMP($J,"BDMGUI",BDMVDT,BDMIEN)=$$FMTE^XLFDT(BD)_U_$$FMTE^XLFDT(ED)_U_$$FMTE^XLFDT(BDMVDT)_U_BDMVAL_U_PAT_U_CHT
Q:$G(EL)="L"
N BDMTDA,BDMTIEM
S BDMTDA=0 F S BDMTDA=$O(^TMP($J,"BDMGUI",BDMTDA)) Q:'BDMTDA D
. S BDMTIEN=0 F S BDMTIEN=$O(^TMP($J,"BDMGUI",BDMTDA,BDMTIEN)) Q:'BDMTIEN D
.. S BDMI=BDMI+1
.. S ^BDMTMP($J,BDMI)=$G(^TMP($J,"BDMGUI",BDMTDA,BDMTIEN))_$C(30)
K ^TMP($J,"BDMGUI")
Q
;
BP(BD,ED,PIEN,PAT,CHT,INST,LAB,EL) ;-- get the chartable bps
S ^BDMTMP($J,BDMI)="T00020Begin Date^T00020End Date^T00020Date^T00004Systolic^T00004Diastolic^T00007Chart"_$C(30)
N BDMDA,BDMEDA,BDMMST,BDMCNT
S BDMCNT=0
S BDMBDA=9999999-BD
S BDMDA=9999999-ED
S BDMMST=$O(^AUTTMSR("B","BP",0))
F S BDMDA=$O(^AUPNVMSR("AA",PIEN,BDMMST,BDMDA)) Q:'BDMDA!(BDMDA>BDMBDA)!(BDMCNT>INST) D
. Q:BDMCNT>INST
. N BDMIEN
. S BDMIEN=0 F S BDMIEN=$O(^AUPNVMSR("AA",PIEN,BDMMST,BDMDA,BDMIEN)) Q:'BDMIEN D
.. N BDMVAL,BDMVDT,BDMSYS,BDMDIA
.. Q:BDMCNT>INST
.. S BDMCNT=BDMCNT+1
.. S BDMVAL=$P($G(^AUPNVMSR(BDMIEN,0)),U,4)
.. S BDMSYS=$P(BDMVAL,"/")
.. S BDMDIA=$P(BDMVAL,"/",2)
.. S BDMVDT=9999999-BDMDA
.. I $G(EL)="L" D Q
... S BDMI=BDMI+1
... S ^BDMTMP($J,BDMI)=$$FMTE^XLFDT(BD)_U_$$FMTE^XLFDT(ED)_U_$$FMTE^XLFDT(BDMVDT)_U_BDMSYS_U_BDMDIA_U_CHT_$C(30)
.. S ^TMP($J,"BDMGUI",BDMVDT,BDMIEN)=$$FMTE^XLFDT(BD)_U_$$FMTE^XLFDT(ED)_U_$$FMTE^XLFDT(BDMVDT)_U_BDMSYS_U_BDMDIA_U_CHT
N BDMTDA,BDMTIEM
S BDMTDA=0 F S BDMTDA=$O(^TMP($J,"BDMGUI",BDMTDA)) Q:'BDMTDA D
. S BDMTIEN=0 F S BDMTIEN=$O(^TMP($J,"BDMGUI",BDMTDA,BDMTIEN)) Q:'BDMTIEN D
.. S BDMI=BDMI+1
.. S ^BDMTMP($J,BDMI)=$G(^TMP($J,"BDMGUI",BDMTDA,BDMTIEN))_$C(30)
K ^TMP($J,"BDMGUI")
Q
;
LAB(BD,ED,PIEN,PAT,CHT,INST,LAB,EL) ;-- get the chartable labs
S ^BDMTMP($J,BDMI)="T00020Begin Date^T00020End Date^T00020Date^T00004Lab Value^T00030Abnormal^T00007Chart"_$C(30)
N BDMDA,BDMEDA,BDMCNT
S BDMCNT=0
S BDMBDA=9999999-BD
S BDMDA=9999999-ED
F S BDMDA=$O(^AUPNVLAB("AA",PIEN,LAB,BDMDA)) Q:'BDMDA!(BDMDA>BDMBDA)!(BDMCNT>INST) D
. Q:BDMCNT>INST
. N BDMIEN
. S BDMIEN=0 F S BDMIEN=$O(^AUPNVLAB("AA",PIEN,LAB,BDMDA,BDMIEN)) Q:'BDMIEN D
.. N BDMVAL,BDMABN,BDMVDT
.. Q:BDMCNT>INST
.. S BDMCNT=BDMCNT+1
.. S BDMVAL=$P($G(^AUPNVLAB(BDMIEN,0)),U,4)
.. S BDMABN=$P($G(^AUPNVLAB(BDMIEN,0)),U,5)
.. S BDMVDT=9999999-BDMDA
.. I $G(EL)="L" D Q
... S BDMI=BDMI+1
... S ^BDMTMP($J,BDMI)=$$FMTE^XLFDT(BD)_U_$$FMTE^XLFDT(ED)_U_$$FMTE^XLFDT(BDMVDT)_U_BDMVAL_U_BDMABN_U_CHT_$C(30)
.. S ^TMP($J,"BDMGUI",BDMVDT,BDMIEN)=$$FMTE^XLFDT(BD)_U_$$FMTE^XLFDT(ED)_U_$$FMTE^XLFDT(BDMVDT)_U_BDMVAL_U_BDMABN_U_CHT
N BDMTDA,BDMTIEM
S BDMTDA=0 F S BDMTDA=$O(^TMP($J,"BDMGUI",BDMTDA)) Q:'BDMTDA D
. S BDMTIEN=0 F S BDMTIEN=$O(^TMP($J,"BDMGUI",BDMTDA,BDMTIEN)) Q:'BDMTIEN D
.. S BDMI=BDMI+1
.. S ^BDMTMP($J,BDMI)=$G(^TMP($J,"BDMGUI",BDMTDA,BDMTIEN))_$C(30)
K ^TMP($J,"BDMGUI")
Q
;
ASTMP(BDMRET,BDMSTR) ;-- add entries search template
S X="MERR^BDMGU",@^%ZOSF("TRAP")
N P,BDMRGE,BDMST,BDMRG,BDMGLB,BDMU,BDMTRNE,BDMTRN
S P="|"
K ^BDMTMP($J)
S BDMRGE=$P(BDMSTR,P)
S BDMRG=$O(^ACM(41.1,"B",BDMRGE,0))
S BDMTRNE=$P(BDMSTR,P,2)
S BDMTRN=$O(^DIBT("B",BDMTRNE,0))
S $P(^ACM(41.1,BDMRG,0),U,9)=1
S BDMGLB="^DIBT("_BDMTRN_",1)"
S BDMU=0 F S BDMU=$O(@BDMGLB@(BDMU)) Q:BDMU="" D
. I '$D(^ACM(41,"AC",BDMU,BDMRG)) D
.. S:$P(^ACM(41.1,BDMRG,0),U,9)="" $P(^(0),U,9)=1
.. D REGADD^BDMGE(.BDMRET,BDMRGE_"|"_BDMU)
S $P(^ACM(41.1,BDMRG,0),U,9)=""
S BDMRET="^BDMTMP("_$J_")"
S ^BDMTMP($J,0)="T00050RETURN"_$C(30)
S ^BDMTMP($J,1)="Patients Added Successfully"_$C(30)
S ^BDMTMP($J,2)=$C(31)_$G(BDMERR)
Q
;
DELRPT(RETVAL,BDMSTR) ;-- delete a report
S X="MERR^BDMGU",@^%ZOSF("TRAP")
N P,R,I
S P="|",R="~"
S BDMERR=""
K ^BDMTMP($J)
S RETVAL="^BDMTMP("_$J_")"
F I=2:1 D Q:$P(BDMSTR,R,I)=""
. N BDMI,BDMDA
. Q:$P(BDMSTR,R,I)=""
. S BDMI=$P(BDMSTR,R,I)
. S BDMDA=$E(BDMI,2,9)
. I $E(BDMI,1,1)="A" D
.. S DIK="^BDMGUI(",DA=BDMDA D ^DIK
. I $E(BDMI,1,1)="B" D
.. S DIK="^BDMGUI(",DA=BDMDA D ^DIK
S ^BDMTMP($J,0)="T00250DATA"_$C(30)
S ^BDMTMP($J,1)=$G(BDMERR)_$C(30)
S ^BDMTMP($J,2)=$C(31)_BDMERR
Q
;
PRB(BDMRET,BDMSTR) ;-- return a list of problems
S X="MERR^BDMGU",@^%ZOSF("TRAP")
N BDMDA,BDMI,BDMERR,BDMDATA,BDMPAT,BDMPIEN,P,BDMDX,BDMDLM,BDMCL,BDMNAR,BDMFAC,BDMNMBR,BDMDE,BDMST,BDMON,BDMULM,BDMENT,BDMUENT
N BDMOEN,BDMFACA,BDMFACE,BDMFAC,BDMPOVD,BDMDEL
S P="|"
S BDMPAT=$P(BDMSTR,P)
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00035NMBR^T00010DIAGNOSISIEN^T00010DIAGNOSIS^T00020DLM^T00025CLASS^T00080NARRATIVE^T00020ENT^T00010STATUS^T00020ONSET^T00030ULM^T00030ENTER^T00003NOTES^T00008IEN^T00050FACILITY"_$C(30)
S DFN=BDMPAT
D GETPLDX^BDMVRL8
S BDMOEN=0 F S BDMOEN=$O(BDMPLDX(BDMOEN)) Q:'BDMOEN D
. S BDMDATA=$G(^AUPNPROB(BDMOEN,0))
. S BDMPOVD=$E($G(^ICD9($P(BDMDATA,U),1)),1,70)
. S BDMDXI=$P(BDMDATA,U)
. S BDMDX=$$GET1^DIQ(9000011,BDMOEN,.01)
. S BDMDLM=$$FMTE^XLFDT($P(BDMDATA,U,3))
. S BDMCL=$S($$GET1^DIQ(9000011,BDMOEN,.04,"I")]"":$$GET1^DIQ(9000011,BDMOEN,.04,"I")_"-"_$$GET1^DIQ(9000011,BDMOEN,.04),1:"")
. S BDMNAR=$TR($$GET1^DIQ(9000011,BDMOEN,.05),"|","")
. S BDMFAC=$P(BDMDATA,U,6)
. I BDMFAC S BDMFACE=$P($G(^DIC(4,BDMFAC,0)),U)
. I BDMFAC S BDMFACA=$P($G(^AUTTLOC(BDMFAC,0)),U,7)
. I BDMFAC S BDMFACS=$P($G(^AUTTLOC(BDMFAC,0)),U,10)
. S BDMNMBR=$P(BDMDATA,U,7)
. S BDMENT=$$FMTE^XLFDT($P(BDMDATA,U,8))
. S BDMST=$$GET1^DIQ(9000011,BDMOEN,.12)
. S BDMON=$$FMTE^XLFDT($P(BDMDATA,U,13))
. S BDMULM=$$GET1^DIQ(9000011,BDMOEN,.14)
. S BDMUENT=$$GET1^DIQ(9000011,BDMOEN,1.03)
. S BDMNOTES=$S($P($G(^AUPNPROB(BDMOEN,11,0)),U,4):"Yes",1:"No")
. S BDMI=BDMI+1
. S ^BDMTMP($J,BDMI)=$G(BDMFACA)_BDMNMBR_U_BDMDXI_U_BDMDX_U_BDMDLM_U_BDMCL_U_BDMNAR_U_BDMENT_U_BDMON_U_BDMST_U_BDMULM_U_BDMUENT_U_BDMNOTES_U_BDMOEN_U_$G(BDMFAC)_"~"_$G(BDMFACS)_"-"_$G(BDMFACE)_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
NOTES(BDMRET,BDMSTR) ;-- get pl notes
S X="MERR^BDMGU",@^%ZOSF("TRAP")
N P,BDMDA,BDMIEN,BDMI
S P="|"
S BDMPIEN=$P(BDMSTR,P)
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00040FAC^T00080NOTE^T00001STATUS^T00007NOTEFAC^T00007NOTEIEN^T00030NOTEDATE"_$C(30)
S BDMDA=0 F S BDMDA=$O(^AUPNPROB(BDMPIEN,11,BDMDA)) Q:'BDMDA D
. N BDMFAC,BDMFACA,BDMFACE
. S BDMFAC=$P($G(^AUPNPROB(BDMPIEN,11,BDMDA,0)),U)
. I BDMFAC S BDMFACE=$P($G(^DIC(4,BDMFAC,0)),U)
. I BDMFAC S BDMFACA=$P($G(^AUTTLOC(BDMFAC,0)),U,7)
. S BDMIEN=0 F S BDMIEN=$O(^AUPNPROB(BDMPIEN,11,BDMDA,11,BDMIEN)) Q:'BDMIEN D
.. N BDMDATA,BDMNBMR,BDMNNAR,BDMST,BDMNDT
.. S BDMDATA=$G(^AUPNPROB(BDMPIEN,11,BDMDA,11,BDMIEN,0))
.. S BDMNMBR=$P(BDMDATA,U)
.. S BDMNNAR=$P(BDMDATA,U,3)
.. S BDMST=$P(BDMDATA,U,4)
.. S BDMNDT=$$FMTE^XLFDT($P(BDMDATA,U,5))
.. S BDMI=BDMI+1
.. S ^BDMTMP($J,BDMI)=$G(BDMFACA)_BDMNMBR_U_BDMNNAR_U_$G(BDMNDT)_U_BDMST_U_BDMDA_U_BDMIEN_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
ADDPRB(BDMRET,BDMSTR) ;-- add a problem
S X="MERR^BDMGU",@^%ZOSF("TRAP")
N P,BDMPAT,BDMDX,BDMDLM,BDMCL,BDMNAR,BDMFAC,BDMDE,BDMST,BDMON
S P="|"
S BDMPAT=$P(BDMSTR,P)
S BDMDX=$TR($P(BDMSTR,P,2)," ")
I $G(BDMDX) S BDMDX="`"_BDMDX
S BDMDLM=$P(BDMSTR,P,3)
S BDMCL=$P(BDMSTR,P,4)
S BDMNAR=$P(BDMSTR,P,5)
S BDMFAC=$P($P(BDMSTR,P,6),"-")
I $G(BDMFAC)'?.N S BDMFAC=$O(^AUTTLOC("C",BDMFAC,0))
S BDMST=$P(BDMSTR,P,7)
S BDMON=$P(BDMSTR,P,8)
S BDMRET=$$ADDPROB^BDMPROB(BDMDX,BDMPAT,BDMDLM,BDMCL,BDMNAR,BDMFAC,"",BDMST,BDMON)
Q
;
DELPR(BDMRET,BDMSTR) ;-- delete a problem
S X="MERR^BDMGU",@^%ZOSF("TRAP")
S R="~"
N BDMIEN,BDMREA,BDMOTH
S BDMIEN=$P(BDMSTR,R)
S BDMREA=$P(BDMSTR,R,2)
S BDMOTH=$P(BDMSTR,R,3)
S BDMRET=$$DELPROB^BDMPROB(BDMIEN,BDMREA,BDMOTH)
Q
;
VC(RETVAL,BDMSTR) ;-- get version number
N P
S P="|"
K ^BDMTMP($J)
N BDMVER,BDMVERI,BDMVERIN,BDMPKG,BDMI,BDMPTCH,BDMPTCHI,BDMVERI
S BDMI=0
S BDMVERIN=$P(BDMSTR,P)
S BDMVERIN=$TR(BDMVERIN,".")
S RETVAL="^BDMTMP("_$J_")"
S ^BDMTMP($J,BDMI)="T00001VersionPresent"_$C(30)
S BDMI=BDMI+1
S BDMPKG=$O(^DIC(9.4,"C","BDM",0))
I '$G(BDMPKG) D Q
. S ^BDMTMP($J,BDMI)=0_$C(30)
. S ^BDMTMP($J,BDMI+1)=$C(31)
S BDMVER=$G(^DIC(9.4,BDMPKG,"VERSION"))
S BDMVERI=$O(^DIC(9.4,BDMPKG,22,"B",BDMVER,0))
S BDMPTCH=$O(^DIC(9.4,BDMPKG,22,BDMVERI,"PAH","B",""),-1)
I ($TR(BDMVER,".")_BDMPTCH)=BDMVERIN D Q
. S ^BDMTMP($J,BDMI)=1_$C(30)
. S ^BDMTMP($J,BDMI+1)=$C(31)
S ^BDMTMP($J,BDMI)=0_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)
Q
BDMGUA ; cmi/anch/maw - BDM DMS GUI Utilities ; 11 Feb 2010 7:45 AM
+1 ;;2.0;BDM DIABETES MANAGEMENT SYSTEM;**1,3,5,6,7,8,9,10,11,12**;JUN 14, 2007;Build 51
+2 ;
+3 ;
+4 ;
+5 ;
DEBUG(BDMRET,BDMSTR) ;-- debug
+1 DO DEBUG^%Serenji("TAXCHK^BDMGUA(.BDMRET,.BDMSTR)")
+2 QUIT
+3 ;
DELPT(BDMRET,BDMSTR) ;-- delete a patient/data from dms
+1 SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BDMPAT,BDMGREF,BDMI,BDMX
+3 SET P="|"
+4 ;patient
SET BDMPAT=$PIECE(BDMSTR,P)
+5 ;register
SET BDMREGE=$PIECE(BDMSTR,P,2)
+6 ;register ien
SET BDMREG=$ORDER(^ACM(41.1,"B",BDMREGE,0))
+7 SET BDMGREF="^ACM(49)"
+8 SET BDMX=0
FOR
SET BDMX=$ORDER(@BDMGREF@("AC",BDMREG,BDMPAT,BDMX))
IF 'BDMX
QUIT
Begin DoDot:1
+9 SET DA=0
FOR
SET DA=$ORDER(@BDMGREF@("AC",BDMREG,BDMPAT,BDMX,DA))
IF 'DA
QUIT
Begin DoDot:2
+10 SET DIK="^ACM(49,"
+11 DO ^DIK
+12 KILL DIK,DIC
End DoDot:2
End DoDot:1
+13 FOR BDMI=42,43,44,45,46,47,48,51,53,54,41
SET BDMGREF="^ACM("_BDMI_")"
+14 SET BDMX=0
FOR
SET BDMX=$ORDER(@BDMGREF@("AC",BDMREG,BDMPAT,BDMX))
IF 'BDMX
QUIT
SET DIK="^ACM("_BDMI_","
SET DA=^(BDMX)
Begin DoDot:1
+15 DO ^DIK
+16 KILL DIK,DIC,DA
End DoDot:1
+17 SET DA=^ACM(41,"AC",BDMPAT,BDMREG)
SET DIK="^ACM(41,"
+18 DO ^DIK
+19 KILL DIK,DIC
+20 SET BDMRET=""
+21 QUIT
+22 ;
TAXCHKO(BDMRET) ;-- check taxonomies
+1 SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMI,BDMJ,BDMDATA,BDMDA
+3 SET BDMI=0
+4 SET BDMERR=""
+5 KILL ^BDMTMP($JOB)
+6 SET BDMRET="^BDMTMP("_$JOB_")"
+7 SET ^BDMTMP($JOB,BDMI)="T00250DATA"_$CHAR(30)
+8 SET BDMJ=0
+9 SET IOM=80
+10 DO GUIR^XBLM("TAXCHK^BDMDA19","^XTMP(""BDMTAX"",$J)")
+11 SET BDMDA=.5
FOR
SET BDMDA=$ORDER(^XTMP("BDMTAX",$JOB,BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+12 NEW BDMDATA
+13 SET BDMI=BDMI+1
+14 SET BDMDATA=$GET(^XTMP("BDMTAX",$JOB,BDMDA))
+15 SET ^BDMTMP($JOB,BDMI)=BDMDATA_$CHAR(30)
End DoDot:1
+16 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_BDMERR
+17 KILL ^XTMP("BDMTAX",$JOB)
+18 QUIT
+19 ;
TAXCHK(RETVAL,BDMSTR) ;-- check taxonomies
+1 SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMI,BDMJ,BDMDATA,BDMDA,BDMRTN,P
+3 SET P="|"
+4 SET BDMI=0
+5 SET BDMERR=""
+6 SET BDMRTN=$PIECE(BDMSTR,P)
+7 KILL ^BDMTMP($JOB)
+8 SET RETVAL="^BDMTMP("_$JOB_")"
+9 SET ^BDMTMP($JOB,BDMI)="T00250DATA"_$CHAR(30)
+10 SET BDMJ=0
+11 SET IOM=80
+12 DO GUIR^XBLM("TAXCHK^"_BDMRTN,"^XTMP(""BDMTAX"",$J)")
+13 SET BDMDA=.5
FOR
SET BDMDA=$ORDER(^XTMP("BDMTAX",$JOB,BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+14 NEW BDMDATA
+15 SET BDMI=BDMI+1
+16 SET BDMDATA=$GET(^XTMP("BDMTAX",$JOB,BDMDA))
+17 SET ^BDMTMP($JOB,BDMI)=BDMDATA_$CHAR(30)
End DoDot:1
+18 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_BDMERR
+19 KILL ^XTMP("BDMTAX",$JOB)
+20 QUIT
+21 ;
UPDTAX(BDMRET,BDMSTR) ;update taxonomies
+1 SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BDMOPT,BDMI
+3 SET P="|"
+4 SET BDMI=0
+5 KILL ^BDMTMP($JOB)
+6 SET BDMRET="^BDMTMP("_$JOB_")"
+7 SET ^BDMTMP($JOB,BDMI)="T00080TAXONOMY NAME"_$CHAR(30)
+8 SET BDMOPT=$PIECE(BDMSTR,P)
+9 IF BDMOPT="Upd DM Audit P 05"
Begin DoDot:1
+10 DO INIT^BDMP5TS
End DoDot:1
+11 IF BDMOPT="Upd DM Audit 05"
Begin DoDot:1
+12 DO INIT^BDMD5TS
End DoDot:1
+13 IF BDMOPT="Upd DM Audit P 06"
Begin DoDot:1
+14 DO INIT^BDMP6TS
End DoDot:1
+15 IF BDMOPT="Upd DM Audit 06"
Begin DoDot:1
+16 DO INIT^BDMD6TS
End DoDot:1
+17 IF BDMOPT="Upd DM Audit P 07"
Begin DoDot:1
+18 DO INIT^BDMP7TS
End DoDot:1
+19 IF BDMOPT="Upd DM Audit 07"
Begin DoDot:1
+20 DO INIT^BDMD7TS
End DoDot:1
+21 IF BDMOPT="Upd DM Audit P 08"
Begin DoDot:1
+22 DO INIT^BDMP8TS
End DoDot:1
+23 IF BDMOPT="Upd DM Audit 08"
Begin DoDot:1
+24 DO INIT^BDMD8TS
End DoDot:1
+25 IF BDMOPT="Upd DM Audit P 09"
Begin DoDot:1
+26 DO INIT^BDMP9TS
End DoDot:1
+27 IF BDMOPT="Upd DM Audit 09"
Begin DoDot:1
+28 DO INIT^BDMD9TS
End DoDot:1
+29 IF BDMOPT="Upd DM Audit P 10"
Begin DoDot:1
+30 DO INIT^BDMP0TS
End DoDot:1
+31 IF BDMOPT="Upd DM Audit 10"
Begin DoDot:1
+32 DO INIT^BDMD0TS
End DoDot:1
+33 IF BDMOPT="Upd DM Audit P 11"
Begin DoDot:1
+34 DO INIT^BDMP1TS
End DoDot:1
+35 IF BDMOPT="Upd DM Audit 11"
Begin DoDot:1
+36 DO INIT^BDMD1TS
End DoDot:1
+37 IF BDMOPT="Upd DM Audit P 12"
Begin DoDot:1
+38 DO INIT^BDMP4TS
End DoDot:1
+39 IF BDMOPT="Upd DM Audit 12"
Begin DoDot:1
+40 DO INIT^BDMD4TS
End DoDot:1
+41 IF BDMOPT="Upd DM Audit P 13"
Begin DoDot:1
+42 DO INIT^BDMPATS
End DoDot:1
+43 IF BDMOPT="Upd DM Audit 13"
Begin DoDot:1
+44 DO INIT^BDMDATS
End DoDot:1
+45 IF BDMOPT="Upd DM Audit P 14"
Begin DoDot:1
+46 DO INIT^BDMPBTS
End DoDot:1
+47 IF BDMOPT="Upd DM Audit 14"
Begin DoDot:1
+48 DO INIT^BDMDBTS
End DoDot:1
+49 IF BDMOPT="Upd DM Audit P 15"
Begin DoDot:1
+50 DO INIT^BDMPCTS
End DoDot:1
+51 IF BDMOPT="Upd DM Audit 15"
Begin DoDot:1
+52 DO INIT^BDMDCTS
End DoDot:1
+53 IF BDMOPT="Upd DM Audit P 16"
Begin DoDot:1
+54 DO INIT^BDMPDTS
End DoDot:1
+55 IF BDMOPT="Upd DM Audit 16"
Begin DoDot:1
+56 DO INIT^BDMDDTS
End DoDot:1
+57 IF BDMOPT="Upd DM Audit P 17"
Begin DoDot:1
+58 DO INIT^BDMPETS
End DoDot:1
+59 IF BDMOPT="Upd DM Audit 17"
Begin DoDot:1
+60 DO INIT^BDMDETS
End DoDot:1
+61 IF BDMOPT="Upd DM Audit P 18"
Begin DoDot:1
+62 DO INIT^BDMPFTS
End DoDot:1
+63 IF BDMOPT="Upd DM Audit 18"
Begin DoDot:1
+64 DO INIT^BDMDFTS
End DoDot:1
+65 IF BDMOPT="Upd DM Audit P 19"
Begin DoDot:1
+66 DO INIT^BDMPGTS
End DoDot:1
+67 IF BDMOPT="Upd DM Audit 19"
Begin DoDot:1
+68 DO INIT^BDMDGTS
End DoDot:1
+69 NEW BDMDA,BDMT
+70 SET BDMDA=0
FOR
SET BDMDA=$ORDER(BDMTAX("IDX",BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+71 NEW BDMN,BDMFL,BDMRO,BDMFLT,BDMPAN
+72 SET BDMI=BDMI+1
+73 SET BDMT=$PIECE($GET(BDMTAX("IDX",BDMDA,BDMDA)),U)
+74 SET BDMTT=$PIECE($GET(BDMTAX("IDX",BDMDA,BDMDA)),U,2)
+75 IF BDMTT="T"
Begin DoDot:2
+76 SET BDMN=$PIECE($GET(^ATXAX(BDMT,0)),U)
+77 SET BDMRO=$SELECT($PIECE($GET(^ATXAX(BDMT,0)),U,22):"Read Only",1:"Editable")
+78 SET BDMFL=$PIECE($GET(^ATXAX(BDMT,0)),U,15)
+79 SET BDMFLT=$SELECT(BDMFL=50:"Med",1:"Tax")
End DoDot:2
+80 IF BDMTT="L"
Begin DoDot:2
+81 SET BDMN=$PIECE($GET(^ATXLAB(BDMT,0)),U)
+82 SET BDMPAN=$PIECE($GET(^ATXLAB(BDMT,0)),U,11)
+83 SET BDMRO=$SELECT($PIECE($GET(^ATXLAB(BDMT,0)),U,22):"Read Only",1:"Editable")
+84 SET BDMFL=$PIECE($GET(^ATXLAB(BDMT,0)),U,9)
+85 SET BDMFLT="Lab"
End DoDot:2
+86 SET ^BDMTMP($JOB,BDMI)=BDMN_"("_BDMRO_"/"_BDMFLT_"/"_BDMFL_"/"_$GET(BDMPAN)_")"_$CHAR(30)
End DoDot:1
+87 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)
+88 QUIT
+89 ;
CHTDATA(BDMRET,BDMSTR) ;-- get lab, bp or wt data for chart
+1 SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BDMCTP,BDMBD,BDMED,BDMPIEN,BDMI,BDMPAT,BDMCHT,BDMINST,BDMLAB,BDMEL
+3 SET P="|"
+4 SET BDMCTP=$PIECE(BDMSTR,P)
+5 SET BDMBD=$PIECE(BDMSTR,P,2)
+6 SET BDMED=$PIECE(BDMSTR,P,3)
+7 SET BDMPIEN=$PIECE(BDMSTR,P,4)
+8 SET BDMINST=$PIECE(BDMSTR,P,5)-1
+9 SET BDMLAB=$PIECE(BDMSTR,P,6)
+10 SET BDMEL=$PIECE(BDMSTR,P,7)
+11 SET BDMPAT=$PIECE($GET(^DPT(BDMPIEN,0)),U)
+12 SET BDMCHT=$$HRN^AUPNPAT(BDMPIEN,DUZ(2))
+13 SET BDMI=0
+14 KILL ^BDMTMP($JOB)
+15 SET BDMRET="^BDMTMP("_$JOB_")"
+16 DO @BDMCTP^BDMGUA(BDMBD,BDMED,BDMPIEN,BDMPAT,BDMCHT,BDMINST,BDMLAB,BDMEL)
+17 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)
+18 QUIT
+19 ;
WEIGHT(BD,ED,PIEN,PAT,CHT,INST,LAB,EL) ;-- get the chartable wts
+1 SET ^BDMTMP($JOB,BDMI)="T00020Begin Date^T00020End Date^T00020Date^T00004Weight^T00030Patient^T00007Chart"_$CHAR(30)
+2 NEW BDMDA,BDMEDA,BDMMST,BDMCNT
+3 SET BDMCNT=0
+4 SET BDMBDA=9999999-BD
+5 SET BDMDA=9999999-ED
+6 SET BDMMST=$ORDER(^AUTTMSR("B","WT",0))
+7 FOR
SET BDMDA=$ORDER(^AUPNVMSR("AA",PIEN,BDMMST,BDMDA))
IF 'BDMDA!(BDMDA>BDMBDA)!(BDMCNT>INST)
QUIT
Begin DoDot:1
+8 IF BDMCNT>INST
QUIT
+9 NEW BDMIEN,BDMVAL,BDMVDT
+10 SET BDMIEN=0
FOR
SET BDMIEN=$ORDER(^AUPNVMSR("AA",PIEN,BDMMST,BDMDA,BDMIEN))
IF 'BDMIEN
QUIT
Begin DoDot:2
+11 IF BDMCNT>INST
QUIT
+12 SET BDMCNT=BDMCNT+1
+13 SET BDMVAL=$PIECE($GET(^AUPNVMSR(BDMIEN,0)),U,4)
+14 SET BDMVDT=9999999-BDMDA
+15 IF $GET(EL)="L"
Begin DoDot:3
+16 SET BDMI=BDMI+1
+17 SET ^BDMTMP($JOB,BDMI)=$$FMTE^XLFDT(BD)_U_$$FMTE^XLFDT(ED)_U_$$FMTE^XLFDT(BDMVDT)_U_BDMVAL_U_PAT_U_CHT_$CHAR(30)
End DoDot:3
QUIT
+18 SET ^TMP($JOB,"BDMGUI",BDMVDT,BDMIEN)=$$FMTE^XLFDT(BD)_U_$$FMTE^XLFDT(ED)_U_$$FMTE^XLFDT(BDMVDT)_U_BDMVAL_U_PAT_U_CHT
End DoDot:2
End DoDot:1
+19 IF $GET(EL)="L"
QUIT
+20 NEW BDMTDA,BDMTIEM
+21 SET BDMTDA=0
FOR
SET BDMTDA=$ORDER(^TMP($JOB,"BDMGUI",BDMTDA))
IF 'BDMTDA
QUIT
Begin DoDot:1
+22 SET BDMTIEN=0
FOR
SET BDMTIEN=$ORDER(^TMP($JOB,"BDMGUI",BDMTDA,BDMTIEN))
IF 'BDMTIEN
QUIT
Begin DoDot:2
+23 SET BDMI=BDMI+1
+24 SET ^BDMTMP($JOB,BDMI)=$GET(^TMP($JOB,"BDMGUI",BDMTDA,BDMTIEN))_$CHAR(30)
End DoDot:2
End DoDot:1
+25 KILL ^TMP($JOB,"BDMGUI")
+26 QUIT
+27 ;
BP(BD,ED,PIEN,PAT,CHT,INST,LAB,EL) ;-- get the chartable bps
+1 SET ^BDMTMP($JOB,BDMI)="T00020Begin Date^T00020End Date^T00020Date^T00004Systolic^T00004Diastolic^T00007Chart"_$CHAR(30)
+2 NEW BDMDA,BDMEDA,BDMMST,BDMCNT
+3 SET BDMCNT=0
+4 SET BDMBDA=9999999-BD
+5 SET BDMDA=9999999-ED
+6 SET BDMMST=$ORDER(^AUTTMSR("B","BP",0))
+7 FOR
SET BDMDA=$ORDER(^AUPNVMSR("AA",PIEN,BDMMST,BDMDA))
IF 'BDMDA!(BDMDA>BDMBDA)!(BDMCNT>INST)
QUIT
Begin DoDot:1
+8 IF BDMCNT>INST
QUIT
+9 NEW BDMIEN
+10 SET BDMIEN=0
FOR
SET BDMIEN=$ORDER(^AUPNVMSR("AA",PIEN,BDMMST,BDMDA,BDMIEN))
IF 'BDMIEN
QUIT
Begin DoDot:2
+11 NEW BDMVAL,BDMVDT,BDMSYS,BDMDIA
+12 IF BDMCNT>INST
QUIT
+13 SET BDMCNT=BDMCNT+1
+14 SET BDMVAL=$PIECE($GET(^AUPNVMSR(BDMIEN,0)),U,4)
+15 SET BDMSYS=$PIECE(BDMVAL,"/")
+16 SET BDMDIA=$PIECE(BDMVAL,"/",2)
+17 SET BDMVDT=9999999-BDMDA
+18 IF $GET(EL)="L"
Begin DoDot:3
+19 SET BDMI=BDMI+1
+20 SET ^BDMTMP($JOB,BDMI)=$$FMTE^XLFDT(BD)_U_$$FMTE^XLFDT(ED)_U_$$FMTE^XLFDT(BDMVDT)_U_BDMSYS_U_BDMDIA_U_CHT_$CHAR(30)
End DoDot:3
QUIT
+21 SET ^TMP($JOB,"BDMGUI",BDMVDT,BDMIEN)=$$FMTE^XLFDT(BD)_U_$$FMTE^XLFDT(ED)_U_$$FMTE^XLFDT(BDMVDT)_U_BDMSYS_U_BDMDIA_U_CHT
End DoDot:2
End DoDot:1
+22 NEW BDMTDA,BDMTIEM
+23 SET BDMTDA=0
FOR
SET BDMTDA=$ORDER(^TMP($JOB,"BDMGUI",BDMTDA))
IF 'BDMTDA
QUIT
Begin DoDot:1
+24 SET BDMTIEN=0
FOR
SET BDMTIEN=$ORDER(^TMP($JOB,"BDMGUI",BDMTDA,BDMTIEN))
IF 'BDMTIEN
QUIT
Begin DoDot:2
+25 SET BDMI=BDMI+1
+26 SET ^BDMTMP($JOB,BDMI)=$GET(^TMP($JOB,"BDMGUI",BDMTDA,BDMTIEN))_$CHAR(30)
End DoDot:2
End DoDot:1
+27 KILL ^TMP($JOB,"BDMGUI")
+28 QUIT
+29 ;
LAB(BD,ED,PIEN,PAT,CHT,INST,LAB,EL) ;-- get the chartable labs
+1 SET ^BDMTMP($JOB,BDMI)="T00020Begin Date^T00020End Date^T00020Date^T00004Lab Value^T00030Abnormal^T00007Chart"_$CHAR(30)
+2 NEW BDMDA,BDMEDA,BDMCNT
+3 SET BDMCNT=0
+4 SET BDMBDA=9999999-BD
+5 SET BDMDA=9999999-ED
+6 FOR
SET BDMDA=$ORDER(^AUPNVLAB("AA",PIEN,LAB,BDMDA))
IF 'BDMDA!(BDMDA>BDMBDA)!(BDMCNT>INST)
QUIT
Begin DoDot:1
+7 IF BDMCNT>INST
QUIT
+8 NEW BDMIEN
+9 SET BDMIEN=0
FOR
SET BDMIEN=$ORDER(^AUPNVLAB("AA",PIEN,LAB,BDMDA,BDMIEN))
IF 'BDMIEN
QUIT
Begin DoDot:2
+10 NEW BDMVAL,BDMABN,BDMVDT
+11 IF BDMCNT>INST
QUIT
+12 SET BDMCNT=BDMCNT+1
+13 SET BDMVAL=$PIECE($GET(^AUPNVLAB(BDMIEN,0)),U,4)
+14 SET BDMABN=$PIECE($GET(^AUPNVLAB(BDMIEN,0)),U,5)
+15 SET BDMVDT=9999999-BDMDA
+16 IF $GET(EL)="L"
Begin DoDot:3
+17 SET BDMI=BDMI+1
+18 SET ^BDMTMP($JOB,BDMI)=$$FMTE^XLFDT(BD)_U_$$FMTE^XLFDT(ED)_U_$$FMTE^XLFDT(BDMVDT)_U_BDMVAL_U_BDMABN_U_CHT_$CHAR(30)
End DoDot:3
QUIT
+19 SET ^TMP($JOB,"BDMGUI",BDMVDT,BDMIEN)=$$FMTE^XLFDT(BD)_U_$$FMTE^XLFDT(ED)_U_$$FMTE^XLFDT(BDMVDT)_U_BDMVAL_U_BDMABN_U_CHT
End DoDot:2
End DoDot:1
+20 NEW BDMTDA,BDMTIEM
+21 SET BDMTDA=0
FOR
SET BDMTDA=$ORDER(^TMP($JOB,"BDMGUI",BDMTDA))
IF 'BDMTDA
QUIT
Begin DoDot:1
+22 SET BDMTIEN=0
FOR
SET BDMTIEN=$ORDER(^TMP($JOB,"BDMGUI",BDMTDA,BDMTIEN))
IF 'BDMTIEN
QUIT
Begin DoDot:2
+23 SET BDMI=BDMI+1
+24 SET ^BDMTMP($JOB,BDMI)=$GET(^TMP($JOB,"BDMGUI",BDMTDA,BDMTIEN))_$CHAR(30)
End DoDot:2
End DoDot:1
+25 KILL ^TMP($JOB,"BDMGUI")
+26 QUIT
+27 ;
ASTMP(BDMRET,BDMSTR) ;-- add entries search template
+1 SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BDMRGE,BDMST,BDMRG,BDMGLB,BDMU,BDMTRNE,BDMTRN
+3 SET P="|"
+4 KILL ^BDMTMP($JOB)
+5 SET BDMRGE=$PIECE(BDMSTR,P)
+6 SET BDMRG=$ORDER(^ACM(41.1,"B",BDMRGE,0))
+7 SET BDMTRNE=$PIECE(BDMSTR,P,2)
+8 SET BDMTRN=$ORDER(^DIBT("B",BDMTRNE,0))
+9 SET $PIECE(^ACM(41.1,BDMRG,0),U,9)=1
+10 SET BDMGLB="^DIBT("_BDMTRN_",1)"
+11 SET BDMU=0
FOR
SET BDMU=$ORDER(@BDMGLB@(BDMU))
IF BDMU=""
QUIT
Begin DoDot:1
+12 IF '$DATA(^ACM(41,"AC",BDMU,BDMRG))
Begin DoDot:2
+13 IF $PIECE(^ACM(41.1,BDMRG,0),U,9)=""
SET $PIECE(^(0),U,9)=1
+14 DO REGADD^BDMGE(.BDMRET,BDMRGE_"|"_BDMU)
End DoDot:2
End DoDot:1
+15 SET $PIECE(^ACM(41.1,BDMRG,0),U,9)=""
+16 SET BDMRET="^BDMTMP("_$JOB_")"
+17 SET ^BDMTMP($JOB,0)="T00050RETURN"_$CHAR(30)
+18 SET ^BDMTMP($JOB,1)="Patients Added Successfully"_$CHAR(30)
+19 SET ^BDMTMP($JOB,2)=$CHAR(31)_$GET(BDMERR)
+20 QUIT
+21 ;
DELRPT(RETVAL,BDMSTR) ;-- delete a report
+1 SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,R,I
+3 SET P="|"
SET R="~"
+4 SET BDMERR=""
+5 KILL ^BDMTMP($JOB)
+6 SET RETVAL="^BDMTMP("_$JOB_")"
+7 FOR I=2:1
Begin DoDot:1
+8 NEW BDMI,BDMDA
+9 IF $PIECE(BDMSTR,R,I)=""
QUIT
+10 SET BDMI=$PIECE(BDMSTR,R,I)
+11 SET BDMDA=$EXTRACT(BDMI,2,9)
+12 IF $EXTRACT(BDMI,1,1)="A"
Begin DoDot:2
+13 SET DIK="^BDMGUI("
SET DA=BDMDA
DO ^DIK
End DoDot:2
+14 IF $EXTRACT(BDMI,1,1)="B"
Begin DoDot:2
+15 SET DIK="^BDMGUI("
SET DA=BDMDA
DO ^DIK
End DoDot:2
End DoDot:1
IF $PIECE(BDMSTR,R,I)=""
QUIT
+16 SET ^BDMTMP($JOB,0)="T00250DATA"_$CHAR(30)
+17 SET ^BDMTMP($JOB,1)=$GET(BDMERR)_$CHAR(30)
+18 SET ^BDMTMP($JOB,2)=$CHAR(31)_BDMERR
+19 QUIT
+20 ;
PRB(BDMRET,BDMSTR) ;-- return a list of problems
+1 SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMDA,BDMI,BDMERR,BDMDATA,BDMPAT,BDMPIEN,P,BDMDX,BDMDLM,BDMCL,BDMNAR,BDMFAC,BDMNMBR,BDMDE,BDMST,BDMON,BDMULM,BDMENT,BDMUENT
+3 NEW BDMOEN,BDMFACA,BDMFACE,BDMFAC,BDMPOVD,BDMDEL
+4 SET P="|"
+5 SET BDMPAT=$PIECE(BDMSTR,P)
+6 KILL ^BDMTMP($JOB)
+7 SET BDMRET="^BDMTMP("_$JOB_")"
+8 SET BDMI=0
+9 SET BDMERR=""
+10 SET ^BDMTMP($JOB,BDMI)="T00035NMBR^T00010DIAGNOSISIEN^T00010DIAGNOSIS^T00020DLM^T00025CLASS^T00080NARRATIVE^T00020ENT^T00010STATUS^T00020ONSET^T00030ULM^T00030ENTER^T00003NOTES^T00008IEN^T00050FACILITY"_$CHAR(30)
+11 SET DFN=BDMPAT
+12 DO GETPLDX^BDMVRL8
+13 SET BDMOEN=0
FOR
SET BDMOEN=$ORDER(BDMPLDX(BDMOEN))
IF 'BDMOEN
QUIT
Begin DoDot:1
+14 SET BDMDATA=$GET(^AUPNPROB(BDMOEN,0))
+15 SET BDMPOVD=$EXTRACT($GET(^ICD9($PIECE(BDMDATA,U),1)),1,70)
+16 SET BDMDXI=$PIECE(BDMDATA,U)
+17 SET BDMDX=$$GET1^DIQ(9000011,BDMOEN,.01)
+18 SET BDMDLM=$$FMTE^XLFDT($PIECE(BDMDATA,U,3))
+19 SET BDMCL=$SELECT($$GET1^DIQ(9000011,BDMOEN,.04,"I")]"":$$GET1^DIQ(9000011,BDMOEN,.04,"I")_"-"_$$GET1^DIQ(9000011,BDMOEN,.04),1:"")
+20 SET BDMNAR=$TRANSLATE($$GET1^DIQ(9000011,BDMOEN,.05),"|","")
+21 SET BDMFAC=$PIECE(BDMDATA,U,6)
+22 IF BDMFAC
SET BDMFACE=$PIECE($GET(^DIC(4,BDMFAC,0)),U)
+23 IF BDMFAC
SET BDMFACA=$PIECE($GET(^AUTTLOC(BDMFAC,0)),U,7)
+24 IF BDMFAC
SET BDMFACS=$PIECE($GET(^AUTTLOC(BDMFAC,0)),U,10)
+25 SET BDMNMBR=$PIECE(BDMDATA,U,7)
+26 SET BDMENT=$$FMTE^XLFDT($PIECE(BDMDATA,U,8))
+27 SET BDMST=$$GET1^DIQ(9000011,BDMOEN,.12)
+28 SET BDMON=$$FMTE^XLFDT($PIECE(BDMDATA,U,13))
+29 SET BDMULM=$$GET1^DIQ(9000011,BDMOEN,.14)
+30 SET BDMUENT=$$GET1^DIQ(9000011,BDMOEN,1.03)
+31 SET BDMNOTES=$SELECT($PIECE($GET(^AUPNPROB(BDMOEN,11,0)),U,4):"Yes",1:"No")
+32 SET BDMI=BDMI+1
+33 SET ^BDMTMP($JOB,BDMI)=$GET(BDMFACA)_BDMNMBR_U_BDMDXI_U_BDMDX_U_BDMDLM_U_BDMCL_U_BDMNAR_U_BDMENT_U_BDMON_U_BDMST_U_BDMULM_U_BDMUENT_U_BDMNOTES_U_BDMOEN_U_$GET(BDMFAC)_"~"_$GET(BDMFACS)_"-"_$GET(BDMFACE)_$CHAR(30)
End DoDot:1
+34 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+35 QUIT
+36 ;
NOTES(BDMRET,BDMSTR) ;-- get pl notes
+1 SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BDMDA,BDMIEN,BDMI
+3 SET P="|"
+4 SET BDMPIEN=$PIECE(BDMSTR,P)
+5 KILL ^BDMTMP($JOB)
+6 SET BDMRET="^BDMTMP("_$JOB_")"
+7 SET BDMI=0
+8 SET BDMERR=""
+9 SET ^BDMTMP($JOB,BDMI)="T00040FAC^T00080NOTE^T00001STATUS^T00007NOTEFAC^T00007NOTEIEN^T00030NOTEDATE"_$CHAR(30)
+10 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^AUPNPROB(BDMPIEN,11,BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+11 NEW BDMFAC,BDMFACA,BDMFACE
+12 SET BDMFAC=$PIECE($GET(^AUPNPROB(BDMPIEN,11,BDMDA,0)),U)
+13 IF BDMFAC
SET BDMFACE=$PIECE($GET(^DIC(4,BDMFAC,0)),U)
+14 IF BDMFAC
SET BDMFACA=$PIECE($GET(^AUTTLOC(BDMFAC,0)),U,7)
+15 SET BDMIEN=0
FOR
SET BDMIEN=$ORDER(^AUPNPROB(BDMPIEN,11,BDMDA,11,BDMIEN))
IF 'BDMIEN
QUIT
Begin DoDot:2
+16 NEW BDMDATA,BDMNBMR,BDMNNAR,BDMST,BDMNDT
+17 SET BDMDATA=$GET(^AUPNPROB(BDMPIEN,11,BDMDA,11,BDMIEN,0))
+18 SET BDMNMBR=$PIECE(BDMDATA,U)
+19 SET BDMNNAR=$PIECE(BDMDATA,U,3)
+20 SET BDMST=$PIECE(BDMDATA,U,4)
+21 SET BDMNDT=$$FMTE^XLFDT($PIECE(BDMDATA,U,5))
+22 SET BDMI=BDMI+1
+23 SET ^BDMTMP($JOB,BDMI)=$GET(BDMFACA)_BDMNMBR_U_BDMNNAR_U_$GET(BDMNDT)_U_BDMST_U_BDMDA_U_BDMIEN_$CHAR(30)
End DoDot:2
End DoDot:1
+24 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+25 QUIT
+26 ;
ADDPRB(BDMRET,BDMSTR) ;-- add a problem
+1 SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BDMPAT,BDMDX,BDMDLM,BDMCL,BDMNAR,BDMFAC,BDMDE,BDMST,BDMON
+3 SET P="|"
+4 SET BDMPAT=$PIECE(BDMSTR,P)
+5 SET BDMDX=$TRANSLATE($PIECE(BDMSTR,P,2)," ")
+6 IF $GET(BDMDX)
SET BDMDX="`"_BDMDX
+7 SET BDMDLM=$PIECE(BDMSTR,P,3)
+8 SET BDMCL=$PIECE(BDMSTR,P,4)
+9 SET BDMNAR=$PIECE(BDMSTR,P,5)
+10 SET BDMFAC=$PIECE($PIECE(BDMSTR,P,6),"-")
+11 IF $GET(BDMFAC)'?.N
SET BDMFAC=$ORDER(^AUTTLOC("C",BDMFAC,0))
+12 SET BDMST=$PIECE(BDMSTR,P,7)
+13 SET BDMON=$PIECE(BDMSTR,P,8)
+14 SET BDMRET=$$ADDPROB^BDMPROB(BDMDX,BDMPAT,BDMDLM,BDMCL,BDMNAR,BDMFAC,"",BDMST,BDMON)
+15 QUIT
+16 ;
DELPR(BDMRET,BDMSTR) ;-- delete a problem
+1 SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 SET R="~"
+3 NEW BDMIEN,BDMREA,BDMOTH
+4 SET BDMIEN=$PIECE(BDMSTR,R)
+5 SET BDMREA=$PIECE(BDMSTR,R,2)
+6 SET BDMOTH=$PIECE(BDMSTR,R,3)
+7 SET BDMRET=$$DELPROB^BDMPROB(BDMIEN,BDMREA,BDMOTH)
+8 QUIT
+9 ;
VC(RETVAL,BDMSTR) ;-- get version number
+1 NEW P
+2 SET P="|"
+3 KILL ^BDMTMP($JOB)
+4 NEW BDMVER,BDMVERI,BDMVERIN,BDMPKG,BDMI,BDMPTCH,BDMPTCHI,BDMVERI
+5 SET BDMI=0
+6 SET BDMVERIN=$PIECE(BDMSTR,P)
+7 SET BDMVERIN=$TRANSLATE(BDMVERIN,".")
+8 SET RETVAL="^BDMTMP("_$JOB_")"
+9 SET ^BDMTMP($JOB,BDMI)="T00001VersionPresent"_$CHAR(30)
+10 SET BDMI=BDMI+1
+11 SET BDMPKG=$ORDER(^DIC(9.4,"C","BDM",0))
+12 IF '$GET(BDMPKG)
Begin DoDot:1
+13 SET ^BDMTMP($JOB,BDMI)=0_$CHAR(30)
+14 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)
End DoDot:1
QUIT
+15 SET BDMVER=$GET(^DIC(9.4,BDMPKG,"VERSION"))
+16 SET BDMVERI=$ORDER(^DIC(9.4,BDMPKG,22,"B",BDMVER,0))
+17 SET BDMPTCH=$ORDER(^DIC(9.4,BDMPKG,22,BDMVERI,"PAH","B",""),-1)
+18 IF ($TRANSLATE(BDMVER,".")_BDMPTCH)=BDMVERIN
Begin DoDot:1
+19 SET ^BDMTMP($JOB,BDMI)=1_$CHAR(30)
+20 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)
End DoDot:1
QUIT
+21 SET ^BDMTMP($JOB,BDMI)=0_$CHAR(30)
+22 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)
+23 QUIT
