BDMUTL ; IHS/CMI/LAB - Area Database Utility Routine ; 14 Sep 2015 12:41 PM
;;2.0;DIABETES MANAGEMENT SYSTEM;**5,8,9,10,11,12**;JUN 14, 2007;Build 51
;
SNOMED(YR,LIST,SMC) ;EP - is snomed code smc on the list for the year
I 'YR S YR=2019
I LIST="" Q ""
I SMC="" Q ""
NEW YRI,LISTI
S YRI=$O(^BDMSNME("B",YR,0)) I 'YRI Q ""
S LISTI=$O(^BDMSNME(YRI,11,"B",LIST,0)) I 'LISTI Q ""
I $D(^BDMSNME(YRI,11,LISTI,11,"B",SMC)) Q 1
Q ""
GETIMMS(P,EDATE,C,BDMX) ;EP
K BDMX
NEW X,Y,I,Z,V
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVIMM(X,0)) ;happens
.S Y=$P(^AUPNVIMM(X,0),U)
.Q:'Y ;happens too
.S I=$P($G(^AUTTIMM(Y,0)),U,3) ;get HL7/CVX code
.F Z=1:1:$L(C,U) I I=$P(C,U,Z) S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".") I D]"",D'>EDATE S BDMX(D)=Y
.Q
Q
IMMREF(P,IMM,BD,ED) ;EP
NEW X,Y,G,D,R
I 'IMM Q ""
S (X,G)=0,Y=$O(^AUTTIMM("C",IMM,0))
I 'Y Q ""
F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=G+1
Q G
ANCONT(P,C,ED) ;EP - ANALPHYLAXIS CONTRAINDICATION
NEW X
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.;Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G="2 No - Contraindication Anaphylaxis"
Q G
DEMO(P,T) ;EP - called to exclude demo patients
I $G(P)="" Q 0
I $G(T)="" S T="I"
I T="I" Q 0
NEW R
S R=""
I T="E" D Q R
.I $P($G(^DPT(P,0)),U)["DEMO,PATIENT" S R=1 Q
.NEW %
.S %=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
.I '% S R=0 Q
.I $D(^DIBT(%,1,P)) S R=1 Q
I T="O" D Q R
.I $P($G(^DPT(P,0)),U)["DEMO,PATIENT" S R=0 Q
.NEW %
.S %=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
.I '% S R=1 Q
.I $D(^DIBT(%,1,P)) S R=0 Q
.S R=1 Q
Q 0
;
RZERO(V,L) ;ep right zero fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=V_"0"
Q V
LZERO(V,L) ;EP - left zero fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
Q V
LBLK(V,L) ;EP -left blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
Q V
RBLK(V,L) ;EP right blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=V_" "
Q V
;
DEMOCHK(R) ;EP - check demo pat
NEW DIR,DA
S R=-1
S DIR(0)="S^I:Include ALL Patients;E:Exclude DEMO Patients;O:Include ONLY DEMO Patients",DIR("A")="Demo Patient Inclusion/Exclusion",DIR("B")="E"
KILL DA D ^DIR KILL DIR
I $D(DIRUT) S R=-1 Q
S R=Y
Q
;
ICD(VAL,TAXNM,TYP) ;EP -- check to see if value is in taxonomy in ^TMP("BDMTMP",$J,Taxonomy Name
;add 3rd param with pass type
I $G(VAL)="" Q 0
I $G(TAXNM)="" Q 0
I $G(TYP)="" Q 0
I $G(BDMJOB)=""!($G(BDMBTH)="") Q $$ICD^ATXCHK(VAL,$O(^ATXAX("B",TAXNM,0)),TYP)
I '$D(^XTMP("BDMTAX",BDMJOB,BDMBTH,TAXNM)) Q $$ICD^ATXCHK(VAL,$O(^ATXAX("B",TAXNM,0)),TYP)
I $D(^XTMP("BDMTAX",BDMJOB,BDMBTH,TAXNM,VAL)) Q 1
Q 0
;
UNFOLDTX(YEAR) ;EP -- unfold all taxes for dm audit into ^TMP("BDMTMP",$J,Taxonomy Name
;lets go through all the taxonomies needed here and put them in above location
;need to check DMS Taxonomies Used option to determine
K ^XTMP("BDMTAX",BDMJOB,BDMBTH)
I '$D(^ICDS(0)) Q ;only in icd10 environment
N BDMYR,BDMDA,BDMTAX,BDMFL,BDMTAXI,BDMVAL,BDMTYP,BDMTGT
S BDMYR=$O(^BDMTAXS("B",YEAR,0))
Q:'BDMYR
S BDMDA=0 F S BDMDA=$O(^BDMTAXS(BDMYR,11,BDMDA)) Q:'BDMDA D
. S BDMTAX=$P($G(^BDMTAXS(BDMYR,11,BDMDA,0)),U)
. S BDMFL=$P($G(^BDMTAXS(BDMYR,11,BDMDA,0)),U,2)
. S BDMTYP=$S(BDMFL=60:"L",1:"")
. S BDMTAXI=$O(^ATXAX("B",BDMTAX,0))
. I BDMTYP="L" D
.. S BDMTAXI=$O(^ATXLAB("B",BDMTAX,0))
. S BDMTGT="^XTMP("_"""BDMTAX"""_","_BDMJOB_","_""""_BDMBTH_""""_","_""""_BDMTAX_""""_")"
. ;D BLDTAX^ATXAPI(BDMTAX,BDMTGT,BDMTAXI,BDMTYP)
. D BLDTAX^BDMTAPI(BDMTAX,BDMTGT,BDMTAXI,BDMTYP)
Q
BUILDSML(Y) ;EP - BUILD SNOMED LISTS FROM SUBSETS
NEW BDMDA,N,OUT,X,BDMY,C,S
I $T(SUBLST^BSTSAPI)="" Q ;NO SNOMED STUFF INSTALLED
S BDMY=$O(^BDMSNME("B",Y,0))
S BDMDA=0 F S BDMDA=$O(^BDMSNME(BDMY,11,BDMDA)) Q:BDMDA'=+BDMDA D
.Q:'$P(^BDMSNME(BDMY,11,BDMDA,0),U,2)
.S N=$P(^BDMSNME(BDMY,11,BDMDA,0),U,1) ;subset name
.K ^TMP($J,"SUB")
.S OUT=$NA(^TMP($J,"SUB"))
.S X=$$SUBLST^BSTSAPI(OUT,N) ;
.I '$O(^TMP($J,"SUB",0)) Q ;NO CODES??
.;BUILD INDEX
.S S=0
.K ^BDMSNME(BDMY,11,BDMDA,11)
.S C=0 F S C=$O(^TMP($J,"SUB",C)) Q:C'=+C S I=$P(^TMP($J,"SUB",C),U,1) I I]"" S ^BDMSNME(BDMY,11,BDMDA,11,C,0)=I,S=S+1
.S ^BDMSNME(BDMY,11,BDMDA,11,0)="^9003202.60111101^"_S_U_S
.K ^TMP($J,"SUB")
.S DIK="^BDMSNME(" D IXALL^DIK
.Q
Q
;
ICDDX(C,D,S,I) ;PEP - CHECK FOR ICD10
I $T(ICDDX^ICDEX)]"" Q $$ICDDX^ICDEX(C,$G(D),,$G(I))
Q $$ICDDX^ICDCODE(C,$G(D),$G(I))
;
ICDOP(C,D,S,I) ;PEP - CHECK FOR ICD10
I $T(ICDOP^ICDEX)]"" Q $$ICDOP^ICDEX(C,$G(D),,$G(I))
Q $$ICDOP^ICDCODE(C,$G(D),$G(I))
;
VSTD(C,D) ;EP - CHECK FOR ICD10
I $T(VSTD^ICDEX)]"" Q $$VSTD^ICDEX(C,$G(D))
Q $$VSTD^ICDCODE(C,$G(D))
;
VSTP(C,D) ;EP - CHECK FOR ICD10
I $T(VSTP^ICDEX)]"" Q $$VSTP^ICDEX(C,$G(D))
Q $$VSTP^ICDCODE(C,$G(D))
;
ICDD(C,A,D) ;EP - CHECK FOR ICD10
I $T(ICDD^ICDEX)]"" Q $$ICDD^ICDEX(C,A,$G(D))
Q $$ICDD^ICDCODE(C,A,$G(D))
CODEN(C,F) ;EP CHECK/GET CODE
I $T(CODEN^ICDEX)]"" Q $$CODEN^ICDEX(C,F)
Q $$CODEN^ICDCODE(C,F)
PLCL(P,BDMY,A,ED,S,BD) ;EP - is DX on problem list 1 or 0
I $G(P)="" Q ""
I $G(A)="" Q ""
I $G(S)="" S S=0
I $G(ED)="" S ED=DT
I $G(BD)="" S BD=$$DOB^AUPNPAT(P)
S BDMY=$O(^BDMSNME("B",BDMY,0))
N T,N S T=$O(^BDMSNME(BDMY,11,"B",A,0))
I 'T Q ""
N X,Y,I,A,D,G S (X,Y)=0,I="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) I $D(^AUPNPROB(X,0)) D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.I S Q:$P(^AUPNPROB(X,0),U,12)="I"
.S A=0,D="",G="" F S A=$O(^AUPNPROB(X,14,A)) Q:A'=+A!(G) D
..S D=$$VD^APCLV($P(^AUPNPROB(X,14,A,0),U,1))
..I D'>ED,D'<BD S G=1 ;GOOD DATE
.I 'G S A=0,D="" F S A=$O(^AUPNPROB(X,15,A)) Q:A'=+A!(G) D
..S D=$$VD^APCLV($P(^AUPNPROB(X,15,A,0),U,1))
..I D'>ED,D'<BD S G=1
.I 'G I $P(^AUPNPROB(X,0),U,8)>ED!($P(^AUPNPROB(X,0),U,8)<BD) Q
.S N=$$VAL^XBDIQ1(9000011,X,80001) I N]"",$D(^BDMSNME(BDMY,11,T,11,"B",N)) S I=1_U_N_U_$P(^AUPNPROB(X,0),U,3)
Q I
PLTAXND(P,A,E) ;EP - is dx on problem list as NOT DELETED
;P is dfn
;a is taxonomy name
I $G(P)="" Q ""
I $G(A)="" Q ""
S E=$G(E)
NEW T S T=$O(^ATXAX("B",A,0))
I 'T Q "" ;bad taxonomy??
NEW X,Y,I,D
S (X,Y,I)=0
F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.S Y=$P(^AUPNPROB(X,0),U)
.I E,$P(^AUPNPROB(X,0),U,13)>E Q ;if there is a doo and it is after report period skip
.I E,$P(^AUPNPROB(X,0),U,8)>E Q ;entered after report period, skip
.Q:'$$ICD^BGP8UTL2(Y,T,9)
.S D=$P(^AUPNPROB(X,0),U,13)
.I 'D S D=$P(^AUPNPROB(X,0),U,3)
.S I=1_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)_U_D
.Q
Q I
PLTAXID(P,A,B,E) ;EP - is dx on problem list as either active or inactive?
;P is dfn
;a is taxonomy name
I $G(P)="" Q ""
I $G(A)="" Q ""
S E=$G(E)
S B=$G(B)
NEW T S T=$O(^ATXAX("B",A,0))
I 'T Q "" ;bad taxonomy??
NEW X,Y,I,D,M,O
S (X,Y,I)=0
F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.S Y=$P(^AUPNPROB(X,0),U)
.S O=$P(^AUPNPROB(X,0),U,13)
.S M=$P(^AUPNPROB(X,0),U,3)
.S D=$P(^AUPNPROB(X,0),U,8)
.I D'<B,D'>E G CHK
.I O,O'<B,O'>E G CHK
.I M,M'<B,M'>E G CHK
.Q
CHK .;
.Q:'$$ICD^BGP8UTL2(Y,T,9)
.S I=1_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)_U_$S(O="":M,1:O)_U_X
.Q
Q I
BDMUTL ; IHS/CMI/LAB - Area Database Utility Routine ; 14 Sep 2015 12:41 PM
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**5,8,9,10,11,12**;JUN 14, 2007;Build 51
+2 ;
SNOMED(YR,LIST,SMC) ;EP - is snomed code smc on the list for the year
+1 IF 'YR
SET YR=2019
+2 IF LIST=""
QUIT ""
+3 IF SMC=""
QUIT ""
+4 NEW YRI,LISTI
+5 SET YRI=$ORDER(^BDMSNME("B",YR,0))
IF 'YRI
QUIT ""
+6 SET LISTI=$ORDER(^BDMSNME(YRI,11,"B",LIST,0))
IF 'LISTI
QUIT ""
+7 IF $DATA(^BDMSNME(YRI,11,LISTI,11,"B",SMC))
QUIT 1
+8 QUIT ""
GETIMMS(P,EDATE,C,BDMX) ;EP
+1 KILL BDMX
+2 NEW X,Y,I,Z,V
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;happens
IF '$DATA(^AUPNVIMM(X,0))
QUIT
+5 SET Y=$PIECE(^AUPNVIMM(X,0),U)
+6 ;happens too
IF 'Y
QUIT
+7 ;get HL7/CVX code
SET I=$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+8 FOR Z=1:1:$LENGTH(C,U)
IF I=$PIECE(C,U,Z)
SET V=$PIECE(^AUPNVIMM(X,0),U,3)
IF V
SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
IF D]""
IF D'>EDATE
SET BDMX(D)=Y
+9 QUIT
End DoDot:1
+10 QUIT
IMMREF(P,IMM,BD,ED) ;EP
+1 NEW X,Y,G,D,R
+2 IF 'IMM
QUIT ""
+3 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",IMM,0))
+4 IF 'Y
QUIT ""
+5 FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET R=$PIECE(^BIPC(X,0),U,3)
+7 IF R=""
QUIT
+8 IF '$DATA(^BICONT(R,0))
QUIT
+9 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+10 SET D=$PIECE(^BIPC(X,0),U,4)
+11 IF D=""
QUIT
+12 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+13 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+14 SET G=G+1
End DoDot:1
+15 QUIT G
ANCONT(P,C,ED) ;EP - ANALPHYLAXIS CONTRAINDICATION
+1 NEW X
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G="2 No - Contraindication Anaphylaxis"
End DoDot:1
+11 QUIT G
DEMO(P,T) ;EP - called to exclude demo patients
+1 IF $GET(P)=""
QUIT 0
+2 IF $GET(T)=""
SET T="I"
+3 IF T="I"
QUIT 0
+4 NEW R
+5 SET R=""
+6 IF T="E"
Begin DoDot:1
+7 IF $PIECE($GET(^DPT(P,0)),U)["DEMO,PATIENT"
SET R=1
QUIT
+8 NEW %
+9 SET %=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
+10 IF '%
SET R=0
QUIT
+11 IF $DATA(^DIBT(%,1,P))
SET R=1
QUIT
End DoDot:1
QUIT R
+12 IF T="O"
Begin DoDot:1
+13 IF $PIECE($GET(^DPT(P,0)),U)["DEMO,PATIENT"
SET R=0
QUIT
+14 NEW %
+15 SET %=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
+16 IF '%
SET R=1
QUIT
+17 IF $DATA(^DIBT(%,1,P))
SET R=0
QUIT
+18 SET R=1
QUIT
End DoDot:1
QUIT R
+19 QUIT 0
+20 ;
RZERO(V,L) ;ep right zero fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=V_"0"
+3 QUIT V
LZERO(V,L) ;EP - left zero fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V="0"_V
+3 QUIT V
LBLK(V,L) ;EP -left blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=" "_V
+3 QUIT V
RBLK(V,L) ;EP right blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=V_" "
+3 QUIT V
+4 ;
DEMOCHK(R) ;EP - check demo pat
+1 NEW DIR,DA
+2 SET R=-1
+3 SET DIR(0)="S^I:Include ALL Patients;E:Exclude DEMO Patients;O:Include ONLY DEMO Patients"
SET DIR("A")="Demo Patient Inclusion/Exclusion"
SET DIR("B")="E"
+4 KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
SET R=-1
QUIT
+6 SET R=Y
+7 QUIT
+8 ;
ICD(VAL,TAXNM,TYP) ;EP -- check to see if value is in taxonomy in ^TMP("BDMTMP",$J,Taxonomy Name
+1 ;add 3rd param with pass type
+2 IF $GET(VAL)=""
QUIT 0
+3 IF $GET(TAXNM)=""
QUIT 0
+4 IF $GET(TYP)=""
QUIT 0
+5 IF $GET(BDMJOB)=""!($GET(BDMBTH)="")
QUIT $$ICD^ATXCHK(VAL,$ORDER(^ATXAX("B",TAXNM,0)),TYP)
+6 IF '$DATA(^XTMP("BDMTAX",BDMJOB,BDMBTH,TAXNM))
QUIT $$ICD^ATXCHK(VAL,$ORDER(^ATXAX("B",TAXNM,0)),TYP)
+7 IF $DATA(^XTMP("BDMTAX",BDMJOB,BDMBTH,TAXNM,VAL))
QUIT 1
+8 QUIT 0
+9 ;
UNFOLDTX(YEAR) ;EP -- unfold all taxes for dm audit into ^TMP("BDMTMP",$J,Taxonomy Name
+1 ;lets go through all the taxonomies needed here and put them in above location
+2 ;need to check DMS Taxonomies Used option to determine
+3 KILL ^XTMP("BDMTAX",BDMJOB,BDMBTH)
+4 ;only in icd10 environment
IF '$DATA(^ICDS(0))
QUIT
+5 NEW BDMYR,BDMDA,BDMTAX,BDMFL,BDMTAXI,BDMVAL,BDMTYP,BDMTGT
+6 SET BDMYR=$ORDER(^BDMTAXS("B",YEAR,0))
+7 IF 'BDMYR
QUIT
+8 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^BDMTAXS(BDMYR,11,BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:1
+9 SET BDMTAX=$PIECE($GET(^BDMTAXS(BDMYR,11,BDMDA,0)),U)
+10 SET BDMFL=$PIECE($GET(^BDMTAXS(BDMYR,11,BDMDA,0)),U,2)
+11 SET BDMTYP=$SELECT(BDMFL=60:"L",1:"")
+12 SET BDMTAXI=$ORDER(^ATXAX("B",BDMTAX,0))
+13 IF BDMTYP="L"
Begin DoDot:2
+14 SET BDMTAXI=$ORDER(^ATXLAB("B",BDMTAX,0))
End DoDot:2
+15 SET BDMTGT="^XTMP("_"""BDMTAX"""_","_BDMJOB_","_""""_BDMBTH_""""_","_""""_BDMTAX_""""_")"
+16 ;D BLDTAX^ATXAPI(BDMTAX,BDMTGT,BDMTAXI,BDMTYP)
+17 DO BLDTAX^BDMTAPI(BDMTAX,BDMTGT,BDMTAXI,BDMTYP)
End DoDot:1
+18 QUIT
BUILDSML(Y) ;EP - BUILD SNOMED LISTS FROM SUBSETS
+1 NEW BDMDA,N,OUT,X,BDMY,C,S
+2 ;NO SNOMED STUFF INSTALLED
IF $TEXT(SUBLST^BSTSAPI)=""
QUIT
+3 SET BDMY=$ORDER(^BDMSNME("B",Y,0))
+4 SET BDMDA=0
FOR
SET BDMDA=$ORDER(^BDMSNME(BDMY,11,BDMDA))
IF BDMDA'=+BDMDA
QUIT
Begin DoDot:1
+5 IF '$PIECE(^BDMSNME(BDMY,11,BDMDA,0),U,2)
QUIT
+6 ;subset name
SET N=$PIECE(^BDMSNME(BDMY,11,BDMDA,0),U,1)
+7 KILL ^TMP($JOB,"SUB")
+8 SET OUT=$NAME(^TMP($JOB,"SUB"))
+9 ;
SET X=$$SUBLST^BSTSAPI(OUT,N)
+10 ;NO CODES??
IF '$ORDER(^TMP($JOB,"SUB",0))
QUIT
+11 ;BUILD INDEX
+12 SET S=0
+13 KILL ^BDMSNME(BDMY,11,BDMDA,11)
+14 SET C=0
FOR
SET C=$ORDER(^TMP($JOB,"SUB",C))
IF C'=+C
QUIT
SET I=$PIECE(^TMP($JOB,"SUB",C),U,1)
IF I]""
SET ^BDMSNME(BDMY,11,BDMDA,11,C,0)=I
SET S=S+1
+15 SET ^BDMSNME(BDMY,11,BDMDA,11,0)="^9003202.60111101^"_S_U_S
+16 KILL ^TMP($JOB,"SUB")
+17 SET DIK="^BDMSNME("
DO IXALL^DIK
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
ICDDX(C,D,S,I) ;PEP - CHECK FOR ICD10
+1 IF $TEXT(ICDDX^ICDEX)]""
QUIT $$ICDDX^ICDEX(C,$GET(D),,$GET(I))
+2 QUIT $$ICDDX^ICDCODE(C,$GET(D),$GET(I))
+3 ;
ICDOP(C,D,S,I) ;PEP - CHECK FOR ICD10
+1 IF $TEXT(ICDOP^ICDEX)]""
QUIT $$ICDOP^ICDEX(C,$GET(D),,$GET(I))
+2 QUIT $$ICDOP^ICDCODE(C,$GET(D),$GET(I))
+3 ;
VSTD(C,D) ;EP - CHECK FOR ICD10
+1 IF $TEXT(VSTD^ICDEX)]""
QUIT $$VSTD^ICDEX(C,$GET(D))
+2 QUIT $$VSTD^ICDCODE(C,$GET(D))
+3 ;
VSTP(C,D) ;EP - CHECK FOR ICD10
+1 IF $TEXT(VSTP^ICDEX)]""
QUIT $$VSTP^ICDEX(C,$GET(D))
+2 QUIT $$VSTP^ICDCODE(C,$GET(D))
+3 ;
ICDD(C,A,D) ;EP - CHECK FOR ICD10
+1 IF $TEXT(ICDD^ICDEX)]""
QUIT $$ICDD^ICDEX(C,A,$GET(D))
+2 QUIT $$ICDD^ICDCODE(C,A,$GET(D))
CODEN(C,F) ;EP CHECK/GET CODE
+1 IF $TEXT(CODEN^ICDEX)]""
QUIT $$CODEN^ICDEX(C,F)
+2 QUIT $$CODEN^ICDCODE(C,F)
PLCL(P,BDMY,A,ED,S,BD) ;EP - is DX on problem list 1 or 0
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 IF $GET(S)=""
SET S=0
+4 IF $GET(ED)=""
SET ED=DT
+5 IF $GET(BD)=""
SET BD=$$DOB^AUPNPAT(P)
+6 SET BDMY=$ORDER(^BDMSNME("B",BDMY,0))
+7 NEW T,N
SET T=$ORDER(^BDMSNME(BDMY,11,"B",A,0))
+8 IF 'T
QUIT ""
+9 NEW X,Y,I,A,D,G
SET (X,Y)=0
SET I=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
Begin DoDot:1
+10 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+11 IF S
IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+12 SET A=0
SET D=""
SET G=""
FOR
SET A=$ORDER(^AUPNPROB(X,14,A))
IF A'=+A!(G)
QUIT
Begin DoDot:2
+13 SET D=$$VD^APCLV($PIECE(^AUPNPROB(X,14,A,0),U,1))
+14 ;GOOD DATE
IF D'>ED
IF D'<BD
SET G=1
End DoDot:2
+15 IF 'G
SET A=0
SET D=""
FOR
SET A=$ORDER(^AUPNPROB(X,15,A))
IF A'=+A!(G)
QUIT
Begin DoDot:2
+16 SET D=$$VD^APCLV($PIECE(^AUPNPROB(X,15,A,0),U,1))
+17 IF D'>ED
IF D'<BD
SET G=1
End DoDot:2
+18 IF 'G
IF $PIECE(^AUPNPROB(X,0),U,8)>ED!($PIECE(^AUPNPROB(X,0),U,8)<BD)
QUIT
+19 SET N=$$VAL^XBDIQ1(9000011,X,80001)
IF N]""
IF $DATA(^BDMSNME(BDMY,11,T,11,"B",N))
SET I=1_U_N_U_$PIECE(^AUPNPROB(X,0),U,3)
End DoDot:1
+20 QUIT I
PLTAXND(P,A,E) ;EP - is dx on problem list as NOT DELETED
+1 ;P is dfn
+2 ;a is taxonomy name
+3 IF $GET(P)=""
QUIT ""
+4 IF $GET(A)=""
QUIT ""
+5 SET E=$GET(E)
+6 NEW T
SET T=$ORDER(^ATXAX("B",A,0))
+7 ;bad taxonomy??
IF 'T
QUIT ""
+8 NEW X,Y,I,D
+9 SET (X,Y,I)=0
+10 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+11 IF '$DATA(^AUPNPROB(X,0))
QUIT
+12 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+13 SET Y=$PIECE(^AUPNPROB(X,0),U)
+14 ;if there is a doo and it is after report period skip
IF E
IF $PIECE(^AUPNPROB(X,0),U,13)>E
QUIT
+15 ;entered after report period, skip
IF E
IF $PIECE(^AUPNPROB(X,0),U,8)>E
QUIT
+16 IF '$$ICD^BGP8UTL2(Y,T,9)
QUIT
+17 SET D=$PIECE(^AUPNPROB(X,0),U,13)
+18 IF 'D
SET D=$PIECE(^AUPNPROB(X,0),U,3)
+19 SET I=1_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)_U_D
+20 QUIT
End DoDot:1
+21 QUIT I
PLTAXID(P,A,B,E) ;EP - is dx on problem list as either active or inactive?
+1 ;P is dfn
+2 ;a is taxonomy name
+3 IF $GET(P)=""
QUIT ""
+4 IF $GET(A)=""
QUIT ""
+5 SET E=$GET(E)
+6 SET B=$GET(B)
+7 NEW T
SET T=$ORDER(^ATXAX("B",A,0))
+8 ;bad taxonomy??
IF 'T
QUIT ""
+9 NEW X,Y,I,D,M,O
+10 SET (X,Y,I)=0
+11 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNPROB(X,0))
QUIT
+13 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+14 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+15 SET Y=$PIECE(^AUPNPROB(X,0),U)
+16 SET O=$PIECE(^AUPNPROB(X,0),U,13)
+17 SET M=$PIECE(^AUPNPROB(X,0),U,3)
+18 SET D=$PIECE(^AUPNPROB(X,0),U,8)
+19 IF D'<B
IF D'>E
GOTO CHK
+20 IF O
IF O'<B
IF O'>E
GOTO CHK
+21 IF M
IF M'<B
IF M'>E
GOTO CHK
+22 QUIT
CHK ;
+1 IF '$$ICD^BGP8UTL2(Y,T,9)
QUIT
+2 SET I=1_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)_U_$SELECT(O="":M,1:O)_U_X
+3 QUIT
End DoDot:1
+4 QUIT I
