BGP4DPE2 ; IHS/CMI/LAB - calc measures 29 Apr 2010 7:38 PM 14 Nov 2006 5:02 PM 09 Jun 2014 5:18 PM ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
5 ;EP
Q:'$D(^AUPNVPED("AC",DFN)) ;no education so don't bother
K BGPALLED,BGPEDPRV S BGPVALUE=""
K BGPPROVS
S BGPFYCT=$O(^BGPCTRL("B",2014,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 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^BGP4DPE1(BGPFYCT,T)
.;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
.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 BGPT=$P($G(^DIC(7,D,9999999)),U,1)
.Q:BGPT="" ;not standard
.S BGPT1=$P(^DIC(7,D,0),U,1)
.;I DUZ=5634,BGPTIME=1 S ^LORIPED0(Y)=""
.D S(BGPRPT,BGPGBL,11,10,1) ;add to total # of topics
.I BGPTIME=1 D SET51
.I BGPTIME=2 D SET52
.I BGPTIME=3 D SET53
.;set PROVS For this patient
.S BGPPROVS(BGPT1)=$G(BGPPROVS(BGPT1))+1
.S %=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U,5)
.;I %="" S %=$P($G(^AUPNVPED(+$P(BGPALLED(X),U,4),12)),U,4)
.;I %="" S %="UNKNOWN"
.I % S BGPEDPRV(%)=""
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
SET51 ;
I '$D(^BGPPEDCJ(BGPRPT,15,0)) S ^BGPPEDCJ(BGPRPT,15,0)="^90552.1215A^0^0"
S Z=$O(^BGPPEDCJ(BGPRPT,15,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDCJ(BGPRPT,15,Z,0),U,3)=$P(^BGPPEDCJ(BGPRPT,15,Z,0),U,3)+1
S Z=$P(^BGPPEDCJ(BGPRPT,15,0),U,3)+1,$P(^BGPPEDCJ(BGPRPT,15,0),U,3)=Z,$P(^BGPPEDCJ(BGPRPT,15,0),U,4)=Z
S ^BGPPEDCJ(BGPRPT,15,Z,0)=BGPT_U_BGPT1_U_1
S ^BGPPEDCJ(BGPRPT,15,"B",BGPT,Z)=""
Q
SET52 ;
I '$D(^BGPPEDPJ(BGPRPT,15,0)) S ^BGPPEDPJ(BGPRPT,15,0)="^90552.1315A^0^0"
S Z=$O(^BGPPEDPJ(BGPRPT,15,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDPJ(BGPRPT,15,Z,0),U,3)=$P(^BGPPEDPJ(BGPRPT,15,Z,0),U,3)+1
S Z=$P(^BGPPEDPJ(BGPRPT,15,0),U,3)+1,$P(^BGPPEDPJ(BGPRPT,15,0),U,3)=Z,$P(^BGPPEDPJ(BGPRPT,15,0),U,4)=Z
S ^BGPPEDPJ(BGPRPT,15,Z,0)=BGPT_U_BGPT1_U_1
S ^BGPPEDPJ(BGPRPT,15,"B",BGPT,Z)=""
Q
SET53 ;
I '$D(^BGPPEDBJ(BGPRPT,15,0)) S ^BGPPEDBJ(BGPRPT,15,0)="^90552.1515A^0^0"
S Z=$O(^BGPPEDBJ(BGPRPT,15,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDBJ(BGPRPT,15,Z,0),U,3)=$P(^BGPPEDBJ(BGPRPT,15,Z,0),U,3)+1
S Z=$P(^BGPPEDBJ(BGPRPT,15,0),U,3)+1,$P(^BGPPEDBJ(BGPRPT,15,0),U,3)=Z,$P(^BGPPEDBJ(BGPRPT,15,0),U,4)=Z
S ^BGPPEDBJ(BGPRPT,15,Z,0)=BGPT_U_BGPT1_U_1
S ^BGPPEDBJ(BGPRPT,15,"B",BGPT,Z)=""
Q
6 ;EP
Q:'$D(^AUPNVPED("AC",DFN)) ;no education so don't bother
K BGPALLED,BGPEDPRV S BGPVALUE=""
K BGPPROVS
S BGPFYCT=$O(^BGPCTRL("B",2014,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 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^BGP4DPE1(BGPFYCT,T)
.;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
.D S(BGPRPT,BGPGBL,11,12,1) ;add to total # of topics
.S BGPLEVEL=$P(^AUPNVPED(Y,0),U,6)
.I BGPLEVEL=1 D S(BGPRPT,BGPGBL,11,13,1)
.I BGPLEVEL=2 D S(BGPRPT,BGPGBL,11,14,1)
.I BGPLEVEL=3 D S(BGPRPT,BGPGBL,11,15,1)
.I BGPLEVEL=5 D S(BGPRPT,BGPGBL,11,16,1)
.I BGPLEVEL=4 D S(BGPRPT,BGPGBL,11,17,1)
.I BGPLEVEL="" D S(BGPRPT,BGPGBL,11,18,1)
.;set PROVS For this patient
.I BGPLEVEL="" S BGPLEVEL="BLANK"
.S BGPPROVS(BGPLEVEL)=$G(BGPPROVS(BGPLEVEL))+1
.S %=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U,5)
.;I %="" S %=$P($G(^AUPNVPED(+$P(BGPALLED(X),U,4),12)),U,4)
.;I %="" S %="UNKNOWN"
.I % S BGPEDPRV(%)=""
Q:'$D(BGPPROVS)
S BGPVALUE=""
S X="" F S X=$O(BGPPROVS(X)) Q:X="" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":";",1:"")_$S(X:$$EXTSET^XBFUNC(9000010.16,.06,X),1:"BLANK-NOT RECORDED")_"-"_BGPPROVS(X)
D SETLIST
Q
;
7 ;EP
;Q:'$D(^AUPNVPED("AC",DFN)) ;no education so don't bother
K BGPALLED,BGPEDPRV S BGPVALUE="",BGPVAX=""
K BGPPROVS
S BGPFYCT=$O(^BGPCTRL("B",2014,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)) G PTG
S (X,D,G)=0,%="",T="" F S X=$O(BGPALLED(X)) Q:X'=+X 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^BGP4DPE1(BGPFYCT,T)
.S G=1
.S BGPLEVEL=$P(^AUPNVPED(Y,0),U,13)
.Q:BGPLEVEL=""
.S BGPPROVS(BGPLEVEL)=$G(BGPPROVS(BGPLEVEL))+1 ;count up
.;get provider
.S R="",R=$P(^AUPNVPED(Y,0),U,5) D
..Q:R]""
..S R=$P($G(^AUPNVPED(Y,12)),U,4)
..Q:R]""
..S R=$P($G(^AUPNVPED(Y,12)),U,2)
..Q:R]""
..S R=$$PRIMPROV^APCLV($P(^AUPNVPED(Y,0),U,3),"I")
.I R D
..S D=$$VALI^XBDIQ1(200,R,53.5)
..S D=$S(D:$$VAL^XBDIQ1(7,D,9999999.01),1:"")
..I D="" S D="??"
..S BGPPROVS(BGPLEVEL,"PROVS")=$G(BGPPROVS(BGPLEVEL,"PROVS"))_"; "_$$DATE^BGP4UTL($$VD^APCLV($P(^AUPNVPED(Y,0),U,3))) ;"; "_$$VAL^XBDIQ1(200,R,.01)_"-"_D
S BGPVALUE=""
I 'G G PTG ;no allowable topics
S BGPVAX=1
D S(BGPRPT,BGPGBL,11,19,1) ;add to total # of patients with a topic
I '$D(BGPPROVS) G PTG
I $G(BGPPROVS("GS")) D S(BGPRPT,BGPGBL,11,20,1) S BGPVALUE="GS"_$G(BGPPROVS("GS","PROVS"))
I $G(BGPPROVS("GNS")),'$G(BGPPROVS("GS")) D S(BGPRPT,BGPGBL,11,21,1) S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":", ",1:"")_"GNS"_$G(BGPPROVS("GNS","PROVS"))
I $G(BGPPROVS("GM")) D S(BGPRPT,BGPGBL,11,22,1) S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":", ",1:"")_"GM"_$G(BGPPROVS("GM","PROVS"))
I $G(BGPPROVS("GNM")),'$G(BGPPROVS("GM")) D S(BGPRPT,BGPGBL,11,23,1) S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":", ",1:"")_"GNM"_$G(BGPPROVS("GNM","PROVS"))
S BGPVALUE="UP PED: "_BGPVALUE
PTG ;now do patient goals stuff
D S(BGPRPT,BGPGBL,11,29,1) ;user pop
;did patient have a goal set with a start date in report period
S BGPVALU=""
K BGPSET
D SET
I $D(BGPSET) D
.D S(BGPRPT,BGPGBL,11,24,1)
.S BGPVALU=BGPVALU_$S(BGPVALU]"":"; GS:",1:"GS:")
.S BGPT="" F S BGPT=$O(BGPSET(BGPT)) Q:BGPT="" S BGPC=BGPSET(BGPT) D SET71 S BGPVALU=BGPVALU_$S($P(BGPVALU,"GS:",2)="":"",1:", ")_$P(BGPSET(BGPT),U,2)
K BGPNSET
D NOTSET
I $D(BGPNSET) D
.D S(BGPRPT,BGPGBL,11,25,1)
.S BGPVALU=BGPVALU_$S(BGPVALU]"":"; GNS:",1:"GNS:")
.S BGPT="" F S BGPT=$O(BGPNSET(BGPT)) Q:BGPT="" S BGPC=BGPNSET(BGPT) D SET72 S BGPVALU=BGPVALU_$S($P(BGPVALU,"GNS:",2)="":"",1:", ")_$P(BGPNSET(BGPT),U,2)
;MET
K BGPMET
D MET
I $D(BGPMET) D
.D S(BGPRPT,BGPGBL,11,26,1)
.S BGPVALU=BGPVALU_$S(BGPVALU]"":"; GM:",1:"GM:")
.S BGPT="" F S BGPT=$O(BGPMET(BGPT)) Q:BGPT="" S BGPC=BGPMET(BGPT) D SET73^BGP4DPE3 S BGPVALU=BGPVALU_$S($P(BGPVALU,"GM:",2)="":"",1:", ")_$P(BGPMET(BGPT),U,2)
K BGPMAIN
D MAINTAIN
I $D(BGPMAIN) D
.D S(BGPRPT,BGPGBL,11,27,1)
.S BGPVALU=BGPVALU_$S(BGPVALU]"":"; GMaint:",1:"GMaint:")
.S BGPT="" F S BGPT=$O(BGPMAIN(BGPT)) Q:BGPT="" S BGPC=BGPMAIN(BGPT) D SET74^BGP4DPE3 S BGPVALU=BGPVALU_$S($P(BGPVALU,"GMaint:",2)="":"",1:", ")_$P(BGPMAIN(BGPT),U,2)
K BGPNMET
D NOTMET
I $D(BGPNMET) D
.D S(BGPRPT,BGPGBL,11,28,1)
.S BGPVALU=BGPVALU_$S(BGPVALU]"":"; GNM:",1:"GNM:")
.S BGPT="" F S BGPT=$O(BGPNMET(BGPT)) Q:BGPT="" S BGPC=BGPNMET(BGPT) D SET75^BGP4DPE3 S BGPVALU=BGPVALU_$S($P(BGPVALU,"GNM:",2)="":"",1:", ")_$P(BGPNMET(BGPT),U,2)
I BGPVALU]"" S BGPVALU=" UP: "_BGPVALU
S BGPVALUE=BGPVALU_" "_BGPVALUE_U_BGPVAX
;
D SETLIST
K BGPSET,BGPNSET,BGPMET,BGPMAIN,BGPNMET
Q
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
;
SETLIST ;
Q:'$D(BGPLIST(BGPIC))
Q:BGPTIME'=1
I BGPLIST="P",$P(^AUPNPAT(DFN,0),U,14)'=BGPLPRV Q
I BGPLIST="O",'$D(BGPEDPRV(BGPEPRV)) Q
S BGPLIST(BGPIC)=$G(BGPLIST(BGPIC))+1
S ^XTMP("BGP4PE",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
NOTSET ;
;FIRST GATHER UP ALL SET GOALS AND GOAL TYPES
K BGPNSET
NEW X,Y,Z,%,D,G
S G=""
S X=0,%=""
F S X=$O(^AUPNGOAL("AC",DFN,X)) Q:X'=+X!(%]"") D
.Q:'$D(^AUPNGOAL(X,0)) ;BAD XREF
.Q:$P(^AUPNGOAL(X,0),U,1)'="S" ;NOT SET ONLY
.S D=$P($P(^AUPNGOAL(X,0),U,9),".")
.Q:D=""
.Q:D<BGPBDATE
.Q:D>BGPEDATE
.S Y=0 F S Y=$O(^AUPNGOAL(X,10,Y)) Q:Y'=+Y D
..S Z=$P($G(^AUPNGOAL(X,10,Y,0)),U,1)
..I Z S G($$VAL^XBDIQ1(9001002.4,Z,.01))=""
;NOW CHECK GOALS NOT SET IN REPORT PERIOD AND CHECK TYPE
S X=0,%=""
F S X=$O(^AUPNGOAL("AC",DFN,X)) Q:X'=+X!(%]"") D
.Q:'$D(^AUPNGOAL(X,0)) ;BAD XREF
.Q:$P(^AUPNGOAL(X,0),U,1)'="N" ;SET ONLY
.S D=$P($P(^AUPNGOAL(X,0),U,5),".")
.Q:D=""
.Q:D<BGPBDATE
.Q:D>BGPEDATE
.S Y=0 F S Y=$O(^AUPNGOAL(X,10,Y)) Q:Y'=+Y D
..S Z=$P($G(^AUPNGOAL(X,10,Y,0)),U,1)
..I Z S Z=$$VAL^XBDIQ1(9001002.4,Z,.01)
..I Z]"",$D(G(Z)) Q ;had a goal set for this type
..Q:Z=""
..S $P(BGPNSET(Z),U,1)=$P($G(BGPNSET(Z)),U,1)+1
..S $P(BGPNSET(Z),U,2)=$P(BGPNSET(Z),U,2)_$S($P(BGPNSET(Z),U,2)]"":",",1:"")_" "_$$DATE^BGP4UTL(D)_" - "_Z
Q
MAINTAIN ;
NEW D,%,X,Y,G
S X=0,%="",G=0
F S X=$O(^AUPNGOAL("AC",DFN,X)) Q:X'=+X!(%]"") D
.S G=""
.Q:'$D(^AUPNGOAL(X,0)) ;BAD XREF
.Q:$P(^AUPNGOAL(X,0),U,1)'="S" ;SET ONLY
.I $P(^AUPNGOAL(X,0),U,11)="MA" S G=1
.I $P(^AUPNGOAL(X,0),U,11)="A" S G=1
.Q:'G
.;DURING REPORT PERIOD MODIFIED DATE)
.S G=0
.S D=$P($P(^AUPNGOAL(X,0),U,5),".")
.I D'<BGPBDATE,D'>BGPEDATE S G=1
.Q:'G
.S Y=0 F S Y=$O(^AUPNGOAL(X,10,Y)) Q:Y'=+Y D
..S Z=$P($G(^AUPNGOAL(X,10,Y,0)),U,1)
..I Z S Z=$$VAL^XBDIQ1(9001002.4,Z,.01)
..Q:Z=""
..S $P(BGPMAIN(Z),U,1)=$P($G(BGPMAIN(Z)),U,1)+1
..S $P(BGPMAIN(Z),U,2)=$P(BGPMAIN(Z),U,2)_$S($P(BGPMAIN(Z),U,2)]"":",",1:"")_" "_$$DATE^BGP4UTL(D)_" - "_Z
..Q
Q
NOTMET ;
NEW D,%,X,Y,G
S X=0,%="",G=0
F S X=$O(^AUPNGOAL("AC",DFN,X)) Q:X'=+X!(%]"") D
.S G=0
.Q:'$D(^AUPNGOAL(X,0)) ;BAD XREF
.Q:$P(^AUPNGOAL(X,0),U,1)'="S" ;SET ONLY
.I $P(^AUPNGOAL(X,0),U,11)="S" S G=1
.Q:'G
.;DURING REPORT PERIOD MODIFIED DATE)
.S G=0
.S D=$P($P(^AUPNGOAL(X,0),U,5),".")
.I D'<BGPBDATE,D'>BGPEDATE S G=1
.Q:'G
.S Y=0 F S Y=$O(^AUPNGOAL(X,10,Y)) Q:Y'=+Y D
..S Z=$P($G(^AUPNGOAL(X,10,Y,0)),U,1)
..I Z S Z=$$VAL^XBDIQ1(9001002.4,Z,.01)
..Q:Z=""
..S $P(BGPNMET(Z),U,1)=$P($G(BGPNMET(Z)),U,1)+1
..S $P(BGPNMET(Z),U,2)=$P(BGPNMET(Z),U,2)_$S($P(BGPNMET(Z),U,2)]"":",",1:"")_" "_$$DATE^BGP4UTL(D)_" - "_Z
..Q
Q
MET ;
NEW D,%,X,Y
S X=0,%=""
F S X=$O(^AUPNGOAL("AC",DFN,X)) Q:X'=+X!(%]"") D
.Q:'$D(^AUPNGOAL(X,0)) ;BAD XREF
.Q:$P(^AUPNGOAL(X,0),U,1)'="S" ;SET ONLY
.Q:$P(^AUPNGOAL(X,0),U,11)'="ME"
.;DURING REPORT PERIOD MODIFIED DATE)
.S G=0
.S D=$P($P(^AUPNGOAL(X,0),U,5),".")
.I D'<BGPBDATE,D'>BGPEDATE S G=1
.Q:'G
.S Y=0 F S Y=$O(^AUPNGOAL(X,10,Y)) Q:Y'=+Y D
..S Z=$P($G(^AUPNGOAL(X,10,Y,0)),U,1)
..I Z S Z=$$VAL^XBDIQ1(9001002.4,Z,.01)
..Q:Z=""
..S $P(BGPMET(Z),U,1)=$P($G(BGPMET(Z)),U,1)+1
..S $P(BGPMET(Z),U,2)=$P(BGPMET(Z),U,2)_$S($P(BGPMET(Z),U,2)]"":",",1:"")_" "_$$DATE^BGP4UTL(D)_" - "_Z
..Q
Q
SET ;
NEW X,Y,Z,%,D
K BGPSET
S X=0,%=""
F S X=$O(^AUPNGOAL("AC",DFN,X)) Q:X'=+X D
.Q:'$D(^AUPNGOAL(X,0)) ;BAD XREF
.Q:$P(^AUPNGOAL(X,0),U,1)'="S" ;SET ONLY
.S D=$P($P(^AUPNGOAL(X,0),U,9),".")
.Q:D=""
.Q:D<BGPBDATE
.Q:D>BGPEDATE
.S Y=0 F S Y=$O(^AUPNGOAL(X,10,Y)) Q:Y'=+Y D
..S Z=$P($G(^AUPNGOAL(X,10,Y,0)),U,1)
..I Z S Z=$$VAL^XBDIQ1(9001002.4,Z,.01)
..Q:Z=""
..S $P(BGPSET(Z),U,1)=$P($G(BGPSET(Z)),U,1)+1
..S $P(BGPSET(Z),U,2)=$P(BGPSET(Z),U,2)_$S($P(BGPSET(Z),U,2)]"":",",1:"")_" "_$$DATE^BGP4UTL(D)_" - "_Z
Q
SET71 ;
I BGPTIME=2 D SET71P Q
I BGPTIME=3 D SET71B Q
I '$D(^BGPPEDCJ(BGPRPT,16,0)) S ^BGPPEDCJ(BGPRPT,16,0)="^90552.1216A^0^0"
S Z=$O(^BGPPEDCJ(BGPRPT,16,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDCJ(BGPRPT,16,Z,0),U,3)=$P(^BGPPEDCJ(BGPRPT,16,Z,0),U,3)+BGPC
S Z=$P(^BGPPEDCJ(BGPRPT,16,0),U,3)+BGPC,$P(^BGPPEDCJ(BGPRPT,16,0),U,3)=Z,$P(^BGPPEDCJ(BGPRPT,16,0),U,4)=Z
S ^BGPPEDCJ(BGPRPT,16,Z,0)=BGPT_U_BGPT_U_BGPC
S ^BGPPEDCJ(BGPRPT,16,"B",BGPT,Z)=""
Q
SET71P ;
I '$D(^BGPPEDPJ(BGPRPT,16,0)) S ^BGPPEDPJ(BGPRPT,16,0)="^90552.1316A^0^0"
S Z=$O(^BGPPEDPJ(BGPRPT,16,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDPJ(BGPRPT,16,Z,0),U,3)=$P(^BGPPEDPJ(BGPRPT,16,Z,0),U,3)+1
S Z=$P(^BGPPEDPJ(BGPRPT,16,0),U,3)+1,$P(^BGPPEDPJ(BGPRPT,16,0),U,3)=Z,$P(^BGPPEDPJ(BGPRPT,16,0),U,4)=Z
S ^BGPPEDPJ(BGPRPT,16,Z,0)=BGPT_U_BGPT_U_1
S ^BGPPEDPJ(BGPRPT,16,"B",BGPT,Z)=""
Q
SET71B ;
I '$D(^BGPPEDBJ(BGPRPT,16,0)) S ^BGPPEDBJ(BGPRPT,16,0)="^90552.1416A^0^0"
S Z=$O(^BGPPEDBJ(BGPRPT,16,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDBJ(BGPRPT,16,Z,0),U,3)=$P(^BGPPEDBJ(BGPRPT,16,Z,0),U,3)+1
S Z=$P(^BGPPEDBJ(BGPRPT,16,0),U,3)+1,$P(^BGPPEDBJ(BGPRPT,16,0),U,3)=Z,$P(^BGPPEDBJ(BGPRPT,16,0),U,4)=Z
S ^BGPPEDBJ(BGPRPT,16,Z,0)=BGPT_U_BGPT_U_1
S ^BGPPEDBJ(BGPRPT,16,"B",BGPT,Z)=""
Q
SET72 ;
I BGPTIME=2 D SET72P Q
I BGPTIME=3 D SET72B Q
I '$D(^BGPPEDCJ(BGPRPT,17,0)) S ^BGPPEDCJ(BGPRPT,17,0)="^90552.1217A^0^0"
S Z=$O(^BGPPEDCJ(BGPRPT,17,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDCJ(BGPRPT,17,Z,0),U,3)=$P(^BGPPEDCJ(BGPRPT,17,Z,0),U,3)+BGPC
S Z=$P(^BGPPEDCJ(BGPRPT,17,0),U,3)+BGPC,$P(^BGPPEDCJ(BGPRPT,17,0),U,3)=Z,$P(^BGPPEDCJ(BGPRPT,17,0),U,4)=Z
S ^BGPPEDCJ(BGPRPT,17,Z,0)=BGPT_U_BGPT_U_BGPC
S ^BGPPEDCJ(BGPRPT,17,"B",BGPT,Z)=""
Q
SET72P ;
I '$D(^BGPPEDPJ(BGPRPT,17,0)) S ^BGPPEDPJ(BGPRPT,17,0)="^90552.1317A^0^0"
S Z=$O(^BGPPEDPJ(BGPRPT,17,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDPJ(BGPRPT,17,Z,0),U,3)=$P(^BGPPEDPJ(BGPRPT,17,Z,0),U,3)+1
S Z=$P(^BGPPEDPJ(BGPRPT,17,0),U,3)+1,$P(^BGPPEDPJ(BGPRPT,17,0),U,3)=Z,$P(^BGPPEDPJ(BGPRPT,17,0),U,4)=Z
S ^BGPPEDPJ(BGPRPT,17,Z,0)=BGPT_U_BGPT_U_1
S ^BGPPEDPJ(BGPRPT,17,"B",BGPT,Z)=""
Q
SET72B ;
I '$D(^BGPPEDBJ(BGPRPT,17,0)) S ^BGPPEDBJ(BGPRPT,17,0)="^90552.1417A^0^0"
S Z=$O(^BGPPEDBJ(BGPRPT,17,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDBJ(BGPRPT,17,Z,0),U,3)=$P(^BGPPEDBJ(BGPRPT,17,Z,0),U,3)+1
S Z=$P(^BGPPEDBJ(BGPRPT,17,0),U,3)+1,$P(^BGPPEDBJ(BGPRPT,17,0),U,3)=Z,$P(^BGPPEDBJ(BGPRPT,17,0),U,4)=Z
S ^BGPPEDBJ(BGPRPT,17,Z,0)=BGPT_U_BGPT_U_1
S ^BGPPEDBJ(BGPRPT,17,"B",BGPT,Z)=""
Q
BGP4DPE2 ; IHS/CMI/LAB - calc measures 29 Apr 2010 7:38 PM 14 Nov 2006 5:02 PM 09 Jun 2014 5:18 PM ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+2 ;
5 ;EP
+1 ;no education so don't bother
IF '$DATA(^AUPNVPED("AC",DFN))
QUIT
+2 KILL BGPALLED,BGPEDPRV
SET BGPVALUE=""
+3 KILL BGPPROVS
+4 SET BGPFYCT=$ORDER(^BGPCTRL("B",2014,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
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^BGP4DPE1(BGPFYCT,T)
QUIT
+16 ;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
+17 ;SKIP IF NO PROVIDER DOCUMENTED
IF $PIECE(^AUPNVPED(Y,0),U,5)=""
QUIT
+18 SET P=$PIECE(^AUPNVPED(Y,0),U,5)
+19 SET D=$PIECE($GET(^VA(200,P,"PS")),U,5)
+20 ;no discipline to tally
IF 'D
QUIT
+21 SET BGPT=$PIECE($GET(^DIC(7,D,9999999)),U,1)
+22 ;not standard
IF BGPT=""
QUIT
+23 SET BGPT1=$PIECE(^DIC(7,D,0),U,1)
+24 ;I DUZ=5634,BGPTIME=1 S ^LORIPED0(Y)=""
+25 ;add to total # of topics
DO S(BGPRPT,BGPGBL,11,10,1)
+26 IF BGPTIME=1
DO SET51
+27 IF BGPTIME=2
DO SET52
+28 IF BGPTIME=3
DO SET53
+29 ;set PROVS For this patient
+30 SET BGPPROVS(BGPT1)=$GET(BGPPROVS(BGPT1))+1
+31 SET %=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U,5)
+32 ;I %="" S %=$P($G(^AUPNVPED(+$P(BGPALLED(X),U,4),12)),U,4)
+33 ;I %="" S %="UNKNOWN"
+34 IF %
SET BGPEDPRV(%)=""
End DoDot:1
+35 IF '$DATA(BGPPROVS)
QUIT
+36 SET BGPVALUE=""
+37 SET X=""
FOR
SET X=$ORDER(BGPPROVS(X))
IF X=""
QUIT
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_X_"-"_BGPPROVS(X)
+38 DO SETLIST
+39 QUIT
SET51 ;
+1 IF '$DATA(^BGPPEDCJ(BGPRPT,15,0))
SET ^BGPPEDCJ(BGPRPT,15,0)="^90552.1215A^0^0"
+2 SET Z=$ORDER(^BGPPEDCJ(BGPRPT,15,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDCJ(BGPRPT,15,Z,0),U,3)=$PIECE(^BGPPEDCJ(BGPRPT,15,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDCJ(BGPRPT,15,0),U,3)+1
SET $PIECE(^BGPPEDCJ(BGPRPT,15,0),U,3)=Z
SET $PIECE(^BGPPEDCJ(BGPRPT,15,0),U,4)=Z
+5 SET ^BGPPEDCJ(BGPRPT,15,Z,0)=BGPT_U_BGPT1_U_1
+6 SET ^BGPPEDCJ(BGPRPT,15,"B",BGPT,Z)=""
+7 QUIT
SET52 ;
+1 IF '$DATA(^BGPPEDPJ(BGPRPT,15,0))
SET ^BGPPEDPJ(BGPRPT,15,0)="^90552.1315A^0^0"
+2 SET Z=$ORDER(^BGPPEDPJ(BGPRPT,15,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDPJ(BGPRPT,15,Z,0),U,3)=$PIECE(^BGPPEDPJ(BGPRPT,15,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDPJ(BGPRPT,15,0),U,3)+1
SET $PIECE(^BGPPEDPJ(BGPRPT,15,0),U,3)=Z
SET $PIECE(^BGPPEDPJ(BGPRPT,15,0),U,4)=Z
+5 SET ^BGPPEDPJ(BGPRPT,15,Z,0)=BGPT_U_BGPT1_U_1
+6 SET ^BGPPEDPJ(BGPRPT,15,"B",BGPT,Z)=""
+7 QUIT
SET53 ;
+1 IF '$DATA(^BGPPEDBJ(BGPRPT,15,0))
SET ^BGPPEDBJ(BGPRPT,15,0)="^90552.1515A^0^0"
+2 SET Z=$ORDER(^BGPPEDBJ(BGPRPT,15,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDBJ(BGPRPT,15,Z,0),U,3)=$PIECE(^BGPPEDBJ(BGPRPT,15,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDBJ(BGPRPT,15,0),U,3)+1
SET $PIECE(^BGPPEDBJ(BGPRPT,15,0),U,3)=Z
SET $PIECE(^BGPPEDBJ(BGPRPT,15,0),U,4)=Z
+5 SET ^BGPPEDBJ(BGPRPT,15,Z,0)=BGPT_U_BGPT1_U_1
+6 SET ^BGPPEDBJ(BGPRPT,15,"B",BGPT,Z)=""
+7 QUIT
6 ;EP
+1 ;no education so don't bother
IF '$DATA(^AUPNVPED("AC",DFN))
QUIT
+2 KILL BGPALLED,BGPEDPRV
SET BGPVALUE=""
+3 KILL BGPPROVS
+4 SET BGPFYCT=$ORDER(^BGPCTRL("B",2014,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
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^BGP4DPE1(BGPFYCT,T)
QUIT
+16 ;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
+17 ;add to total # of topics
DO S(BGPRPT,BGPGBL,11,12,1)
+18 SET BGPLEVEL=$PIECE(^AUPNVPED(Y,0),U,6)
+19 IF BGPLEVEL=1
DO S(BGPRPT,BGPGBL,11,13,1)
+20 IF BGPLEVEL=2
DO S(BGPRPT,BGPGBL,11,14,1)
+21 IF BGPLEVEL=3
DO S(BGPRPT,BGPGBL,11,15,1)
+22 IF BGPLEVEL=5
DO S(BGPRPT,BGPGBL,11,16,1)
+23 IF BGPLEVEL=4
DO S(BGPRPT,BGPGBL,11,17,1)
+24 IF BGPLEVEL=""
DO S(BGPRPT,BGPGBL,11,18,1)
+25 ;set PROVS For this patient
+26 IF BGPLEVEL=""
SET BGPLEVEL="BLANK"
+27 SET BGPPROVS(BGPLEVEL)=$GET(BGPPROVS(BGPLEVEL))+1
+28 SET %=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U,5)
+29 ;I %="" S %=$P($G(^AUPNVPED(+$P(BGPALLED(X),U,4),12)),U,4)
+30 ;I %="" S %="UNKNOWN"
+31 IF %
SET BGPEDPRV(%)=""
End DoDot:1
+32 IF '$DATA(BGPPROVS)
QUIT
+33 SET BGPVALUE=""
+34 SET X=""
FOR
SET X=$ORDER(BGPPROVS(X))
IF X=""
QUIT
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_$SELECT(X:$$EXTSET^XBFUNC(9000010.16,.06,X),1:"BLANK-NOT RECORDED")_"-"_BGPPROVS(X)
+35 DO SETLIST
+36 QUIT
+37 ;
7 ;EP
+1 ;Q:'$D(^AUPNVPED("AC",DFN)) ;no education so don't bother
+2 KILL BGPALLED,BGPEDPRV
SET BGPVALUE=""
SET BGPVAX=""
+3 KILL BGPPROVS
+4 SET BGPFYCT=$ORDER(^BGPCTRL("B",2014,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))
GOTO PTG
+8 SET (X,D,G)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X
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^BGP4DPE1(BGPFYCT,T)
QUIT
+16 SET G=1
+17 SET BGPLEVEL=$PIECE(^AUPNVPED(Y,0),U,13)
+18 IF BGPLEVEL=""
QUIT
+19 ;count up
SET BGPPROVS(BGPLEVEL)=$GET(BGPPROVS(BGPLEVEL))+1
+20 ;get provider
+21 SET R=""
SET R=$PIECE(^AUPNVPED(Y,0),U,5)
Begin DoDot:2
+22 IF R]""
QUIT
+23 SET R=$PIECE($GET(^AUPNVPED(Y,12)),U,4)
+24 IF R]""
QUIT
+25 SET R=$PIECE($GET(^AUPNVPED(Y,12)),U,2)
+26 IF R]""
QUIT
+27 SET R=$$PRIMPROV^APCLV($PIECE(^AUPNVPED(Y,0),U,3),"I")
End DoDot:2
+28 IF R
Begin DoDot:2
+29 SET D=$$VALI^XBDIQ1(200,R,53.5)
+30 SET D=$SELECT(D:$$VAL^XBDIQ1(7,D,9999999.01),1:"")
+31 IF D=""
SET D="??"
+32 ;"; "_$$VAL^XBDIQ1(200,R,.01)_"-"_D
SET BGPPROVS(BGPLEVEL,"PROVS")=$GET(BGPPROVS(BGPLEVEL,"PROVS"))_"; "_$$DATE^BGP4UTL($$VD^APCLV($PIECE(^AUPNVPED(Y,0),U,3)))
End DoDot:2
End DoDot:1
+33 SET BGPVALUE=""
+34 ;no allowable topics
IF 'G
GOTO PTG
+35 SET BGPVAX=1
+36 ;add to total # of patients with a topic
DO S(BGPRPT,BGPGBL,11,19,1)
+37 IF '$DATA(BGPPROVS)
GOTO PTG
+38 IF $GET(BGPPROVS("GS"))
DO S(BGPRPT,BGPGBL,11,20,1)
SET BGPVALUE="GS"_$GET(BGPPROVS("GS","PROVS"))
+39 IF $GET(BGPPROVS("GNS"))
IF '$GET(BGPPROVS("GS"))
DO S(BGPRPT,BGPGBL,11,21,1)
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":", ",1:"")_"GNS"_$GET(BGPPROVS("GNS","PROVS"))
+40 IF $GET(BGPPROVS("GM"))
DO S(BGPRPT,BGPGBL,11,22,1)
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":", ",1:"")_"GM"_$GET(BGPPROVS("GM","PROVS"))
+41 IF $GET(BGPPROVS("GNM"))
IF '$GET(BGPPROVS("GM"))
DO S(BGPRPT,BGPGBL,11,23,1)
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":", ",1:"")_"GNM"_$GET(BGPPROVS("GNM","PROVS"))
+42 SET BGPVALUE="UP PED: "_BGPVALUE
PTG ;now do patient goals stuff
+1 ;user pop
DO S(BGPRPT,BGPGBL,11,29,1)
+2 ;did patient have a goal set with a start date in report period
+3 SET BGPVALU=""
+4 KILL BGPSET
+5 DO SET
+6 IF $DATA(BGPSET)
Begin DoDot:1
+7 DO S(BGPRPT,BGPGBL,11,24,1)
+8 SET BGPVALU=BGPVALU_$SELECT(BGPVALU]"":"; GS:",1:"GS:")
+9 SET BGPT=""
FOR
SET BGPT=$ORDER(BGPSET(BGPT))
IF BGPT=""
QUIT
SET BGPC=BGPSET(BGPT)
DO SET71
SET BGPVALU=BGPVALU_$SELECT($PIECE(BGPVALU,"GS:",2)="":"",1:", ")_$PIECE(BGPSET(BGPT),U,2)
End DoDot:1
+10 KILL BGPNSET
+11 DO NOTSET
+12 IF $DATA(BGPNSET)
Begin DoDot:1
+13 DO S(BGPRPT,BGPGBL,11,25,1)
+14 SET BGPVALU=BGPVALU_$SELECT(BGPVALU]"":"; GNS:",1:"GNS:")
+15 SET BGPT=""
FOR
SET BGPT=$ORDER(BGPNSET(BGPT))
IF BGPT=""
QUIT
SET BGPC=BGPNSET(BGPT)
DO SET72
SET BGPVALU=BGPVALU_$SELECT($PIECE(BGPVALU,"GNS:",2)="":"",1:", ")_$PIECE(BGPNSET(BGPT),U,2)
End DoDot:1
+16 ;MET
+17 KILL BGPMET
+18 DO MET
+19 IF $DATA(BGPMET)
Begin DoDot:1
+20 DO S(BGPRPT,BGPGBL,11,26,1)
+21 SET BGPVALU=BGPVALU_$SELECT(BGPVALU]"":"; GM:",1:"GM:")
+22 SET BGPT=""
FOR
SET BGPT=$ORDER(BGPMET(BGPT))
IF BGPT=""
QUIT
SET BGPC=BGPMET(BGPT)
DO SET73^BGP4DPE3
SET BGPVALU=BGPVALU_$SELECT($PIECE(BGPVALU,"GM:",2)="":"",1:", ")_$PIECE(BGPMET(BGPT),U,2)
End DoDot:1
+23 KILL BGPMAIN
+24 DO MAINTAIN
+25 IF $DATA(BGPMAIN)
Begin DoDot:1
+26 DO S(BGPRPT,BGPGBL,11,27,1)
+27 SET BGPVALU=BGPVALU_$SELECT(BGPVALU]"":"; GMaint:",1:"GMaint:")
+28 SET BGPT=""
FOR
SET BGPT=$ORDER(BGPMAIN(BGPT))
IF BGPT=""
QUIT
SET BGPC=BGPMAIN(BGPT)
DO SET74^BGP4DPE3
SET BGPVALU=BGPVALU_$SELECT($PIECE(BGPVALU,"GMaint:",2)="":"",1:", ")_$PIECE(BGPMAIN(BGPT),U,2)
End DoDot:1
+29 KILL BGPNMET
+30 DO NOTMET
+31 IF $DATA(BGPNMET)
Begin DoDot:1
+32 DO S(BGPRPT,BGPGBL,11,28,1)
+33 SET BGPVALU=BGPVALU_$SELECT(BGPVALU]"":"; GNM:",1:"GNM:")
+34 SET BGPT=""
FOR
SET BGPT=$ORDER(BGPNMET(BGPT))
IF BGPT=""
QUIT
SET BGPC=BGPNMET(BGPT)
DO SET75^BGP4DPE3
SET BGPVALU=BGPVALU_$SELECT($PIECE(BGPVALU,"GNM:",2)="":"",1:", ")_$PIECE(BGPNMET(BGPT),U,2)
End DoDot:1
+35 IF BGPVALU]""
SET BGPVALU=" UP: "_BGPVALU
+36 SET BGPVALUE=BGPVALU_" "_BGPVALUE_U_BGPVAX
+37 ;
+38 DO SETLIST
+39 KILL BGPSET,BGPNSET,BGPMET,BGPMAIN,BGPNMET
+40 QUIT
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 ;
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 IF BGPLIST="O"
IF '$DATA(BGPEDPRV(BGPEPRV))
QUIT
+5 SET BGPLIST(BGPIC)=$GET(BGPLIST(BGPIC))+1
+6 SET ^XTMP("BGP4PE",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)
+7 QUIT
NOTSET ;
+1 ;FIRST GATHER UP ALL SET GOALS AND GOAL TYPES
+2 KILL BGPNSET
+3 NEW X,Y,Z,%,D,G
+4 SET G=""
+5 SET X=0
SET %=""
+6 FOR
SET X=$ORDER(^AUPNGOAL("AC",DFN,X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+7 ;BAD XREF
IF '$DATA(^AUPNGOAL(X,0))
QUIT
+8 ;NOT SET ONLY
IF $PIECE(^AUPNGOAL(X,0),U,1)'="S"
QUIT
+9 SET D=$PIECE($PIECE(^AUPNGOAL(X,0),U,9),".")
+10 IF D=""
QUIT
+11 IF D<BGPBDATE
QUIT
+12 IF D>BGPEDATE
QUIT
+13 SET Y=0
FOR
SET Y=$ORDER(^AUPNGOAL(X,10,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+14 SET Z=$PIECE($GET(^AUPNGOAL(X,10,Y,0)),U,1)
+15 IF Z
SET G($$VAL^XBDIQ1(9001002.4,Z,.01))=""
End DoDot:2
End DoDot:1
+16 ;NOW CHECK GOALS NOT SET IN REPORT PERIOD AND CHECK TYPE
+17 SET X=0
SET %=""
+18 FOR
SET X=$ORDER(^AUPNGOAL("AC",DFN,X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+19 ;BAD XREF
IF '$DATA(^AUPNGOAL(X,0))
QUIT
+20 ;SET ONLY
IF $PIECE(^AUPNGOAL(X,0),U,1)'="N"
QUIT
+21 SET D=$PIECE($PIECE(^AUPNGOAL(X,0),U,5),".")
+22 IF D=""
QUIT
+23 IF D<BGPBDATE
QUIT
+24 IF D>BGPEDATE
QUIT
+25 SET Y=0
FOR
SET Y=$ORDER(^AUPNGOAL(X,10,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+26 SET Z=$PIECE($GET(^AUPNGOAL(X,10,Y,0)),U,1)
+27 IF Z
SET Z=$$VAL^XBDIQ1(9001002.4,Z,.01)
+28 ;had a goal set for this type
IF Z]""
IF $DATA(G(Z))
QUIT
+29 IF Z=""
QUIT
+30 SET $PIECE(BGPNSET(Z),U,1)=$PIECE($GET(BGPNSET(Z)),U,1)+1
+31 SET $PIECE(BGPNSET(Z),U,2)=$PIECE(BGPNSET(Z),U,2)_$SELECT($PIECE(BGPNSET(Z),U,2)]"":",",1:"")_" "_$$DATE^BGP4UTL(D)_" - "_Z
End DoDot:2
End DoDot:1
+32 QUIT
MAINTAIN ;
+1 NEW D,%,X,Y,G
+2 SET X=0
SET %=""
SET G=0
+3 FOR
SET X=$ORDER(^AUPNGOAL("AC",DFN,X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+4 SET G=""
+5 ;BAD XREF
IF '$DATA(^AUPNGOAL(X,0))
QUIT
+6 ;SET ONLY
IF $PIECE(^AUPNGOAL(X,0),U,1)'="S"
QUIT
+7 IF $PIECE(^AUPNGOAL(X,0),U,11)="MA"
SET G=1
+8 IF $PIECE(^AUPNGOAL(X,0),U,11)="A"
SET G=1
+9 IF 'G
QUIT
+10 ;DURING REPORT PERIOD MODIFIED DATE)
+11 SET G=0
+12 SET D=$PIECE($PIECE(^AUPNGOAL(X,0),U,5),".")
+13 IF D'<BGPBDATE
IF D'>BGPEDATE
SET G=1
+14 IF 'G
QUIT
+15 SET Y=0
FOR
SET Y=$ORDER(^AUPNGOAL(X,10,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+16 SET Z=$PIECE($GET(^AUPNGOAL(X,10,Y,0)),U,1)
+17 IF Z
SET Z=$$VAL^XBDIQ1(9001002.4,Z,.01)
+18 IF Z=""
QUIT
+19 SET $PIECE(BGPMAIN(Z),U,1)=$PIECE($GET(BGPMAIN(Z)),U,1)+1
+20 SET $PIECE(BGPMAIN(Z),U,2)=$PIECE(BGPMAIN(Z),U,2)_$SELECT($PIECE(BGPMAIN(Z),U,2)]"":",",1:"")_" "_$$DATE^BGP4UTL(D)_" - "_Z
+21 QUIT
End DoDot:2
End DoDot:1
+22 QUIT
NOTMET ;
+1 NEW D,%,X,Y,G
+2 SET X=0
SET %=""
SET G=0
+3 FOR
SET X=$ORDER(^AUPNGOAL("AC",DFN,X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+4 SET G=0
+5 ;BAD XREF
IF '$DATA(^AUPNGOAL(X,0))
QUIT
+6 ;SET ONLY
IF $PIECE(^AUPNGOAL(X,0),U,1)'="S"
QUIT
+7 IF $PIECE(^AUPNGOAL(X,0),U,11)="S"
SET G=1
+8 IF 'G
QUIT
+9 ;DURING REPORT PERIOD MODIFIED DATE)
+10 SET G=0
+11 SET D=$PIECE($PIECE(^AUPNGOAL(X,0),U,5),".")
+12 IF D'<BGPBDATE
IF D'>BGPEDATE
SET G=1
+13 IF 'G
QUIT
+14 SET Y=0
FOR
SET Y=$ORDER(^AUPNGOAL(X,10,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+15 SET Z=$PIECE($GET(^AUPNGOAL(X,10,Y,0)),U,1)
+16 IF Z
SET Z=$$VAL^XBDIQ1(9001002.4,Z,.01)
+17 IF Z=""
QUIT
+18 SET $PIECE(BGPNMET(Z),U,1)=$PIECE($GET(BGPNMET(Z)),U,1)+1
+19 SET $PIECE(BGPNMET(Z),U,2)=$PIECE(BGPNMET(Z),U,2)_$SELECT($PIECE(BGPNMET(Z),U,2)]"":",",1:"")_" "_$$DATE^BGP4UTL(D)_" - "_Z
+20 QUIT
End DoDot:2
End DoDot:1
+21 QUIT
MET ;
+1 NEW D,%,X,Y
+2 SET X=0
SET %=""
+3 FOR
SET X=$ORDER(^AUPNGOAL("AC",DFN,X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+4 ;BAD XREF
IF '$DATA(^AUPNGOAL(X,0))
QUIT
+5 ;SET ONLY
IF $PIECE(^AUPNGOAL(X,0),U,1)'="S"
QUIT
+6 IF $PIECE(^AUPNGOAL(X,0),U,11)'="ME"
QUIT
+7 ;DURING REPORT PERIOD MODIFIED DATE)
+8 SET G=0
+9 SET D=$PIECE($PIECE(^AUPNGOAL(X,0),U,5),".")
+10 IF D'<BGPBDATE
IF D'>BGPEDATE
SET G=1
+11 IF 'G
QUIT
+12 SET Y=0
FOR
SET Y=$ORDER(^AUPNGOAL(X,10,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+13 SET Z=$PIECE($GET(^AUPNGOAL(X,10,Y,0)),U,1)
+14 IF Z
SET Z=$$VAL^XBDIQ1(9001002.4,Z,.01)
+15 IF Z=""
QUIT
+16 SET $PIECE(BGPMET(Z),U,1)=$PIECE($GET(BGPMET(Z)),U,1)+1
+17 SET $PIECE(BGPMET(Z),U,2)=$PIECE(BGPMET(Z),U,2)_$SELECT($PIECE(BGPMET(Z),U,2)]"":",",1:"")_" "_$$DATE^BGP4UTL(D)_" - "_Z
+18 QUIT
End DoDot:2
End DoDot:1
+19 QUIT
SET ;
+1 NEW X,Y,Z,%,D
+2 KILL BGPSET
+3 SET X=0
SET %=""
+4 FOR
SET X=$ORDER(^AUPNGOAL("AC",DFN,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 ;BAD XREF
IF '$DATA(^AUPNGOAL(X,0))
QUIT
+6 ;SET ONLY
IF $PIECE(^AUPNGOAL(X,0),U,1)'="S"
QUIT
+7 SET D=$PIECE($PIECE(^AUPNGOAL(X,0),U,9),".")
+8 IF D=""
QUIT
+9 IF D<BGPBDATE
QUIT
+10 IF D>BGPEDATE
QUIT
+11 SET Y=0
FOR
SET Y=$ORDER(^AUPNGOAL(X,10,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+12 SET Z=$PIECE($GET(^AUPNGOAL(X,10,Y,0)),U,1)
+13 IF Z
SET Z=$$VAL^XBDIQ1(9001002.4,Z,.01)
+14 IF Z=""
QUIT
+15 SET $PIECE(BGPSET(Z),U,1)=$PIECE($GET(BGPSET(Z)),U,1)+1
+16 SET $PIECE(BGPSET(Z),U,2)=$PIECE(BGPSET(Z),U,2)_$SELECT($PIECE(BGPSET(Z),U,2)]"":",",1:"")_" "_$$DATE^BGP4UTL(D)_" - "_Z
End DoDot:2
End DoDot:1
+17 QUIT
SET71 ;
+1 IF BGPTIME=2
DO SET71P
QUIT
+2 IF BGPTIME=3
DO SET71B
QUIT
+3 IF '$DATA(^BGPPEDCJ(BGPRPT,16,0))
SET ^BGPPEDCJ(BGPRPT,16,0)="^90552.1216A^0^0"
+4 SET Z=$ORDER(^BGPPEDCJ(BGPRPT,16,"B",BGPT,0))
IF Z
Begin DoDot:1
+5 SET $PIECE(^BGPPEDCJ(BGPRPT,16,Z,0),U,3)=$PIECE(^BGPPEDCJ(BGPRPT,16,Z,0),U,3)+BGPC
End DoDot:1
QUIT
+6 SET Z=$PIECE(^BGPPEDCJ(BGPRPT,16,0),U,3)+BGPC
SET $PIECE(^BGPPEDCJ(BGPRPT,16,0),U,3)=Z
SET $PIECE(^BGPPEDCJ(BGPRPT,16,0),U,4)=Z
+7 SET ^BGPPEDCJ(BGPRPT,16,Z,0)=BGPT_U_BGPT_U_BGPC
+8 SET ^BGPPEDCJ(BGPRPT,16,"B",BGPT,Z)=""
+9 QUIT
SET71P ;
+1 IF '$DATA(^BGPPEDPJ(BGPRPT,16,0))
SET ^BGPPEDPJ(BGPRPT,16,0)="^90552.1316A^0^0"
+2 SET Z=$ORDER(^BGPPEDPJ(BGPRPT,16,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDPJ(BGPRPT,16,Z,0),U,3)=$PIECE(^BGPPEDPJ(BGPRPT,16,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDPJ(BGPRPT,16,0),U,3)+1
SET $PIECE(^BGPPEDPJ(BGPRPT,16,0),U,3)=Z
SET $PIECE(^BGPPEDPJ(BGPRPT,16,0),U,4)=Z
+5 SET ^BGPPEDPJ(BGPRPT,16,Z,0)=BGPT_U_BGPT_U_1
+6 SET ^BGPPEDPJ(BGPRPT,16,"B",BGPT,Z)=""
+7 QUIT
SET71B ;
+1 IF '$DATA(^BGPPEDBJ(BGPRPT,16,0))
SET ^BGPPEDBJ(BGPRPT,16,0)="^90552.1416A^0^0"
+2 SET Z=$ORDER(^BGPPEDBJ(BGPRPT,16,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDBJ(BGPRPT,16,Z,0),U,3)=$PIECE(^BGPPEDBJ(BGPRPT,16,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDBJ(BGPRPT,16,0),U,3)+1
SET $PIECE(^BGPPEDBJ(BGPRPT,16,0),U,3)=Z
SET $PIECE(^BGPPEDBJ(BGPRPT,16,0),U,4)=Z
+5 SET ^BGPPEDBJ(BGPRPT,16,Z,0)=BGPT_U_BGPT_U_1
+6 SET ^BGPPEDBJ(BGPRPT,16,"B",BGPT,Z)=""
+7 QUIT
SET72 ;
+1 IF BGPTIME=2
DO SET72P
QUIT
+2 IF BGPTIME=3
DO SET72B
QUIT
+3 IF '$DATA(^BGPPEDCJ(BGPRPT,17,0))
SET ^BGPPEDCJ(BGPRPT,17,0)="^90552.1217A^0^0"
+4 SET Z=$ORDER(^BGPPEDCJ(BGPRPT,17,"B",BGPT,0))
IF Z
Begin DoDot:1
+5 SET $PIECE(^BGPPEDCJ(BGPRPT,17,Z,0),U,3)=$PIECE(^BGPPEDCJ(BGPRPT,17,Z,0),U,3)+BGPC
End DoDot:1
QUIT
+6 SET Z=$PIECE(^BGPPEDCJ(BGPRPT,17,0),U,3)+BGPC
SET $PIECE(^BGPPEDCJ(BGPRPT,17,0),U,3)=Z
SET $PIECE(^BGPPEDCJ(BGPRPT,17,0),U,4)=Z
+7 SET ^BGPPEDCJ(BGPRPT,17,Z,0)=BGPT_U_BGPT_U_BGPC
+8 SET ^BGPPEDCJ(BGPRPT,17,"B",BGPT,Z)=""
+9 QUIT
SET72P ;
+1 IF '$DATA(^BGPPEDPJ(BGPRPT,17,0))
SET ^BGPPEDPJ(BGPRPT,17,0)="^90552.1317A^0^0"
+2 SET Z=$ORDER(^BGPPEDPJ(BGPRPT,17,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDPJ(BGPRPT,17,Z,0),U,3)=$PIECE(^BGPPEDPJ(BGPRPT,17,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDPJ(BGPRPT,17,0),U,3)+1
SET $PIECE(^BGPPEDPJ(BGPRPT,17,0),U,3)=Z
SET $PIECE(^BGPPEDPJ(BGPRPT,17,0),U,4)=Z
+5 SET ^BGPPEDPJ(BGPRPT,17,Z,0)=BGPT_U_BGPT_U_1
+6 SET ^BGPPEDPJ(BGPRPT,17,"B",BGPT,Z)=""
+7 QUIT
SET72B ;
+1 IF '$DATA(^BGPPEDBJ(BGPRPT,17,0))
SET ^BGPPEDBJ(BGPRPT,17,0)="^90552.1417A^0^0"
+2 SET Z=$ORDER(^BGPPEDBJ(BGPRPT,17,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDBJ(BGPRPT,17,Z,0),U,3)=$PIECE(^BGPPEDBJ(BGPRPT,17,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDBJ(BGPRPT,17,0),U,3)+1
SET $PIECE(^BGPPEDBJ(BGPRPT,17,0),U,3)=Z
SET $PIECE(^BGPPEDBJ(BGPRPT,17,0),U,4)=Z
+5 SET ^BGPPEDBJ(BGPRPT,17,Z,0)=BGPT_U_BGPT_U_1
+6 SET ^BGPPEDBJ(BGPRPT,17,"B",BGPT,Z)=""
+7 QUIT
