BDMGTB ; cmi/anch/maw - BDM DMS GUI Table Lookup ;
;;2.0;BDM DIABETES MANAGEMENT SYSTEM;**1,8,12**;JUN 14, 2007;Build 51
;
;
DEBUG(BDMRET,BDMSTR) ;-- debug entry point for Serenji
D DEBUG^%Serenji("ICD^BDMGT(.BDMRET,.BDMSTR)")
Q
;
DEBUGR(BDMRET) ;-- single entry point debugger
D DEBUG^%Serenji("ICD^BDMGT(.BDMRET)")
Q
;
CPT(BDMRET) ;-- get all cpts
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMCPT,BDMI,BDMERR,BDMIEN,BDMDA,BDMCPTD
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00050CPT"_$C(30)
S BDMDA=0 F S BDMDA=$O(^ICPT(BDMDA)) Q:BDMDA="" D
. Q:$P($G(^ICPT(BDMDA,0)),U,4) ;inactive
. S BDMCPT=$P($G(^ICPT(BDMDA,0)),U)
. S BDMCPTD=$P($G(^ICPT(BDMDA,0)),U,2)
. S BDMI=BDMI+1
. S ^BDMTMP($J,BDMI)=BDMCPT_"-"_BDMCPTD_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
ADA(BDMRET) ;-- get all ada
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMADA,BDMI,BDMERR,BDMIEN,BDMDA,BDMADAD
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00050ADA"_$C(30)
S BDMDA=0 F S BDMDA=$O(^AUTTADA(BDMDA)) Q:BDMDA="" D
. Q:$P($G(^AUTTADA(BDMDA,0)),U,8) ;inactive
. S BDMADA=$P($G(^AUTTADA(BDMDA,0)),U)
. S BDMADAD=$P($G(^AUTTADA(BDMDA,0)),U,2)
. S BDMI=BDMI+1
. S ^BDMTMP($J,BDMI)=BDMADA_"-"_BDMADAD_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
PRV(BDMRET) ;-- get all providers
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMPRV,BDMI,BDMERR,BDMIEN,BDMDA
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00007BMXIEN^T00050PRV"_$C(30)
S BDMDA=0 F S BDMDA=$O(^VA(200,"B",BDMDA)) Q:BDMDA="" D
. S BDMIEN=0 F S BDMIEN=$O(^VA(200,"B",BDMDA,BDMIEN)) Q:'BDMIEN D
.. Q:'$O(^VA(200,"AK.PROVIDER",BDMDA,0)) ;not a provider
.. S BDMPRV=$P($G(^VA(200,BDMIEN,0)),U)
.. S BDMI=BDMI+1
.. S ^BDMTMP($J,BDMI)=BDMIEN_U_BDMPRV_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
PRVC(BDMRET) ;-- get all provider classes
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMPRVC,BDMI,BDMERR,BDMDA
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00050PRVC"_$C(30)
S BDMDA=0 F S BDMDA=$O(^DIC(7,"B",BDMDA)) Q:BDMDA="" D
. ;S BDMPRVC=$P($G(^DIC(7,BDMDA,0)),U)
. S BDMI=BDMI+1
. S ^BDMTMP($J,BDMI)=BDMDA_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
LABL(BDMRET) ;-- get all lab loinc codes
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMLABL,BDMI,BDMERR,BDMIEN,BDMDA,BDMLABD
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00050LABL"_$C(30)
S BDMDA=0 F S BDMDA=$O(^LAB(95.3,"B",BDMDA)) Q:BDMDA="" D
. S BDMIEN=0 F S BDMIEN=$O(^LAB(95.3,"B",BDMDA,BDMIEN)) Q:'BDMIEN D
.. S BDMLABL=$P($G(^LAB(95.3,BDMDA,0)),U)
.. S BDMLABD=$G(^LAB(95.3,BDMIEN,80))
.. S BDMI=BDMI+1
.. S ^BDMTMP($J,BDMI)=BDMLABL_"-"_BDMLABD_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
DENO(BDMRET) ;-- get all dental op site codes
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMDENO,BDMI,BDMERR,BDMIEN,BDMDA
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00050DENO^T00007IEN"_$C(30)
S BDMDA=0 F S BDMDA=$O(^ADEOPS("B",BDMDA)) Q:BDMDA="" D
. S BDMIEN=0 F S BDMIEN=$O(^ADEOPS("B",BDMDA,BDMIEN)) Q:'BDMIEN D
.. S BDMDENO=$P($G(^ADEOPS(BDMIEN,0)),U)
.. S BDMI=BDMI+1
.. S ^BDMTMP($J,BDMI)=BDMDENO_U_BDMIEN_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
CLN(BDMRET) ;-- get all clinic stop codes
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMCLN,BDMI,BDMERR,BDMIEN,BDMDA
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00050CLN"_$C(30)
S BDMDA=0 F S BDMDA=$O(^DIC(40.7,"B",BDMDA)) Q:BDMDA="" D
. ;S BDMLABL=$P($G(^LAB(95.3,BDMDA,0)),U)
. S BDMI=BDMI+1
. S ^BDMTMP($J,BDMI)=BDMDA_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
ICDO(BDMRET) ;-- get all icd operation and procedure codes
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMICDO,BDMICDD,BDMI,BDMERR,BDMIEN,BDMDA
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00050ICDO^T00007IEN"_$C(30)
S BDMDA=0 F S BDMDA=$O(^ICD0(BDMDA)) Q:'BDMDA D
. S BDMICD0=$P($G(^ICD0(BDMDA,0)),U)
. S BDMICDD=$P($G(^ICD0(BDMDA,0)),U,4)
. S BDMI=BDMI+1
. S ^BDMTMP($J,BDMI)=BDMICD0_"-"_BDMICDD_U_BDMDA_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
COM(BDMRET) ;-- get all communities
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMCOM,BDMCOMS,BDMI,BDMERR,BDMIEN,BDMDA
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00050CLN^T00007IEN"_$C(30)
S BDMDA=0 F S BDMDA=$O(^AUTTCOM("B",BDMDA)) Q:BDMDA="" D
. S BDMIEN=0 F S BDMIEN=$O(^AUTTCOM("B",BDMDA,BDMIEN)) Q:'BDMIEN D
.. S BDMCOM=$P($G(^AUTTCOM(BDMIEN,0)),U)
.. S BDMCOMS=$S($P($G(^AUTTCOM(BDMIEN,0)),U,3):$P($G(^DIC(5,$P($G(^AUTTCOM(BDMIEN,0)),U,3),0)),U,2),1:"")
.. S BDMI=BDMI+1
.. S ^BDMTMP($J,BDMI)=BDMCOM_"-"_BDMCOMS_U_BDMIEN_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
FILES(BDMRET) ;-- get all RPMS Files
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMFLS,BDMI,BDMERR,BDMIEN,BDMDA
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00050FILENUMBER^T00050FILENAME"_$C(30)
S BDMDA=0 F S BDMDA=$O(^DIC(BDMDA)) Q:'BDMDA D
. S BDMFLS=$P($G(^DIC(BDMDA,0)),U)
. S BDMI=BDMI+1
. S ^BDMTMP($J,BDMI)=BDMDA_U_BDMFLS_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
GETTABLE(BDMRET,BDMSTR) ;-- get a table based upon file number and flds passed in
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMFLS,BDMI,BDMERR,BDMIEN,BDMDA,P,R
S P="|",R="~"
S BDMFN=$P(BDMSTR,P)
S BDFLDN=$P(BDMSTR,P,2)
S BDMXRF=$P(BDMSTR,P,3)
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00050FILENUMBER^T00050FILENAME"_$C(30)
S BDMDA=0 F S BDMDA=$O(^DIC(BDMDA)) Q:'BDMDA D
. S BDMFLS=$P($G(^DIC(BDMDA,0)),U)
. S BDMI=BDMI+1
. S ^BDMTMP($J,BDMI)=BDMDA_U_BDMFLS_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
STMP(BDMRET) ;-- return the search template screen
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMFLS,BDMI,BDMERR,BDMIEN,BDMDA,P,R
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00050SEARCHTEMPLATE"_$C(30)
N BDMDA
S BDMDA=0 F S BDMDA=$O(^DIBT("B",BDMDA)) Q:BDMDA="" D
. N BDMIEN
. S BDMIEN=0 F S BDMIEN=$O(^DIBT("B",BDMDA,BDMIEN)) Q:'BDMIEN D
.. Q:'$D(^DIBT(BDMIEN,1))
.. S BDMI=BDMI+1
.. S ^BDMTMP($J,BDMI)=BDMDA_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
REGADO(BDMRET) ;-- return register to work with
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMDA,BDMC,BDMREG
S BDMC=0
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S ^BDMTMP($J,BDMC)="T00030REGISTERNAME"_$C(30)
S BDMDA=0 F S BDMDA=$O(^ACM(41.1,"B",BDMDA)) Q:BDMDA="" D
. Q:BDMDA'["DIAB"
. S BDMRIEN=$O(^ACM(41.1,"B",BDMDA,0))
. ;Q:'$D(^ACM(41.1,BDMRIEN,"AU","B",DUZ))
. S BDMC=BDMC+1
. S ^BDMTMP($J,BDMC)=BDMDA_$C(30)
S ^BDMTMP($J,BDMC+1)=$C(31)_$G(BDMERR)
Q
;
REGADOAU(BDMRET) ;-- return register to work with
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMDA,BDMC,BDMREG
S BDMC=0
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S ^BDMTMP($J,BDMC)="T00007BMXIEN^T00030REGISTER NAME"_$C(30)
S BDMDA=0 F S BDMDA=$O(^ACM(41.1,"B",BDMDA)) Q:BDMDA="" D
. Q:BDMDA'["DIAB"
. S BDMRIEN=$O(^ACM(41.1,"B",BDMDA,0))
. Q:'$D(^ACM(41.1,BDMRIEN,"AU","B",DUZ))
. S BDMC=BDMC+1
. S ^BDMTMP($J,BDMC)=BDMRIEN_U_BDMDA_$C(30)
S ^BDMTMP($J,BDMC+1)=$C(31)_$G(BDMERR)
Q
;
AU(BDMRET,BDMSTR) ;-- returns a list of Authorized Users
N P,BDMDA,BDMREGE,BDMREG,BDMMKEY,BDMMGR,BDMI
S P="|"
S BDMI=0
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S ^BDMTMP($J,BDMI)="T00010BMXIEN^T00050User^T00001Manager Authority"_$C(30)
S BDMREGE=$P(BDMSTR,P)
S BDMREG=$O(^ACM(41.1,"B",BDMREGE,0))
S BDMMKEY=$O(^DIC(19.1,"B","BDMZ REGISTER MAINTENANCE",0))
S BDMDA=0 F S BDMDA=$O(^ACM(41.1,BDMREG,"AU",BDMDA)) Q:'BDMDA D
. S BDMMGR=0
. S BDMI=BDMI+1
. I $D(^VA(200,BDMDA,51,"B",BDMMKEY)) S BDMMGR=1
. S ^BDMTMP($J,BDMI)=BDMDA_U_$P($G(^VA(200,BDMDA,0)),U)_U_$S(BDMMGR:"Y",1:"N")_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
STMPS(BDMRET) ;-- return search template with screen
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMFLS,BDMI,BDMERR,BDMIEN,BDMDA,P,R
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00050Search Template"_$C(30)
N BDMDA
S BDMDA=0 F S BDMDA=$O(^DIBT("B",BDMDA)) Q:BDMDA="" D
. N BDMIEN
. S BDMIEN=0 F S BDMIEN=$O(^DIBT("B",BDMDA,BDMIEN)) Q:'BDMIEN D
.. N BDMOK
.. S BDMOK=0
.. I $P($G(^DIBT(BDMIEN,0)),U,4)=2 S BDMOK=1
.. I $P($G(^DIBT(BDMIEN,0)),U,4)=9000001 S BDMOK=1
.. Q:'BDMOK
.. Q:'$D(^DIBT(BDMIEN,1))
.. S BDMI=BDMI+1
.. S ^BDMTMP($J,BDMI)=BDMDA_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
CMPI(BDMRET,BDMSTR) ;-- return complications with IEN
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N BDMCMP,BDMI,BDMERR,BDMREGE,BDMREG,BDMIEN,BDMCMPE
S BDMREGE=$P(BDMSTR,"|")
S BDMREG=$O(^ACM(41.1,"B",BDMREGE,0))
K ^BDMTMP($J)
S BDMRET="^BDMTMP("_$J_")"
S BDMI=0
S BDMERR=""
S ^BDMTMP($J,BDMI)="T00010BMXIEN^T00060COMPLICATION"_$C(30)
S BDMCMP=0 F S BDMCMP=$O(^ACM(42.1,"RG",BDMREG,BDMCMP)) Q:BDMCMP="" D
. ;S BDMIEN=$O(^ACM(42.1,"RG",BDMREG,BDMCMP,0))
. S BDMCMPE=$P($G(^ACM(42.1,BDMCMP,0)),U)
. S BDMI=BDMI+1
. S ^BDMTMP($J,BDMI)=BDMCMP_U_BDMCMPE_$C(30)
S ^BDMTMP($J,BDMI+1)=$C(31)_$G(BDMERR)
Q
;
DX(RETVAL,BDMSTR) ;-- get DX based on Search string
S X="MERR^BDMGU",@^%ZOSF("TRAP") ; m error trap
N P,BDMI,BDMS,BDMTGT,BDMIDX
K ^BDMTMP($J)
S RETVAL="^BDMTMP("_$J_")"
S BDMI=0
S @RETVAL@(BDMI)="T00010BMXIEN^T00010DX^T00250Description"_$C(30)
S P="|"
K ^BDMTMPD($J)
S BDMTGT="^BDMTMPD("_$J_")" ;target for find^dic lookup
S BDMIDX=$P(BDMSTR,P,2)
I BDMIDX]"" S BDMIDX=$TR(BDMIDX,"*","^")
S BDMS=$P(BDMSTR,P)
I BDMS="" D
. D LIST^DIC(80,"",.01,"","","",BDMS,BDMIDX,"","",BDMTGT,"BDMERRR(1)")
I BDMS]"" D
. S X=BDMS X ^%ZOSF("UPPERCASE") S BDMS=Y ;cmi/maw 03/05/2014 p4 change all to uppercase
. D FIND^DIC(80,"",.01,"",BDMS,"",BDMIDX,"","",BDMTGT,"BDMERRR(1)")
S BDMDA=0 F S BDMDA=$O(@BDMTGT@("DILIST","ID",BDMDA)) Q:'BDMDA D
. N BDMIEN,BDMBMX,BDMDESC,BDMDX
. S BDMIEN=0 F S BDMIEN=$O(@BDMTGT@("DILIST","ID",BDMDA,BDMIEN)) Q:'BDMIEN D
.. S BDMBMX=$G(@BDMTGT@("DILIST",2,BDMDA))
.. S BDMDX=$G(@BDMTGT@("DILIST","ID",BDMDA,BDMIEN))
.. I $D(^ICDS(0)) S BDMDX=$$ICDDX^ICDEX(BDMDX,DT)
.. I '$D(^ICDS(0)) S BDMDX=$$ICDDX^ICDCODE(BDMDX,DT)
.. S BDMDESC=""
.. Q:'$G(BDMBMX)
.. S BDMI=BDMI+1
.. S @RETVAL@(BDMI)=BDMBMX_U_$P(BDMDX,U,2)_U_$P(BDMDX,U,4)_$C(30)
S @RETVAL@(BDMI+1)=$C(31)
Q
Q
;
BDMGTB ; cmi/anch/maw - BDM DMS GUI Table Lookup ;
+1 ;;2.0;BDM DIABETES MANAGEMENT SYSTEM;**1,8,12**;JUN 14, 2007;Build 51
+2 ;
+3 ;
DEBUG(BDMRET,BDMSTR) ;-- debug entry point for Serenji
+1 DO DEBUG^%Serenji("ICD^BDMGT(.BDMRET,.BDMSTR)")
+2 QUIT
+3 ;
DEBUGR(BDMRET) ;-- single entry point debugger
+1 DO DEBUG^%Serenji("ICD^BDMGT(.BDMRET)")
+2 QUIT
+3 ;
CPT(BDMRET) ;-- get all cpts
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMCPT,BDMI,BDMERR,BDMIEN,BDMDA,BDMCPTD
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET BDMI=0
+6 SET BDMERR=""
+7 SET ^BDMTMP($JOB,BDMI)="T00050CPT"_$CHAR(30)
+8 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^ICPT(BDMDA))
IF BDMDA=""
QUIT
Begin DoDot:1
+9 ;inactive
IF $PIECE($GET(^ICPT(BDMDA,0)),U,4)
QUIT
+10 SET BDMCPT=$PIECE($GET(^ICPT(BDMDA,0)),U)
+11 SET BDMCPTD=$PIECE($GET(^ICPT(BDMDA,0)),U,2)
+12 SET BDMI=BDMI+1
+13 SET ^BDMTMP($JOB,BDMI)=BDMCPT_"-"_BDMCPTD_$CHAR(30)
End DoDot:1
+14 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+15 QUIT
+16 ;
ADA(BDMRET) ;-- get all ada
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMADA,BDMI,BDMERR,BDMIEN,BDMDA,BDMADAD
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET BDMI=0
+6 SET BDMERR=""
+7 SET ^BDMTMP($JOB,BDMI)="T00050ADA"_$CHAR(30)
+8 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^AUTTADA(BDMDA))
IF BDMDA=""
QUIT
Begin DoDot:1
+9 ;inactive
IF $PIECE($GET(^AUTTADA(BDMDA,0)),U,8)
QUIT
+10 SET BDMADA=$PIECE($GET(^AUTTADA(BDMDA,0)),U)
+11 SET BDMADAD=$PIECE($GET(^AUTTADA(BDMDA,0)),U,2)
+12 SET BDMI=BDMI+1
+13 SET ^BDMTMP($JOB,BDMI)=BDMADA_"-"_BDMADAD_$CHAR(30)
End DoDot:1
+14 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+15 QUIT
+16 ;
PRV(BDMRET) ;-- get all providers
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMPRV,BDMI,BDMERR,BDMIEN,BDMDA
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET BDMI=0
+6 SET BDMERR=""
+7 SET ^BDMTMP($JOB,BDMI)="T00007BMXIEN^T00050PRV"_$CHAR(30)
+8 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^VA(200,"B",BDMDA))
IF BDMDA=""
QUIT
Begin DoDot:1
+9 SET BDMIEN=0
FOR
SET BDMIEN=$ORDER(^VA(200,"B",BDMDA,BDMIEN))
IF 'BDMIEN
QUIT
Begin DoDot:2
+10 ;not a provider
IF '$ORDER(^VA(200,"AK.PROVIDER",BDMDA,0))
QUIT
+11 SET BDMPRV=$PIECE($GET(^VA(200,BDMIEN,0)),U)
+12 SET BDMI=BDMI+1
+13 SET ^BDMTMP($JOB,BDMI)=BDMIEN_U_BDMPRV_$CHAR(30)
End DoDot:2
End DoDot:1
+14 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+15 QUIT
+16 ;
PRVC(BDMRET) ;-- get all provider classes
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMPRVC,BDMI,BDMERR,BDMDA
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET BDMI=0
+6 SET BDMERR=""
+7 SET ^BDMTMP($JOB,BDMI)="T00050PRVC"_$CHAR(30)
+8 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^DIC(7,"B",BDMDA))
IF BDMDA=""
QUIT
Begin DoDot:1
+9 ;S BDMPRVC=$P($G(^DIC(7,BDMDA,0)),U)
+10 SET BDMI=BDMI+1
+11 SET ^BDMTMP($JOB,BDMI)=BDMDA_$CHAR(30)
End DoDot:1
+12 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+13 QUIT
+14 ;
LABL(BDMRET) ;-- get all lab loinc codes
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMLABL,BDMI,BDMERR,BDMIEN,BDMDA,BDMLABD
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET BDMI=0
+6 SET BDMERR=""
+7 SET ^BDMTMP($JOB,BDMI)="T00050LABL"_$CHAR(30)
+8 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^LAB(95.3,"B",BDMDA))
IF BDMDA=""
QUIT
Begin DoDot:1
+9 SET BDMIEN=0
FOR
SET BDMIEN=$ORDER(^LAB(95.3,"B",BDMDA,BDMIEN))
IF 'BDMIEN
QUIT
Begin DoDot:2
+10 SET BDMLABL=$PIECE($GET(^LAB(95.3,BDMDA,0)),U)
+11 SET BDMLABD=$GET(^LAB(95.3,BDMIEN,80))
+12 SET BDMI=BDMI+1
+13 SET ^BDMTMP($JOB,BDMI)=BDMLABL_"-"_BDMLABD_$CHAR(30)
End DoDot:2
End DoDot:1
+14 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+15 QUIT
+16 ;
DENO(BDMRET) ;-- get all dental op site codes
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMDENO,BDMI,BDMERR,BDMIEN,BDMDA
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET BDMI=0
+6 SET BDMERR=""
+7 SET ^BDMTMP($JOB,BDMI)="T00050DENO^T00007IEN"_$CHAR(30)
+8 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^ADEOPS("B",BDMDA))
IF BDMDA=""
QUIT
Begin DoDot:1
+9 SET BDMIEN=0
FOR
SET BDMIEN=$ORDER(^ADEOPS("B",BDMDA,BDMIEN))
IF 'BDMIEN
QUIT
Begin DoDot:2
+10 SET BDMDENO=$PIECE($GET(^ADEOPS(BDMIEN,0)),U)
+11 SET BDMI=BDMI+1
+12 SET ^BDMTMP($JOB,BDMI)=BDMDENO_U_BDMIEN_$CHAR(30)
End DoDot:2
End DoDot:1
+13 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+14 QUIT
+15 ;
CLN(BDMRET) ;-- get all clinic stop codes
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMCLN,BDMI,BDMERR,BDMIEN,BDMDA
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET BDMI=0
+6 SET BDMERR=""
+7 SET ^BDMTMP($JOB,BDMI)="T00050CLN"_$CHAR(30)
+8 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^DIC(40.7,"B",BDMDA))
IF BDMDA=""
QUIT
Begin DoDot:1
+9 ;S BDMLABL=$P($G(^LAB(95.3,BDMDA,0)),U)
+10 SET BDMI=BDMI+1
+11 SET ^BDMTMP($JOB,BDMI)=BDMDA_$CHAR(30)
End DoDot:1
+12 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+13 QUIT
+14 ;
ICDO(BDMRET) ;-- get all icd operation and procedure codes
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMICDO,BDMICDD,BDMI,BDMERR,BDMIEN,BDMDA
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET BDMI=0
+6 SET BDMERR=""
+7 SET ^BDMTMP($JOB,BDMI)="T00050ICDO^T00007IEN"_$CHAR(30)
+8 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^ICD0(BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+9 SET BDMICD0=$PIECE($GET(^ICD0(BDMDA,0)),U)
+10 SET BDMICDD=$PIECE($GET(^ICD0(BDMDA,0)),U,4)
+11 SET BDMI=BDMI+1
+12 SET ^BDMTMP($JOB,BDMI)=BDMICD0_"-"_BDMICDD_U_BDMDA_$CHAR(30)
End DoDot:1
+13 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+14 QUIT
+15 ;
COM(BDMRET) ;-- get all communities
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMCOM,BDMCOMS,BDMI,BDMERR,BDMIEN,BDMDA
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET BDMI=0
+6 SET BDMERR=""
+7 SET ^BDMTMP($JOB,BDMI)="T00050CLN^T00007IEN"_$CHAR(30)
+8 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^AUTTCOM("B",BDMDA))
IF BDMDA=""
QUIT
Begin DoDot:1
+9 SET BDMIEN=0
FOR
SET BDMIEN=$ORDER(^AUTTCOM("B",BDMDA,BDMIEN))
IF 'BDMIEN
QUIT
Begin DoDot:2
+10 SET BDMCOM=$PIECE($GET(^AUTTCOM(BDMIEN,0)),U)
+11 SET BDMCOMS=$SELECT($PIECE($GET(^AUTTCOM(BDMIEN,0)),U,3):$PIECE($GET(^DIC(5,$PIECE($GET(^AUTTCOM(BDMIEN,0)),U,3),0)),U,2),1:"")
+12 SET BDMI=BDMI+1
+13 SET ^BDMTMP($JOB,BDMI)=BDMCOM_"-"_BDMCOMS_U_BDMIEN_$CHAR(30)
End DoDot:2
End DoDot:1
+14 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+15 QUIT
+16 ;
FILES(BDMRET) ;-- get all RPMS Files
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMFLS,BDMI,BDMERR,BDMIEN,BDMDA
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET BDMI=0
+6 SET BDMERR=""
+7 SET ^BDMTMP($JOB,BDMI)="T00050FILENUMBER^T00050FILENAME"_$CHAR(30)
+8 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^DIC(BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+9 SET BDMFLS=$PIECE($GET(^DIC(BDMDA,0)),U)
+10 SET BDMI=BDMI+1
+11 SET ^BDMTMP($JOB,BDMI)=BDMDA_U_BDMFLS_$CHAR(30)
End DoDot:1
+12 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+13 QUIT
+14 ;
GETTABLE(BDMRET,BDMSTR) ;-- get a table based upon file number and flds passed in
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMFLS,BDMI,BDMERR,BDMIEN,BDMDA,P,R
+3 SET P="|"
SET R="~"
+4 SET BDMFN=$PIECE(BDMSTR,P)
+5 SET BDFLDN=$PIECE(BDMSTR,P,2)
+6 SET BDMXRF=$PIECE(BDMSTR,P,3)
+7 KILL ^BDMTMP($JOB)
+8 SET BDMRET="^BDMTMP("_$JOB_")"
+9 SET BDMI=0
+10 SET BDMERR=""
+11 SET ^BDMTMP($JOB,BDMI)="T00050FILENUMBER^T00050FILENAME"_$CHAR(30)
+12 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^DIC(BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+13 SET BDMFLS=$PIECE($GET(^DIC(BDMDA,0)),U)
+14 SET BDMI=BDMI+1
+15 SET ^BDMTMP($JOB,BDMI)=BDMDA_U_BDMFLS_$CHAR(30)
End DoDot:1
+16 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+17 QUIT
+18 ;
STMP(BDMRET) ;-- return the search template screen
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMFLS,BDMI,BDMERR,BDMIEN,BDMDA,P,R
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET BDMI=0
+6 SET BDMERR=""
+7 SET ^BDMTMP($JOB,BDMI)="T00050SEARCHTEMPLATE"_$CHAR(30)
+8 NEW BDMDA
+9 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^DIBT("B",BDMDA))
IF BDMDA=""
QUIT
Begin DoDot:1
+10 NEW BDMIEN
+11 SET BDMIEN=0
FOR
SET BDMIEN=$ORDER(^DIBT("B",BDMDA,BDMIEN))
IF 'BDMIEN
QUIT
Begin DoDot:2
+12 IF '$DATA(^DIBT(BDMIEN,1))
QUIT
+13 SET BDMI=BDMI+1
+14 SET ^BDMTMP($JOB,BDMI)=BDMDA_$CHAR(30)
End DoDot:2
End DoDot:1
+15 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+16 QUIT
+17 ;
REGADO(BDMRET) ;-- return register to work with
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMDA,BDMC,BDMREG
+3 SET BDMC=0
+4 KILL ^BDMTMP($JOB)
+5 SET BDMRET="^BDMTMP("_$JOB_")"
+6 SET ^BDMTMP($JOB,BDMC)="T00030REGISTERNAME"_$CHAR(30)
+7 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^ACM(41.1,"B",BDMDA))
IF BDMDA=""
QUIT
Begin DoDot:1
+8 IF BDMDA'["DIAB"
QUIT
+9 SET BDMRIEN=$ORDER(^ACM(41.1,"B",BDMDA,0))
+10 ;Q:'$D(^ACM(41.1,BDMRIEN,"AU","B",DUZ))
+11 SET BDMC=BDMC+1
+12 SET ^BDMTMP($JOB,BDMC)=BDMDA_$CHAR(30)
End DoDot:1
+13 SET ^BDMTMP($JOB,BDMC+1)=$CHAR(31)_$GET(BDMERR)
+14 QUIT
+15 ;
REGADOAU(BDMRET) ;-- return register to work with
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMDA,BDMC,BDMREG
+3 SET BDMC=0
+4 KILL ^BDMTMP($JOB)
+5 SET BDMRET="^BDMTMP("_$JOB_")"
+6 SET ^BDMTMP($JOB,BDMC)="T00007BMXIEN^T00030REGISTER NAME"_$CHAR(30)
+7 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^ACM(41.1,"B",BDMDA))
IF BDMDA=""
QUIT
Begin DoDot:1
+8 IF BDMDA'["DIAB"
QUIT
+9 SET BDMRIEN=$ORDER(^ACM(41.1,"B",BDMDA,0))
+10 IF '$DATA(^ACM(41.1,BDMRIEN,"AU","B",DUZ))
QUIT
+11 SET BDMC=BDMC+1
+12 SET ^BDMTMP($JOB,BDMC)=BDMRIEN_U_BDMDA_$CHAR(30)
End DoDot:1
+13 SET ^BDMTMP($JOB,BDMC+1)=$CHAR(31)_$GET(BDMERR)
+14 QUIT
+15 ;
AU(BDMRET,BDMSTR) ;-- returns a list of Authorized Users
+1 NEW P,BDMDA,BDMREGE,BDMREG,BDMMKEY,BDMMGR,BDMI
+2 SET P="|"
+3 SET BDMI=0
+4 KILL ^BDMTMP($JOB)
+5 SET BDMRET="^BDMTMP("_$JOB_")"
+6 SET ^BDMTMP($JOB,BDMI)="T00010BMXIEN^T00050User^T00001Manager Authority"_$CHAR(30)
+7 SET BDMREGE=$PIECE(BDMSTR,P)
+8 SET BDMREG=$ORDER(^ACM(41.1,"B",BDMREGE,0))
+9 SET BDMMKEY=$ORDER(^DIC(19.1,"B","BDMZ REGISTER MAINTENANCE",0))
+10 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^ACM(41.1,BDMREG,"AU",BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+11 SET BDMMGR=0
+12 SET BDMI=BDMI+1
+13 IF $DATA(^VA(200,BDMDA,51,"B",BDMMKEY))
SET BDMMGR=1
+14 SET ^BDMTMP($JOB,BDMI)=BDMDA_U_$PIECE($GET(^VA(200,BDMDA,0)),U)_U_$SELECT(BDMMGR:"Y",1:"N")_$CHAR(30)
End DoDot:1
+15 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+16 QUIT
+17 ;
STMPS(BDMRET) ;-- return search template with screen
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMFLS,BDMI,BDMERR,BDMIEN,BDMDA,P,R
+3 KILL ^BDMTMP($JOB)
+4 SET BDMRET="^BDMTMP("_$JOB_")"
+5 SET BDMI=0
+6 SET BDMERR=""
+7 SET ^BDMTMP($JOB,BDMI)="T00050Search Template"_$CHAR(30)
+8 NEW BDMDA
+9 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^DIBT("B",BDMDA))
IF BDMDA=""
QUIT
Begin DoDot:1
+10 NEW BDMIEN
+11 SET BDMIEN=0
FOR
SET BDMIEN=$ORDER(^DIBT("B",BDMDA,BDMIEN))
IF 'BDMIEN
QUIT
Begin DoDot:2
+12 NEW BDMOK
+13 SET BDMOK=0
+14 IF $PIECE($GET(^DIBT(BDMIEN,0)),U,4)=2
SET BDMOK=1
+15 IF $PIECE($GET(^DIBT(BDMIEN,0)),U,4)=9000001
SET BDMOK=1
+16 IF 'BDMOK
QUIT
+17 IF '$DATA(^DIBT(BDMIEN,1))
QUIT
+18 SET BDMI=BDMI+1
+19 SET ^BDMTMP($JOB,BDMI)=BDMDA_$CHAR(30)
End DoDot:2
End DoDot:1
+20 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+21 QUIT
+22 ;
CMPI(BDMRET,BDMSTR) ;-- return complications with IEN
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW BDMCMP,BDMI,BDMERR,BDMREGE,BDMREG,BDMIEN,BDMCMPE
+3 SET BDMREGE=$PIECE(BDMSTR,"|")
+4 SET BDMREG=$ORDER(^ACM(41.1,"B",BDMREGE,0))
+5 KILL ^BDMTMP($JOB)
+6 SET BDMRET="^BDMTMP("_$JOB_")"
+7 SET BDMI=0
+8 SET BDMERR=""
+9 SET ^BDMTMP($JOB,BDMI)="T00010BMXIEN^T00060COMPLICATION"_$CHAR(30)
+10 SET BDMCMP=0
FOR
SET BDMCMP=$ORDER(^ACM(42.1,"RG",BDMREG,BDMCMP))
IF BDMCMP=""
QUIT
Begin DoDot:1
+11 ;S BDMIEN=$O(^ACM(42.1,"RG",BDMREG,BDMCMP,0))
+12 SET BDMCMPE=$PIECE($GET(^ACM(42.1,BDMCMP,0)),U)
+13 SET BDMI=BDMI+1
+14 SET ^BDMTMP($JOB,BDMI)=BDMCMP_U_BDMCMPE_$CHAR(30)
End DoDot:1
+15 SET ^BDMTMP($JOB,BDMI+1)=$CHAR(31)_$GET(BDMERR)
+16 QUIT
+17 ;
DX(RETVAL,BDMSTR) ;-- get DX based on Search string
+1 ; m error trap
SET X="MERR^BDMGU"
SET @^%ZOSF("TRAP")
+2 NEW P,BDMI,BDMS,BDMTGT,BDMIDX
+3 KILL ^BDMTMP($JOB)
+4 SET RETVAL="^BDMTMP("_$JOB_")"
+5 SET BDMI=0
+6 SET @RETVAL@(BDMI)="T00010BMXIEN^T00010DX^T00250Description"_$CHAR(30)
+7 SET P="|"
+8 KILL ^BDMTMPD($JOB)
+9 ;target for find^dic lookup
SET BDMTGT="^BDMTMPD("_$JOB_")"
+10 SET BDMIDX=$PIECE(BDMSTR,P,2)
+11 IF BDMIDX]""
SET BDMIDX=$TRANSLATE(BDMIDX,"*","^")
+12 SET BDMS=$PIECE(BDMSTR,P)
+13 IF BDMS=""
Begin DoDot:1
+14 DO LIST^DIC(80,"",.01,"","","",BDMS,BDMIDX,"","",BDMTGT,"BDMERRR(1)")
End DoDot:1
+15 IF BDMS]""
Begin DoDot:1
+16 ;cmi/maw 03/05/2014 p4 change all to uppercase
SET X=BDMS
XECUTE ^%ZOSF("UPPERCASE")
SET BDMS=Y
+17 DO FIND^DIC(80,"",.01,"",BDMS,"",BDMIDX,"","",BDMTGT,"BDMERRR(1)")
End DoDot:1
+18 SET BDMDA=0
FOR
SET BDMDA=$ORDER(@BDMTGT@("DILIST","ID",BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+19 NEW BDMIEN,BDMBMX,BDMDESC,BDMDX
+20 SET BDMIEN=0
FOR
SET BDMIEN=$ORDER(@BDMTGT@("DILIST","ID",BDMDA,BDMIEN))
IF 'BDMIEN
QUIT
Begin DoDot:2
+21 SET BDMBMX=$GET(@BDMTGT@("DILIST",2,BDMDA))
+22 SET BDMDX=$GET(@BDMTGT@("DILIST","ID",BDMDA,BDMIEN))
+23 IF $DATA(^ICDS(0))
SET BDMDX=$$ICDDX^ICDEX(BDMDX,DT)
+24 IF '$DATA(^ICDS(0))
SET BDMDX=$$ICDDX^ICDCODE(BDMDX,DT)
+25 SET BDMDESC=""
+26 IF '$GET(BDMBMX)
QUIT
+27 SET BDMI=BDMI+1
+28 SET @RETVAL@(BDMI)=BDMBMX_U_$PIECE(BDMDX,U,2)_U_$PIECE(BDMDX,U,4)_$CHAR(30)
End DoDot:2
End DoDot:1
+29 SET @RETVAL@(BDMI+1)=$CHAR(31)
+30 QUIT
+31 QUIT
+32 ;
