BGP8DPE1 ;IHS/CMI/LAB - EDUC REPRT;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 65
;
PROC ;EP
S BGPBT=$H
D JRNL
S BGPJ=$J,BGPH=$H
D XTMP^BGP8UTL("BGP8PE","CRS PT ED Patient List")
;calculate 3 years before end of each time frame
S BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
S BGPP3YE=$$FMADD^XLFDT(BGPPED,-1096)
S BGPB3YE=$$FMADD^XLFDT(BGPBED,-1096)
;process each patient
S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN D
.Q:'$D(^DPT(DFN,0))
.I $G(BGPSEAT) G N
.Q:$P($G(^DPT(DFN,0)),U)["DEMO,PATIENT"
.;I $P($G(^BGPSITE(DUZ(2),0)),U,12) Q:$D(^DIBT($P(^BGPSITE(DUZ(2),0),U,12),1,DFN))
.S X=$O(^DIBT("B","RPMS DEMO PATIENT NAMES",0)) I X Q:$D(^DIBT(X,1,DFN))
N .;
.I $G(BGPSEAT) Q:'$D(^DIBT(BGPSEAT,1,DFN))
.D PROCCY,PROCPY,PROCBY
S BGPET=$H
Q
EDUALLOW(Y,T) ;EP - is this a valid topic?
I $G(T)="" Q ""
I $G(Y)="" Q ""
I $D(^BGPCTRL(Y,62,"B",T)) Q 1
NEW D
S D=$P(T,"-")
I $P($$ICDDX^BGP8UTL2(D),U)'=-1 Q 1
I $P($$CPT^ICPTCOD(D),U)'=-1 Q 1
Q ""
;
ICDMAP(Y,T) ;EP - CAN THIS ICD CODE BE MAPPED TO A CATEGORY, IF YES, RETURN CATEGORY
I $G(T)="" Q ""
I $G(Y)="" Q ""
NEW C,X,G,Z,L,E,F,S
S G="",X=0
S C=$P($$ICDDX^BGP8UTL2(T),U,1) ;NOT A VALID ICD CODE
I C=-1 Q ""
F S X=$O(^BGPCTRL(Y,63,X)) Q:X'=+X!(G]"") D
.S Z=$P(^BGPCTRL(Y,63,X,0),U,3)
.Q:Z=""
.Q:'$D(^ATXAX("B",Z)) ;taxonomy doesn't exist
.I Z]"",$$ICD^BGP8UTL2(C,$O(^ATXAX("B",Z,0)),9) S G=$P(^BGPCTRL(Y,63,X,0),U,2)_U_$P(^BGPCTRL(Y,63,X,0),U,1)
.Q
Q G
CAT(C) ;
NEW X
I $G(C)="" Q C
S X=$O(^APCDEDCV("C",C,0))
I X="" Q C
Q $P(^APCDEDCV(X,0),U)
;
JRNL ;
N (DT,U,ZTQUEUED) S %=$$NOJOURN^ZIBGCHAR("BGPPEDCR"),%=$$NOJOURN^ZIBGCHAR("BGPPEDPR"),%=$$NOJOURN^ZIBGCHAR("BGPPEDBR")
S %=$$NOJOURN^ZIBGCHAR("BGPDATA"),%=$$NOJOURN^ZIBGCHAR("BGPGUI")
Q
PROCCY ;current time period
K ^TMP($J)
S (BGPACTUP,BGPACTCL)=""
Q:'$D(^DPT(DFN,0))
Q:$P(^DPT(DFN,0),U,2)=""
Q:"FM"'[$P(^DPT(DFN,0),U,2)
S BGPEDATE=BGPED,BGPTIME=1,BGPBDATE=BGPBD,BGPGBL="^BGPPEDCR("
S BGP365=BGPBDATE
I '$G(BGPSEAT) S BGPACTUP=$$ACTUP(DFN,BGP3YE,BGPEDATE,BGPTAXI,BGPBEN) ;user pop
I $G(BGPSEAT) S BGPACTUP=1
I 'BGPACTUP Q
S BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)
S BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)
S BGPSEX=$P(^DPT(DFN,0),U,2)
D CALCIND
K ^TMP($J,"A")
Q
PROCPY ;
K ^TMP($J)
S (BGPACTUP,BGPACTCL)=""
Q:'$D(^DPT(DFN,0))
Q:$P(^DPT(DFN,0),U,2)=""
Q:"FM"'[$P(^DPT(DFN,0),U,2)
S BGPEDATE=BGPPED,BGPTIME=2,BGPBDATE=BGPPBD,BGPGBL="^BGPPEDPR("
S BGP365=BGPBDATE
;S BGPACTUP=$$ACTUP(DFN,BGPP3YE,BGPEDATE,BGPTAXI,BGPBEN) ;user pop
I '$G(BGPSEAT) S BGPACTUP=$$ACTUP(DFN,BGPP3YE,BGPEDATE,BGPTAXI,BGPBEN) ;user pop
I $G(BGPSEAT) S BGPACTUP=1
I 'BGPACTUP Q ;if not in user pop, don't use patient
S BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)
S BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)
S BGPSEX=$P(^DPT(DFN,0),U,2)
D CALCIND
K ^TMP($J)
Q
PROCBY ;
K ^TMP($J)
S (BGPACTUP,BGPACTCL)=""
Q:'$D(^DPT(DFN,0))
Q:$P(^DPT(DFN,0),U,2)=""
Q:"FM"'[$P(^DPT(DFN,0),U,2)
S BGPEDATE=BGPBED,BGPTIME=3,BGPBDATE=BGPBBD,BGPGBL="^BGPPEDBR("
S BGP365=BGPBDATE
I '$G(BGPSEAT) S BGPACTUP=$$ACTUP(DFN,BGPB3YE,BGPEDATE,BGPTAXI,BGPBEN) ;user pop
I $G(BGPSEAT) S BGPACTUP=1
I 'BGPACTUP Q ;if not in user pop, don't use patient
S BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)
S BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)
S BGPSEX=$P(^DPT(DFN,0),U,2)
D CALCIND
K ^TMP($J)
Q
CALCIND ;
S BGPIC=0 F S BGPIC=$O(BGPIND(BGPIC)) Q:BGPIC'=+BGPIC D @BGPIC
Q
1 ;
S N=11,P=1 D S(BGPRPT,BGPGBL,N,P,1) ;set user pop total
S (BGPPEUP,BGPPEUPW)=""
Q:'$D(^AUPNVPED("AC",DFN)) ;no education so don't bother
K BGPALLED
S BGPFYCT=$O(^BGPCTRL("B",2018,0))
S Y="BGPALLED("
S X=DFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BGPBDATE)_"-"_$$FMTE^XLFDT(BGPEDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPALLED(1)) Q
S (X,D,G)=0,%="",T="" F S X=$O(BGPALLED(X)) Q:X'=+X!(G) D
.S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I T="" Q
.Q:'$$EDUALLOW(BGPFYCT,T)
.;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
.S G=1 ;patient had 1 topic
I G S N=11,P=2 D S(BGPRPT,BGPGBL,N,P,1) S BGPVALUE="Received Education" D SETLIST ;set # w/education total
Q
2 ;
Q:'$D(^AUPNVPED("AC",DFN)) ;no education so don't bother
K BGPALLED S BGPVALUE=""
K BGPPROVS
S BGPFYCT=$O(^BGPCTRL("B",2018,0))
S Y="BGPALLED("
S X=DFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BGPBDATE)_"-"_$$FMTE^XLFDT(BGPEDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPALLED(1)) Q
S (X,D,G)=0,%="",T="" F S X=$O(BGPALLED(X)) Q:X'=+X!(G) D
.S Y=+$P(BGPALLED(X),U,4)
.S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I T="" Q
.Q:'$$EDUALLOW(BGPFYCT,T)
.;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
.Q:'$P(^AUPNVPED(Y,0),U,8) ;SKIP IF NO MINUTES
.Q:$P(^AUPNVPED(Y,0),U,5)="" ;SKIP IF NO PROVIDER DOCUMENTED
.S P=$P(^AUPNVPED(Y,0),U,5)
.S D=$P($G(^VA(200,P,"PS")),U,5)
.I 'D Q ;no discipline to tally
.S D=$P($G(^DIC(7,D,9999999)),U,1)
.I D="" Q ;not standard
.;add to total # of topics
.D S(BGPRPT,BGPGBL,11,6,1) ;add to total # of topics
.S M=$P(^AUPNVPED(Y,0),U,8) ;MINUTES
.D SMIN(BGPRPT,BGPGBL,11,4,M)
.D SMAX(BGPRPT,BGPGBL,11,5,M)
.D S(BGPRPT,BGPGBL,11,7,M)
.S E=$O(^DIC(7,"D",D,0)),N=$P(^DIC(7,E,0),U)
.I BGPTIME=1 D SET21
.I BGPTIME=2 D SET22
.I BGPTIME=3 D SET23
.;set PROVS For this patient
.S BGPPROVS(N)=$G(BGPPROVS(N))+M
Q:'$D(BGPPROVS)
S BGPVALUE=""
S X="" F S X=$O(BGPPROVS(X)) Q:X="" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":";",1:"")_X_"-"_BGPPROVS(X)
D SETLIST
Q
SET21 ;
I $P($G(^BGPPEDCR(BGPRPT,11)),U,6) S $P(^BGPPEDCR(BGPRPT,11),U,3)=$P(^BGPPEDCR(BGPRPT,11),U,7)/$P(^BGPPEDCR(BGPRPT,11),U,6)
I '$D(^BGPPEDCR(BGPRPT,12,0)) S ^BGPPEDCR(BGPRPT,12,0)="^90560.1212A^0^0"
S Z=$O(^BGPPEDCR(BGPRPT,12,"B",D,0)) I Z D Q
.S $P(^BGPPEDCR(BGPRPT,12,Z,0),U,3)=$P(^BGPPEDCR(BGPRPT,12,Z,0),U,3)+M
S Z=$P(^BGPPEDCR(BGPRPT,12,0),U,3)+1,$P(^BGPPEDCR(BGPRPT,12,0),U,3)=Z,$P(^BGPPEDCR(BGPRPT,12,0),U,4)=Z
S ^BGPPEDCR(BGPRPT,12,Z,0)=D_U_N_U_M
S ^BGPPEDCR(BGPRPT,12,"B",D,Z)=""
Q
SET22 ;
I $P($G(^BGPPEDPR(BGPRPT,11)),U,6) S $P(^BGPPEDPR(BGPRPT,11),U,3)=$P(^BGPPEDPR(BGPRPT,11),U,7)/$P(^BGPPEDPR(BGPRPT,11),U,6)
I '$D(^BGPPEDPR(BGPRPT,12,0)) S ^BGPPEDPR(BGPRPT,12,0)="^90560.1312A^0^0"
S Z=$O(^BGPPEDPR(BGPRPT,12,"B",D,0)) I Z D Q
.S $P(^BGPPEDPR(BGPRPT,12,Z,0),U,3)=$P(^BGPPEDPR(BGPRPT,12,Z,0),U,3)+M
S Z=$P(^BGPPEDPR(BGPRPT,12,0),U,3)+1,$P(^BGPPEDPR(BGPRPT,12,0),U,3)=Z,$P(^BGPPEDPR(BGPRPT,12,0),U,4)=Z
S ^BGPPEDPR(BGPRPT,12,Z,0)=D_U_N_U_M
S ^BGPPEDPR(BGPRPT,12,"B",D,Z)=""
Q
SET23 ;
I $P($G(^BGPPEDBR(BGPRPT,11)),U,6) S $P(^BGPPEDBR(BGPRPT,11),U,3)=$P(^BGPPEDBR(BGPRPT,11),U,7)/$P(^BGPPEDBR(BGPRPT,11),U,6)
I '$D(^BGPPEDBR(BGPRPT,12,0)) S ^BGPPEDBR(BGPRPT,12,0)="^90560.1412A^0^0"
S Z=$O(^BGPPEDBR(BGPRPT,12,"B",D,0)) I Z D Q
.S $P(^BGPPEDBR(BGPRPT,12,Z,0),U,3)=$P(^BGPPEDBR(BGPRPT,12,Z,0),U,3)+M
S Z=$P(^BGPPEDBR(BGPRPT,12,0),U,3)+1,$P(^BGPPEDBR(BGPRPT,12,0),U,3)=Z,$P(^BGPPEDBR(BGPRPT,12,0),U,4)=Z
S ^BGPPEDBR(BGPRPT,12,Z,0)=D_U_N_U_M
S ^BGPPEDBR(BGPRPT,12,"B",D,Z)=""
Q
3 ;
Q:'$D(^AUPNVPED("AC",DFN)) ;no education so don't bother
K BGPALLED S BGPVALUE=""
K BGPPROVS
S BGPFYCT=$O(^BGPCTRL("B",2018,0))
S Y="BGPALLED("
S X=DFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BGPBDATE)_"-"_$$FMTE^XLFDT(BGPEDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPALLED(1)) Q
S (X,D,G)=0,%="",T="" F S X=$O(BGPALLED(X)) Q:X'=+X!(G) D
.S Y=+$P(BGPALLED(X),U,4)
.S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I T="" Q
.Q:'$$EDUALLOW(BGPFYCT,T)
.;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
.S BGPS=$O(^BGPCTRL(BGPFYCT,62,"B",T,0))
.;add to total # of topics
.S BGPT=$P(T,"-") ;dx is first piece
.I BGPS S BGPT1=$P(^BGPCTRL(BGPFYCT,62,BGPS,0),U,2) G S3
.S J="" S J=$$ICDMAP(BGPFYCT,BGPT),BGPT=$P(J,U,2),BGPT1=$P(J,U,1)
.I BGPT1="" S BGPT1=$P(T,"-")
.I BGPT="" S BGPT=$P(T,"-")
S3 .D S(BGPRPT,BGPGBL,11,8,1) ;add to total # of topics
.I BGPTIME=1 D SET31
.I BGPTIME=2 D SET32
.I BGPTIME=3 D SET33
.;set PROVS For this patient
.S BGPPROVS(BGPT1)=$G(BGPPROVS(BGPT1))+1
Q:'$D(BGPPROVS)
S BGPVALUE=""
S X="" F S X=$O(BGPPROVS(X)) Q:X="" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":";",1:"")_X_"-"_BGPPROVS(X)
D SETLIST
Q
SET31 ;
I '$D(^BGPPEDCR(BGPRPT,13,0)) S ^BGPPEDCR(BGPRPT,13,0)="^90560.1213A^0^0"
S Z=$O(^BGPPEDCR(BGPRPT,13,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDCR(BGPRPT,13,Z,0),U,3)=$P(^BGPPEDCR(BGPRPT,13,Z,0),U,3)+1
S Z=$P(^BGPPEDCR(BGPRPT,13,0),U,3)+1,$P(^BGPPEDCR(BGPRPT,13,0),U,3)=Z,$P(^BGPPEDCR(BGPRPT,13,0),U,4)=Z
S ^BGPPEDCR(BGPRPT,13,Z,0)=BGPT_U_BGPT1_U_1
S ^BGPPEDCR(BGPRPT,13,"B",BGPT,Z)=""
Q
SET32 ;
I '$D(^BGPPEDPR(BGPRPT,13,0)) S ^BGPPEDPR(BGPRPT,13,0)="^90560.1313A^0^0"
S Z=$O(^BGPPEDPR(BGPRPT,13,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDPR(BGPRPT,13,Z,0),U,3)=$P(^BGPPEDPR(BGPRPT,13,Z,0),U,3)+1
S Z=$P(^BGPPEDPR(BGPRPT,13,0),U,3)+1,$P(^BGPPEDPR(BGPRPT,13,0),U,3)=Z,$P(^BGPPEDPR(BGPRPT,13,0),U,4)=Z
S ^BGPPEDPR(BGPRPT,13,Z,0)=BGPT_U_BGPT1_U_1
S ^BGPPEDPR(BGPRPT,13,"B",BGPT,Z)=""
Q
SET33 ;
I '$D(^BGPPEDBR(BGPRPT,13,0)) S ^BGPPEDBR(BGPRPT,13,0)="^90560.1413A^0^0"
S Z=$O(^BGPPEDBR(BGPRPT,13,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDBR(BGPRPT,13,Z,0),U,3)=$P(^BGPPEDBR(BGPRPT,13,Z,0),U,3)+1
S Z=$P(^BGPPEDBR(BGPRPT,13,0),U,3)+1,$P(^BGPPEDBR(BGPRPT,13,0),U,3)=Z,$P(^BGPPEDBR(BGPRPT,13,0),U,4)=Z
S ^BGPPEDBR(BGPRPT,13,Z,0)=BGPT_U_BGPT1_U_1
S ^BGPPEDBR(BGPRPT,13,"B",BGPT,Z)=""
Q
4 ;
Q:'$D(^AUPNVPED("AC",DFN)) ;no education so don't bother
K BGPALLED S BGPVALUE=""
K BGPPROVS
S BGPFYCT=$O(^BGPCTRL("B",2018,0))
S Y="BGPALLED("
S X=DFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BGPBDATE)_"-"_$$FMTE^XLFDT(BGPEDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPALLED(1)) Q
S (X,D,G)=0,%="",T="" F S X=$O(BGPALLED(X)) Q:X'=+X!(G) D
.S Y=+$P(BGPALLED(X),U,4)
.S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I T="" Q
.Q:'$$EDUALLOW(BGPFYCT,T)
.;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
.S BGPS=$O(^BGPCTRL(BGPFYCT,62,"B",T,0))
.;add to total # of topics
.S BGPT=$P(T,"-",2) ;dx is first piece
.I BGPS S BGPT1=$P(^BGPCTRL(BGPFYCT,62,BGPS,0),U,3)
.I 'BGPS S BGPT1=$$CAT(BGPT)
.D S(BGPRPT,BGPGBL,11,9,1) ;add to total # of topics
.I BGPTIME=1 D SET41
.I BGPTIME=2 D SET42
.I BGPTIME=3 D SET43
.;set PROVS For this patient
.S BGPPROVS(BGPT1)=$G(BGPPROVS(BGPT1))+1
Q:'$D(BGPPROVS)
S BGPVALUE=""
S X="" F S X=$O(BGPPROVS(X)) Q:X="" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":";",1:"")_X_"-"_BGPPROVS(X)
D SETLIST
Q
SET41 ;
I '$D(^BGPPEDCR(BGPRPT,14,0)) S ^BGPPEDCR(BGPRPT,14,0)="^90560.1214A^0^0"
S Z=$O(^BGPPEDCR(BGPRPT,14,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDCR(BGPRPT,14,Z,0),U,3)=$P(^BGPPEDCR(BGPRPT,14,Z,0),U,3)+1
S Z=$P(^BGPPEDCR(BGPRPT,14,0),U,3)+1,$P(^BGPPEDCR(BGPRPT,14,0),U,3)=Z,$P(^BGPPEDCR(BGPRPT,14,0),U,4)=Z
S ^BGPPEDCR(BGPRPT,14,Z,0)=BGPT_U_BGPT1_U_1
S ^BGPPEDCR(BGPRPT,14,"B",BGPT,Z)=""
Q
SET42 ;
I '$D(^BGPPEDPR(BGPRPT,14,0)) S ^BGPPEDPR(BGPRPT,14,0)="^90560.1314A^0^0"
S Z=$O(^BGPPEDPR(BGPRPT,14,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDPR(BGPRPT,14,Z,0),U,3)=$P(^BGPPEDPR(BGPRPT,14,Z,0),U,3)+1
S Z=$P(^BGPPEDPR(BGPRPT,14,0),U,3)+1,$P(^BGPPEDPR(BGPRPT,14,0),U,3)=Z,$P(^BGPPEDPR(BGPRPT,14,0),U,4)=Z
S ^BGPPEDPR(BGPRPT,14,Z,0)=BGPT_U_BGPT1_U_1
S ^BGPPEDPR(BGPRPT,14,"B",BGPT,Z)=""
Q
SET43 ;
I '$D(^BGPPEDBR(BGPRPT,14,0)) S ^BGPPEDBR(BGPRPT,14,0)="^90560.1414A^0^0"
S Z=$O(^BGPPEDBR(BGPRPT,14,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDBR(BGPRPT,14,Z,0),U,3)=$P(^BGPPEDBR(BGPRPT,14,Z,0),U,3)+1
S Z=$P(^BGPPEDBR(BGPRPT,14,0),U,3)+1,$P(^BGPPEDBR(BGPRPT,14,0),U,3)=Z,$P(^BGPPEDBR(BGPRPT,14,0),U,4)=Z
S ^BGPPEDBR(BGPRPT,14,Z,0)=BGPT_U_BGPT1_U_1
S ^BGPPEDBR(BGPRPT,14,"B",BGPT,Z)=""
Q
5 ;
D 5^BGP8DPE2
Q
6 ;
D 6^BGP8DPE2
Q
7 ;
D 7^BGP8DPE2
Q
ACTUP(P,BDATE,EDATE,T,B) ;EP - is this patient in user pop?
I B=1,$$BEN^AUPNPAT(P,"C")'="01" Q 0 ;must be Indian/Alaskan Native
I B=2,$$BEN^AUPNPAT(P,"C")="01" Q 0 ;must not be I/A
S DOD=$$DOD^AUPNPAT(P) I DOD]"",DOD<EDATE Q 0
S X=$P($G(^AUPNPAT(P,11)),U,18) I X="" Q 0
I '$D(^ATXAX(T,21,"B",($P(^AUPNPAT(P,11),U,18)))),'$D(^ATXAX(T,21,"AA",$P(^AUPNPAT(P,11),U,18),$P(^AUPNPAT(P,11),U,18))) Q 0
S X=$$LASTVD(P,BDATE,EDATE)
Q $S(X:1,1:0)
;
S(R,G,N,P,V,J) ;
I 'V Q ;no value to add
I $G(J) S $P(@(G_R_","_N_")"),U,P)=$P($G(@(G_R_","_N_")")),U,P)=V Q
S $P(@(G_R_","_N_")"),U,P)=$P($G(@(G_R_","_N_")")),U,P)+V
Q
;
SMIN(R,G,N,P,V,J) ;
I 'V Q ;no value to add
I $P(@(G_R_","_N_")"),U,P)="" S $P(@(G_R_","_N_")"),U,P)=V
I V<$P(@(G_R_","_N_")"),U,P) S $P(@(G_R_","_N_")"),U,P)=V Q
Q
SMAX(R,G,N,P,V,J) ;
I 'V Q ;no value to add
I V>$P(@(G_R_","_N_")"),U,P) S $P(@(G_R_","_N_")"),U,P)=V Q
Q
SETLIST ;
Q:'$D(BGPLIST(BGPIC))
Q:BGPTIME'=1
I BGPLIST="P",$P(^AUPNPAT(DFN,0),U,14)'=BGPLPRV Q
S BGPLIST(BGPIC)=$G(BGPLIST(BGPIC))+1
S ^XTMP("BGP8PE",BGPJ,BGPH,"LIST",BGPIC,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),BGPAGEB,DFN)=$G(BGPVALUE)
Q
LASTVD(P,BDATE,EDATE) ;
I '$D(^AUPNVSIT("AC",P)) Q ""
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:'$D(^AUPNVPRV("AD",V))
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.Q:"V"[$P(^AUPNVSIT(V,0),U,3)
.Q:$P(^AUPNVSIT(V,0),U,6)=""
.S G=1
.Q
Q G
BGP8DPE1 ;IHS/CMI/LAB - EDUC REPRT;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 65
+2 ;
PROC ;EP
+1 SET BGPBT=$HOROLOG
+2 DO JRNL
+3 SET BGPJ=$JOB
SET BGPH=$HOROLOG
+4 DO XTMP^BGP8UTL("BGP8PE","CRS PT ED Patient List")
+5 ;calculate 3 years before end of each time frame
+6 SET BGP3YE=$$FMADD^XLFDT(BGPED,-1096)
+7 SET BGPP3YE=$$FMADD^XLFDT(BGPPED,-1096)
+8 SET BGPB3YE=$$FMADD^XLFDT(BGPBED,-1096)
+9 ;process each patient
+10 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
Begin DoDot:1
+11 IF '$DATA(^DPT(DFN,0))
QUIT
+12 IF $GET(BGPSEAT)
GOTO N
+13 IF $PIECE($GET(^DPT(DFN,0)),U)["DEMO,PATIENT"
QUIT
+14 ;I $P($G(^BGPSITE(DUZ(2),0)),U,12) Q:$D(^DIBT($P(^BGPSITE(DUZ(2),0),U,12),1,DFN))
+15 SET X=$ORDER(^DIBT("B","RPMS DEMO PATIENT NAMES",0))
IF X
IF $DATA(^DIBT(X,1,DFN))
QUIT
N ;
+1 IF $GET(BGPSEAT)
IF '$DATA(^DIBT(BGPSEAT,1,DFN))
QUIT
+2 DO PROCCY
DO PROCPY
DO PROCBY
End DoDot:1
+3 SET BGPET=$HOROLOG
+4 QUIT
EDUALLOW(Y,T) ;EP - is this a valid topic?
+1 IF $GET(T)=""
QUIT ""
+2 IF $GET(Y)=""
QUIT ""
+3 IF $DATA(^BGPCTRL(Y,62,"B",T))
QUIT 1
+4 NEW D
+5 SET D=$PIECE(T,"-")
+6 IF $PIECE($$ICDDX^BGP8UTL2(D),U)'=-1
QUIT 1
+7 IF $PIECE($$CPT^ICPTCOD(D),U)'=-1
QUIT 1
+8 QUIT ""
+9 ;
ICDMAP(Y,T) ;EP - CAN THIS ICD CODE BE MAPPED TO A CATEGORY, IF YES, RETURN CATEGORY
+1 IF $GET(T)=""
QUIT ""
+2 IF $GET(Y)=""
QUIT ""
+3 NEW C,X,G,Z,L,E,F,S
+4 SET G=""
SET X=0
+5 ;NOT A VALID ICD CODE
SET C=$PIECE($$ICDDX^BGP8UTL2(T),U,1)
+6 IF C=-1
QUIT ""
+7 FOR
SET X=$ORDER(^BGPCTRL(Y,63,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+8 SET Z=$PIECE(^BGPCTRL(Y,63,X,0),U,3)
+9 IF Z=""
QUIT
+10 ;taxonomy doesn't exist
IF '$DATA(^ATXAX("B",Z))
QUIT
+11 IF Z]""
IF $$ICD^BGP8UTL2(C,$ORDER(^ATXAX("B",Z,0)),9)
SET G=$PIECE(^BGPCTRL(Y,63,X,0),U,2)_U_$PIECE(^BGPCTRL(Y,63,X,0),U,1)
+12 QUIT
End DoDot:1
+13 QUIT G
CAT(C) ;
+1 NEW X
+2 IF $GET(C)=""
QUIT C
+3 SET X=$ORDER(^APCDEDCV("C",C,0))
+4 IF X=""
QUIT C
+5 QUIT $PIECE(^APCDEDCV(X,0),U)
+6 ;
JRNL ;
+1 NEW (DT,U,ZTQUEUED)
SET %=$$NOJOURN^ZIBGCHAR("BGPPEDCR")
SET %=$$NOJOURN^ZIBGCHAR("BGPPEDPR")
SET %=$$NOJOURN^ZIBGCHAR("BGPPEDBR")
+2 SET %=$$NOJOURN^ZIBGCHAR("BGPDATA")
SET %=$$NOJOURN^ZIBGCHAR("BGPGUI")
+3 QUIT
PROCCY ;current time period
+1 KILL ^TMP($JOB)
+2 SET (BGPACTUP,BGPACTCL)=""
+3 IF '$DATA(^DPT(DFN,0))
QUIT
+4 IF $PIECE(^DPT(DFN,0),U,2)=""
QUIT
+5 IF "FM"'[$PIECE(^DPT(DFN,0),U,2)
QUIT
+6 SET BGPEDATE=BGPED
SET BGPTIME=1
SET BGPBDATE=BGPBD
SET BGPGBL="^BGPPEDCR("
+7 SET BGP365=BGPBDATE
+8 ;user pop
IF '$GET(BGPSEAT)
SET BGPACTUP=$$ACTUP(DFN,BGP3YE,BGPEDATE,BGPTAXI,BGPBEN)
+9 IF $GET(BGPSEAT)
SET BGPACTUP=1
+10 IF 'BGPACTUP
QUIT
+11 SET BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)
+12 SET BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)
+13 SET BGPSEX=$PIECE(^DPT(DFN,0),U,2)
+14 DO CALCIND
+15 KILL ^TMP($JOB,"A")
+16 QUIT
PROCPY ;
+1 KILL ^TMP($JOB)
+2 SET (BGPACTUP,BGPACTCL)=""
+3 IF '$DATA(^DPT(DFN,0))
QUIT
+4 IF $PIECE(^DPT(DFN,0),U,2)=""
QUIT
+5 IF "FM"'[$PIECE(^DPT(DFN,0),U,2)
QUIT
+6 SET BGPEDATE=BGPPED
SET BGPTIME=2
SET BGPBDATE=BGPPBD
SET BGPGBL="^BGPPEDPR("
+7 SET BGP365=BGPBDATE
+8 ;S BGPACTUP=$$ACTUP(DFN,BGPP3YE,BGPEDATE,BGPTAXI,BGPBEN) ;user pop
+9 ;user pop
IF '$GET(BGPSEAT)
SET BGPACTUP=$$ACTUP(DFN,BGPP3YE,BGPEDATE,BGPTAXI,BGPBEN)
+10 IF $GET(BGPSEAT)
SET BGPACTUP=1
+11 ;if not in user pop, don't use patient
IF 'BGPACTUP
QUIT
+12 SET BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)
+13 SET BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)
+14 SET BGPSEX=$PIECE(^DPT(DFN,0),U,2)
+15 DO CALCIND
+16 KILL ^TMP($JOB)
+17 QUIT
PROCBY ;
+1 KILL ^TMP($JOB)
+2 SET (BGPACTUP,BGPACTCL)=""
+3 IF '$DATA(^DPT(DFN,0))
QUIT
+4 IF $PIECE(^DPT(DFN,0),U,2)=""
QUIT
+5 IF "FM"'[$PIECE(^DPT(DFN,0),U,2)
QUIT
+6 SET BGPEDATE=BGPBED
SET BGPTIME=3
SET BGPBDATE=BGPBBD
SET BGPGBL="^BGPPEDBR("
+7 SET BGP365=BGPBDATE
+8 ;user pop
IF '$GET(BGPSEAT)
SET BGPACTUP=$$ACTUP(DFN,BGPB3YE,BGPEDATE,BGPTAXI,BGPBEN)
+9 IF $GET(BGPSEAT)
SET BGPACTUP=1
+10 ;if not in user pop, don't use patient
IF 'BGPACTUP
QUIT
+11 SET BGPAGEB=$$AGE^AUPNPAT(DFN,BGPBDATE)
+12 SET BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)
+13 SET BGPSEX=$PIECE(^DPT(DFN,0),U,2)
+14 DO CALCIND
+15 KILL ^TMP($JOB)
+16 QUIT
CALCIND ;
+1 SET BGPIC=0
FOR
SET BGPIC=$ORDER(BGPIND(BGPIC))
IF BGPIC'=+BGPIC
QUIT
DO @BGPIC
+2 QUIT
1 ;
+1 ;set user pop total
SET N=11
SET P=1
DO S(BGPRPT,BGPGBL,N,P,1)
+2 SET (BGPPEUP,BGPPEUPW)=""
+3 ;no education so don't bother
IF '$DATA(^AUPNVPED("AC",DFN))
QUIT
+4 KILL BGPALLED
+5 SET BGPFYCT=$ORDER(^BGPCTRL("B",2018,0))
+6 SET Y="BGPALLED("
+7 SET X=DFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BGPBDATE)_"-"_$$FMTE^XLFDT(BGPEDATE)
SET E=$$START1^APCLDF(X,Y)
+8 IF '$DATA(BGPALLED(1))
QUIT
+9 SET (X,D,G)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+10 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+11 IF 'T
QUIT
+12 IF '$DATA(^AUTTEDT(T,0))
QUIT
+13 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+14 IF T=""
QUIT
+15 IF '$$EDUALLOW(BGPFYCT,T)
QUIT
+16 ;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
+17 ;patient had 1 topic
SET G=1
End DoDot:1
+18 ;set # w/education total
IF G
SET N=11
SET P=2
DO S(BGPRPT,BGPGBL,N,P,1)
SET BGPVALUE="Received Education"
DO SETLIST
+19 QUIT
2 ;
+1 ;no education so don't bother
IF '$DATA(^AUPNVPED("AC",DFN))
QUIT
+2 KILL BGPALLED
SET BGPVALUE=""
+3 KILL BGPPROVS
+4 SET BGPFYCT=$ORDER(^BGPCTRL("B",2018,0))
+5 SET Y="BGPALLED("
+6 SET X=DFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BGPBDATE)_"-"_$$FMTE^XLFDT(BGPEDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF '$DATA(BGPALLED(1))
QUIT
+8 SET (X,D,G)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+9 SET Y=+$PIECE(BGPALLED(X),U,4)
+10 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+11 IF 'T
QUIT
+12 IF '$DATA(^AUTTEDT(T,0))
QUIT
+13 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+14 IF T=""
QUIT
+15 IF '$$EDUALLOW(BGPFYCT,T)
QUIT
+16 ;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
+17 ;SKIP IF NO MINUTES
IF '$PIECE(^AUPNVPED(Y,0),U,8)
QUIT
+18 ;SKIP IF NO PROVIDER DOCUMENTED
IF $PIECE(^AUPNVPED(Y,0),U,5)=""
QUIT
+19 SET P=$PIECE(^AUPNVPED(Y,0),U,5)
+20 SET D=$PIECE($GET(^VA(200,P,"PS")),U,5)
+21 ;no discipline to tally
IF 'D
QUIT
+22 SET D=$PIECE($GET(^DIC(7,D,9999999)),U,1)
+23 ;not standard
IF D=""
QUIT
+24 ;add to total # of topics
+25 ;add to total # of topics
DO S(BGPRPT,BGPGBL,11,6,1)
+26 ;MINUTES
SET M=$PIECE(^AUPNVPED(Y,0),U,8)
+27 DO SMIN(BGPRPT,BGPGBL,11,4,M)
+28 DO SMAX(BGPRPT,BGPGBL,11,5,M)
+29 DO S(BGPRPT,BGPGBL,11,7,M)
+30 SET E=$ORDER(^DIC(7,"D",D,0))
SET N=$PIECE(^DIC(7,E,0),U)
+31 IF BGPTIME=1
DO SET21
+32 IF BGPTIME=2
DO SET22
+33 IF BGPTIME=3
DO SET23
+34 ;set PROVS For this patient
+35 SET BGPPROVS(N)=$GET(BGPPROVS(N))+M
End DoDot:1
+36 IF '$DATA(BGPPROVS)
QUIT
+37 SET BGPVALUE=""
+38 SET X=""
FOR
SET X=$ORDER(BGPPROVS(X))
IF X=""
QUIT
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_X_"-"_BGPPROVS(X)
+39 DO SETLIST
+40 QUIT
SET21 ;
+1 IF $PIECE($GET(^BGPPEDCR(BGPRPT,11)),U,6)
SET $PIECE(^BGPPEDCR(BGPRPT,11),U,3)=$PIECE(^BGPPEDCR(BGPRPT,11),U,7)/$PIECE(^BGPPEDCR(BGPRPT,11),U,6)
+2 IF '$DATA(^BGPPEDCR(BGPRPT,12,0))
SET ^BGPPEDCR(BGPRPT,12,0)="^90560.1212A^0^0"
+3 SET Z=$ORDER(^BGPPEDCR(BGPRPT,12,"B",D,0))
IF Z
Begin DoDot:1
+4 SET $PIECE(^BGPPEDCR(BGPRPT,12,Z,0),U,3)=$PIECE(^BGPPEDCR(BGPRPT,12,Z,0),U,3)+M
End DoDot:1
QUIT
+5 SET Z=$PIECE(^BGPPEDCR(BGPRPT,12,0),U,3)+1
SET $PIECE(^BGPPEDCR(BGPRPT,12,0),U,3)=Z
SET $PIECE(^BGPPEDCR(BGPRPT,12,0),U,4)=Z
+6 SET ^BGPPEDCR(BGPRPT,12,Z,0)=D_U_N_U_M
+7 SET ^BGPPEDCR(BGPRPT,12,"B",D,Z)=""
+8 QUIT
SET22 ;
+1 IF $PIECE($GET(^BGPPEDPR(BGPRPT,11)),U,6)
SET $PIECE(^BGPPEDPR(BGPRPT,11),U,3)=$PIECE(^BGPPEDPR(BGPRPT,11),U,7)/$PIECE(^BGPPEDPR(BGPRPT,11),U,6)
+2 IF '$DATA(^BGPPEDPR(BGPRPT,12,0))
SET ^BGPPEDPR(BGPRPT,12,0)="^90560.1312A^0^0"
+3 SET Z=$ORDER(^BGPPEDPR(BGPRPT,12,"B",D,0))
IF Z
Begin DoDot:1
+4 SET $PIECE(^BGPPEDPR(BGPRPT,12,Z,0),U,3)=$PIECE(^BGPPEDPR(BGPRPT,12,Z,0),U,3)+M
End DoDot:1
QUIT
+5 SET Z=$PIECE(^BGPPEDPR(BGPRPT,12,0),U,3)+1
SET $PIECE(^BGPPEDPR(BGPRPT,12,0),U,3)=Z
SET $PIECE(^BGPPEDPR(BGPRPT,12,0),U,4)=Z
+6 SET ^BGPPEDPR(BGPRPT,12,Z,0)=D_U_N_U_M
+7 SET ^BGPPEDPR(BGPRPT,12,"B",D,Z)=""
+8 QUIT
SET23 ;
+1 IF $PIECE($GET(^BGPPEDBR(BGPRPT,11)),U,6)
SET $PIECE(^BGPPEDBR(BGPRPT,11),U,3)=$PIECE(^BGPPEDBR(BGPRPT,11),U,7)/$PIECE(^BGPPEDBR(BGPRPT,11),U,6)
+2 IF '$DATA(^BGPPEDBR(BGPRPT,12,0))
SET ^BGPPEDBR(BGPRPT,12,0)="^90560.1412A^0^0"
+3 SET Z=$ORDER(^BGPPEDBR(BGPRPT,12,"B",D,0))
IF Z
Begin DoDot:1
+4 SET $PIECE(^BGPPEDBR(BGPRPT,12,Z,0),U,3)=$PIECE(^BGPPEDBR(BGPRPT,12,Z,0),U,3)+M
End DoDot:1
QUIT
+5 SET Z=$PIECE(^BGPPEDBR(BGPRPT,12,0),U,3)+1
SET $PIECE(^BGPPEDBR(BGPRPT,12,0),U,3)=Z
SET $PIECE(^BGPPEDBR(BGPRPT,12,0),U,4)=Z
+6 SET ^BGPPEDBR(BGPRPT,12,Z,0)=D_U_N_U_M
+7 SET ^BGPPEDBR(BGPRPT,12,"B",D,Z)=""
+8 QUIT
3 ;
+1 ;no education so don't bother
IF '$DATA(^AUPNVPED("AC",DFN))
QUIT
+2 KILL BGPALLED
SET BGPVALUE=""
+3 KILL BGPPROVS
+4 SET BGPFYCT=$ORDER(^BGPCTRL("B",2018,0))
+5 SET Y="BGPALLED("
+6 SET X=DFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BGPBDATE)_"-"_$$FMTE^XLFDT(BGPEDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF '$DATA(BGPALLED(1))
QUIT
+8 SET (X,D,G)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+9 SET Y=+$PIECE(BGPALLED(X),U,4)
+10 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+11 IF 'T
QUIT
+12 IF '$DATA(^AUTTEDT(T,0))
QUIT
+13 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+14 IF T=""
QUIT
+15 IF '$$EDUALLOW(BGPFYCT,T)
QUIT
+16 ;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
+17 SET BGPS=$ORDER(^BGPCTRL(BGPFYCT,62,"B",T,0))
+18 ;add to total # of topics
+19 ;dx is first piece
SET BGPT=$PIECE(T,"-")
+20 IF BGPS
SET BGPT1=$PIECE(^BGPCTRL(BGPFYCT,62,BGPS,0),U,2)
GOTO S3
+21 SET J=""
SET J=$$ICDMAP(BGPFYCT,BGPT)
SET BGPT=$PIECE(J,U,2)
SET BGPT1=$PIECE(J,U,1)
+22 IF BGPT1=""
SET BGPT1=$PIECE(T,"-")
+23 IF BGPT=""
SET BGPT=$PIECE(T,"-")
S3 ;add to total # of topics
DO S(BGPRPT,BGPGBL,11,8,1)
+1 IF BGPTIME=1
DO SET31
+2 IF BGPTIME=2
DO SET32
+3 IF BGPTIME=3
DO SET33
+4 ;set PROVS For this patient
+5 SET BGPPROVS(BGPT1)=$GET(BGPPROVS(BGPT1))+1
End DoDot:1
+6 IF '$DATA(BGPPROVS)
QUIT
+7 SET BGPVALUE=""
+8 SET X=""
FOR
SET X=$ORDER(BGPPROVS(X))
IF X=""
QUIT
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_X_"-"_BGPPROVS(X)
+9 DO SETLIST
+10 QUIT
SET31 ;
+1 IF '$DATA(^BGPPEDCR(BGPRPT,13,0))
SET ^BGPPEDCR(BGPRPT,13,0)="^90560.1213A^0^0"
+2 SET Z=$ORDER(^BGPPEDCR(BGPRPT,13,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDCR(BGPRPT,13,Z,0),U,3)=$PIECE(^BGPPEDCR(BGPRPT,13,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDCR(BGPRPT,13,0),U,3)+1
SET $PIECE(^BGPPEDCR(BGPRPT,13,0),U,3)=Z
SET $PIECE(^BGPPEDCR(BGPRPT,13,0),U,4)=Z
+5 SET ^BGPPEDCR(BGPRPT,13,Z,0)=BGPT_U_BGPT1_U_1
+6 SET ^BGPPEDCR(BGPRPT,13,"B",BGPT,Z)=""
+7 QUIT
SET32 ;
+1 IF '$DATA(^BGPPEDPR(BGPRPT,13,0))
SET ^BGPPEDPR(BGPRPT,13,0)="^90560.1313A^0^0"
+2 SET Z=$ORDER(^BGPPEDPR(BGPRPT,13,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDPR(BGPRPT,13,Z,0),U,3)=$PIECE(^BGPPEDPR(BGPRPT,13,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDPR(BGPRPT,13,0),U,3)+1
SET $PIECE(^BGPPEDPR(BGPRPT,13,0),U,3)=Z
SET $PIECE(^BGPPEDPR(BGPRPT,13,0),U,4)=Z
+5 SET ^BGPPEDPR(BGPRPT,13,Z,0)=BGPT_U_BGPT1_U_1
+6 SET ^BGPPEDPR(BGPRPT,13,"B",BGPT,Z)=""
+7 QUIT
SET33 ;
+1 IF '$DATA(^BGPPEDBR(BGPRPT,13,0))
SET ^BGPPEDBR(BGPRPT,13,0)="^90560.1413A^0^0"
+2 SET Z=$ORDER(^BGPPEDBR(BGPRPT,13,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDBR(BGPRPT,13,Z,0),U,3)=$PIECE(^BGPPEDBR(BGPRPT,13,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDBR(BGPRPT,13,0),U,3)+1
SET $PIECE(^BGPPEDBR(BGPRPT,13,0),U,3)=Z
SET $PIECE(^BGPPEDBR(BGPRPT,13,0),U,4)=Z
+5 SET ^BGPPEDBR(BGPRPT,13,Z,0)=BGPT_U_BGPT1_U_1
+6 SET ^BGPPEDBR(BGPRPT,13,"B",BGPT,Z)=""
+7 QUIT
4 ;
+1 ;no education so don't bother
IF '$DATA(^AUPNVPED("AC",DFN))
QUIT
+2 KILL BGPALLED
SET BGPVALUE=""
+3 KILL BGPPROVS
+4 SET BGPFYCT=$ORDER(^BGPCTRL("B",2018,0))
+5 SET Y="BGPALLED("
+6 SET X=DFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BGPBDATE)_"-"_$$FMTE^XLFDT(BGPEDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF '$DATA(BGPALLED(1))
QUIT
+8 SET (X,D,G)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+9 SET Y=+$PIECE(BGPALLED(X),U,4)
+10 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+11 IF 'T
QUIT
+12 IF '$DATA(^AUTTEDT(T,0))
QUIT
+13 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+14 IF T=""
QUIT
+15 IF '$$EDUALLOW(BGPFYCT,T)
QUIT
+16 ;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
+17 SET BGPS=$ORDER(^BGPCTRL(BGPFYCT,62,"B",T,0))
+18 ;add to total # of topics
+19 ;dx is first piece
SET BGPT=$PIECE(T,"-",2)
+20 IF BGPS
SET BGPT1=$PIECE(^BGPCTRL(BGPFYCT,62,BGPS,0),U,3)
+21 IF 'BGPS
SET BGPT1=$$CAT(BGPT)
+22 ;add to total # of topics
DO S(BGPRPT,BGPGBL,11,9,1)
+23 IF BGPTIME=1
DO SET41
+24 IF BGPTIME=2
DO SET42
+25 IF BGPTIME=3
DO SET43
+26 ;set PROVS For this patient
+27 SET BGPPROVS(BGPT1)=$GET(BGPPROVS(BGPT1))+1
End DoDot:1
+28 IF '$DATA(BGPPROVS)
QUIT
+29 SET BGPVALUE=""
+30 SET X=""
FOR
SET X=$ORDER(BGPPROVS(X))
IF X=""
QUIT
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_X_"-"_BGPPROVS(X)
+31 DO SETLIST
+32 QUIT
SET41 ;
+1 IF '$DATA(^BGPPEDCR(BGPRPT,14,0))
SET ^BGPPEDCR(BGPRPT,14,0)="^90560.1214A^0^0"
+2 SET Z=$ORDER(^BGPPEDCR(BGPRPT,14,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDCR(BGPRPT,14,Z,0),U,3)=$PIECE(^BGPPEDCR(BGPRPT,14,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDCR(BGPRPT,14,0),U,3)+1
SET $PIECE(^BGPPEDCR(BGPRPT,14,0),U,3)=Z
SET $PIECE(^BGPPEDCR(BGPRPT,14,0),U,4)=Z
+5 SET ^BGPPEDCR(BGPRPT,14,Z,0)=BGPT_U_BGPT1_U_1
+6 SET ^BGPPEDCR(BGPRPT,14,"B",BGPT,Z)=""
+7 QUIT
SET42 ;
+1 IF '$DATA(^BGPPEDPR(BGPRPT,14,0))
SET ^BGPPEDPR(BGPRPT,14,0)="^90560.1314A^0^0"
+2 SET Z=$ORDER(^BGPPEDPR(BGPRPT,14,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDPR(BGPRPT,14,Z,0),U,3)=$PIECE(^BGPPEDPR(BGPRPT,14,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDPR(BGPRPT,14,0),U,3)+1
SET $PIECE(^BGPPEDPR(BGPRPT,14,0),U,3)=Z
SET $PIECE(^BGPPEDPR(BGPRPT,14,0),U,4)=Z
+5 SET ^BGPPEDPR(BGPRPT,14,Z,0)=BGPT_U_BGPT1_U_1
+6 SET ^BGPPEDPR(BGPRPT,14,"B",BGPT,Z)=""
+7 QUIT
SET43 ;
+1 IF '$DATA(^BGPPEDBR(BGPRPT,14,0))
SET ^BGPPEDBR(BGPRPT,14,0)="^90560.1414A^0^0"
+2 SET Z=$ORDER(^BGPPEDBR(BGPRPT,14,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDBR(BGPRPT,14,Z,0),U,3)=$PIECE(^BGPPEDBR(BGPRPT,14,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDBR(BGPRPT,14,0),U,3)+1
SET $PIECE(^BGPPEDBR(BGPRPT,14,0),U,3)=Z
SET $PIECE(^BGPPEDBR(BGPRPT,14,0),U,4)=Z
+5 SET ^BGPPEDBR(BGPRPT,14,Z,0)=BGPT_U_BGPT1_U_1
+6 SET ^BGPPEDBR(BGPRPT,14,"B",BGPT,Z)=""
+7 QUIT
5 ;
+1 DO 5^BGP8DPE2
+2 QUIT
6 ;
+1 DO 6^BGP8DPE2
+2 QUIT
7 ;
+1 DO 7^BGP8DPE2
+2 QUIT
ACTUP(P,BDATE,EDATE,T,B) ;EP - is this patient in user pop?
+1 ;must be Indian/Alaskan Native
IF B=1
IF $$BEN^AUPNPAT(P,"C")'="01"
QUIT 0
+2 ;must not be I/A
IF B=2
IF $$BEN^AUPNPAT(P,"C")="01"
QUIT 0
+3 SET DOD=$$DOD^AUPNPAT(P)
IF DOD]""
IF DOD<EDATE
QUIT 0
+4 SET X=$PIECE($GET(^AUPNPAT(P,11)),U,18)
IF X=""
QUIT 0
+5 IF '$DATA(^ATXAX(T,21,"B",($PIECE(^AUPNPAT(P,11),U,18))))
IF '$DATA(^ATXAX(T,21,"AA",$PIECE(^AUPNPAT(P,11),U,18),$PIECE(^AUPNPAT(P,11),U,18)))
QUIT 0
+6 SET X=$$LASTVD(P,BDATE,EDATE)
+7 QUIT $SELECT(X:1,1:0)
+8 ;
S(R,G,N,P,V,J) ;
+1 ;no value to add
IF 'V
QUIT
+2 IF $GET(J)
SET $PIECE(@(G_R_","_N_")"),U,P)=$PIECE($GET(@(G_R_","_N_")")),U,P)=V
QUIT
+3 SET $PIECE(@(G_R_","_N_")"),U,P)=$PIECE($GET(@(G_R_","_N_")")),U,P)+V
+4 QUIT
+5 ;
SMIN(R,G,N,P,V,J) ;
+1 ;no value to add
IF 'V
QUIT
+2 IF $PIECE(@(G_R_","_N_")"),U,P)=""
SET $PIECE(@(G_R_","_N_")"),U,P)=V
+3 IF V<$PIECE(@(G_R_","_N_")"),U,P)
SET $PIECE(@(G_R_","_N_")"),U,P)=V
QUIT
+4 QUIT
SMAX(R,G,N,P,V,J) ;
+1 ;no value to add
IF 'V
QUIT
+2 IF V>$PIECE(@(G_R_","_N_")"),U,P)
SET $PIECE(@(G_R_","_N_")"),U,P)=V
QUIT
+3 QUIT
SETLIST ;
+1 IF '$DATA(BGPLIST(BGPIC))
QUIT
+2 IF BGPTIME'=1
QUIT
+3 IF BGPLIST="P"
IF $PIECE(^AUPNPAT(DFN,0),U,14)'=BGPLPRV
QUIT
+4 SET BGPLIST(BGPIC)=$GET(BGPLIST(BGPIC))+1
+5 SET ^XTMP("BGP8PE",BGPJ,BGPH,"LIST",BGPIC,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),BGPAGEB,DFN)=$GET(BGPVALUE)
+6 QUIT
LASTVD(P,BDATE,EDATE) ;
+1 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+2 KILL ^TMP($JOB,"A")
+3 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+4 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+5 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+8 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+9 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+10 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+11 IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+12 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+13 SET G=1
+14 QUIT
End DoDot:1
+15 QUIT G
