BDMGEA ; cmi/anch/maw - BDM DMS GUI Filing Routine ; 28 Oct 2014 4:31 PM
;;2.0;BDM DIABETES MANAGEMENT SYSTEM;**1,8,10**;JUN 14, 2007;Build 12
;
;
DEBUG(BDMRET,BDMSTR) ;-- debugger
D DEBUG^%Serenji("REF^BDMGEA(.BDMRET,.BDMSTR)")
Q
;
HF(BDMRET,BDMSTR) ;-- update dm health factors
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N P,BDMDMIEN,BDMPIEN,BDMTU,BDMTB,BDMGLU,BDMBAR,BDMREAD,BDMLRN,BDMTOBD,BDMTBD,BDMSMD,BDMBLD,BDMLPD
N BDMENDS,BDMENDSD
S P="|"
I $G(BDMSTR)="" D CATSTR^BDMGU(.BDMSTR,.BDMSTR)
I $G(BDMSTR)="" S BDMRET="Error Updating BDMEDMUP Entry, Invalid String" Q
S BDMDMIEN=$P(BDMSTR,P)
S BDMPIEN=$P(BDMSTR,P,2)
S BDMTU=$P(BDMSTR,P,3)
S BDMTU=$S($G(BDMTU)]"":$O(^AUTTHF("B",BDMTU,0)),1:"")
S BDMTB=$P(BDMSTR,P,4)
S BDMTB=$S($G(BDMTB)]"":$O(^AUTTHF("B",BDMTB,0)),1:"")
S BDMGLU=$P(BDMSTR,P,5)
S BDMGLU=$S($G(BDMGLU)]"":$O(^AUTTHF("B",BDMGLU,0)),1:"")
S BDMBAR=$P(BDMSTR,P,6)
S BDMBAR=$S($G(BDMBAR)]"":$O(^AUTTHF("B",BDMBAR,0)),1:"")
S BDMREAD=$P(BDMSTR,P,7)
S BDMREAD=$S($G(BDMREAD)]"":$O(^AUTTHF("B",BDMREAD,0)),1:"")
S BDMLRN=$P(BDMSTR,P,8)
S BDMLRN=$S($G(BDMLRN)]"":$O(^AUTTHF("B",BDMLRN,0)),1:"")
S BDMTOBD=$P(BDMSTR,P,9)
S BDMTBD=$P(BDMSTR,P,10)
S BDMSMD=$P(BDMSTR,P,11)
S BDMBLD=$P(BDMSTR,P,12)
S BDMLPD=$P(BDMSTR,P,13)
S BDMENDS=$P(BDMSTR,P,14)
S BDMENDS=$S($G(BDMENDS)]"":$O(^AUTTHF("B",BDMENDS,0)),1:"")
S BDMENDSD=$P(BDMSTR,P,15)
N BDMERR,BDMIENS,BDMFDA
S BDMIENS=BDMDMIEN
S BDMFDA(9003203.2,BDMIENS_",",.09)=BDMTU
S BDMFDA(9003203.2,BDMIENS_",",.1)=BDMTB
S BDMFDA(9003203.2,BDMIENS_",",1107)=BDMGLU
S BDMFDA(9003203.2,BDMIENS_",",1108)=BDMBAR
S BDMFDA(9003203.2,BDMIENS_",",1109)=BDMREAD
S BDMFDA(9003203.2,BDMIENS_",",1110)=BDMLRN
S BDMFDA(9003203.2,BDMIENS_",",1114)=BDMTOBD
S BDMFDA(9003203.2,BDMIENS_",",1115)=BDMTBD
S BDMFDA(9003203.2,BDMIENS_",",1116)=BDMSMD
S BDMFDA(9003203.2,BDMIENS_",",1117)=BDMBLD
S BDMFDA(9003203.2,BDMIENS_",",1119)=BDMLPD
S BDMFDA(9003203.2,BDMIENS_",",1122)=BDMENDS
S BDMFDA(9003203.2,BDMIENS_",",1123)=BDMENDSD
D FILE^DIE("K","BDMFDA","BDMERR(1)")
I $G(BDMERR(1)) S BDMRET="" Q
S BDMRET=$G(BDMIENS(1))
Q
;
IMM(BDMRET,BDMSTR) ;-- update dm Immunizations
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N P,BDMDMIEN,BDMPIEN,BDMFLU,BDMPNU,BDMTD,BDMFLUD,BDMTDD,BDMPNUD,BDMHEPBD,BDMHEPB
S P="|"
I $G(BDMSTR)="" D CATSTR^BDMGU(.BDMSTR,.BDMSTR)
I $G(BDMSTR)="" S BDMRET="Error Updating BDMEDMUP Entry, Invalid String" Q
S BDMDMIEN=$P(BDMSTR,P)
S BDMPIEN=$P(BDMSTR,P,2)
S BDMFLUD=$P(BDMSTR,P,3)
S BDMFLU=$P(BDMSTR,P,4)
S BDMFLU=$S($G(BDMFLU)]"":$O(^AUTTIMM("D",BDMFLU,0)),1:"")
S BDMPNUD=$P(BDMSTR,P,5)
S BDMPNU=$P(BDMSTR,P,6)
S BDMPNU=$S($G(BDMPNU)]"":$O(^AUTTIMM("D",BDMPNU,0)),1:"")
S BDMTDD=$P(BDMSTR,P,7)
S BDMTD=$P(BDMSTR,P,8)
S BDMTD=$S($G(BDMTD)]"":$O(^AUTTIMM("D",BDMTD,0)),1:"")
S BDMHEPBD=$P(BDMSTR,P,7)
S BDMHEPB=$P(BDMSTR,P,8)
S BDMHEPB=$S($G(BDMHEPB)]"":$O(^AUTTIMM("D",BDMHEPB,0)),1:"")
N BDMERR,BDMIENS,BDMFDA
S BDMIENS=""
S BDMFDA(9003203.2,BDMDMIEN_",",.16)=BDMFLUD
S BDMFDA(9003203.2,BDMDMIEN_",",.17)=BDMPNUD
S BDMFDA(9003203.2,BDMDMIEN_",",.18)=BDMTDD
S BDMFDA(9003203.2,BDMDMIEN_",",1111)=BDMFLU
S BDMFDA(9003203.2,BDMDMIEN_",",1112)=BDMPNU
S BDMFDA(9003203.2,BDMDMIEN_",",1113)=BDMTD
S BDMFDA(9003203.2,BDMDMIEN_",",1120)=BDMHEPBD
S BDMFDA(9003203.2,BDMDMIEN_",",1121)=BDMHEPB
D FILE^DIE("K","BDMFDA","BDMERR(1)")
I $G(BDMERR(1)) S BDMRET="" Q
S BDMRET=$G(BDMIENS(1))
Q
;
DMEE(BDMRET,BDMSTR) ;EP - edit the entry in APCDDMUP
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
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)
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)
N BDMERR,BDMIENS,BDMFDA
S BDMIENS=""
S BDMFDA(9003203.2,BDMDMIEN_",",.02)=DT
S BDMFDA(9003203.2,BDMDMIEN_",",.03)=BDMON
S BDMFDA(9003203.2,BDMDMIEN_",",.04)=BDMPN
S BDMFDA(9003203.2,BDMDMIEN_",",.05)=BDMHD
S BDMFDA(9003203.2,BDMDMIEN_",",.06)=BDMHV
S BDMFDA(9003203.2,BDMDMIEN_",",.07)=BDMWD
S BDMFDA(9003203.2,BDMDMIEN_",",.08)=BDMWV
S BDMFDA(9003203.2,BDMDMIEN_",",.11)=BDMFTD
S BDMFDA(9003203.2,BDMDMIEN_",",.12)=BDMEYED
S BDMFDA(9003203.2,BDMDMIEN_",",.13)=BDMDEND
S BDMFDA(9003203.2,BDMDMIEN_",",.14)=BDMPAPD
S BDMFDA(9003203.2,BDMDMIEN_",",.15)=BDMMAMD
S BDMFDA(9003203.2,BDMDMIEN_",",.19)=BDMBPD
S BDMFDA(9003203.2,BDMDMIEN_",",.2)=BDMBPV
S BDMFDA(9003203.2,BDMDMIEN_",",.21)=BDMFTR
S BDMFDA(9003203.2,BDMDMIEN_",",.22)=BDMEYER
S BDMFDA(9003203.2,BDMDMIEN_",",.23)=BDMEKGR
S BDMFDA(9003203.2,BDMDMIEN_",",.24)=BDMMAMP
S BDMFDA(9003203.2,BDMDMIEN_",",1103)=BDMEKGD
S BDMFDA(9003203.2,BDMDMIEN_",",1101)=BDMPPDD
S BDMFDA(9003203.2,BDMDMIEN_",",1102)=BDMPPDR
D FILE^DIE("K","BDMFDA","BDMERR(1)")
I $G(BDMERR(1)) S BDMRET="" Q
I $G(BDMIENS(1)) S BDMRET=$G(BDMIENS(1)) Q
S BDMRET=$P(BDMSTR,P)
Q
;
LAB(BDMRET,BDMSTR) ;-- add lab entries to APCDDMUP
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMDMIEN,BDMPIEN,BDMLABT,BDMLAB,BDMLABD,BDMLABR,P,R
S P="|",R="~"
I $G(BDMSTR)="" D CATSTR^BDMGU(.BDMSTR,.BDMSTR)
I $G(BDMSTR)="" S BDMRET="Error Creating BDMEDMUP Lab Entry, Invalid String" Q
S BDMDMIEN=$P(BDMSTR,P)
S BDMPIEN=$P(BDMSTR,P,2)
F BDMI=3:1 D Q:$P(BDMSTR,P,BDMI)=""
. N BDMDATA
. S BDMDATA=$P(BDMSTR,P,BDMI)
. Q:$G(BDMDATA)=""
. S BDMLAB=$P(BDMDATA,R)
. S BDMLABD=$P(BDMDATA,R,2)
. S BDMLABR=$P(BDMDATA,R,3)
. N BDMERR,BDMIENS,BDMFDA
. S BDMIENS=""
. S BDMFDA(9003203.213,"+2,"_BDMDMIEN_",",.01)=BDMLAB
. S BDMFDA(9003203.213,"+2,"_BDMDMIEN_",",.02)=BDMLABD
. S BDMFDA(9003203.213,"+2,"_BDMDMIEN_",",.03)=BDMLABR
. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
. I $G(BDMERR(1)) S BDMRET="" Q
. S BDMRET=$G(BDMIENS(1))
Q
;
MED(BDMRET,BDMSTR) ;-- add med entries to APCDDMUP
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMDMIEN,BDMPIEN,BDMMEDT,BDMMED,BDMMEDD,BDMQTY,BDMSIG,R,P
S P="|",R="~"
I $G(BDMSTR)="" D CATSTR^BDMGU(.BDMSTR,.BDMSTR)
I $G(BDMSTR)="" S BDMRET="Error Creating BDMEDMUP Medication Entry, Invalid String" Q
S BDMDMIEN=$P(BDMSTR,P)
S BDMPIEN=$P(BDMSTR,P,2)
F BDMI=3:1 D Q:$P(BDMSTR,P,BDMI)=""
. N BDMDATA
. S BDMDATA=$P(BDMSTR,P,BDMI)
. Q:$G(BDMDATA)=""
. S BDMMED=$P(BDMDATA,R)
. S BDMMEDD=$P(BDMDATA,R,2)
. S BDMQTY=$P(BDMDATA,R,3)
. S BDMSIG=$P(BDMDATA,R,4)
. N BDMERR,BDMIENS,BDMFDA
. S BDMIENS=""
. S BDMFDA(9003203.214,"+2,"_BDMDMIEN_",",.01)=BDMMED
. S BDMFDA(9003203.214,"+2,"_BDMDMIEN_",",.02)=BDMMEDD
. S BDMFDA(9003203.214,"+2,"_BDMDMIEN_",",.03)=BDMQTY
. S BDMFDA(9003203.214,"+2,"_BDMDMIEN_",",.04)=BDMSIG
. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
. I $G(BDMERR(1)) S BDMRET="" Q
. S BDMRET=$G(BDMIENS(1))
Q
;
EDU(BDMRET,BDMSTR) ;-- add EDU entries to APCDDMUP
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMDMIEN,BDMPIEN,BDMEDUT,BDMEDU,BDMPRVE,BDMPRV,BDMLOU,BDMEDUD,P,R
N BDMTS,BDMIG,BDMOBJ,BDMBC
S P="|",R="~"
I $G(BDMSTR)="" D CATSTR^BDMGU(.BDMSTR,.BDMSTR)
I $G(BDMSTR)="" S BDMRET="Error Creating BDMEDMUP Education Entry, Invalid String" Q
S BDMDMIEN=$P(BDMSTR,P)
S BDMPIEN=$P(BDMSTR,P,2)
F BDMI=3:1 D Q:$P(BDMSTR,P,BDMI)=""
. N BDMDATA
. S BDMDATA=$P(BDMSTR,P,BDMI)
. Q:$G(BDMDATA)=""
. S BDMEDUT=$P(BDMDATA,R)
. S BDMEDU=$O(^AUTTEDT("B",BDMEDUT,0))
. S BDMEDUD=$P(BDMDATA,R,2)
. S BDMPRV=$P(BDMDATA,R,3)
. S BDMLOU=$P(BDMDATA,R,4)
. S BDMTS=$P(BDMDATA,R,5)
. S BDMIG=$P(BDMDATA,R,6)
. S BDMOBJ=$P(BDMDATA,R,7)
. S BDMBC=$P(BDMDATA,R,8)
. N BDMERR,BDMIENS,BDMFDA
. S BDMIENS=""
. S BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.01)=BDMEDU
. S BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.02)=BDMEDUD
. S BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.04)=BDMPRV
. S BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.03)=BDMLOU
. S BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.05)=BDMOBJ
. S BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.06)=BDMIG
. S BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.07)=BDMTS
. S BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.08)=BDMBC
. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
. I $G(BDMERR(1)) S BDMRET="" Q
. S BDMRET=$G(BDMIENS(1))
Q
;
REF(BDMRET,BDMSTR) ;-- refusals
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N P,R,BDMDMIEN,BDMPIEN
S P="|",R="~"
I BDMSTR="" S BDMSTR=$$CATSTR^BDMGU(.BDMSTR,.BDMSTR)
I $G(BDMSTR)="" S BDMRET="Error Concatenating String for Refusals" Q
S BDMDMIEN=$P(BDMSTR,P)
S BDMPIEN=$P(BDMSTR,P,2)
N BDMI
F BDMI=3:1 D Q:$P(BDMSTR,P,BDMI)=""
. N BDMDATA,BDMFDA,BDMTERM,BDMIENS,BDMERR,BDMRES,BDMREFT,BDMREFR,BDMREFDT,BDMVAL
. S BDMIENS=""
. S BDMDATA=$P(BDMSTR,P,BDMI)
. Q:$G(BDMDATA)=""
. S BDMTERM=$P(BDMDATA,R)
. S BDMTIEN=$O(^AUTTREFT("B",BDMTERM,0))
. S BDMFILE=$P($G(^AUTTREFT(BDMTIEN,0)),U,2)
. S BDMFLD=$P($G(^AUTTREFT(BDMTIEN,0)),U,3)
. S BDMREFDT=$P(BDMDATA,R,2)
. S BDMREFT=$P(BDMDATA,R,3)
. S BDMREFR=$P(BDMDATA,R,4)
. S BDMVAL=$$FIND1^DIC(BDMFILE,,"MX",BDMREFT,,,"BDMERR(1)")
. S BDMFDA(9000022,"+1,",.01)=BDMTIEN
. S BDMFDA(9000022,"+1,",.02)=BDMPIEN
. S BDMFDA(9000022,"+1,",.03)=BDMREFDT
. S BDMFDA(9000022,"+1,",.04)=BDMREFT
. S BDMFDA(9000022,"+1,",.05)=BDMFILE
. S BDMFDA(9000022,"+1,",.06)=BDMVAL
. S BDMFDA(9000022,"+1,",.07)=BDMREFR
. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
. I $D(BDMERR) S BDMRET=$G(BDMERR(1)) Q
Q
;
PCC(BDMRET,BDMSTR) ;-- return pcc data errors/result
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
K BDMDIEN,BDMEBSDV,BDMEDA,BDMEDMDT,BDMEDMPT,BDMEIN,BDMEMTYP,BDMEREC,BDMEREC1 ;p10
D EN^BDMEDMUP(BDMSTR,.PCCRET)
N BDMPCC,BDMI,BDMERR,BDMIEN
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00080PCC"_$C(30)
I '$D(PCCRET(1)) D Q
. S BDMI=BDMI+1
. S ^BDMTMP($J,BDMI)="PCC Data Filed Successfully"_$C(30)
. S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
S BDMDA=0 F S BDMDA=$O(PCCRET(BDMDA)) Q:'BDMDA D
. S BDMI=BDMI+1
. S ^BDMTMP($J,BDMI)=$G(PCCRET(BDMDA))_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
TAX(BDMRET,BDMSTR) ;-- save taxonomy
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N P,BDMFL,BDMTAXN,BDMTAXF,BDMTAX,BDMI,BDMP,BDMERR,BDMTAXM,BDMTXG,BDMTXF,BDMTAXPF,BDMLOOK,BDMTX,BDMTXM
I BDMSTR="" D CATSTR^BDMGU(.BDMSTR,.BDMSTR)
I $G(BDMSTR)="" S BDMRET="Error Concatenating String for Taxonomy" Q
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00080TAXONOMYSAVE"_$C(30)
S P="|"
S BDMTAXN=$P(BDMSTR,P)
S BDMTAXF=$P(BDMSTR,P,2)
S BDMTXG="^ATXAX(""B"")"
S BDMTX="^ATXAX("
S BDMTXF=9002226
S BDMTXM=9002226.02101
I BDMTAXF="Lab" D
. S BDMTXG="^ATXLAB(""B"")"
. S BDMTX="^ATXLAB("
. S BDMTXF=9002228
. S BDMTXM=9002228.02101
. S BDMFL=60
S BDMTAX=$O(@BDMTXG@(BDMTAXN,0))
S BDMLOOK=0
I 'BDMTAX S BDMRET="Taxonomy does not exist on System" Q
S BDMLOOK=0
I '$$GET1^DIQ(BDMTXF,BDMTAX,.13) S BDMLOOK=1
D CLEANTAX(BDMTX,BDMTAX)
F BDMP=3:1 S BDMTAXM=$P(BDMSTR,P,BDMP) Q:$G(BDMTAXM)="" D
. N BDMIENS,BDMFDA
. S BDMIENS="+2,"_BDMTAX_","
. I BDMLOOK D
.. N BDMGLF
.. I '$G(BDMFL) S BDMFL=$P($G(^ATXAX(BDMTAX,0)),U,15)
.. S BDMGLF=$G(^DIC(BDMFL,0,"GL"))
.. S BDMGLF=BDMGLF_"""B"")"
.. S BDMTAXM=$O(@BDMGLF@(BDMTAXM,0))
. I 'BDMLOOK D
.. S BDMTAXM=$P(BDMTAXM,"-")
.. S BDMTAXM=BDMTAXM_" "
. Q:$G(BDMTAXM)=""
. S BDMFDA(BDMTXM,BDMIENS,.01)=BDMTAXM
. I BDMTXM=9002226.02101 S BDMFDA(BDMTXM,BDMIENS,.02)=BDMTAXM
. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
CLEANTAX(TAXF,TAX) ;-- remove existing entries from 21 multiple before adding
N BDMDA,TAXI,BDMAA
S TAXI=TAXF_TAX_",21)"
S DIK=TAXF_TAX_",21,",DA(1)=TAX
S BDMDA=0 F S BDMDA=$O(@TAXI@(BDMDA)) Q:'BDMDA D
. S DA=BDMDA
. D ^DIK
S BDMAA=TAXF_TAX_",21)"
K @BDMAA@("AA")
K DIK,DA
Q
;
AU(BDMRET,BDMSTR) ;-- file the Authorized User
N P,R,BDMREGE,BDMREG,BDMAU,BDMMK,BDMU
S P="|",R="~"
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S ^BDMTMP($J,0)="T00080RETURN"_$C(30)
I $G(BDMSTR)="" D CATSTR^BDMGU(.BDMSTR,.BDMSTR)
S BDMREGE=$P(BDMSTR,P)
S BDMREG=$O(^ACM(41.1,"B",BDMREGE,0))
F I=2:1 D Q:$P(BDMSTR,P,I)=""
. Q:$P(BDMSTR,P,I)=""
. S BDMAU=$P($P(BDMSTR,P,I),R)
. S BDMMK=$P($P(BDMSTR,P,I),R,2)
. S BDMU(BDMAU)=BDMMK
N BDMDA
D CLNAU(BDMREG,.BDMU)
S BDMDA=0 F S BDMDA=$O(BDMU(BDMDA)) Q:'BDMDA D
. N BDMM
. S BDMM=$G(BDMU(BDMDA))
. D CHKKEY(BDMDA,BDMM)
. Q:$D(^ACM(41.1,BDMREG,"AU",BDMDA))
. N BDMFDA,BDMIENS,BDMERR
. S BDMIENS(1)=BDMREG
. S BDMIENS(2)=BDMDA
. ;S BDMFDA(9002241,"?1,",.01)=BDMREGE
. S BDMFDA(9002241.12,"+2,"_BDMIENS(1)_",",.01)=BDMDA
. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
. I $G(BDMERR) Q
S ^BDMTMP($J,1)="DMS User Updated"_$C(30)
S ^BDMTMP($J,2)=$C(31)
Q
;
CHKKEY(PT,MM) ;-- check to see if the user holds the key and is auth
N BDMKEY
S BDMKEY=$O(^DIC(19.1,"B","BDMZ REGISTER MAINTENANCE",0))
I $G(MM)="Y" D Q
. Q:$D(^VA(200,PT,51,BDMKEY,0))
. N BDMIENS,BDMFDA,BDMERR
. S BDMIENS(1)=PT
. S BDMIENS(2)=BDMKEY
. S BDMFDA(200.051,"+2,"_BDMIENS(1)_",",.01)=BDMKEY
. S BDMFDA(200.051,"+2,"_BDMIENS(1)_",",1)=DUZ
. D UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
. I $G(BDMERR) Q
Q:'$D(^VA(200,PT,51,BDMKEY))
S DA(1)=PT,DA=BDMKEY,DIK="^VA(200,"_DA(1)_",51,"
D ^DIK
Q
;
CLNAU(REG,DMU) ;-- clean up authorized user first
N BDMDA
S BDMDA=0 F S BDMDA=$O(^ACM(41.1,REG,"AU",BDMDA)) Q:'BDMDA D
. I '$D(DMU(BDMDA)) D
.. S DA(1)=REG,DA=BDMDA,DIK="^ACM(41.1,"_DA(1)_",""AU"","
.. D ^DIK
Q
;
BDMGEA ; cmi/anch/maw - BDM DMS GUI Filing Routine ; 28 Oct 2014 4:31 PM
+1 ;;2.0;BDM DIABETES MANAGEMENT SYSTEM;**1,8,10**;JUN 14, 2007;Build 12
+2 ;
+3 ;
DEBUG(BDMRET,BDMSTR) ;-- debugger
+1 DO DEBUG^%Serenji("REF^BDMGEA(.BDMRET,.BDMSTR)")
+2 QUIT
+3 ;
HF(BDMRET,BDMSTR) ;-- update dm health factors
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BDMDMIEN,BDMPIEN,BDMTU,BDMTB,BDMGLU,BDMBAR,BDMREAD,BDMLRN,BDMTOBD,BDMTBD,BDMSMD,BDMBLD,BDMLPD
+3 NEW BDMENDS,BDMENDSD
+4 SET P="|"
+5 IF $GET(BDMSTR)=""
DO CATSTR^BDMGU(.BDMSTR,.BDMSTR)
+6 IF $GET(BDMSTR)=""
SET BDMRET="Error Updating BDMEDMUP Entry, Invalid String"
QUIT
+7 SET BDMDMIEN=$PIECE(BDMSTR,P)
+8 SET BDMPIEN=$PIECE(BDMSTR,P,2)
+9 SET BDMTU=$PIECE(BDMSTR,P,3)
+10 SET BDMTU=$SELECT($GET(BDMTU)]"":$ORDER(^AUTTHF("B",BDMTU,0)),1:"")
+11 SET BDMTB=$PIECE(BDMSTR,P,4)
+12 SET BDMTB=$SELECT($GET(BDMTB)]"":$ORDER(^AUTTHF("B",BDMTB,0)),1:"")
+13 SET BDMGLU=$PIECE(BDMSTR,P,5)
+14 SET BDMGLU=$SELECT($GET(BDMGLU)]"":$ORDER(^AUTTHF("B",BDMGLU,0)),1:"")
+15 SET BDMBAR=$PIECE(BDMSTR,P,6)
+16 SET BDMBAR=$SELECT($GET(BDMBAR)]"":$ORDER(^AUTTHF("B",BDMBAR,0)),1:"")
+17 SET BDMREAD=$PIECE(BDMSTR,P,7)
+18 SET BDMREAD=$SELECT($GET(BDMREAD)]"":$ORDER(^AUTTHF("B",BDMREAD,0)),1:"")
+19 SET BDMLRN=$PIECE(BDMSTR,P,8)
+20 SET BDMLRN=$SELECT($GET(BDMLRN)]"":$ORDER(^AUTTHF("B",BDMLRN,0)),1:"")
+21 SET BDMTOBD=$PIECE(BDMSTR,P,9)
+22 SET BDMTBD=$PIECE(BDMSTR,P,10)
+23 SET BDMSMD=$PIECE(BDMSTR,P,11)
+24 SET BDMBLD=$PIECE(BDMSTR,P,12)
+25 SET BDMLPD=$PIECE(BDMSTR,P,13)
+26 SET BDMENDS=$PIECE(BDMSTR,P,14)
+27 SET BDMENDS=$SELECT($GET(BDMENDS)]"":$ORDER(^AUTTHF("B",BDMENDS,0)),1:"")
+28 SET BDMENDSD=$PIECE(BDMSTR,P,15)
+29 NEW BDMERR,BDMIENS,BDMFDA
+30 SET BDMIENS=BDMDMIEN
+31 SET BDMFDA(9003203.2,BDMIENS_",",.09)=BDMTU
+32 SET BDMFDA(9003203.2,BDMIENS_",",.1)=BDMTB
+33 SET BDMFDA(9003203.2,BDMIENS_",",1107)=BDMGLU
+34 SET BDMFDA(9003203.2,BDMIENS_",",1108)=BDMBAR
+35 SET BDMFDA(9003203.2,BDMIENS_",",1109)=BDMREAD
+36 SET BDMFDA(9003203.2,BDMIENS_",",1110)=BDMLRN
+37 SET BDMFDA(9003203.2,BDMIENS_",",1114)=BDMTOBD
+38 SET BDMFDA(9003203.2,BDMIENS_",",1115)=BDMTBD
+39 SET BDMFDA(9003203.2,BDMIENS_",",1116)=BDMSMD
+40 SET BDMFDA(9003203.2,BDMIENS_",",1117)=BDMBLD
+41 SET BDMFDA(9003203.2,BDMIENS_",",1119)=BDMLPD
+42 SET BDMFDA(9003203.2,BDMIENS_",",1122)=BDMENDS
+43 SET BDMFDA(9003203.2,BDMIENS_",",1123)=BDMENDSD
+44 DO FILE^DIE("K","BDMFDA","BDMERR(1)")
+45 IF $GET(BDMERR(1))
SET BDMRET=""
QUIT
+46 SET BDMRET=$GET(BDMIENS(1))
+47 QUIT
+48 ;
IMM(BDMRET,BDMSTR) ;-- update dm Immunizations
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BDMDMIEN,BDMPIEN,BDMFLU,BDMPNU,BDMTD,BDMFLUD,BDMTDD,BDMPNUD,BDMHEPBD,BDMHEPB
+3 SET P="|"
+4 IF $GET(BDMSTR)=""
DO CATSTR^BDMGU(.BDMSTR,.BDMSTR)
+5 IF $GET(BDMSTR)=""
SET BDMRET="Error Updating BDMEDMUP Entry, Invalid String"
QUIT
+6 SET BDMDMIEN=$PIECE(BDMSTR,P)
+7 SET BDMPIEN=$PIECE(BDMSTR,P,2)
+8 SET BDMFLUD=$PIECE(BDMSTR,P,3)
+9 SET BDMFLU=$PIECE(BDMSTR,P,4)
+10 SET BDMFLU=$SELECT($GET(BDMFLU)]"":$ORDER(^AUTTIMM("D",BDMFLU,0)),1:"")
+11 SET BDMPNUD=$PIECE(BDMSTR,P,5)
+12 SET BDMPNU=$PIECE(BDMSTR,P,6)
+13 SET BDMPNU=$SELECT($GET(BDMPNU)]"":$ORDER(^AUTTIMM("D",BDMPNU,0)),1:"")
+14 SET BDMTDD=$PIECE(BDMSTR,P,7)
+15 SET BDMTD=$PIECE(BDMSTR,P,8)
+16 SET BDMTD=$SELECT($GET(BDMTD)]"":$ORDER(^AUTTIMM("D",BDMTD,0)),1:"")
+17 SET BDMHEPBD=$PIECE(BDMSTR,P,7)
+18 SET BDMHEPB=$PIECE(BDMSTR,P,8)
+19 SET BDMHEPB=$SELECT($GET(BDMHEPB)]"":$ORDER(^AUTTIMM("D",BDMHEPB,0)),1:"")
+20 NEW BDMERR,BDMIENS,BDMFDA
+21 SET BDMIENS=""
+22 SET BDMFDA(9003203.2,BDMDMIEN_",",.16)=BDMFLUD
+23 SET BDMFDA(9003203.2,BDMDMIEN_",",.17)=BDMPNUD
+24 SET BDMFDA(9003203.2,BDMDMIEN_",",.18)=BDMTDD
+25 SET BDMFDA(9003203.2,BDMDMIEN_",",1111)=BDMFLU
+26 SET BDMFDA(9003203.2,BDMDMIEN_",",1112)=BDMPNU
+27 SET BDMFDA(9003203.2,BDMDMIEN_",",1113)=BDMTD
+28 SET BDMFDA(9003203.2,BDMDMIEN_",",1120)=BDMHEPBD
+29 SET BDMFDA(9003203.2,BDMDMIEN_",",1121)=BDMHEPB
+30 DO FILE^DIE("K","BDMFDA","BDMERR(1)")
+31 IF $GET(BDMERR(1))
SET BDMRET=""
QUIT
+32 SET BDMRET=$GET(BDMIENS(1))
+33 QUIT
+34 ;
DMEE(BDMRET,BDMSTR) ;EP - edit the entry in APCDDMUP
+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
+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 SET BDMPIEN=$PIECE(BDMSTR,P,2)
+10 SET BDMON=$PIECE(BDMSTR,P,3)
+11 SET BDMPN=$PIECE(BDMSTR,P,4)
+12 SET BDMHD=$PIECE(BDMSTR,P,5)
+13 SET BDMHV=$PIECE(BDMSTR,P,6)
+14 SET BDMWD=$PIECE(BDMSTR,P,7)
+15 SET BDMWV=$PIECE(BDMSTR,P,8)
+16 SET BDMBPD=$PIECE(BDMSTR,P,9)
+17 SET BDMBPV=$PIECE(BDMSTR,P,10)
+18 SET BDMFTD=$PIECE(BDMSTR,P,11)
+19 SET BDMFTR=$PIECE(BDMSTR,P,12)
+20 SET BDMEYED=$PIECE(BDMSTR,P,13)
+21 SET BDMEYER=$PIECE(BDMSTR,P,14)
+22 SET BDMEKGD=$PIECE(BDMSTR,P,15)
+23 SET BDMEKGR=$PIECE(BDMSTR,P,16)
+24 SET BDMDEND=$PIECE(BDMSTR,P,17)
+25 SET BDMPAPD=$PIECE(BDMSTR,P,18)
+26 SET BDMMAMD=$PIECE(BDMSTR,P,19)
+27 SET BDMPPDD=$PIECE(BDMSTR,P,20)
+28 SET BDMPPDR=$PIECE(BDMSTR,P,21)
+29 SET BDMMAMP=$PIECE(BDMSTR,P,22)
+30 NEW BDMERR,BDMIENS,BDMFDA
+31 SET BDMIENS=""
+32 SET BDMFDA(9003203.2,BDMDMIEN_",",.02)=DT
+33 SET BDMFDA(9003203.2,BDMDMIEN_",",.03)=BDMON
+34 SET BDMFDA(9003203.2,BDMDMIEN_",",.04)=BDMPN
+35 SET BDMFDA(9003203.2,BDMDMIEN_",",.05)=BDMHD
+36 SET BDMFDA(9003203.2,BDMDMIEN_",",.06)=BDMHV
+37 SET BDMFDA(9003203.2,BDMDMIEN_",",.07)=BDMWD
+38 SET BDMFDA(9003203.2,BDMDMIEN_",",.08)=BDMWV
+39 SET BDMFDA(9003203.2,BDMDMIEN_",",.11)=BDMFTD
+40 SET BDMFDA(9003203.2,BDMDMIEN_",",.12)=BDMEYED
+41 SET BDMFDA(9003203.2,BDMDMIEN_",",.13)=BDMDEND
+42 SET BDMFDA(9003203.2,BDMDMIEN_",",.14)=BDMPAPD
+43 SET BDMFDA(9003203.2,BDMDMIEN_",",.15)=BDMMAMD
+44 SET BDMFDA(9003203.2,BDMDMIEN_",",.19)=BDMBPD
+45 SET BDMFDA(9003203.2,BDMDMIEN_",",.2)=BDMBPV
+46 SET BDMFDA(9003203.2,BDMDMIEN_",",.21)=BDMFTR
+47 SET BDMFDA(9003203.2,BDMDMIEN_",",.22)=BDMEYER
+48 SET BDMFDA(9003203.2,BDMDMIEN_",",.23)=BDMEKGR
+49 SET BDMFDA(9003203.2,BDMDMIEN_",",.24)=BDMMAMP
+50 SET BDMFDA(9003203.2,BDMDMIEN_",",1103)=BDMEKGD
+51 SET BDMFDA(9003203.2,BDMDMIEN_",",1101)=BDMPPDD
+52 SET BDMFDA(9003203.2,BDMDMIEN_",",1102)=BDMPPDR
+53 DO FILE^DIE("K","BDMFDA","BDMERR(1)")
+54 IF $GET(BDMERR(1))
SET BDMRET=""
QUIT
+55 IF $GET(BDMIENS(1))
SET BDMRET=$GET(BDMIENS(1))
QUIT
+56 SET BDMRET=$PIECE(BDMSTR,P)
+57 QUIT
+58 ;
LAB(BDMRET,BDMSTR) ;-- add lab entries to APCDDMUP
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMDMIEN,BDMPIEN,BDMLABT,BDMLAB,BDMLABD,BDMLABR,P,R
+3 SET P="|"
SET R="~"
+4 IF $GET(BDMSTR)=""
DO CATSTR^BDMGU(.BDMSTR,.BDMSTR)
+5 IF $GET(BDMSTR)=""
SET BDMRET="Error Creating BDMEDMUP Lab Entry, Invalid String"
QUIT
+6 SET BDMDMIEN=$PIECE(BDMSTR,P)
+7 SET BDMPIEN=$PIECE(BDMSTR,P,2)
+8 FOR BDMI=3:1
Begin DoDot:1
+9 NEW BDMDATA
+10 SET BDMDATA=$PIECE(BDMSTR,P,BDMI)
+11 IF $GET(BDMDATA)=""
QUIT
+12 SET BDMLAB=$PIECE(BDMDATA,R)
+13 SET BDMLABD=$PIECE(BDMDATA,R,2)
+14 SET BDMLABR=$PIECE(BDMDATA,R,3)
+15 NEW BDMERR,BDMIENS,BDMFDA
+16 SET BDMIENS=""
+17 SET BDMFDA(9003203.213,"+2,"_BDMDMIEN_",",.01)=BDMLAB
+18 SET BDMFDA(9003203.213,"+2,"_BDMDMIEN_",",.02)=BDMLABD
+19 SET BDMFDA(9003203.213,"+2,"_BDMDMIEN_",",.03)=BDMLABR
+20 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
+21 IF $GET(BDMERR(1))
SET BDMRET=""
QUIT
+22 SET BDMRET=$GET(BDMIENS(1))
End DoDot:1
IF $PIECE(BDMSTR,P,BDMI)=""
QUIT
+23 QUIT
+24 ;
MED(BDMRET,BDMSTR) ;-- add med entries to APCDDMUP
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMDMIEN,BDMPIEN,BDMMEDT,BDMMED,BDMMEDD,BDMQTY,BDMSIG,R,P
+3 SET P="|"
SET R="~"
+4 IF $GET(BDMSTR)=""
DO CATSTR^BDMGU(.BDMSTR,.BDMSTR)
+5 IF $GET(BDMSTR)=""
SET BDMRET="Error Creating BDMEDMUP Medication Entry, Invalid String"
QUIT
+6 SET BDMDMIEN=$PIECE(BDMSTR,P)
+7 SET BDMPIEN=$PIECE(BDMSTR,P,2)
+8 FOR BDMI=3:1
Begin DoDot:1
+9 NEW BDMDATA
+10 SET BDMDATA=$PIECE(BDMSTR,P,BDMI)
+11 IF $GET(BDMDATA)=""
QUIT
+12 SET BDMMED=$PIECE(BDMDATA,R)
+13 SET BDMMEDD=$PIECE(BDMDATA,R,2)
+14 SET BDMQTY=$PIECE(BDMDATA,R,3)
+15 SET BDMSIG=$PIECE(BDMDATA,R,4)
+16 NEW BDMERR,BDMIENS,BDMFDA
+17 SET BDMIENS=""
+18 SET BDMFDA(9003203.214,"+2,"_BDMDMIEN_",",.01)=BDMMED
+19 SET BDMFDA(9003203.214,"+2,"_BDMDMIEN_",",.02)=BDMMEDD
+20 SET BDMFDA(9003203.214,"+2,"_BDMDMIEN_",",.03)=BDMQTY
+21 SET BDMFDA(9003203.214,"+2,"_BDMDMIEN_",",.04)=BDMSIG
+22 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
+23 IF $GET(BDMERR(1))
SET BDMRET=""
QUIT
+24 SET BDMRET=$GET(BDMIENS(1))
End DoDot:1
IF $PIECE(BDMSTR,P,BDMI)=""
QUIT
+25 QUIT
+26 ;
EDU(BDMRET,BDMSTR) ;-- add EDU entries to APCDDMUP
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMDMIEN,BDMPIEN,BDMEDUT,BDMEDU,BDMPRVE,BDMPRV,BDMLOU,BDMEDUD,P,R
+3 NEW BDMTS,BDMIG,BDMOBJ,BDMBC
+4 SET P="|"
SET R="~"
+5 IF $GET(BDMSTR)=""
DO CATSTR^BDMGU(.BDMSTR,.BDMSTR)
+6 IF $GET(BDMSTR)=""
SET BDMRET="Error Creating BDMEDMUP Education Entry, Invalid String"
QUIT
+7 SET BDMDMIEN=$PIECE(BDMSTR,P)
+8 SET BDMPIEN=$PIECE(BDMSTR,P,2)
+9 FOR BDMI=3:1
Begin DoDot:1
+10 NEW BDMDATA
+11 SET BDMDATA=$PIECE(BDMSTR,P,BDMI)
+12 IF $GET(BDMDATA)=""
QUIT
+13 SET BDMEDUT=$PIECE(BDMDATA,R)
+14 SET BDMEDU=$ORDER(^AUTTEDT("B",BDMEDUT,0))
+15 SET BDMEDUD=$PIECE(BDMDATA,R,2)
+16 SET BDMPRV=$PIECE(BDMDATA,R,3)
+17 SET BDMLOU=$PIECE(BDMDATA,R,4)
+18 SET BDMTS=$PIECE(BDMDATA,R,5)
+19 SET BDMIG=$PIECE(BDMDATA,R,6)
+20 SET BDMOBJ=$PIECE(BDMDATA,R,7)
+21 SET BDMBC=$PIECE(BDMDATA,R,8)
+22 NEW BDMERR,BDMIENS,BDMFDA
+23 SET BDMIENS=""
+24 SET BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.01)=BDMEDU
+25 SET BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.02)=BDMEDUD
+26 SET BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.04)=BDMPRV
+27 SET BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.03)=BDMLOU
+28 SET BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.05)=BDMOBJ
+29 SET BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.06)=BDMIG
+30 SET BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.07)=BDMTS
+31 SET BDMFDA(9003203.212,"+2,"_BDMDMIEN_",",.08)=BDMBC
+32 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
+33 IF $GET(BDMERR(1))
SET BDMRET=""
QUIT
+34 SET BDMRET=$GET(BDMIENS(1))
End DoDot:1
IF $PIECE(BDMSTR,P,BDMI)=""
QUIT
+35 QUIT
+36 ;
REF(BDMRET,BDMSTR) ;-- refusals
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,R,BDMDMIEN,BDMPIEN
+3 SET P="|"
SET R="~"
+4 IF BDMSTR=""
SET BDMSTR=$$CATSTR^BDMGU(.BDMSTR,.BDMSTR)
+5 IF $GET(BDMSTR)=""
SET BDMRET="Error Concatenating String for Refusals"
QUIT
+6 SET BDMDMIEN=$PIECE(BDMSTR,P)
+7 SET BDMPIEN=$PIECE(BDMSTR,P,2)
+8 NEW BDMI
+9 FOR BDMI=3:1
Begin DoDot:1
+10 NEW BDMDATA,BDMFDA,BDMTERM,BDMIENS,BDMERR,BDMRES,BDMREFT,BDMREFR,BDMREFDT,BDMVAL
+11 SET BDMIENS=""
+12 SET BDMDATA=$PIECE(BDMSTR,P,BDMI)
+13 IF $GET(BDMDATA)=""
QUIT
+14 SET BDMTERM=$PIECE(BDMDATA,R)
+15 SET BDMTIEN=$ORDER(^AUTTREFT("B",BDMTERM,0))
+16 SET BDMFILE=$PIECE($GET(^AUTTREFT(BDMTIEN,0)),U,2)
+17 SET BDMFLD=$PIECE($GET(^AUTTREFT(BDMTIEN,0)),U,3)
+18 SET BDMREFDT=$PIECE(BDMDATA,R,2)
+19 SET BDMREFT=$PIECE(BDMDATA,R,3)
+20 SET BDMREFR=$PIECE(BDMDATA,R,4)
+21 SET BDMVAL=$$FIND1^DIC(BDMFILE,,"MX",BDMREFT,,,"BDMERR(1)")
+22 SET BDMFDA(9000022,"+1,",.01)=BDMTIEN
+23 SET BDMFDA(9000022,"+1,",.02)=BDMPIEN
+24 SET BDMFDA(9000022,"+1,",.03)=BDMREFDT
+25 SET BDMFDA(9000022,"+1,",.04)=BDMREFT
+26 SET BDMFDA(9000022,"+1,",.05)=BDMFILE
+27 SET BDMFDA(9000022,"+1,",.06)=BDMVAL
+28 SET BDMFDA(9000022,"+1,",.07)=BDMREFR
+29 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
+30 IF $DATA(BDMERR)
SET BDMRET=$GET(BDMERR(1))
QUIT
End DoDot:1
IF $PIECE(BDMSTR,P,BDMI)=""
QUIT
+31 QUIT
+32 ;
PCC(BDMRET,BDMSTR) ;-- return pcc data errors/result
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 ;p10
KILL BDMDIEN,BDMEBSDV,BDMEDA,BDMEDMDT,BDMEDMPT,BDMEIN,BDMEMTYP,BDMEREC,BDMEREC1
+3 DO EN^BDMEDMUP(BDMSTR,.PCCRET)
+4 NEW BDMPCC,BDMI,BDMERR,BDMIEN
+5 KILL ^BDMTMP($JOB)
+6 SET BDMRET="^BDMTMP("_$JOB_")"
+7 SET BDMI=0
+8 SET BDMERR=""
+9 SET ^BDMTMP($JOB,BDMI)="T00080PCC"_$CHAR(30)
+10 IF '$DATA(PCCRET(1))
Begin DoDot:1
+11 SET BDMI=BDMI+1
+12 SET ^BDMTMP($JOB,BDMI)="PCC Data Filed Successfully"_$CHAR(30)
+13 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
End DoDot:1
QUIT
+14 SET BDMDA=0
FOR
SET BDMDA=$ORDER(PCCRET(BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+15 SET BDMI=BDMI+1
+16 SET ^BDMTMP($JOB,BDMI)=$GET(PCCRET(BDMDA))_$CHAR(30)
End DoDot:1
+17 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+18 QUIT
+19 ;
TAX(BDMRET,BDMSTR) ;-- save taxonomy
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BDMFL,BDMTAXN,BDMTAXF,BDMTAX,BDMI,BDMP,BDMERR,BDMTAXM,BDMTXG,BDMTXF,BDMTAXPF,BDMLOOK,BDMTX,BDMTXM
+3 IF BDMSTR=""
DO CATSTR^BDMGU(.BDMSTR,.BDMSTR)
+4 IF $GET(BDMSTR)=""
SET BDMRET="Error Concatenating String for Taxonomy"
QUIT
+5 KILL ^BDMTMP($JOB)
+6 SET BDMRET="^BDMTMP("_$JOB_")"
+7 SET BDMI=0
+8 SET BDMERR=""
+9 SET ^BDMTMP($JOB,BDMI)="T00080TAXONOMYSAVE"_$CHAR(30)
+10 SET P="|"
+11 SET BDMTAXN=$PIECE(BDMSTR,P)
+12 SET BDMTAXF=$PIECE(BDMSTR,P,2)
+13 SET BDMTXG="^ATXAX(""B"")"
+14 SET BDMTX="^ATXAX("
+15 SET BDMTXF=9002226
+16 SET BDMTXM=9002226.02101
+17 IF BDMTAXF="Lab"
Begin DoDot:1
+18 SET BDMTXG="^ATXLAB(""B"")"
+19 SET BDMTX="^ATXLAB("
+20 SET BDMTXF=9002228
+21 SET BDMTXM=9002228.02101
+22 SET BDMFL=60
End DoDot:1
+23 SET BDMTAX=$ORDER(@BDMTXG@(BDMTAXN,0))
+24 SET BDMLOOK=0
+25 IF 'BDMTAX
SET BDMRET="Taxonomy does not exist on System"
QUIT
+26 SET BDMLOOK=0
+27 IF '$$GET1^DIQ(BDMTXF,BDMTAX,.13)
SET BDMLOOK=1
+28 DO CLEANTAX(BDMTX,BDMTAX)
+29 FOR BDMP=3:1
SET BDMTAXM=$PIECE(BDMSTR,P,BDMP)
IF $GET(BDMTAXM)=""
QUIT
Begin DoDot:1
+30 NEW BDMIENS,BDMFDA
+31 SET BDMIENS="+2,"_BDMTAX_","
+32 IF BDMLOOK
Begin DoDot:2
+33 NEW BDMGLF
+34 IF '$GET(BDMFL)
SET BDMFL=$PIECE($GET(^ATXAX(BDMTAX,0)),U,15)
+35 SET BDMGLF=$GET(^DIC(BDMFL,0,"GL"))
+36 SET BDMGLF=BDMGLF_"""B"")"
+37 SET BDMTAXM=$ORDER(@BDMGLF@(BDMTAXM,0))
End DoDot:2
+38 IF 'BDMLOOK
Begin DoDot:2
+39 SET BDMTAXM=$PIECE(BDMTAXM,"-")
+40 SET BDMTAXM=BDMTAXM_" "
End DoDot:2
+41 IF $GET(BDMTAXM)=""
QUIT
+42 SET BDMFDA(BDMTXM,BDMIENS,.01)=BDMTAXM
+43 IF BDMTXM=9002226.02101
SET BDMFDA(BDMTXM,BDMIENS,.02)=BDMTAXM
+44 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
End DoDot:1
+45 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+46 QUIT
+47 ;
CLEANTAX(TAXF,TAX) ;-- remove existing entries from 21 multiple before adding
+1 NEW BDMDA,TAXI,BDMAA
+2 SET TAXI=TAXF_TAX_",21)"
+3 SET DIK=TAXF_TAX_",21,"
SET DA(1)=TAX
+4 SET BDMDA=0
FOR
SET BDMDA=$ORDER(@TAXI@(BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+5 SET DA=BDMDA
+6 DO ^DIK
End DoDot:1
+7 SET BDMAA=TAXF_TAX_",21)"
+8 KILL @BDMAA@("AA")
+9 KILL DIK,DA
+10 QUIT
+11 ;
AU(BDMRET,BDMSTR) ;-- file the Authorized User
+1 NEW P,R,BDMREGE,BDMREG,BDMAU,BDMMK,BDMU
+2 SET P="|"
SET R="~"
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET ^BDMTMP($JOB,0)="T00080RETURN"_$CHAR(30)
+6 IF $GET(BDMSTR)=""
DO CATSTR^BDMGU(.BDMSTR,.BDMSTR)
+7 SET BDMREGE=$PIECE(BDMSTR,P)
+8 SET BDMREG=$ORDER(^ACM(41.1,"B",BDMREGE,0))
+9 FOR I=2:1
Begin DoDot:1
+10 IF $PIECE(BDMSTR,P,I)=""
QUIT
+11 SET BDMAU=$PIECE($PIECE(BDMSTR,P,I),R)
+12 SET BDMMK=$PIECE($PIECE(BDMSTR,P,I),R,2)
+13 SET BDMU(BDMAU)=BDMMK
End DoDot:1
IF $PIECE(BDMSTR,P,I)=""
QUIT
+14 NEW BDMDA
+15 DO CLNAU(BDMREG,.BDMU)
+16 SET BDMDA=0
FOR
SET BDMDA=$ORDER(BDMU(BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+17 NEW BDMM
+18 SET BDMM=$GET(BDMU(BDMDA))
+19 DO CHKKEY(BDMDA,BDMM)
+20 IF $DATA(^ACM(41.1,BDMREG,"AU",BDMDA))
QUIT
+21 NEW BDMFDA,BDMIENS,BDMERR
+22 SET BDMIENS(1)=BDMREG
+23 SET BDMIENS(2)=BDMDA
+24 ;S BDMFDA(9002241,"?1,",.01)=BDMREGE
+25 SET BDMFDA(9002241.12,"+2,"_BDMIENS(1)_",",.01)=BDMDA
+26 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
+27 IF $GET(BDMERR)
QUIT
End DoDot:1
+28 SET ^BDMTMP($JOB,1)="DMS User Updated"_$CHAR(30)
+29 SET ^BDMTMP($JOB,2)=$CHAR(31)
+30 QUIT
+31 ;
CHKKEY(PT,MM) ;-- check to see if the user holds the key and is auth
+1 NEW BDMKEY
+2 SET BDMKEY=$ORDER(^DIC(19.1,"B","BDMZ REGISTER MAINTENANCE",0))
+3 IF $GET(MM)="Y"
Begin DoDot:1
+4 IF $DATA(^VA(200,PT,51,BDMKEY,0))
QUIT
+5 NEW BDMIENS,BDMFDA,BDMERR
+6 SET BDMIENS(1)=PT
+7 SET BDMIENS(2)=BDMKEY
+8 SET BDMFDA(200.051,"+2,"_BDMIENS(1)_",",.01)=BDMKEY
+9 SET BDMFDA(200.051,"+2,"_BDMIENS(1)_",",1)=DUZ
+10 DO UPDATE^DIE("","BDMFDA","BDMIENS","BDMERR(1)")
+11 IF $GET(BDMERR)
QUIT
End DoDot:1
QUIT
+12 IF '$DATA(^VA(200,PT,51,BDMKEY))
QUIT
+13 SET DA(1)=PT
SET DA=BDMKEY
SET DIK="^VA(200,"_DA(1)_",51,"
+14 DO ^DIK
+15 QUIT
+16 ;
CLNAU(REG,DMU) ;-- clean up authorized user first
+1 NEW BDMDA
+2 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^ACM(41.1,REG,"AU",BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+3 IF '$DATA(DMU(BDMDA))
Begin DoDot:2
+4 SET DA(1)=REG
SET DA=BDMDA
SET DIK="^ACM(41.1,"_DA(1)_",""AU"","
+5 DO ^DIK
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
