BDMGE ; cmi/anch/maw - BDM DMS GUI Filing Routine ; 28 Oct 2014 4:31 PM
;;2.0;BDM DIABETES MANAGEMENT SYSTEM;**1,8**;JUN 14, 2007;Build 53
;
;
;
;1/25/2005 added in REGSV a check for DX
;3/22/2006 added diagnosis save to complications list add, subroutine CMPA
;
DEBUG(BDMRET,BDMSTR) ;-- debugger
D DEBUG^%Serenji("DME^BDMGE(.BDMRET,.BDMSTR)")
Q
;
REGADD(BDMRET,BDMSTR) ;EP - add patient to register
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMREG,BDMREGE,BDMFDA,BDMIENS,BDMERR,P
S P="|"
S BDMREGE=$P(BDMSTR,P)
S BDMREG=$O(^ACM(41.1,"B",BDMREGE,0))
S BDMPAT=$P(BDMSTR,P,2)
S BDMIENS=""
S BDMFDA(9002241,"+1,",.01)=BDMREG
S BDMFDA(9002241,"+1,",.02)=BDMPAT
S BDMFDA(9002241,"+1,",1)="A"
S BDMFDA(9002241,"+1,",2)=DT
S BDMFDA(9002241,"+1,",4)=DT
D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
I $D(BDMERR) S BDMRET="" Q
S BDMRET=+$G(BDMIENS(1))
Q
;
REGSV(BDMRET,BDMSTR) ;-- save the data to the register
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMREG,BDMPIEN,BDMPCP,BDMREGE,BDMFDA,BDMIENS,BDMERR,P,R,BDMST,BDMRP,BDMCM,BDMWF,BDMCON,BDMED,BDMLE,BDMLR,BDMNR,BDMON,BDMDX,BDMDXE
S P="|",R="~"
S BDMRET=1
S BDMREGE=$P(BDMSTR,P)
S BDMREG=$O(^ACM(41.1,"B",BDMREGE,0))
S BDMPAT=$P(BDMSTR,P,2)
S BDMPIEN=$P($G(^ACM(41,BDMPAT,0)),U,2)
S BDMST=$P($P(BDMSTR,P,3),"-")
S BDMRP=$P($P(BDMSTR,P,4),R)
S BDMCM=$P($P(BDMSTR,P,5),R)
S BDMWF=$P($P(BDMSTR,P,6),R)
;S BDMRP=$S($P(BDMSTR,P,4)]"":$O(^VA(200,"B",$P(BDMSTR,P,4),0)),1:"")
;S BDMCM=$S($P(BDMSTR,P,5)]"":$O(^VA(200,"B",$P(BDMSTR,P,5),0)),1:"")
;S BDMWF=$S($P($P(BDMSTR,P,6),"-")]"":$O(^AUTTLOC("C",$P($P(BDMSTR,P,6),"-"),0)),1:"")
S BDMCON=$P(BDMSTR,P,7)
S BDMLR=$P(BDMSTR,P,8)
S BDMNR=$P(BDMSTR,P,9)
;S BDMDXE=$P(BDMSTR,P,10)
;cmi/anch/maw 1/25/2005 added due to possibility of null dx
S BDMDX=$S($G(BDMDXE)]"":$O(^ACM(44.1,"B",BDMDXE,0)),1:"")
S BDMON=$P(BDMSTR,P,11)
S BDMPCP=$P($P(BDMSTR,P,12),R)
S BDMIENS=BDMPAT_","
S BDMFDA(9002241,BDMIENS,1)=BDMST
S BDMFDA(9002241,BDMIENS,6)=BDMCM
S BDMFDA(9002241,BDMIENS,8)=BDMLR
S BDMFDA(9002241,BDMIENS,9)=BDMNR
S BDMFDA(9002241,BDMIENS,10)=BDMWF
S BDMFDA(9002241,BDMIENS,11)=DT
S BDMFDA(9002241,BDMIENS,14)=BDMCON
S BDMFDA(9002241,BDMIENS,15)=BDMRP
S BDMFDA(9002241,BDMIENS,20)=BDMON
D FILE^DIE("K","BDMFDA","BDMERR(1)")
I $G(BDMERR(1)) S BDMRET=1 Q
S BDMRET=""
;D REGDX(BDMPAT,BDMREG,BDMPIEN,BDMDX,BDMON)
D PCP(BDMPCP,BDMPIEN)
Q
;
REGDX(PAT,REG,PIEN,DIAG,ON) ;-- add the diagnosis if not there already
;10/19/2005 added cleanup of existing entries if changed dx
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
Q:DIAG=""
I $D(^ACM(44,"AC",REG,PIEN)) Q:$D(^ACM(44,"AC",REG,PIEN,DIAG))
N BDMDA
S BDMDA=0 F S BDMDA=$O(^ACM(44,"AC",REG,PIEN,BDMDA)) Q:'BDMDA D
. S DIK="^ACM(44,",DA=$G(^ACM(44,"AC",REG,PIEN,BDMDA)) D ^DIK
N BDMFDA,BDMIENS,BDMERR
S BDMIENS=""
S BDMFDA(9002244,"+1,",.01)=DIAG
S BDMFDA(9002244,"+1,",.02)=PIEN
S BDMFDA(9002244,"+1,",.03)=PAT
S BDMFDA(9002244,"+1,",.04)=REG
S BDMFDA(9002244,"+1,",2)=ON
D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
I $G(BDMERR(1)) S BDMRET=1 Q
S BDMRET=""
Q
;
PCP(PCP,PAT) ;-- file the primary care provider
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
Q:'PCP
N BDMFDA,BDMIENS,BDMERR
S BDMIENS=PAT_","
S BDMIENS(1)=PAT
S BDMFDA(9000001,BDMIENS,.14)=PCP
D FILE^DIE("K","BDMFDA","BDMERR(1)")
Q
;
CMP(BDMRET,BDMSTR) ;-- save complications
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMDA,BDMI,BDMPAT,BDMPIEN,BDMREG,BDMREGE,P,CS
S P="|"
S CS="~"
I $G(BDMSTR)="" D CATSTR^BDMGU(.BDMSTR,.BDMSTR)
S BDMREGE=$P(BDMSTR,P)
S BDMREG=$O(^ACM(41.1,"B",BDMREGE,0))
S BDMPAT=$P(BDMSTR,P,2)
S BDMPIEN=$P($G(^ACM(41,BDMPAT,0)),U,2)
S BDMERR=""
;S BDMDA=0 F S BDMDA=$O(^ACM(42,"AC",BDMREG,BDMPIEN,BDMDA)) Q:'BDMDA D
;. S BDMCMPI=$G(^ACM(42,"AC",BDMREG,BDMPIEN,BDMDA))
;. S DIK="^ACM(42,",DA=BDMCMPI D ^DIK
F BDMI=3:1 D Q:$G(BDMDATA)=""
. N BDMCMPE,BDMSTE,BDMON,BDMCMT,BDMCMP,BDMST
. S BDMDATA=$P(BDMSTR,P,BDMI)
. Q:BDMDATA=""
. S BDMCMPE=$P(BDMDATA,CS)
. S BDMSTE=$P(BDMDATA,CS,2)
. S BDMON=$P(BDMDATA,CS,3)
. S BDMCMP=$O(^ACM(42.1,"B",BDMCMPE,0))
. S BDMST=$S($G(BDMSTE)]"":$O(^ACM(42.3,"B",BDMSTE,0)),1:"")
. I $D(^ACM(42,"AC",BDMREG,BDMPIEN,BDMCMP)) D Q
.. N BDMENT
.. S BDMENT=$G(^ACM(42,"AC",BDMREG,BDMPIEN,BDMCMP))
.. D ECMP(BDMST,BDMON,BDMENT,$P(BDMDATA,CS,4)) ;edit if it exists
. N BDMERR,BDMIENS,BDMFDA
. S BDMIENS=""
. S BDMFDA(9002242,"+1,",.01)=BDMCMP
. S BDMFDA(9002242,"+1,",.02)=BDMPIEN
. S BDMFDA(9002242,"+1,",.03)=BDMPAT
. S BDMFDA(9002242,"+1,",.04)=BDMREG
. S BDMFDA(9002242,"+1,",1)=BDMON
. S BDMFDA(9002242,"+1,",2)=BDMST
. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
. I $G(BDMERR(1)) S BDMRET="" Q
. S BDMRET=$G(BDMIENS(1))
. N BDMFL,BDMIENS,BDMFLD,BDMERR
. S BDMFL=9002242
. S BDMIENS=BDMRET_","
. S BDMFLD=3
. S BDMCMT(1)=$P(BDMDATA,CS,4)
. D WP^DIE(BDMFL,BDMIENS,BDMFLD,,"BDMCMT","BDMERR")
. S BDMRET=1
. I $D(BDMERR(1)) S BDMRET=""
Q
;
ECMP(ST,ON,ENT,CMT) ;-- edit the entry
N BDMERR,BDMIENS,BDMFDA
S BDMIENS=ENT_","
S BDMFDA(9002242,BDMIENS,1)=ON
S BDMFDA(9002242,BDMIENS,2)=ST
D FILE^DIE("K","BDMFDA","BDMERR(1)")
I $G(BDMERR(1)) S BDMRET="" Q
N BDMFL,BDMFLD,BDMERR
S BDMFL=9002242
S BDMFLD=3
S BDMCMT(1)=CMT
D WP^DIE(BDMFL,BDMIENS,BDMFLD,,"BDMCMT","BDMERR")
Q
;
DCMP(BDMRET,BDMSTR) ;-- delete the complication
N I,P
S P="|"
F I=2:1 D Q:$P(BDMSTR,P,I)=""
. Q:$P(BDMSTR,P,I)=""
. S DIK="^ACM(42,"
. S DA=$P(BDMSTR,P,I)
. D ^DIK
S BDMRET="^BDMTMP("_$J_")"
S ^BDMTMP($J,0)="T00030Error"_$C(30)
S ^BDMTMP($J,1)=$C(31)
Q
;
DIAG(BDMRET,BDMSTR) ;-- save complications
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMDA,BDMI,BDMPAT,BDMPIEN,BDMREG,BDMREGE,P,CS
S P="|"
S CS="~"
I $G(BDMSTR)="" D CATSTR^BDMGU(.BDMSTR,.BDMSTR)
S BDMREGE=$P(BDMSTR,P)
S BDMREG=$O(^ACM(41.1,"B",BDMREGE,0))
S BDMPAT=$P(BDMSTR,P,2)
S BDMPIEN=$P($G(^ACM(41,BDMPAT,0)),U,2)
S BDMERR=""
;S BDMDA=0 F S BDMDA=$O(^ACM(42,"AC",BDMREG,BDMPIEN,BDMDA)) Q:'BDMDA D
;. S BDMCMPI=$G(^ACM(42,"AC",BDMREG,BDMPIEN,BDMDA))
;. S DIK="^ACM(42,",DA=BDMCMPI D ^DIK
F BDMI=3:1 D Q:$G(BDMDATA)=""
. N BDMCMPE,BDMSTE,BDMON,BDMCMT,BDMCMP,BDMST
. S BDMDATA=$P(BDMSTR,P,BDMI)
. Q:BDMDATA=""
. S BDMCMPE=$P(BDMDATA,CS)
. S BDMSTE=$P(BDMDATA,CS,2)
. S BDMON=$P(BDMDATA,CS,3)
. S BDMCMP=$O(^ACM(44.1,"B",BDMCMPE,0))
. I $D(^ACM(44,"AC",BDMREG,BDMPIEN,BDMCMP)) D Q
.. N BDMENT
.. S BDMENT=$G(^ACM(44,"AC",BDMREG,BDMPIEN,BDMCMP))
.. D EDIAG(BDMSTE,BDMON,BDMENT) ;edit if it exists
. N BDMERR,BDMIENS,BDMFDA
. S BDMIENS=""
. S BDMFDA(9002244,"+1,",.01)=BDMCMP
. S BDMFDA(9002244,"+1,",.02)=BDMPIEN
. S BDMFDA(9002244,"+1,",.03)=BDMPAT
. S BDMFDA(9002244,"+1,",.04)=BDMREG
. S BDMFDA(9002244,"+1,",2)=BDMON
. S BDMFDA(9002244,"+1,",1)=BDMSTE
. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
. I $G(BDMERR(1)) S BDMRET="" Q
. S BDMRET=$G(BDMIENS(1))
Q
;
EDIAG(ST,ON,ENT) ;-- edit the entry
N BDMERR,BDMIENS,BDMFDA
S BDMIENS=ENT_","
S BDMFDA(9002244,BDMIENS,1)=ST
S BDMFDA(9002244,BDMIENS,2)=ON
D FILE^DIE("K","BDMFDA","BDMERR(1)")
I $G(BDMERR(1)) S BDMRET="" Q
Q
;
DDIAG(BDMRET,BDMSTR) ;-- delete the diagnosis
N I,P
S P="|"
F I=2:1 D Q:$P(BDMSTR,P,I)=""
. Q:$P(BDMSTR,P,I)=""
. S DIK="^ACM(44,"
. S DA=$P(BDMSTR,P,I)
. D ^DIK
S BDMRET="^BDMTMP("_$J_")"
S ^BDMTMP($J,0)="T00030Error"_$C(30)
S ^BDMTMP($J,1)=$C(31)
Q
;
EPRB(BDMRET,BDMSTR) ;-- edit a problem on the problem list
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N P,BDMP,BDMDX,BDMDLM,BDMCL,BDMNAR,BDMFAC,BDMDE,BDMST,BDMON
S P="|"
S BDMP=$P(BDMSTR,P)
S BDMDX=$P(BDMSTR,P,2)
I '$G(BDMDX) S BDMRET="1^Invalid Diagnosis Code" Q ;maw added 10/19/2005
;S BDMDX=$O(^ICD9("BA",BDMDX,0))
;I 'BDMDX S BDMRET="1^Invalid Diagnosis Code" Q
S BDMDLM=$P(BDMSTR,P,3)
S BDMCL=$P(BDMSTR,P,4)
S BDMNAR=$P(BDMSTR,P,5)
S BDMNAR=$$FIND1^DIC(9999999.27,,"X",BDMNAR)
I 'BDMNAR S BDMRET="2^Provider Narrative Not Found in AUTNPOV" Q
;S BDMFAC=$P($P(BDMSTR,P,6),"-")
;I $G(BDMFAC) S BDMFAC=$O(^AUTTLOC("C",BDMFAC,0))
S BDMFAC=$P(BDMSTR,P,6)
S BDMST=$P(BDMSTR,P,7)
S BDMON=$P(BDMSTR,P,8)
N BDMERR,BDMFDA,BDMIENS
S BDMIENS=BDMP_","
S BDMFDA(9000011,BDMIENS,.01)=BDMDX
S BDMFDA(9000011,BDMIENS,.03)=DT
S BDMFDA(9000011,BDMIENS,.04)=BDMCL
S BDMFDA(9000011,BDMIENS,.05)=BDMNAR
S BDMFDA(9000011,BDMIENS,.14)=DUZ
;S BDMFDA(9000011,BDMIENS,.07)=BDMNMBR why???
S BDMFDA(9000011,BDMIENS,.12)=BDMST
S BDMFDA(9000011,BDMIENS,.13)=BDMON
D FILE^DIE("K","BDMFDA","BDMERR")
S BDMRET=$S($G(BDMERR(1)):$G(BDMERR(1)),1:0)
Q
;
NOTEA(BDMRET,BDMSTR) ;-- add a note
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMNAR,BDMLOC,BDMIEN,BDMLIEN,P
S P="|"
S BDMIEN=$P(BDMSTR,P)
;S BDMLOC=$P($P(BDMSTR,P,2),"-")
S BDMLOC=$P(BDMSTR,P,2)
S BDMNAR=$P(BDMSTR,P,3)
;S BDMLOC=$O(^AUTTLOC("C",BDMLOC,0))
N BDMIENS,BDMERR,BDMFDA
I $O(^AUPNPROB(BDMIEN,11,"B",BDMLOC,0)) D
. S BDMLIEN=$O(^AUPNPROB(BDMIEN,11,"B",BDMLOC,0))
I '$O(^AUPNPROB(BDMIEN,11,"B",BDMLOC,0)) D Q:$G(BDMERR(1))
. S BDMIENS="+2,"_BDMIEN_","
. S BDMFDA(9000011.11,BDMIENS,.01)=BDMLOC
. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR")
. I $G(BDMERR(1)) S BDMRET="1^Error Adding Note Location" Q
. S BDMLIEN=$G(BDMIENS(2))
N BDMIENS,BDMERR,BDMFDA
S BDMIENS="+3,"_BDMLIEN_","_BDMIEN_","
S BDMNN=+$P($G(^AUPNPROB(BDMIEN,11,BDMLIEN,11,0)),U,3)+1
S BDMFDA(9000011.1111,BDMIENS,.01)=BDMNN
S BDMFDA(9000011.1111,BDMIENS,.03)=BDMNAR
S BDMFDA(9000011.1111,BDMIENS,.05)=DT
D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR")
I $G(BDMERR(1)) S BDMRET="1^Error Adding Note" Q
S BDMRET=0
Q
;
NOTEE(BDMRET,BDMSTR) ;-- edit a note
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMNAR,BDMLOC,BDMIEN,BDMLIEN,BDMNIEN,BDMLIEN,P
S P="|"
S BDMIEN=$P(BDMSTR,P)
S BDMLIEN=$P(BDMSTR,P,2)
S BDMNIEN=$P(BDMSTR,P,3)
S BDMNAR=$P(BDMSTR,P,4)
N BDMIENS,BDMERR,BDMFDA
S BDMIENS=BDMNIEN_","_BDMLIEN_","_BDMIEN_","
S BDMFDA(9000011.1111,BDMIENS,.03)=BDMNAR
S BDMFDA(9000011.1111,BDMIENS,.05)=DT
D FILE^DIE("K","BDMFDA","BDMERR")
I $G(BDMERR(1)) S BDMRET="1^Error Editing Note" Q
S BDMRET=0
Q
;
NOTED(BDMRET,BDMSTR) ;-- delete a note
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMIEN,BDMLIEN,BDMNIEN,BDMLIEN,P
S P="|"
S BDMIEN=$P(BDMSTR,P)
S BDMLIEN=$P(BDMSTR,P,2)
S BDMNIEN=$P(BDMSTR,P,3)
S DIK="^AUPNPROB("_BDMIEN_",11,"_BDMLIEN_",11,",DA=BDMNIEN,DA(1)=BDMLIEN,DA(2)=BDMIEN
D ^DIK
I '$P($G(^AUPNPROB(BDMIEN,11,BDMLIEN,11,0)),U,4) D
. S DIK="^AUPNPROB("_BDMIEN_",11,",DA=BDMLIEN,DA(1)=BDMIEN
. D ^DIK
S BDMRET=0
Q
;
ACMT(BDMRET,BDMSTR) ;-- call CMT
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
D CMT(.BDMRET,.BDMSTR)
Q
;
CMT(BDMRET,BDMSTR) ;-- the entire array
N P,BDMVIEN,BDMTXT
S P="|"
I $G(BDMSTR)]"" D
. S BDMVIEN=$P(BDMSTR,P)
. S BDMTXT(1)=$P(BDMSTR,P,2)
I $G(BDMSTR)="" D
. S BDMTXT(1)=""
. S BDMVIEN=$P($G(BDMSTR(1)),P)
. S BDMTXT(1)=$P($G(BDMSTR(1)),P,2)
. S BDMDA=1 F S BDMDA=$O(BDMSTR(BDMDA)) Q:'BDMDA D
.. S BDMTXT(1)=BDMTXT(1)_$G(BDMSTR(BDMDA))
N BDMFL,BDMIENS,BDMFLD,BDMERR
S BDMFL=9002241
S BDMIENS=BDMVIEN_","
S BDMFLD=13
D WP^DIE(BDMFL,BDMIENS,BDMFLD,,"BDMTXT","BDMERR")
S BDMRET=""
I $D(BDMERR(1)) S BDMRET=1
Q
;
DME(BDMRET,BDMSTR) ;-- create entry in BDMEDMUP
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N P,BDMIEN,BDMPIEN,BDMON,BDMPN,BDMHD,BDMHV,BDMWD,BDMWV,BDMTU,BDMTB,BDMFTD
N BDMEYED,BDMDEND,BDMPAPD,BDMMAMD,BDMFLUD,BDMPNUD,BDMTDD,BDMBPD,BDMBPV,BDMFTR
N BDMEYER,BDMEKGR,BDMPPDD,BDMPPDR,BDMEKGD,BDMGLU,BDMASTR,BDMMAMP,BDMDEPD,BDMDEPR
S P="|"
I $G(BDMSTR)="" D CATSTR^BDMGU(.BDMSTR,.BDMSTR)
I $G(BDMSTR)="" S BDMRET="Error Creating BDMEDMUP Entry, Invalid String" Q
S BDMDMIEN=$P(BDMSTR,P)
I $G(BDMDMIEN) D Q
. D DMEE^BDMGEA(.BDMRET,.BDMSTR)
S BDMPIEN=$P(BDMSTR,P,2)
S BDMON=$P(BDMSTR,P,3)
S BDMPN=$P(BDMSTR,P,4)
S BDMHD=$P(BDMSTR,P,5)
S BDMHV=$P(BDMSTR,P,6)
S BDMWD=$P(BDMSTR,P,7)
S BDMWV=$P(BDMSTR,P,8)
S BDMBPD=$P(BDMSTR,P,9)
S BDMBPV=$P(BDMSTR,P,10)
S BDMFTD=$P(BDMSTR,P,11)
S BDMFTR=$P(BDMSTR,P,12)
S BDMEYED=$P(BDMSTR,P,13)
S BDMEYER=$P(BDMSTR,P,14)
S BDMEKGD=$P(BDMSTR,P,15)
S BDMEKGR=$P(BDMSTR,P,16)
S BDMDEND=$P(BDMSTR,P,17)
S BDMPAPD=$P(BDMSTR,P,18)
S BDMMAMD=$P(BDMSTR,P,19)
S BDMPPDD=$P(BDMSTR,P,20)
S BDMPPDR=$P(BDMSTR,P,21)
S BDMMAMP=$P(BDMSTR,P,22)
S BDMDEPD=$P(BDMSTR,P,23)
S BDMDEPR=$P(BDMSTR,P,24)
S BDMASTR="+1,"
N BDMERR,BDMIENS,BDMFDA
S BDMIENS=""
S BDMFDA(9003203.2,"+1,",.01)=BDMPIEN
S BDMFDA(9003203.2,"+1,",.02)=DT
S BDMFDA(9003203.2,"+1,",.03)=BDMON
S BDMFDA(9003203.2,"+1,",.04)=BDMPN
S BDMFDA(9003203.2,"+1,",.05)=BDMHD
S BDMFDA(9003203.2,"+1,",.06)=BDMHV
S BDMFDA(9003203.2,"+1,",.07)=BDMWD
S BDMFDA(9003203.2,"+1,",.08)=BDMWV
S BDMFDA(9003203.2,"+1,",.11)=BDMFTD
S BDMFDA(9003203.2,"+1,",.12)=BDMEYED
S BDMFDA(9003203.2,"+1,",.13)=BDMDEND
S BDMFDA(9003203.2,"+1,",.14)=BDMPAPD
S BDMFDA(9003203.2,"+1,",.15)=BDMMAMD
S BDMFDA(9003203.2,"+1,",.19)=BDMBPD
S BDMFDA(9003203.2,"+1,",.2)=BDMBPV
S BDMFDA(9003203.2,"+1,",.21)=BDMFTR
S BDMFDA(9003203.2,"+1,",.22)=BDMEYER
S BDMFDA(9003203.2,"+1,",.23)=BDMEKGR
S BDMFDA(9003203.2,"+1,",.24)=BDMMAMP
S BDMFDA(9003203.2,"+1,",.25)=BDMDEPD
S BDMFDA(9003203.2,"+1,",.26)=BDMDEPR
S BDMFDA(9003203.2,"+1,",1103)=BDMEKGD
S BDMFDA(9003203.2,"+1,",1101)=BDMPPDD
S BDMFDA(9003203.2,"+1,",1102)=BDMPPDR
D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
I $G(BDMERR(1)) S BDMRET="" Q
S BDMRET=$G(BDMIENS(1))
Q
;
BDMGE ; cmi/anch/maw - BDM DMS GUI Filing Routine ; 28 Oct 2014 4:31 PM
+1 ;;2.0;BDM DIABETES MANAGEMENT SYSTEM;**1,8**;JUN 14, 2007;Build 53
+2 ;
+3 ;
+4 ;
+5 ;1/25/2005 added in REGSV a check for DX
+6 ;3/22/2006 added diagnosis save to complications list add, subroutine CMPA
+7 ;
DEBUG(BDMRET,BDMSTR) ;-- debugger
+1 DO DEBUG^%Serenji("DME^BDMGE(.BDMRET,.BDMSTR)")
+2 QUIT
+3 ;
REGADD(BDMRET,BDMSTR) ;EP - add patient to register
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMREG,BDMREGE,BDMFDA,BDMIENS,BDMERR,P
+3 SET P="|"
+4 SET BDMREGE=$PIECE(BDMSTR,P)
+5 SET BDMREG=$ORDER(^ACM(41.1,"B",BDMREGE,0))
+6 SET BDMPAT=$PIECE(BDMSTR,P,2)
+7 SET BDMIENS=""
+8 SET BDMFDA(9002241,"+1,",.01)=BDMREG
+9 SET BDMFDA(9002241,"+1,",.02)=BDMPAT
+10 SET BDMFDA(9002241,"+1,",1)="A"
+11 SET BDMFDA(9002241,"+1,",2)=DT
+12 SET BDMFDA(9002241,"+1,",4)=DT
+13 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
+14 IF $DATA(BDMERR)
SET BDMRET=""
QUIT
+15 SET BDMRET=+$GET(BDMIENS(1))
+16 QUIT
+17 ;
REGSV(BDMRET,BDMSTR) ;-- save the data to the register
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMREG,BDMPIEN,BDMPCP,BDMREGE,BDMFDA,BDMIENS,BDMERR,P,R,BDMST,BDMRP,BDMCM,BDMWF,BDMCON,BDMED,BDMLE,BDMLR,BDMNR,BDMON,BDMDX,BDMDXE
+3 SET P="|"
SET R="~"
+4 SET BDMRET=1
+5 SET BDMREGE=$PIECE(BDMSTR,P)
+6 SET BDMREG=$ORDER(^ACM(41.1,"B",BDMREGE,0))
+7 SET BDMPAT=$PIECE(BDMSTR,P,2)
+8 SET BDMPIEN=$PIECE($GET(^ACM(41,BDMPAT,0)),U,2)
+9 SET BDMST=$PIECE($PIECE(BDMSTR,P,3),"-")
+10 SET BDMRP=$PIECE($PIECE(BDMSTR,P,4),R)
+11 SET BDMCM=$PIECE($PIECE(BDMSTR,P,5),R)
+12 SET BDMWF=$PIECE($PIECE(BDMSTR,P,6),R)
+13 ;S BDMRP=$S($P(BDMSTR,P,4)]"":$O(^VA(200,"B",$P(BDMSTR,P,4),0)),1:"")
+14 ;S BDMCM=$S($P(BDMSTR,P,5)]"":$O(^VA(200,"B",$P(BDMSTR,P,5),0)),1:"")
+15 ;S BDMWF=$S($P($P(BDMSTR,P,6),"-")]"":$O(^AUTTLOC("C",$P($P(BDMSTR,P,6),"-"),0)),1:"")
+16 SET BDMCON=$PIECE(BDMSTR,P,7)
+17 SET BDMLR=$PIECE(BDMSTR,P,8)
+18 SET BDMNR=$PIECE(BDMSTR,P,9)
+19 ;S BDMDXE=$P(BDMSTR,P,10)
+20 ;cmi/anch/maw 1/25/2005 added due to possibility of null dx
+21 SET BDMDX=$SELECT($GET(BDMDXE)]"":$ORDER(^ACM(44.1,"B",BDMDXE,0)),1:"")
+22 SET BDMON=$PIECE(BDMSTR,P,11)
+23 SET BDMPCP=$PIECE($PIECE(BDMSTR,P,12),R)
+24 SET BDMIENS=BDMPAT_","
+25 SET BDMFDA(9002241,BDMIENS,1)=BDMST
+26 SET BDMFDA(9002241,BDMIENS,6)=BDMCM
+27 SET BDMFDA(9002241,BDMIENS,8)=BDMLR
+28 SET BDMFDA(9002241,BDMIENS,9)=BDMNR
+29 SET BDMFDA(9002241,BDMIENS,10)=BDMWF
+30 SET BDMFDA(9002241,BDMIENS,11)=DT
+31 SET BDMFDA(9002241,BDMIENS,14)=BDMCON
+32 SET BDMFDA(9002241,BDMIENS,15)=BDMRP
+33 SET BDMFDA(9002241,BDMIENS,20)=BDMON
+34 DO FILE^DIE("K","BDMFDA","BDMERR(1)")
+35 IF $GET(BDMERR(1))
SET BDMRET=1
QUIT
+36 SET BDMRET=""
+37 ;D REGDX(BDMPAT,BDMREG,BDMPIEN,BDMDX,BDMON)
+38 DO PCP(BDMPCP,BDMPIEN)
+39 QUIT
+40 ;
REGDX(PAT,REG,PIEN,DIAG,ON) ;-- add the diagnosis if not there already
+1 ;10/19/2005 added cleanup of existing entries if changed dx
+2 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+3 IF DIAG=""
QUIT
+4 IF $DATA(^ACM(44,"AC",REG,PIEN))
IF $DATA(^ACM(44,"AC",REG,PIEN,DIAG))
QUIT
+5 NEW BDMDA
+6 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^ACM(44,"AC",REG,PIEN,BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+7 SET DIK="^ACM(44,"
SET DA=$GET(^ACM(44,"AC",REG,PIEN,BDMDA))
DO ^DIK
End DoDot:1
+8 NEW BDMFDA,BDMIENS,BDMERR
+9 SET BDMIENS=""
+10 SET BDMFDA(9002244,"+1,",.01)=DIAG
+11 SET BDMFDA(9002244,"+1,",.02)=PIEN
+12 SET BDMFDA(9002244,"+1,",.03)=PAT
+13 SET BDMFDA(9002244,"+1,",.04)=REG
+14 SET BDMFDA(9002244,"+1,",2)=ON
+15 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
+16 IF $GET(BDMERR(1))
SET BDMRET=1
QUIT
+17 SET BDMRET=""
+18 QUIT
+19 ;
PCP(PCP,PAT) ;-- file the primary care provider
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 IF 'PCP
QUIT
+3 NEW BDMFDA,BDMIENS,BDMERR
+4 SET BDMIENS=PAT_","
+5 SET BDMIENS(1)=PAT
+6 SET BDMFDA(9000001,BDMIENS,.14)=PCP
+7 DO FILE^DIE("K","BDMFDA","BDMERR(1)")
+8 QUIT
+9 ;
CMP(BDMRET,BDMSTR) ;-- save complications
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMDA,BDMI,BDMPAT,BDMPIEN,BDMREG,BDMREGE,P,CS
+3 SET P="|"
+4 SET CS="~"
+5 IF $GET(BDMSTR)=""
DO CATSTR^BDMGU(.BDMSTR,.BDMSTR)
+6 SET BDMREGE=$PIECE(BDMSTR,P)
+7 SET BDMREG=$ORDER(^ACM(41.1,"B",BDMREGE,0))
+8 SET BDMPAT=$PIECE(BDMSTR,P,2)
+9 SET BDMPIEN=$PIECE($GET(^ACM(41,BDMPAT,0)),U,2)
+10 SET BDMERR=""
+11 ;S BDMDA=0 F S BDMDA=$O(^ACM(42,"AC",BDMREG,BDMPIEN,BDMDA)) Q:'BDMDA D
+12 ;. S BDMCMPI=$G(^ACM(42,"AC",BDMREG,BDMPIEN,BDMDA))
+13 ;. S DIK="^ACM(42,",DA=BDMCMPI D ^DIK
+14 FOR BDMI=3:1
Begin DoDot:1
+15 NEW BDMCMPE,BDMSTE,BDMON,BDMCMT,BDMCMP,BDMST
+16 SET BDMDATA=$PIECE(BDMSTR,P,BDMI)
+17 IF BDMDATA=""
QUIT
+18 SET BDMCMPE=$PIECE(BDMDATA,CS)
+19 SET BDMSTE=$PIECE(BDMDATA,CS,2)
+20 SET BDMON=$PIECE(BDMDATA,CS,3)
+21 SET BDMCMP=$ORDER(^ACM(42.1,"B",BDMCMPE,0))
+22 SET BDMST=$SELECT($GET(BDMSTE)]"":$ORDER(^ACM(42.3,"B",BDMSTE,0)),1:"")
+23 IF $DATA(^ACM(42,"AC",BDMREG,BDMPIEN,BDMCMP))
Begin DoDot:2
+24 NEW BDMENT
+25 SET BDMENT=$GET(^ACM(42,"AC",BDMREG,BDMPIEN,BDMCMP))
+26 ;edit if it exists
DO ECMP(BDMST,BDMON,BDMENT,$PIECE(BDMDATA,CS,4))
End DoDot:2
QUIT
+27 NEW BDMERR,BDMIENS,BDMFDA
+28 SET BDMIENS=""
+29 SET BDMFDA(9002242,"+1,",.01)=BDMCMP
+30 SET BDMFDA(9002242,"+1,",.02)=BDMPIEN
+31 SET BDMFDA(9002242,"+1,",.03)=BDMPAT
+32 SET BDMFDA(9002242,"+1,",.04)=BDMREG
+33 SET BDMFDA(9002242,"+1,",1)=BDMON
+34 SET BDMFDA(9002242,"+1,",2)=BDMST
+35 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
+36 IF $GET(BDMERR(1))
SET BDMRET=""
QUIT
+37 SET BDMRET=$GET(BDMIENS(1))
+38 NEW BDMFL,BDMIENS,BDMFLD,BDMERR
+39 SET BDMFL=9002242
+40 SET BDMIENS=BDMRET_","
+41 SET BDMFLD=3
+42 SET BDMCMT(1)=$PIECE(BDMDATA,CS,4)
+43 DO WP^DIE(BDMFL,BDMIENS,BDMFLD,,"BDMCMT","BDMERR")
+44 SET BDMRET=1
+45 IF $DATA(BDMERR(1))
SET BDMRET=""
End DoDot:1
IF $GET(BDMDATA)=""
QUIT
+46 QUIT
+47 ;
ECMP(ST,ON,ENT,CMT) ;-- edit the entry
+1 NEW BDMERR,BDMIENS,BDMFDA
+2 SET BDMIENS=ENT_","
+3 SET BDMFDA(9002242,BDMIENS,1)=ON
+4 SET BDMFDA(9002242,BDMIENS,2)=ST
+5 DO FILE^DIE("K","BDMFDA","BDMERR(1)")
+6 IF $GET(BDMERR(1))
SET BDMRET=""
QUIT
+7 NEW BDMFL,BDMFLD,BDMERR
+8 SET BDMFL=9002242
+9 SET BDMFLD=3
+10 SET BDMCMT(1)=CMT
+11 DO WP^DIE(BDMFL,BDMIENS,BDMFLD,,"BDMCMT","BDMERR")
+12 QUIT
+13 ;
DCMP(BDMRET,BDMSTR) ;-- delete the complication
+1 NEW I,P
+2 SET P="|"
+3 FOR I=2:1
Begin DoDot:1
+4 IF $PIECE(BDMSTR,P,I)=""
QUIT
+5 SET DIK="^ACM(42,"
+6 SET DA=$PIECE(BDMSTR,P,I)
+7 DO ^DIK
End DoDot:1
IF $PIECE(BDMSTR,P,I)=""
QUIT
+8 SET BDMRET="^BDMTMP("_$JOB_")"
+9 SET ^BDMTMP($JOB,0)="T00030Error"_$CHAR(30)
+10 SET ^BDMTMP($JOB,1)=$CHAR(31)
+11 QUIT
+12 ;
DIAG(BDMRET,BDMSTR) ;-- save complications
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMDA,BDMI,BDMPAT,BDMPIEN,BDMREG,BDMREGE,P,CS
+3 SET P="|"
+4 SET CS="~"
+5 IF $GET(BDMSTR)=""
DO CATSTR^BDMGU(.BDMSTR,.BDMSTR)
+6 SET BDMREGE=$PIECE(BDMSTR,P)
+7 SET BDMREG=$ORDER(^ACM(41.1,"B",BDMREGE,0))
+8 SET BDMPAT=$PIECE(BDMSTR,P,2)
+9 SET BDMPIEN=$PIECE($GET(^ACM(41,BDMPAT,0)),U,2)
+10 SET BDMERR=""
+11 ;S BDMDA=0 F S BDMDA=$O(^ACM(42,"AC",BDMREG,BDMPIEN,BDMDA)) Q:'BDMDA D
+12 ;. S BDMCMPI=$G(^ACM(42,"AC",BDMREG,BDMPIEN,BDMDA))
+13 ;. S DIK="^ACM(42,",DA=BDMCMPI D ^DIK
+14 FOR BDMI=3:1
Begin DoDot:1
+15 NEW BDMCMPE,BDMSTE,BDMON,BDMCMT,BDMCMP,BDMST
+16 SET BDMDATA=$PIECE(BDMSTR,P,BDMI)
+17 IF BDMDATA=""
QUIT
+18 SET BDMCMPE=$PIECE(BDMDATA,CS)
+19 SET BDMSTE=$PIECE(BDMDATA,CS,2)
+20 SET BDMON=$PIECE(BDMDATA,CS,3)
+21 SET BDMCMP=$ORDER(^ACM(44.1,"B",BDMCMPE,0))
+22 IF $DATA(^ACM(44,"AC",BDMREG,BDMPIEN,BDMCMP))
Begin DoDot:2
+23 NEW BDMENT
+24 SET BDMENT=$GET(^ACM(44,"AC",BDMREG,BDMPIEN,BDMCMP))
+25 ;edit if it exists
DO EDIAG(BDMSTE,BDMON,BDMENT)
End DoDot:2
QUIT
+26 NEW BDMERR,BDMIENS,BDMFDA
+27 SET BDMIENS=""
+28 SET BDMFDA(9002244,"+1,",.01)=BDMCMP
+29 SET BDMFDA(9002244,"+1,",.02)=BDMPIEN
+30 SET BDMFDA(9002244,"+1,",.03)=BDMPAT
+31 SET BDMFDA(9002244,"+1,",.04)=BDMREG
+32 SET BDMFDA(9002244,"+1,",2)=BDMON
+33 SET BDMFDA(9002244,"+1,",1)=BDMSTE
+34 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
+35 IF $GET(BDMERR(1))
SET BDMRET=""
QUIT
+36 SET BDMRET=$GET(BDMIENS(1))
End DoDot:1
IF $GET(BDMDATA)=""
QUIT
+37 QUIT
+38 ;
EDIAG(ST,ON,ENT) ;-- edit the entry
+1 NEW BDMERR,BDMIENS,BDMFDA
+2 SET BDMIENS=ENT_","
+3 SET BDMFDA(9002244,BDMIENS,1)=ST
+4 SET BDMFDA(9002244,BDMIENS,2)=ON
+5 DO FILE^DIE("K","BDMFDA","BDMERR(1)")
+6 IF $GET(BDMERR(1))
SET BDMRET=""
QUIT
+7 QUIT
+8 ;
DDIAG(BDMRET,BDMSTR) ;-- delete the diagnosis
+1 NEW I,P
+2 SET P="|"
+3 FOR I=2:1
Begin DoDot:1
+4 IF $PIECE(BDMSTR,P,I)=""
QUIT
+5 SET DIK="^ACM(44,"
+6 SET DA=$PIECE(BDMSTR,P,I)
+7 DO ^DIK
End DoDot:1
IF $PIECE(BDMSTR,P,I)=""
QUIT
+8 SET BDMRET="^BDMTMP("_$JOB_")"
+9 SET ^BDMTMP($JOB,0)="T00030Error"_$CHAR(30)
+10 SET ^BDMTMP($JOB,1)=$CHAR(31)
+11 QUIT
+12 ;
EPRB(BDMRET,BDMSTR) ;-- edit a problem on the problem list
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BDMP,BDMDX,BDMDLM,BDMCL,BDMNAR,BDMFAC,BDMDE,BDMST,BDMON
+3 SET P="|"
+4 SET BDMP=$PIECE(BDMSTR,P)
+5 SET BDMDX=$PIECE(BDMSTR,P,2)
+6 ;maw added 10/19/2005
IF '$GET(BDMDX)
SET BDMRET="1^Invalid Diagnosis Code"
QUIT
+7 ;S BDMDX=$O(^ICD9("BA",BDMDX,0))
+8 ;I 'BDMDX S BDMRET="1^Invalid Diagnosis Code" Q
+9 SET BDMDLM=$PIECE(BDMSTR,P,3)
+10 SET BDMCL=$PIECE(BDMSTR,P,4)
+11 SET BDMNAR=$PIECE(BDMSTR,P,5)
+12 SET BDMNAR=$$FIND1^DIC(9999999.27,,"X",BDMNAR)
+13 IF 'BDMNAR
SET BDMRET="2^Provider Narrative Not Found in AUTNPOV"
QUIT
+14 ;S BDMFAC=$P($P(BDMSTR,P,6),"-")
+15 ;I $G(BDMFAC) S BDMFAC=$O(^AUTTLOC("C",BDMFAC,0))
+16 SET BDMFAC=$PIECE(BDMSTR,P,6)
+17 SET BDMST=$PIECE(BDMSTR,P,7)
+18 SET BDMON=$PIECE(BDMSTR,P,8)
+19 NEW BDMERR,BDMFDA,BDMIENS
+20 SET BDMIENS=BDMP_","
+21 SET BDMFDA(9000011,BDMIENS,.01)=BDMDX
+22 SET BDMFDA(9000011,BDMIENS,.03)=DT
+23 SET BDMFDA(9000011,BDMIENS,.04)=BDMCL
+24 SET BDMFDA(9000011,BDMIENS,.05)=BDMNAR
+25 SET BDMFDA(9000011,BDMIENS,.14)=DUZ
+26 ;S BDMFDA(9000011,BDMIENS,.07)=BDMNMBR why???
+27 SET BDMFDA(9000011,BDMIENS,.12)=BDMST
+28 SET BDMFDA(9000011,BDMIENS,.13)=BDMON
+29 DO FILE^DIE("K","BDMFDA","BDMERR")
+30 SET BDMRET=$SELECT($GET(BDMERR(1)):$GET(BDMERR(1)),1:0)
+31 QUIT
+32 ;
NOTEA(BDMRET,BDMSTR) ;-- add a note
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMNAR,BDMLOC,BDMIEN,BDMLIEN,P
+3 SET P="|"
+4 SET BDMIEN=$PIECE(BDMSTR,P)
+5 ;S BDMLOC=$P($P(BDMSTR,P,2),"-")
+6 SET BDMLOC=$PIECE(BDMSTR,P,2)
+7 SET BDMNAR=$PIECE(BDMSTR,P,3)
+8 ;S BDMLOC=$O(^AUTTLOC("C",BDMLOC,0))
+9 NEW BDMIENS,BDMERR,BDMFDA
+10 IF $ORDER(^AUPNPROB(BDMIEN,11,"B",BDMLOC,0))
Begin DoDot:1
+11 SET BDMLIEN=$ORDER(^AUPNPROB(BDMIEN,11,"B",BDMLOC,0))
End DoDot:1
+12 IF '$ORDER(^AUPNPROB(BDMIEN,11,"B",BDMLOC,0))
Begin DoDot:1
+13 SET BDMIENS="+2,"_BDMIEN_","
+14 SET BDMFDA(9000011.11,BDMIENS,.01)=BDMLOC
+15 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR")
+16 IF $GET(BDMERR(1))
SET BDMRET="1^Error Adding Note Location"
QUIT
+17 SET BDMLIEN=$GET(BDMIENS(2))
End DoDot:1
IF $GET(BDMERR(1))
QUIT
+18 NEW BDMIENS,BDMERR,BDMFDA
+19 SET BDMIENS="+3,"_BDMLIEN_","_BDMIEN_","
+20 SET BDMNN=+$PIECE($GET(^AUPNPROB(BDMIEN,11,BDMLIEN,11,0)),U,3)+1
+21 SET BDMFDA(9000011.1111,BDMIENS,.01)=BDMNN
+22 SET BDMFDA(9000011.1111,BDMIENS,.03)=BDMNAR
+23 SET BDMFDA(9000011.1111,BDMIENS,.05)=DT
+24 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR")
+25 IF $GET(BDMERR(1))
SET BDMRET="1^Error Adding Note"
QUIT
+26 SET BDMRET=0
+27 QUIT
+28 ;
NOTEE(BDMRET,BDMSTR) ;-- edit a note
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMNAR,BDMLOC,BDMIEN,BDMLIEN,BDMNIEN,BDMLIEN,P
+3 SET P="|"
+4 SET BDMIEN=$PIECE(BDMSTR,P)
+5 SET BDMLIEN=$PIECE(BDMSTR,P,2)
+6 SET BDMNIEN=$PIECE(BDMSTR,P,3)
+7 SET BDMNAR=$PIECE(BDMSTR,P,4)
+8 NEW BDMIENS,BDMERR,BDMFDA
+9 SET BDMIENS=BDMNIEN_","_BDMLIEN_","_BDMIEN_","
+10 SET BDMFDA(9000011.1111,BDMIENS,.03)=BDMNAR
+11 SET BDMFDA(9000011.1111,BDMIENS,.05)=DT
+12 DO FILE^DIE("K","BDMFDA","BDMERR")
+13 IF $GET(BDMERR(1))
SET BDMRET="1^Error Editing Note"
QUIT
+14 SET BDMRET=0
+15 QUIT
+16 ;
NOTED(BDMRET,BDMSTR) ;-- delete a note
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMIEN,BDMLIEN,BDMNIEN,BDMLIEN,P
+3 SET P="|"
+4 SET BDMIEN=$PIECE(BDMSTR,P)
+5 SET BDMLIEN=$PIECE(BDMSTR,P,2)
+6 SET BDMNIEN=$PIECE(BDMSTR,P,3)
+7 SET DIK="^AUPNPROB("_BDMIEN_",11,"_BDMLIEN_",11,"
SET DA=BDMNIEN
SET DA(1)=BDMLIEN
SET DA(2)=BDMIEN
+8 DO ^DIK
+9 IF '$PIECE($GET(^AUPNPROB(BDMIEN,11,BDMLIEN,11,0)),U,4)
Begin DoDot:1
+10 SET DIK="^AUPNPROB("_BDMIEN_",11,"
SET DA=BDMLIEN
SET DA(1)=BDMIEN
+11 DO ^DIK
End DoDot:1
+12 SET BDMRET=0
+13 QUIT
+14 ;
ACMT(BDMRET,BDMSTR) ;-- call CMT
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 DO CMT(.BDMRET,.BDMSTR)
+3 QUIT
+4 ;
CMT(BDMRET,BDMSTR) ;-- the entire array
+1 NEW P,BDMVIEN,BDMTXT
+2 SET P="|"
+3 IF $GET(BDMSTR)]""
Begin DoDot:1
+4 SET BDMVIEN=$PIECE(BDMSTR,P)
+5 SET BDMTXT(1)=$PIECE(BDMSTR,P,2)
End DoDot:1
+6 IF $GET(BDMSTR)=""
Begin DoDot:1
+7 SET BDMTXT(1)=""
+8 SET BDMVIEN=$PIECE($GET(BDMSTR(1)),P)
+9 SET BDMTXT(1)=$PIECE($GET(BDMSTR(1)),P,2)
+10 SET BDMDA=1
FOR
SET BDMDA=$ORDER(BDMSTR(BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:2
+11 SET BDMTXT(1)=BDMTXT(1)_$GET(BDMSTR(BDMDA))
End DoDot:2
End DoDot:1
+12 NEW BDMFL,BDMIENS,BDMFLD,BDMERR
+13 SET BDMFL=9002241
+14 SET BDMIENS=BDMVIEN_","
+15 SET BDMFLD=13
+16 DO WP^DIE(BDMFL,BDMIENS,BDMFLD,,"BDMTXT","BDMERR")
+17 SET BDMRET=""
+18 IF $DATA(BDMERR(1))
SET BDMRET=1
+19 QUIT
+20 ;
DME(BDMRET,BDMSTR) ;-- create entry in BDMEDMUP
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BDMIEN,BDMPIEN,BDMON,BDMPN,BDMHD,BDMHV,BDMWD,BDMWV,BDMTU,BDMTB,BDMFTD
+3 NEW BDMEYED,BDMDEND,BDMPAPD,BDMMAMD,BDMFLUD,BDMPNUD,BDMTDD,BDMBPD,BDMBPV,BDMFTR
+4 NEW BDMEYER,BDMEKGR,BDMPPDD,BDMPPDR,BDMEKGD,BDMGLU,BDMASTR,BDMMAMP,BDMDEPD,BDMDEPR
+5 SET P="|"
+6 IF $GET(BDMSTR)=""
DO CATSTR^BDMGU(.BDMSTR,.BDMSTR)
+7 IF $GET(BDMSTR)=""
SET BDMRET="Error Creating BDMEDMUP Entry, Invalid String"
QUIT
+8 SET BDMDMIEN=$PIECE(BDMSTR,P)
+9 IF $GET(BDMDMIEN)
Begin DoDot:1
+10 DO DMEE^BDMGEA(.BDMRET,.BDMSTR)
End DoDot:1
QUIT
+11 SET BDMPIEN=$PIECE(BDMSTR,P,2)
+12 SET BDMON=$PIECE(BDMSTR,P,3)
+13 SET BDMPN=$PIECE(BDMSTR,P,4)
+14 SET BDMHD=$PIECE(BDMSTR,P,5)
+15 SET BDMHV=$PIECE(BDMSTR,P,6)
+16 SET BDMWD=$PIECE(BDMSTR,P,7)
+17 SET BDMWV=$PIECE(BDMSTR,P,8)
+18 SET BDMBPD=$PIECE(BDMSTR,P,9)
+19 SET BDMBPV=$PIECE(BDMSTR,P,10)
+20 SET BDMFTD=$PIECE(BDMSTR,P,11)
+21 SET BDMFTR=$PIECE(BDMSTR,P,12)
+22 SET BDMEYED=$PIECE(BDMSTR,P,13)
+23 SET BDMEYER=$PIECE(BDMSTR,P,14)
+24 SET BDMEKGD=$PIECE(BDMSTR,P,15)
+25 SET BDMEKGR=$PIECE(BDMSTR,P,16)
+26 SET BDMDEND=$PIECE(BDMSTR,P,17)
+27 SET BDMPAPD=$PIECE(BDMSTR,P,18)
+28 SET BDMMAMD=$PIECE(BDMSTR,P,19)
+29 SET BDMPPDD=$PIECE(BDMSTR,P,20)
+30 SET BDMPPDR=$PIECE(BDMSTR,P,21)
+31 SET BDMMAMP=$PIECE(BDMSTR,P,22)
+32 SET BDMDEPD=$PIECE(BDMSTR,P,23)
+33 SET BDMDEPR=$PIECE(BDMSTR,P,24)
+34 SET BDMASTR="+1,"
+35 NEW BDMERR,BDMIENS,BDMFDA
+36 SET BDMIENS=""
+37 SET BDMFDA(9003203.2,"+1,",.01)=BDMPIEN
+38 SET BDMFDA(9003203.2,"+1,",.02)=DT
+39 SET BDMFDA(9003203.2,"+1,",.03)=BDMON
+40 SET BDMFDA(9003203.2,"+1,",.04)=BDMPN
+41 SET BDMFDA(9003203.2,"+1,",.05)=BDMHD
+42 SET BDMFDA(9003203.2,"+1,",.06)=BDMHV
+43 SET BDMFDA(9003203.2,"+1,",.07)=BDMWD
+44 SET BDMFDA(9003203.2,"+1,",.08)=BDMWV
+45 SET BDMFDA(9003203.2,"+1,",.11)=BDMFTD
+46 SET BDMFDA(9003203.2,"+1,",.12)=BDMEYED
+47 SET BDMFDA(9003203.2,"+1,",.13)=BDMDEND
+48 SET BDMFDA(9003203.2,"+1,",.14)=BDMPAPD
+49 SET BDMFDA(9003203.2,"+1,",.15)=BDMMAMD
+50 SET BDMFDA(9003203.2,"+1,",.19)=BDMBPD
+51 SET BDMFDA(9003203.2,"+1,",.2)=BDMBPV
+52 SET BDMFDA(9003203.2,"+1,",.21)=BDMFTR
+53 SET BDMFDA(9003203.2,"+1,",.22)=BDMEYER
+54 SET BDMFDA(9003203.2,"+1,",.23)=BDMEKGR
+55 SET BDMFDA(9003203.2,"+1,",.24)=BDMMAMP
+56 SET BDMFDA(9003203.2,"+1,",.25)=BDMDEPD
+57 SET BDMFDA(9003203.2,"+1,",.26)=BDMDEPR
+58 SET BDMFDA(9003203.2,"+1,",1103)=BDMEKGD
+59 SET BDMFDA(9003203.2,"+1,",1101)=BDMPPDD
+60 SET BDMFDA(9003203.2,"+1,",1102)=BDMPPDR
+61 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
+62 IF $GET(BDMERR(1))
SET BDMRET=""
QUIT
+63 SET BDMRET=$GET(BDMIENS(1))
+64 QUIT
+65 ;
