BGP6DPED ; IHS/CMI/LAB - IHS gpra print 10 Apr 2016 2:46 PM ; 27 Jan 2016 12:37 PM
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
;
PRINT ;
DEL ;EP - create delimited output file
S BGPRTYPE=6,BGPRPTH=""
K ^TMP($J)
S ^TMP($J,"BGPDEL",0)=0
D ^BGP6PDLH
K BGPSUMP
D DEL1
D ^BGP6DPEE ;print lists to delimited file
;if screen selected do screen
I BGPDELT="S" D SCREEN,EXIT Q
;call xbgsave to create output file
S XBGL="BGPDATA"
L +^BGPDATA:300 E W:'$D(ZTQUEUED) "Unable to lock global" Q
K ^BGPDATA ;global for saving
S X=0 F S X=$O(^TMP($J,"BGPDEL",X)) Q:X'=+X S ^BGPDATA(X)=^TMP($J,"BGPDEL",X)
I '$D(BGPGUI) D
.;S XBUF=BGPUF
.S XBFLT=1,XBFN=BGPDELF_".txt",XBMED="F",XBTLE="GPRA 16 DELIMITED PT ED OUTPUT",XBQ="N",XBF=0
.D ^XBGSAVE
.K XBFLT,XBFN,XBMED,XBTLE,XBE,XBF
I $D(BGPGUI) D
.S (C,X)=0 F S X=$O(^BGPDATA(X)) Q:X'=+X S C=C+1,^BGPGUIM(BGPGIEN,12,C,0)=^BGPDATA(X)
.S ^BGPGUIM(BGPGIEN,12,0)="^90556.1912^"_C_"^"_C_"^"_DT
L -^BGPDATA
K ^BGPDATA ;export global
D EXIT
Q
;
SCREEN ;
S X=0 F S X=$O(^TMP($J,"BGPDEL",X)) Q:X'=+X W !,^TMP($J,"BGPDEL",X)
Q
DEL1 ;EP
S BGPIC=0 F S BGPIC=$O(BGPIND(BGPIC)) Q:BGPIC="" D
.;now print individual measure
.D S(" ",1,1),S(" ",1,1)
.S X=$P(^BGPPEIM(BGPIC,0),U,2) D S(X,1,1)
.D S(" ",1,1)
.I $G(BGPDNT) G CALC
.S X="Denominator(s):" D S(X,1,1)
.S BGPX=0 F S BGPX=$O(^BGPPEIM(BGPIC,61,"B",BGPX)) Q:BGPX'=+BGPX D
..S BGPY=0 F S BGPY=$O(^BGPPEIM(BGPIC,61,"B",BGPX,BGPY)) Q:BGPY'=+BGPY D
...S BGPZ=0 F S BGPZ=$O(^BGPPEIM(BGPIC,61,BGPY,11,BGPZ)) Q:BGPZ'=+BGPZ D
....S Y=^BGPPEIM(BGPIC,61,BGPY,11,BGPZ,0) S:BGPZ=1 Y=" - "_Y D S(Y,1,1)
....Q
...Q
..Q
.D S(" ",1,1)
.S X="Numerator(s):" D S(X,1,1)
.S BGPX=0 F S BGPX=$O(^BGPPEIM(BGPIC,62,"B",BGPX)) Q:BGPX'=+BGPX D
..S BGPY=0 F S BGPY=$O(^BGPPEIM(BGPIC,62,"B",BGPX,BGPY)) Q:BGPY'=+BGPY D
...S BGPZ=0 F S BGPZ=$O(^BGPPEIM(BGPIC,62,BGPY,11,BGPZ)) Q:BGPZ'=+BGPZ D
....S X=^BGPPEIM(BGPIC,62,BGPY,11,BGPZ,0) S:BGPZ=1 X=" - "_X D S(X,1,1)
....Q
...Q
..Q
.D S(" ",1,1)
.S BGPNODE=11
.S BGPX=0 F S BGPX=$O(^BGPPEIM(BGPIC,BGPNODE,BGPX)) Q:BGPX'=+BGPX D
..S X=^BGPPEIM(BGPIC,BGPNODE,BGPX,0) D S(X,1,1)
CALC .D @BGPIC
Q
EXIT ;
K ^TMP($J)
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
S(Y,F,P) ;EP set up array
I '$G(F) S F=0
S %=$P(^TMP($J,"BGPDEL",0),U)+F,$P(^TMP($J,"BGPDEL",0),U)=%
I '$D(^TMP($J,"BGPDEL",%)) S ^TMP($J,"BGPDEL",%)=""
S $P(^TMP($J,"BGPDEL",%),U,P)=Y
Q
C(X,X2,X3) ;
D COMMA^%DTC
Q X
;
1 ;
D S(" ",1,1) ;S X=$P(^BGPPEIM(BGPIC,0),U,2) D S(X,1,1)
D H1^BGP6PDL1
D S(" ",1,1)
S BGPCYD=$$V(1,BGPRPT,11,1)
S BGPPRD=$$V(2,BGPRPT,11,1)
S BGPBLD=$$V(3,BGPRPT,11,1)
I $G(BGPSEAT) S X=$P(^DIBT(BGPSEAT,0),U,1)_" Population" D S(X,1,1)
I '$G(BGPSEAT) S X="User Pop" D S(X,1,1)
S Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD D S(Y,,2)
D S(" ",1,1)
S N=11,P=2 D SETN
S X="# w/ Patient Ed" D S(X,1,1)
D H2^BGP6PDL1
Q
2 ;
D S(" ",1,1) D S(" ",1,1) ;S X=$P(^BGPPEIM(BGPIC,0),U,2) D S(X,1,1)
D H1^BGP6PDL1
D S(" ",1,1)
S BGPCYD=$$V(1,BGPRPT,11,7)
S BGPPRD=$$V(2,BGPRPT,11,7)
S BGPBLD=$$V(3,BGPRPT,11,7)
I $G(BGPSEAT) S X=$P(^DIBT(BGPSEAT,0),U,1)_" Population" D S(X,1,1)
S X="Total Time Spent" D S(X,1,1) S X="Providing Education (mins)" D S(X,1,1)
S Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD D S(Y,,2)
D S(" ",1,1)
K BGPPROVS
S N=12 D SETNM
K BGPX
S X="",C=0 F S X=$O(BGPPROVS(X)) Q:X="" S Y="" F S Y=$O(BGPPROVS(X,Y)) Q:Y="" S C=C+1 S BGPX((9999999-$P(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)
S BGP1=0,BGPCNT=0 F S BGP1=$O(BGPX(BGP1)) Q:BGP1'=+BGP1 D
.S BGP2=0 F S BGP2=$O(BGPX(BGP1,BGP2)) Q:BGP2'=+BGP2 D
..S X=$P(BGPX(BGP1,BGP2),U,2) D S(X,1,1)
..S BGPCYN=$P(BGPX(BGP1,BGP2),U,3)
..S BGPPRN=$P(BGPX(BGP1,BGP2),U,4)
..S BGPBLN=$P(BGPX(BGP1,BGP2),U,5)
..S BGPCYP=$P(BGPX(BGP1,BGP2),U,6)
..S BGPPRP=$P(BGPX(BGP1,BGP2),U,7)
..S BGPBLP=$P(BGPX(BGP1,BGP2),U,8)
..D H2^BGP6PDL1
I '$G(BGPAREAA) D
.S BGPAA=$$V(1,BGPRPT,11,7)
.S BGPAB=$$V(2,BGPRPT,11,7)
.S BGPAC=$$V(3,BGPRPT,11,7)
.S BGPCYN=$$V(1,BGPRPT,11,6)
.S BGPPRN=$$V(2,BGPRPT,11,6)
.S BGPBLN=$$V(3,BGPRPT,11,6)
.S BGPCYD=$$V(1,BGPRPT,11,3)
.S BGPPRD=$$V(2,BGPRPT,11,3)
.S BGPBLD=$$V(3,BGPRPT,11,3)
I $G(BGPAREAA) D
.S BGPAA=$$V(1,BGPRPT,11,7)
.S BGPAB=$$V(2,BGPRPT,11,7)
.S BGPAC=$$V(3,BGPRPT,11,7)
.S BGPCYN=$$V(1,BGPRPT,11,6)
.S BGPPRN=$$V(2,BGPRPT,11,6)
.S BGPBLN=$$V(3,BGPRPT,11,6)
.S BGPCYD=$S(BGPAA:BGPAA/BGPCYN,1:0)
.S BGPPRD=$S(BGPAB:BGPAB/BGPPRN,1:0)
.S BGPBLD=$S(BGPAC:BGPAC/BGPBLN,1:0)
S X="" D S(X,1,1)
D S("Total # of Minutes recorded",1,1) D S("for All Providers",1,1)
S Y=BGPAA_"^^"_BGPAB_"^^^"_BGPAC D S(Y,,2)
D S("Total # of Pt Ed Codes with Provider",1,1) D S("and minutes recorded",1,1)
S Y=BGPCYN_"^^"_BGPPRN_"^^^"_BGPBLN D S(Y,,2)
D S(" ",1,1)
S X="Average Time Spent" D S(X,1,1) S X="All Providers (minutes)" D S(X,1,1)
S Y=$$SL(BGPCYD)_"^^"_$$SL(BGPPRD)_"^^^"_$$SL(BGPBLD) D S(Y,,2)
I '$G(BGPAREAA) D
.S BGPCYD=$$V(1,BGPRPT,11,4)
.S BGPPRD=$$V(2,BGPRPT,11,4)
.S BGPBLD=$$V(3,BGPRPT,11,4)
I $G(BGPAREAA) D
.S BGPCYD=999999999,BGPBLD=999999999,BGPPRD=999999999
.S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
..I $P($G(^BGPPEDCM(X,11)),U,4)]"",$P(^BGPPEDCM(X,11),U,4)<BGPCYD S BGPCYD=$P(^BGPPEDCM(X,11),U,4)
..I $P($G(^BGPPEDPM(X,11)),U,4)]"",$P(^BGPPEDPM(X,11),U,4)<BGPPRD S BGPPRD=$P(^BGPPEDPM(X,11),U,4)
..I $P($G(^BGPPEDBM(X,11)),U,4)]"",$P(^BGPPEDBM(X,11),U,4)<BGPBLD S BGPBLD=$P(^BGPPEDBM(X,11),U,4)
.I BGPCYD=999999999 S BGPCYD=0
.I BGPBLD=999999999 S BGPBLD=0
.I BGPPRD=999999999 S BGPPRD=0
S X="" D S(X,1,1)
S X="Minimum Time Spent" D S(X,2,1) S X="All Providers (minutes)" D S(X,1,1)
S Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD D S(Y,,2)
I '$G(BGPAREAA) D
.S BGPCYD=$$V(1,BGPRPT,11,5)
.S BGPPRD=$$V(2,BGPRPT,11,5)
.S BGPBLD=$$V(3,BGPRPT,11,5)
I $G(BGPAREAA) D
.S (BGPCYD,BGPPRD,BGPBLD)=0
.S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
..I $P($G(^BGPPEDCM(X,11)),U,5)>BGPCYD S BGPCYD=$P(^BGPPEDCM(X,11),U,5)
..I $P($G(^BGPPEDPM(X,11)),U,5)>BGPPRD S BGPPRD=$P(^BGPPEDPM(X,11),U,5)
..I $P($G(^BGPPEDBM(X,11)),U,5)>BGPBLD S BGPBLD=$P(^BGPPEDBM(X,11),U,5)
S X="" D S(X,1,1)
S X="Maximum Time Spent" D S(X,1,1) S X="All Providers (minutes)" D S(X,1,1)
S Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD D S(Y,,2)
Q
3 ;
S X=""
D S(" ",1,1) D S(" ",1,1) ;S X=$P(^BGPPEIM(BGPIC,0),U,2) D S(X,1,1)
D H1^BGP6PDL1
D S(" ",1,1)
S BGPCYD=$$V(1,BGPRPT,11,8)
S BGPPRD=$$V(2,BGPRPT,11,8)
S BGPBLD=$$V(3,BGPRPT,11,8)
I $G(BGPSEAT) S X=$P(^DIBT(BGPSEAT,0),U,1)_" Population" D S(X,1,1)
S X="Total # Education Codes" D S(X,1,1)
S Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD D S(Y,,2)
D S(" ",1,1)
K BGPPROVS
S N=13 D SETNM
K BGPX
S BGPCNT=0
S X="",C=0 F S X=$O(BGPPROVS(X)) Q:X="" S Y="" F S Y=$O(BGPPROVS(X,Y)) Q:Y="" S C=C+1 S BGPX((9999999-$P(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)
S BGP1=0 F S BGP1=$O(BGPX(BGP1)) Q:BGP1'=+BGP1!(BGPCNT>24) D
.S BGPCNT=BGPCNT+1 S BGP2=0 F S BGP2=$O(BGPX(BGP1,BGP2)) Q:BGP2'=+BGP2 D
..S X=BGPCNT_". "_$P(BGPX(BGP1,BGP2),U,2) D S(X,1,1)
..S BGPCYN=$P(BGPX(BGP1,BGP2),U,3)
..S BGPPRN=$P(BGPX(BGP1,BGP2),U,4)
..S BGPBLN=$P(BGPX(BGP1,BGP2),U,5)
..S BGPCYP=$P(BGPX(BGP1,BGP2),U,6)
..S BGPPRP=$P(BGPX(BGP1,BGP2),U,7)
..S BGPBLP=$P(BGPX(BGP1,BGP2),U,8)
..D H2^BGP6PDL1
Q
4 ;
S X=""
D S(" ",1,1) D S(" ",1,1) ;S X=$P(^BGPPEIM(BGPIC,0),U,2) D S(X,1,1)
D H1^BGP6PDL1
D S(" ",1,1)
S BGPCYD=$$V(1,BGPRPT,11,9)
S BGPPRD=$$V(2,BGPRPT,11,9)
S BGPBLD=$$V(3,BGPRPT,11,9)
I $G(BGPSEAT) S X=$P(^DIBT(BGPSEAT,0),U,1)_" Population" D S(X,1,1)
S X="Total # Education Codes" D S(X,1,1)
S Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD D S(Y,,2)
D S(" ",1,1)
K BGPPROVS
S N=14 D SETNM
K BGPX
S BGPCNT=0
S X="",C=0 F S X=$O(BGPPROVS(X)) Q:X="" S Y="" F S Y=$O(BGPPROVS(X,Y)) Q:Y="" S C=C+1 S BGPX((9999999-$P(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)
S BGP1=0 F S BGP1=$O(BGPX(BGP1)) Q:BGP1'=+BGP1!(BGPCNT>24) D
.S BGPCNT=BGPCNT+1 S BGP2=0 F S BGP2=$O(BGPX(BGP1,BGP2)) Q:BGP2'=+BGP2 D
..S X=BGPCNT_". "_$P(BGPX(BGP1,BGP2),U,2) D S(X,1,1)
..S BGPCYN=$P(BGPX(BGP1,BGP2),U,3)
..S BGPPRN=$P(BGPX(BGP1,BGP2),U,4)
..S BGPBLN=$P(BGPX(BGP1,BGP2),U,5)
..S BGPCYP=$P(BGPX(BGP1,BGP2),U,6)
..S BGPPRP=$P(BGPX(BGP1,BGP2),U,7)
..S BGPBLP=$P(BGPX(BGP1,BGP2),U,8)
..D H2^BGP6PDL1
Q
5 ;
S X=""
D S(" ",1,1) D S(" ",1,1) ;S X=$P(^BGPPEIM(BGPIC,0),U,2) D S(X,1,1)
D H1^BGP6PDL1
D S(" ",1,1)
S BGPCYD=$$V(1,BGPRPT,11,10)
S BGPPRD=$$V(2,BGPRPT,11,10)
S BGPBLD=$$V(3,BGPRPT,11,10)
I $G(BGPSEAT) S X=$P(^DIBT(BGPSEAT,0),U,1)_" Population" D S(X,1,1)
S X="Total # Education Codes" D S(X,1,1)
S Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD D S(Y,,2)
D S(" ",1,1)
K BGPPROVS
S N=15 D SETNM
K BGPX
S BGPCNT=0
S X="",C=0 F S X=$O(BGPPROVS(X)) Q:X="" S Y="" F S Y=$O(BGPPROVS(X,Y)) Q:Y="" S C=C+1 S BGPX((9999999-$P(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)
S BGP1=0 F S BGP1=$O(BGPX(BGP1)) Q:BGP1'=+BGP1!(BGPCNT>15) D
.S BGPCNT=BGPCNT+1 S BGP2=0 F S BGP2=$O(BGPX(BGP1,BGP2)) Q:BGP2'=+BGP2 D
..S X=BGPCNT_". "_$P(BGPX(BGP1,BGP2),U,2) D S(X,1,1)
..S BGPCYN=$P(BGPX(BGP1,BGP2),U,3)
..S BGPPRN=$P(BGPX(BGP1,BGP2),U,4)
..S BGPBLN=$P(BGPX(BGP1,BGP2),U,5)
..S BGPCYP=$P(BGPX(BGP1,BGP2),U,6)
..S BGPPRP=$P(BGPX(BGP1,BGP2),U,7)
..S BGPBLP=$P(BGPX(BGP1,BGP2),U,8)
..D H2^BGP6PDL1
Q
6 ;
S X=""
D S(" ",1,1) D S(" ",1,1) ;S X=$P(^BGPPEIM(BGPIC,0),U,2) D S(X,1,1)
D H1^BGP6PDL1
D S(" ",1,1)
S BGPCYD=$$V(1,BGPRPT,11,12)
S BGPPRD=$$V(2,BGPRPT,11,12)
S BGPBLD=$$V(3,BGPRPT,11,12)
I $G(BGPSEAT) S X=$P(^DIBT(BGPSEAT,0),U,1)_" Population" D S(X,1,1)
S X="Total # Education Codes" D S(X,1,1)
S Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD D S(Y,,2)
D S(" ",1,1)
S X="Patient Understanding" D S(X,1,1)
S N=11,P=15 D SETN
S X="Good" D S(X,1,1)
D H2^BGP6PDL1
S N=11,P=14 D SETN
S X="Fair" D S(X,1,1)
D H2^BGP6PDL1
S N=11,P=13 D SETN
S X="Poor" D S(X,1,1)
D H2^BGP6PDL1
S N=11,P=16 D SETN
S X="Refused" D S(X,1,1)
D H2^BGP6PDL1
S N=11,P=17 D SETN
S X="Group-No Assessment" D S(X,1,1)
D H2^BGP6PDL1
S N=11,P=18 D SETN
S X="Blank (Not recorded)" D S(X,1,1)
D H2^BGP6PDL1
Q
7 ;
D 7^BGP6DPEF
Q
KITM ;
K ^TMP($J)
K ^XTMP("BGP6PE",BGPJ,BGPH)
Q
SETNM ;
K BGPPROVS
I $G(BGPAREAA) D SETNMA Q
S X=0 F S X=$O(^BGPPEDCM(BGPRPT,N,X)) Q:X'=+X D
.S C=$P(^BGPPEDCM(BGPRPT,N,X,0),U),L=$P(^BGPPEDCM(BGPRPT,N,X,0),U,2),M=$P(^BGPPEDCM(BGPRPT,N,X,0),U,3)
.I $D(BGPPROVS(C,L)) S $P(BGPPROVS(C,L),U,1)=M Q
.S $P(BGPPROVS(C,L),U,1)=M
S X=0 F S X=$O(^BGPPEDPM(BGPRPT,N,X)) Q:X'=+X D
.S C=$P(^BGPPEDPM(BGPRPT,N,X,0),U),L=$P(^BGPPEDPM(BGPRPT,N,X,0),U,2),M=$P(^BGPPEDPM(BGPRPT,N,X,0),U,3)
.I $D(BGPPROVS(C,L)) S $P(BGPPROVS(C,L),U,2)=M Q
.S $P(BGPPROVS(C,L),U,2)=M
S X=0 F S X=$O(^BGPPEDBM(BGPRPT,N,X)) Q:X'=+X D
.S C=$P(^BGPPEDBM(BGPRPT,N,X,0),U),L=$P(^BGPPEDBM(BGPRPT,N,X,0),U,2),M=$P(^BGPPEDBM(BGPRPT,N,X,0),U,3)
.I $D(BGPPROVS(C,L)) S $P(BGPPROVS(C,L),U,3)=M Q
.S $P(BGPPROVS(C,L),U,3)=M
;set %ages
S X="" F S X=$O(BGPPROVS(X)) Q:X="" S Y="" F S Y=$O(BGPPROVS(X,Y)) Q:Y="" D
.F Z=1:1:3 I $P(BGPPROVS(X,Y),U,Z)="" S $P(BGPPROVS(X,Y),U,Z)=0
.S A=$P(BGPPROVS(X,Y),U,1),$P(BGPPROVS(X,Y),U,4)=$S(BGPCYD:((A/BGPCYD)*100),1:"")
.S B=$P(BGPPROVS(X,Y),U,2),$P(BGPPROVS(X,Y),U,5)=$S(BGPPRD:((B/BGPPRD)*100),1:"")
.S C=$P(BGPPROVS(X,Y),U,3),$P(BGPPROVS(X,Y),U,6)=$S(BGPBLD:((C/BGPBLD)*100),1:"")
.Q
Q
SETNMA ;
NEW X,V,C S Z=0,C="" F S Z=$O(BGPSUL(Z)) Q:Z'=+Z D SETNMA1
;set %ages
S X="" F S X=$O(BGPPROVS(X)) Q:X="" S Y="" F S Y=$O(BGPPROVS(X,Y)) Q:Y="" D
.F Z=1:1:3 I $P(BGPPROVS(X,Y),U,Z)="" S $P(BGPPROVS(X,Y),U,Z)=0
.S A=$P(BGPPROVS(X,Y),U,1),$P(BGPPROVS(X,Y),U,4)=$S(BGPCYD:((A/BGPCYD)*100),1:"")
.S B=$P(BGPPROVS(X,Y),U,2),$P(BGPPROVS(X,Y),U,5)=$S(BGPPRD:((B/BGPPRD)*100),1:"")
.S C=$P(BGPPROVS(X,Y),U,3),$P(BGPPROVS(X,Y),U,6)=$S(BGPBLD:((C/BGPBLD)*100),1:"")
.Q
Q
SETNMA1 ;
S X=0 F S X=$O(^BGPPEDCM(Z,N,X)) Q:X'=+X D
.S C=$P(^BGPPEDCM(Z,N,X,0),U),L=$P(^BGPPEDCM(Z,N,X,0),U,2),M=$P(^BGPPEDCM(Z,N,X,0),U,3)
.;I $D(BGPPROVS(C,L)) S $P(BGPPROVS(C,L),U,1)=M Q
.S $P(BGPPROVS(C,L),U,1)=$P($G(BGPPROVS(C,L)),U,1)+M
S X=0 F S X=$O(^BGPPEDPM(Z,N,X)) Q:X'=+X D
.S C=$P(^BGPPEDPM(Z,N,X,0),U),L=$P(^BGPPEDPM(Z,N,X,0),U,2),M=$P(^BGPPEDPM(Z,N,X,0),U,3)
.;I $D(BGPPROVS(C,L)) S $P(BGPPROVS(C,L),U,2)=M Q
.S $P(BGPPROVS(C,L),U,2)=$P($G(BGPPROVS(C,L)),U,2)+M
S X=0 F S X=$O(^BGPPEDBM(Z,N,X)) Q:X'=+X D
.S C=$P(^BGPPEDBM(Z,N,X,0),U),L=$P(^BGPPEDBM(Z,N,X,0),U,2),M=$P(^BGPPEDBM(Z,N,X,0),U,3)
.;I $D(BGPPROVS(C,L)) S $P(BGPPROVS(C,L),U,3)=M Q
.S $P(BGPPROVS(C,L),U,3)=$P($G(BGPPROVS(C,L)),U,3)+M
.Q
Q
SETN ;EP - set numerator fields
S BGPCYN=$$V(1,BGPRPT,N,P,2) ;SPDX
S BGPPRN=$$V(2,BGPRPT,N,P,2) ;SPDX
S BGPBLN=$$V(3,BGPRPT,N,P,2) ;SPDX
S BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")
S BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")
S BGPBLP=$S(BGPBLD:((BGPBLN/BGPBLD)*100),1:"")
Q
SL(V) ;
I V="" S V=0
Q $$STRIP^XLFSTR($J(V,7,0)," ")
V(T,R,N,P,ND) ;EP ;SPDX
I $G(BGPAREAA) G VA
NEW X
I T=1 S X=$P($G(^BGPPEDCM(R,N)),U,P) Q $S(X]"":X,1:0)
I T=2 S X=$P($G(^BGPPEDPM(R,N)),U,P) Q $S(X]"":X,1:0)
I T=3 S X=$P($G(^BGPPEDBM(R,N)),U,P) Q $S(X]"":X,1:0)
Q ""
VA ;
NEW X,V,C S X=0,C="" F S X=$O(BGPSUL(X)) Q:X'=+X D
.I T=1 S C=C+$P($G(^BGPPEDCM(X,N)),U,P)
.I T=2 S C=C+$P($G(^BGPPEDPM(X,N)),U,P)
.I T=3 S C=C+$P($G(^BGPPEDBM(X,N)),U,P)
.Q
Q $S(C]"":C,1:0)
BGP6DPED ; IHS/CMI/LAB - IHS gpra print 10 Apr 2016 2:46 PM ; 27 Jan 2016 12:37 PM
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+2 ;
+3 ;
PRINT ;
DEL ;EP - create delimited output file
+1 SET BGPRTYPE=6
SET BGPRPTH=""
+2 KILL ^TMP($JOB)
+3 SET ^TMP($JOB,"BGPDEL",0)=0
+4 DO ^BGP6PDLH
+5 KILL BGPSUMP
+6 DO DEL1
+7 ;print lists to delimited file
DO ^BGP6DPEE
+8 ;if screen selected do screen
+9 IF BGPDELT="S"
DO SCREEN
DO EXIT
QUIT
+10 ;call xbgsave to create output file
+11 SET XBGL="BGPDATA"
+12 LOCK +^BGPDATA:300
IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE "Unable to lock global"
QUIT
+13 ;global for saving
KILL ^BGPDATA
+14 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"BGPDEL",X))
IF X'=+X
QUIT
SET ^BGPDATA(X)=^TMP($JOB,"BGPDEL",X)
+15 IF '$DATA(BGPGUI)
Begin DoDot:1
+16 ;S XBUF=BGPUF
+17 SET XBFLT=1
SET XBFN=BGPDELF_".txt"
SET XBMED="F"
SET XBTLE="GPRA 16 DELIMITED PT ED OUTPUT"
SET XBQ="N"
SET XBF=0
+18 DO ^XBGSAVE
+19 KILL XBFLT,XBFN,XBMED,XBTLE,XBE,XBF
End DoDot:1
+20 IF $DATA(BGPGUI)
Begin DoDot:1
+21 SET (C,X)=0
FOR
SET X=$ORDER(^BGPDATA(X))
IF X'=+X
QUIT
SET C=C+1
SET ^BGPGUIM(BGPGIEN,12,C,0)=^BGPDATA(X)
+22 SET ^BGPGUIM(BGPGIEN,12,0)="^90556.1912^"_C_"^"_C_"^"_DT
End DoDot:1
+23 LOCK -^BGPDATA
+24 ;export global
KILL ^BGPDATA
+25 DO EXIT
+26 QUIT
+27 ;
SCREEN ;
+1 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"BGPDEL",X))
IF X'=+X
QUIT
WRITE !,^TMP($JOB,"BGPDEL",X)
+2 QUIT
DEL1 ;EP
+1 SET BGPIC=0
FOR
SET BGPIC=$ORDER(BGPIND(BGPIC))
IF BGPIC=""
QUIT
Begin DoDot:1
+2 ;now print individual measure
+3 DO S(" ",1,1)
DO S(" ",1,1)
+4 SET X=$PIECE(^BGPPEIM(BGPIC,0),U,2)
DO S(X,1,1)
+5 DO S(" ",1,1)
+6 IF $GET(BGPDNT)
GOTO CALC
+7 SET X="Denominator(s):"
DO S(X,1,1)
+8 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPPEIM(BGPIC,61,"B",BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+9 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPPEIM(BGPIC,61,"B",BGPX,BGPY))
IF BGPY'=+BGPY
QUIT
Begin DoDot:3
+10 SET BGPZ=0
FOR
SET BGPZ=$ORDER(^BGPPEIM(BGPIC,61,BGPY,11,BGPZ))
IF BGPZ'=+BGPZ
QUIT
Begin DoDot:4
+11 SET Y=^BGPPEIM(BGPIC,61,BGPY,11,BGPZ,0)
IF BGPZ=1
SET Y=" - "_Y
DO S(Y,1,1)
+12 QUIT
End DoDot:4
+13 QUIT
End DoDot:3
+14 QUIT
End DoDot:2
+15 DO S(" ",1,1)
+16 SET X="Numerator(s):"
DO S(X,1,1)
+17 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPPEIM(BGPIC,62,"B",BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+18 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPPEIM(BGPIC,62,"B",BGPX,BGPY))
IF BGPY'=+BGPY
QUIT
Begin DoDot:3
+19 SET BGPZ=0
FOR
SET BGPZ=$ORDER(^BGPPEIM(BGPIC,62,BGPY,11,BGPZ))
IF BGPZ'=+BGPZ
QUIT
Begin DoDot:4
+20 SET X=^BGPPEIM(BGPIC,62,BGPY,11,BGPZ,0)
IF BGPZ=1
SET X=" - "_X
DO S(X,1,1)
+21 QUIT
End DoDot:4
+22 QUIT
End DoDot:3
+23 QUIT
End DoDot:2
+24 DO S(" ",1,1)
+25 SET BGPNODE=11
+26 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPPEIM(BGPIC,BGPNODE,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+27 SET X=^BGPPEIM(BGPIC,BGPNODE,BGPX,0)
DO S(X,1,1)
End DoDot:2
CALC DO @BGPIC
End DoDot:1
+1 QUIT
EXIT ;
+1 KILL ^TMP($JOB)
+2 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
S(Y,F,P) ;EP set up array
+1 IF '$GET(F)
SET F=0
+2 SET %=$PIECE(^TMP($JOB,"BGPDEL",0),U)+F
SET $PIECE(^TMP($JOB,"BGPDEL",0),U)=%
+3 IF '$DATA(^TMP($JOB,"BGPDEL",%))
SET ^TMP($JOB,"BGPDEL",%)=""
+4 SET $PIECE(^TMP($JOB,"BGPDEL",%),U,P)=Y
+5 QUIT
C(X,X2,X3) ;
+1 DO COMMA^%DTC
+2 QUIT X
+3 ;
1 ;
+1 ;S X=$P(^BGPPEIM(BGPIC,0),U,2) D S(X,1,1)
DO S(" ",1,1)
+2 DO H1^BGP6PDL1
+3 DO S(" ",1,1)
+4 SET BGPCYD=$$V(1,BGPRPT,11,1)
+5 SET BGPPRD=$$V(2,BGPRPT,11,1)
+6 SET BGPBLD=$$V(3,BGPRPT,11,1)
+7 IF $GET(BGPSEAT)
SET X=$PIECE(^DIBT(BGPSEAT,0),U,1)_" Population"
DO S(X,1,1)
+8 IF '$GET(BGPSEAT)
SET X="User Pop"
DO S(X,1,1)
+9 SET Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD
DO S(Y,,2)
+10 DO S(" ",1,1)
+11 SET N=11
SET P=2
DO SETN
+12 SET X="# w/ Patient Ed"
DO S(X,1,1)
+13 DO H2^BGP6PDL1
+14 QUIT
2 ;
+1 ;S X=$P(^BGPPEIM(BGPIC,0),U,2) D S(X,1,1)
DO S(" ",1,1)
DO S(" ",1,1)
+2 DO H1^BGP6PDL1
+3 DO S(" ",1,1)
+4 SET BGPCYD=$$V(1,BGPRPT,11,7)
+5 SET BGPPRD=$$V(2,BGPRPT,11,7)
+6 SET BGPBLD=$$V(3,BGPRPT,11,7)
+7 IF $GET(BGPSEAT)
SET X=$PIECE(^DIBT(BGPSEAT,0),U,1)_" Population"
DO S(X,1,1)
+8 SET X="Total Time Spent"
DO S(X,1,1)
SET X="Providing Education (mins)"
DO S(X,1,1)
+9 SET Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD
DO S(Y,,2)
+10 DO S(" ",1,1)
+11 KILL BGPPROVS
+12 SET N=12
DO SETNM
+13 KILL BGPX
+14 SET X=""
SET C=0
FOR
SET X=$ORDER(BGPPROVS(X))
IF X=""
QUIT
SET Y=""
FOR
SET Y=$ORDER(BGPPROVS(X,Y))
IF Y=""
QUIT
SET C=C+1
SET BGPX((9999999-$PIECE(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)
+15 SET BGP1=0
SET BGPCNT=0
FOR
SET BGP1=$ORDER(BGPX(BGP1))
IF BGP1'=+BGP1
QUIT
Begin DoDot:1
+16 SET BGP2=0
FOR
SET BGP2=$ORDER(BGPX(BGP1,BGP2))
IF BGP2'=+BGP2
QUIT
Begin DoDot:2
+17 SET X=$PIECE(BGPX(BGP1,BGP2),U,2)
DO S(X,1,1)
+18 SET BGPCYN=$PIECE(BGPX(BGP1,BGP2),U,3)
+19 SET BGPPRN=$PIECE(BGPX(BGP1,BGP2),U,4)
+20 SET BGPBLN=$PIECE(BGPX(BGP1,BGP2),U,5)
+21 SET BGPCYP=$PIECE(BGPX(BGP1,BGP2),U,6)
+22 SET BGPPRP=$PIECE(BGPX(BGP1,BGP2),U,7)
+23 SET BGPBLP=$PIECE(BGPX(BGP1,BGP2),U,8)
+24 DO H2^BGP6PDL1
End DoDot:2
End DoDot:1
+25 IF '$GET(BGPAREAA)
Begin DoDot:1
+26 SET BGPAA=$$V(1,BGPRPT,11,7)
+27 SET BGPAB=$$V(2,BGPRPT,11,7)
+28 SET BGPAC=$$V(3,BGPRPT,11,7)
+29 SET BGPCYN=$$V(1,BGPRPT,11,6)
+30 SET BGPPRN=$$V(2,BGPRPT,11,6)
+31 SET BGPBLN=$$V(3,BGPRPT,11,6)
+32 SET BGPCYD=$$V(1,BGPRPT,11,3)
+33 SET BGPPRD=$$V(2,BGPRPT,11,3)
+34 SET BGPBLD=$$V(3,BGPRPT,11,3)
End DoDot:1
+35 IF $GET(BGPAREAA)
Begin DoDot:1
+36 SET BGPAA=$$V(1,BGPRPT,11,7)
+37 SET BGPAB=$$V(2,BGPRPT,11,7)
+38 SET BGPAC=$$V(3,BGPRPT,11,7)
+39 SET BGPCYN=$$V(1,BGPRPT,11,6)
+40 SET BGPPRN=$$V(2,BGPRPT,11,6)
+41 SET BGPBLN=$$V(3,BGPRPT,11,6)
+42 SET BGPCYD=$SELECT(BGPAA:BGPAA/BGPCYN,1:0)
+43 SET BGPPRD=$SELECT(BGPAB:BGPAB/BGPPRN,1:0)
+44 SET BGPBLD=$SELECT(BGPAC:BGPAC/BGPBLN,1:0)
End DoDot:1
+45 SET X=""
DO S(X,1,1)
+46 DO S("Total # of Minutes recorded",1,1)
DO S("for All Providers",1,1)
+47 SET Y=BGPAA_"^^"_BGPAB_"^^^"_BGPAC
DO S(Y,,2)
+48 DO S("Total # of Pt Ed Codes with Provider",1,1)
DO S("and minutes recorded",1,1)
+49 SET Y=BGPCYN_"^^"_BGPPRN_"^^^"_BGPBLN
DO S(Y,,2)
+50 DO S(" ",1,1)
+51 SET X="Average Time Spent"
DO S(X,1,1)
SET X="All Providers (minutes)"
DO S(X,1,1)
+52 SET Y=$$SL(BGPCYD)_"^^"_$$SL(BGPPRD)_"^^^"_$$SL(BGPBLD)
DO S(Y,,2)
+53 IF '$GET(BGPAREAA)
Begin DoDot:1
+54 SET BGPCYD=$$V(1,BGPRPT,11,4)
+55 SET BGPPRD=$$V(2,BGPRPT,11,4)
+56 SET BGPBLD=$$V(3,BGPRPT,11,4)
End DoDot:1
+57 IF $GET(BGPAREAA)
Begin DoDot:1
+58 SET BGPCYD=999999999
SET BGPBLD=999999999
SET BGPPRD=999999999
+59 SET X=0
FOR
SET X=$ORDER(BGPSUL(X))
IF X'=+X
QUIT
Begin DoDot:2
+60 IF $PIECE($GET(^BGPPEDCM(X,11)),U,4)]""
IF $PIECE(^BGPPEDCM(X,11),U,4)<BGPCYD
SET BGPCYD=$PIECE(^BGPPEDCM(X,11),U,4)
+61 IF $PIECE($GET(^BGPPEDPM(X,11)),U,4)]""
IF $PIECE(^BGPPEDPM(X,11),U,4)<BGPPRD
SET BGPPRD=$PIECE(^BGPPEDPM(X,11),U,4)
+62 IF $PIECE($GET(^BGPPEDBM(X,11)),U,4)]""
IF $PIECE(^BGPPEDBM(X,11),U,4)<BGPBLD
SET BGPBLD=$PIECE(^BGPPEDBM(X,11),U,4)
End DoDot:2
+63 IF BGPCYD=999999999
SET BGPCYD=0
+64 IF BGPBLD=999999999
SET BGPBLD=0
+65 IF BGPPRD=999999999
SET BGPPRD=0
End DoDot:1
+66 SET X=""
DO S(X,1,1)
+67 SET X="Minimum Time Spent"
DO S(X,2,1)
SET X="All Providers (minutes)"
DO S(X,1,1)
+68 SET Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD
DO S(Y,,2)
+69 IF '$GET(BGPAREAA)
Begin DoDot:1
+70 SET BGPCYD=$$V(1,BGPRPT,11,5)
+71 SET BGPPRD=$$V(2,BGPRPT,11,5)
+72 SET BGPBLD=$$V(3,BGPRPT,11,5)
End DoDot:1
+73 IF $GET(BGPAREAA)
Begin DoDot:1
+74 SET (BGPCYD,BGPPRD,BGPBLD)=0
+75 SET X=0
FOR
SET X=$ORDER(BGPSUL(X))
IF X'=+X
QUIT
Begin DoDot:2
+76 IF $PIECE($GET(^BGPPEDCM(X,11)),U,5)>BGPCYD
SET BGPCYD=$PIECE(^BGPPEDCM(X,11),U,5)
+77 IF $PIECE($GET(^BGPPEDPM(X,11)),U,5)>BGPPRD
SET BGPPRD=$PIECE(^BGPPEDPM(X,11),U,5)
+78 IF $PIECE($GET(^BGPPEDBM(X,11)),U,5)>BGPBLD
SET BGPBLD=$PIECE(^BGPPEDBM(X,11),U,5)
End DoDot:2
End DoDot:1
+79 SET X=""
DO S(X,1,1)
+80 SET X="Maximum Time Spent"
DO S(X,1,1)
SET X="All Providers (minutes)"
DO S(X,1,1)
+81 SET Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD
DO S(Y,,2)
+82 QUIT
3 ;
+1 SET X=""
+2 ;S X=$P(^BGPPEIM(BGPIC,0),U,2) D S(X,1,1)
DO S(" ",1,1)
DO S(" ",1,1)
+3 DO H1^BGP6PDL1
+4 DO S(" ",1,1)
+5 SET BGPCYD=$$V(1,BGPRPT,11,8)
+6 SET BGPPRD=$$V(2,BGPRPT,11,8)
+7 SET BGPBLD=$$V(3,BGPRPT,11,8)
+8 IF $GET(BGPSEAT)
SET X=$PIECE(^DIBT(BGPSEAT,0),U,1)_" Population"
DO S(X,1,1)
+9 SET X="Total # Education Codes"
DO S(X,1,1)
+10 SET Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD
DO S(Y,,2)
+11 DO S(" ",1,1)
+12 KILL BGPPROVS
+13 SET N=13
DO SETNM
+14 KILL BGPX
+15 SET BGPCNT=0
+16 SET X=""
SET C=0
FOR
SET X=$ORDER(BGPPROVS(X))
IF X=""
QUIT
SET Y=""
FOR
SET Y=$ORDER(BGPPROVS(X,Y))
IF Y=""
QUIT
SET C=C+1
SET BGPX((9999999-$PIECE(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)
+17 SET BGP1=0
FOR
SET BGP1=$ORDER(BGPX(BGP1))
IF BGP1'=+BGP1!(BGPCNT>24)
QUIT
Begin DoDot:1
+18 SET BGPCNT=BGPCNT+1
SET BGP2=0
FOR
SET BGP2=$ORDER(BGPX(BGP1,BGP2))
IF BGP2'=+BGP2
QUIT
Begin DoDot:2
+19 SET X=BGPCNT_". "_$PIECE(BGPX(BGP1,BGP2),U,2)
DO S(X,1,1)
+20 SET BGPCYN=$PIECE(BGPX(BGP1,BGP2),U,3)
+21 SET BGPPRN=$PIECE(BGPX(BGP1,BGP2),U,4)
+22 SET BGPBLN=$PIECE(BGPX(BGP1,BGP2),U,5)
+23 SET BGPCYP=$PIECE(BGPX(BGP1,BGP2),U,6)
+24 SET BGPPRP=$PIECE(BGPX(BGP1,BGP2),U,7)
+25 SET BGPBLP=$PIECE(BGPX(BGP1,BGP2),U,8)
+26 DO H2^BGP6PDL1
End DoDot:2
End DoDot:1
+27 QUIT
4 ;
+1 SET X=""
+2 ;S X=$P(^BGPPEIM(BGPIC,0),U,2) D S(X,1,1)
DO S(" ",1,1)
DO S(" ",1,1)
+3 DO H1^BGP6PDL1
+4 DO S(" ",1,1)
+5 SET BGPCYD=$$V(1,BGPRPT,11,9)
+6 SET BGPPRD=$$V(2,BGPRPT,11,9)
+7 SET BGPBLD=$$V(3,BGPRPT,11,9)
+8 IF $GET(BGPSEAT)
SET X=$PIECE(^DIBT(BGPSEAT,0),U,1)_" Population"
DO S(X,1,1)
+9 SET X="Total # Education Codes"
DO S(X,1,1)
+10 SET Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD
DO S(Y,,2)
+11 DO S(" ",1,1)
+12 KILL BGPPROVS
+13 SET N=14
DO SETNM
+14 KILL BGPX
+15 SET BGPCNT=0
+16 SET X=""
SET C=0
FOR
SET X=$ORDER(BGPPROVS(X))
IF X=""
QUIT
SET Y=""
FOR
SET Y=$ORDER(BGPPROVS(X,Y))
IF Y=""
QUIT
SET C=C+1
SET BGPX((9999999-$PIECE(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)
+17 SET BGP1=0
FOR
SET BGP1=$ORDER(BGPX(BGP1))
IF BGP1'=+BGP1!(BGPCNT>24)
QUIT
Begin DoDot:1
+18 SET BGPCNT=BGPCNT+1
SET BGP2=0
FOR
SET BGP2=$ORDER(BGPX(BGP1,BGP2))
IF BGP2'=+BGP2
QUIT
Begin DoDot:2
+19 SET X=BGPCNT_". "_$PIECE(BGPX(BGP1,BGP2),U,2)
DO S(X,1,1)
+20 SET BGPCYN=$PIECE(BGPX(BGP1,BGP2),U,3)
+21 SET BGPPRN=$PIECE(BGPX(BGP1,BGP2),U,4)
+22 SET BGPBLN=$PIECE(BGPX(BGP1,BGP2),U,5)
+23 SET BGPCYP=$PIECE(BGPX(BGP1,BGP2),U,6)
+24 SET BGPPRP=$PIECE(BGPX(BGP1,BGP2),U,7)
+25 SET BGPBLP=$PIECE(BGPX(BGP1,BGP2),U,8)
+26 DO H2^BGP6PDL1
End DoDot:2
End DoDot:1
+27 QUIT
5 ;
+1 SET X=""
+2 ;S X=$P(^BGPPEIM(BGPIC,0),U,2) D S(X,1,1)
DO S(" ",1,1)
DO S(" ",1,1)
+3 DO H1^BGP6PDL1
+4 DO S(" ",1,1)
+5 SET BGPCYD=$$V(1,BGPRPT,11,10)
+6 SET BGPPRD=$$V(2,BGPRPT,11,10)
+7 SET BGPBLD=$$V(3,BGPRPT,11,10)
+8 IF $GET(BGPSEAT)
SET X=$PIECE(^DIBT(BGPSEAT,0),U,1)_" Population"
DO S(X,1,1)
+9 SET X="Total # Education Codes"
DO S(X,1,1)
+10 SET Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD
DO S(Y,,2)
+11 DO S(" ",1,1)
+12 KILL BGPPROVS
+13 SET N=15
DO SETNM
+14 KILL BGPX
+15 SET BGPCNT=0
+16 SET X=""
SET C=0
FOR
SET X=$ORDER(BGPPROVS(X))
IF X=""
QUIT
SET Y=""
FOR
SET Y=$ORDER(BGPPROVS(X,Y))
IF Y=""
QUIT
SET C=C+1
SET BGPX((9999999-$PIECE(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)
+17 SET BGP1=0
FOR
SET BGP1=$ORDER(BGPX(BGP1))
IF BGP1'=+BGP1!(BGPCNT>15)
QUIT
Begin DoDot:1
+18 SET BGPCNT=BGPCNT+1
SET BGP2=0
FOR
SET BGP2=$ORDER(BGPX(BGP1,BGP2))
IF BGP2'=+BGP2
QUIT
Begin DoDot:2
+19 SET X=BGPCNT_". "_$PIECE(BGPX(BGP1,BGP2),U,2)
DO S(X,1,1)
+20 SET BGPCYN=$PIECE(BGPX(BGP1,BGP2),U,3)
+21 SET BGPPRN=$PIECE(BGPX(BGP1,BGP2),U,4)
+22 SET BGPBLN=$PIECE(BGPX(BGP1,BGP2),U,5)
+23 SET BGPCYP=$PIECE(BGPX(BGP1,BGP2),U,6)
+24 SET BGPPRP=$PIECE(BGPX(BGP1,BGP2),U,7)
+25 SET BGPBLP=$PIECE(BGPX(BGP1,BGP2),U,8)
+26 DO H2^BGP6PDL1
End DoDot:2
End DoDot:1
+27 QUIT
6 ;
+1 SET X=""
+2 ;S X=$P(^BGPPEIM(BGPIC,0),U,2) D S(X,1,1)
DO S(" ",1,1)
DO S(" ",1,1)
+3 DO H1^BGP6PDL1
+4 DO S(" ",1,1)
+5 SET BGPCYD=$$V(1,BGPRPT,11,12)
+6 SET BGPPRD=$$V(2,BGPRPT,11,12)
+7 SET BGPBLD=$$V(3,BGPRPT,11,12)
+8 IF $GET(BGPSEAT)
SET X=$PIECE(^DIBT(BGPSEAT,0),U,1)_" Population"
DO S(X,1,1)
+9 SET X="Total # Education Codes"
DO S(X,1,1)
+10 SET Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD
DO S(Y,,2)
+11 DO S(" ",1,1)
+12 SET X="Patient Understanding"
DO S(X,1,1)
+13 SET N=11
SET P=15
DO SETN
+14 SET X="Good"
DO S(X,1,1)
+15 DO H2^BGP6PDL1
+16 SET N=11
SET P=14
DO SETN
+17 SET X="Fair"
DO S(X,1,1)
+18 DO H2^BGP6PDL1
+19 SET N=11
SET P=13
DO SETN
+20 SET X="Poor"
DO S(X,1,1)
+21 DO H2^BGP6PDL1
+22 SET N=11
SET P=16
DO SETN
+23 SET X="Refused"
DO S(X,1,1)
+24 DO H2^BGP6PDL1
+25 SET N=11
SET P=17
DO SETN
+26 SET X="Group-No Assessment"
DO S(X,1,1)
+27 DO H2^BGP6PDL1
+28 SET N=11
SET P=18
DO SETN
+29 SET X="Blank (Not recorded)"
DO S(X,1,1)
+30 DO H2^BGP6PDL1
+31 QUIT
7 ;
+1 DO 7^BGP6DPEF
+2 QUIT
KITM ;
+1 KILL ^TMP($JOB)
+2 KILL ^XTMP("BGP6PE",BGPJ,BGPH)
+3 QUIT
SETNM ;
+1 KILL BGPPROVS
+2 IF $GET(BGPAREAA)
DO SETNMA
QUIT
+3 SET X=0
FOR
SET X=$ORDER(^BGPPEDCM(BGPRPT,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 SET C=$PIECE(^BGPPEDCM(BGPRPT,N,X,0),U)
SET L=$PIECE(^BGPPEDCM(BGPRPT,N,X,0),U,2)
SET M=$PIECE(^BGPPEDCM(BGPRPT,N,X,0),U,3)
+5 IF $DATA(BGPPROVS(C,L))
SET $PIECE(BGPPROVS(C,L),U,1)=M
QUIT
+6 SET $PIECE(BGPPROVS(C,L),U,1)=M
End DoDot:1
+7 SET X=0
FOR
SET X=$ORDER(^BGPPEDPM(BGPRPT,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+8 SET C=$PIECE(^BGPPEDPM(BGPRPT,N,X,0),U)
SET L=$PIECE(^BGPPEDPM(BGPRPT,N,X,0),U,2)
SET M=$PIECE(^BGPPEDPM(BGPRPT,N,X,0),U,3)
+9 IF $DATA(BGPPROVS(C,L))
SET $PIECE(BGPPROVS(C,L),U,2)=M
QUIT
+10 SET $PIECE(BGPPROVS(C,L),U,2)=M
End DoDot:1
+11 SET X=0
FOR
SET X=$ORDER(^BGPPEDBM(BGPRPT,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+12 SET C=$PIECE(^BGPPEDBM(BGPRPT,N,X,0),U)
SET L=$PIECE(^BGPPEDBM(BGPRPT,N,X,0),U,2)
SET M=$PIECE(^BGPPEDBM(BGPRPT,N,X,0),U,3)
+13 IF $DATA(BGPPROVS(C,L))
SET $PIECE(BGPPROVS(C,L),U,3)=M
QUIT
+14 SET $PIECE(BGPPROVS(C,L),U,3)=M
End DoDot:1
+15 ;set %ages
+16 SET X=""
FOR
SET X=$ORDER(BGPPROVS(X))
IF X=""
QUIT
SET Y=""
FOR
SET Y=$ORDER(BGPPROVS(X,Y))
IF Y=""
QUIT
Begin DoDot:1
+17 FOR Z=1:1:3
IF $PIECE(BGPPROVS(X,Y),U,Z)=""
SET $PIECE(BGPPROVS(X,Y),U,Z)=0
+18 SET A=$PIECE(BGPPROVS(X,Y),U,1)
SET $PIECE(BGPPROVS(X,Y),U,4)=$SELECT(BGPCYD:((A/BGPCYD)*100),1:"")
+19 SET B=$PIECE(BGPPROVS(X,Y),U,2)
SET $PIECE(BGPPROVS(X,Y),U,5)=$SELECT(BGPPRD:((B/BGPPRD)*100),1:"")
+20 SET C=$PIECE(BGPPROVS(X,Y),U,3)
SET $PIECE(BGPPROVS(X,Y),U,6)=$SELECT(BGPBLD:((C/BGPBLD)*100),1:"")
+21 QUIT
End DoDot:1
+22 QUIT
SETNMA ;
+1 NEW X,V,C
SET Z=0
SET C=""
FOR
SET Z=$ORDER(BGPSUL(Z))
IF Z'=+Z
QUIT
DO SETNMA1
+2 ;set %ages
+3 SET X=""
FOR
SET X=$ORDER(BGPPROVS(X))
IF X=""
QUIT
SET Y=""
FOR
SET Y=$ORDER(BGPPROVS(X,Y))
IF Y=""
QUIT
Begin DoDot:1
+4 FOR Z=1:1:3
IF $PIECE(BGPPROVS(X,Y),U,Z)=""
SET $PIECE(BGPPROVS(X,Y),U,Z)=0
+5 SET A=$PIECE(BGPPROVS(X,Y),U,1)
SET $PIECE(BGPPROVS(X,Y),U,4)=$SELECT(BGPCYD:((A/BGPCYD)*100),1:"")
+6 SET B=$PIECE(BGPPROVS(X,Y),U,2)
SET $PIECE(BGPPROVS(X,Y),U,5)=$SELECT(BGPPRD:((B/BGPPRD)*100),1:"")
+7 SET C=$PIECE(BGPPROVS(X,Y),U,3)
SET $PIECE(BGPPROVS(X,Y),U,6)=$SELECT(BGPBLD:((C/BGPBLD)*100),1:"")
+8 QUIT
End DoDot:1
+9 QUIT
SETNMA1 ;
+1 SET X=0
FOR
SET X=$ORDER(^BGPPEDCM(Z,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 SET C=$PIECE(^BGPPEDCM(Z,N,X,0),U)
SET L=$PIECE(^BGPPEDCM(Z,N,X,0),U,2)
SET M=$PIECE(^BGPPEDCM(Z,N,X,0),U,3)
+3 ;I $D(BGPPROVS(C,L)) S $P(BGPPROVS(C,L),U,1)=M Q
+4 SET $PIECE(BGPPROVS(C,L),U,1)=$PIECE($GET(BGPPROVS(C,L)),U,1)+M
End DoDot:1
+5 SET X=0
FOR
SET X=$ORDER(^BGPPEDPM(Z,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET C=$PIECE(^BGPPEDPM(Z,N,X,0),U)
SET L=$PIECE(^BGPPEDPM(Z,N,X,0),U,2)
SET M=$PIECE(^BGPPEDPM(Z,N,X,0),U,3)
+7 ;I $D(BGPPROVS(C,L)) S $P(BGPPROVS(C,L),U,2)=M Q
+8 SET $PIECE(BGPPROVS(C,L),U,2)=$PIECE($GET(BGPPROVS(C,L)),U,2)+M
End DoDot:1
+9 SET X=0
FOR
SET X=$ORDER(^BGPPEDBM(Z,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+10 SET C=$PIECE(^BGPPEDBM(Z,N,X,0),U)
SET L=$PIECE(^BGPPEDBM(Z,N,X,0),U,2)
SET M=$PIECE(^BGPPEDBM(Z,N,X,0),U,3)
+11 ;I $D(BGPPROVS(C,L)) S $P(BGPPROVS(C,L),U,3)=M Q
+12 SET $PIECE(BGPPROVS(C,L),U,3)=$PIECE($GET(BGPPROVS(C,L)),U,3)+M
+13 QUIT
End DoDot:1
+14 QUIT
SETN ;EP - set numerator fields
+1 ;SPDX
SET BGPCYN=$$V(1,BGPRPT,N,P,2)
+2 ;SPDX
SET BGPPRN=$$V(2,BGPRPT,N,P,2)
+3 ;SPDX
SET BGPBLN=$$V(3,BGPRPT,N,P,2)
+4 SET BGPCYP=$SELECT(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")
+5 SET BGPPRP=$SELECT(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")
+6 SET BGPBLP=$SELECT(BGPBLD:((BGPBLN/BGPBLD)*100),1:"")
+7 QUIT
SL(V) ;
+1 IF V=""
SET V=0
+2 QUIT $$STRIP^XLFSTR($JUSTIFY(V,7,0)," ")
V(T,R,N,P,ND) ;EP ;SPDX
+1 IF $GET(BGPAREAA)
GOTO VA
+2 NEW X
+3 IF T=1
SET X=$PIECE($GET(^BGPPEDCM(R,N)),U,P)
QUIT $SELECT(X]"":X,1:0)
+4 IF T=2
SET X=$PIECE($GET(^BGPPEDPM(R,N)),U,P)
QUIT $SELECT(X]"":X,1:0)
+5 IF T=3
SET X=$PIECE($GET(^BGPPEDBM(R,N)),U,P)
QUIT $SELECT(X]"":X,1:0)
+6 QUIT ""
VA ;
+1 NEW X,V,C
SET X=0
SET C=""
FOR
SET X=$ORDER(BGPSUL(X))
IF X'=+X
QUIT
Begin DoDot:1
+2 IF T=1
SET C=C+$PIECE($GET(^BGPPEDCM(X,N)),U,P)
+3 IF T=2
SET C=C+$PIECE($GET(^BGPPEDPM(X,N)),U,P)
+4 IF T=3
SET C=C+$PIECE($GET(^BGPPEDBM(X,N)),U,P)
+5 QUIT
End DoDot:1
+6 QUIT $SELECT(C]"":C,1:0)
