BGP8DCI ;IHS/CMI/LAB - AREA GPRA;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
CALCIND ;EP - CALCULATE ALL MEASURES
S BGPIC=0 F S BGPIC=$O(BGPIND(BGPIC)) Q:BGPIC'=+BGPIC D
.I BGPRTYPE=1,$P(^BGPINDR(BGPIC,0),U,7)'=1 Q ;national gpra report
.I BGPRTYPE=7,$P($G(^BGPINDR(BGPIC,12)),U,1)'=1 Q ;OTHER NATIONAL
.K BGPSTOP,BGPVAL,BGPVALUE,BGPVALUD,BGPG,BGPC,BGPALLED,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z,BGPSKIP
.F X=1:1:99 S Y="BGPN"_X K @Y
.F X=1:1:99 S Y="BGPD"_X K @Y
.K BGPNUMV
.K ^TMP($J)
.I $D(^BGPINDR(BGPIC,1)) X ^BGPINDR(BGPIC,1)
.K BGPVAL,BGPG,BGPC,BGPALLED,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
.K ^TMP($J)
.;Set up global for iCare
.I $G(BQIGREF)'="",$D(BGPSTOP) S @BQIGREF@(DFN,BGPIC)=$P(^BGPINDR(BGPIC,0),U,3)_"^N/A" Q
.I $D(BGPSTOP) Q ;no need to set since no num/denom
.;loop each individual to set numerator and denominator
.S BGPI=0 F S BGPI=$O(^BGPINDRC("B",BGPIC,BGPI)) Q:BGPI'=+BGPI D
..S (BGPNUM,BGPDEN)=0
..X ^BGPINDRC(BGPI,1)
..X ^BGPINDRC(BGPI,2) ;denominator 1 or 0
..;set field counter
..S BGPNF=$P(^BGPINDRC(BGPI,0),U,9)
..S BGPN=$P(^DD(90560.03,BGPNF,0),U,4)
..S N=$P(BGPN,";"),P=$P(BGPN,";",2)
..D S(BGPRPT,BGPGBL,N,P,BGPNUM),S1("N",BGPNUM)
..S BGPDF=$P(^BGPINDRC(BGPI,0),U,8)
..S BGPN=$P(^DD(90560.03,BGPDF,0),U,4),N=$P(BGPN,";"),P=$P(BGPN,";",2)
..I BGPDEN'="NO" D S(BGPRPT,BGPGBL,N,P,BGPDEN),S1("D",BGPDEN)
..I $G(BGPCPPL) D CPL
.I $D(BGPLIST(BGPIC)) D STMP^BGP8UTL
.I $G(BGPNPL) D NPL
.F X=1:1:99 S Y="BGPN"_X K @Y
.F X=1:1:99 S Y="BGPD"_X K @Y
Q
;
CPL ;comprehensive pat list check and set xtmp
I BGPLIST="P",$P(^AUPNPAT(DFN,0),U,14)'=BGPLPRV Q ;not this provider
Q:BGPTIME'=1
Q:$P($G(^BGPINDRC(BGPI,12)),U,1)=""
X ^BGPINDRC(BGPI,3) Q:'$T
S C=$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN")
S S=$P(^DPT(DFN,0),U,2)
S D=$P(BGPVALUE,"|||")
S F=$P($G(^XTMP("BGP28CPL",BGPJ,BGPH,"LIST",C,S,BGPAGEB,DFN)),"|||")
I D["UP" S $P(F,"$$",1)="UP"
I D["AC" S $P(F,"$$",2)="AC"
I D["AD" S $P(F,"$$",3)="AD"
I D["AAD" S $P(F,"$$",4)="AAD"
I D["PREG" S $P(F,"$$",5)="PREG"
I D["IMM" S $P(F,"$$",6)="IMM"
I D["IHD" S $P(F,"$$",7)="IHD"
I '$D(^XTMP("BGP28CPL",BGPJ,BGPH,"LIST",C,S,BGPAGEB,DFN)) D Q
.S ^XTMP("BGP28CPL",BGPJ,BGPH,"LIST",C,S,BGPAGEB,DFN)=F_"|||"_$P(^BGPINDRC(BGPI,12),U),BGPCPLC=BGPCPLC+1
S $P(^XTMP("BGP28CPL",BGPJ,BGPH,"LIST",C,S,BGPAGEB,DFN),"|||")=F
S $P(^XTMP("BGP28CPL",BGPJ,BGPH,"LIST",C,S,BGPAGEB,DFN),"|||",2)=$P(^XTMP("BGP28CPL",BGPJ,BGPH,"LIST",C,S,BGPAGEB,DFN),"|||",2)_"#"_$P(^BGPINDRC(BGPI,12),U)
Q
NPL ;
Q:BGPTIME'=1
Q:'$D(BGPINDL(BGPIC)) ;not a selected topic
NEW A
S BGPX=0 F S BGPX=$O(BGPINDL(BGPIC,BGPX)) Q:BGPX'=+BGPX D
.I BGPLIST="P",$P(^AUPNPAT(DFN,0),U,14)'=BGPLPRV Q
.S BGPORD=$P($G(^BGPINDR(BGPIC,12)),U,6)
.X ^BGPNPLR(BGPX,12) K ^TMP($J) Q:'$T
.S BGPINDL(BGPIC,BGPX)=$G(BGPINDL(BGPIC,BGPX))+1
.I $G(BGPYNPLT) S ^XTMP("BGP8DNP",BGPJ,BGPH,"LIST",BGPORD,BGPIC,BGPX,DFN)="" Q
.S BGPO=$S(BGPRTYPE=7:$P(^BGPNPLR(BGPX,0),U,6),1:$P(^BGPNPLR(BGPX,0),U,5))
.S A=""
.I $P(^BGPINDR(BGPIC,0),U,2)=151 S A=BGPAGEE G SL
.I $P(^BGPINDR(BGPIC,0),U,2)=171 S A=BGPAGEE G SL
.S A=BGPAGEB
SL .I $P(^BGPNPLR(BGPX,0),U,7)=9,$G(BGPVALUD)]"" S BGPVALUE=BGPVALUD
.S ^XTMP("BGP8DNP",BGPJ,BGPH,"LIST",BGPORD,BGPIC,BGPO,BGPX,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),A,DFN)=$G(BGPVALUE)
K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPX,A
Q
S(R,G,N,P,V) ;
I 'V Q ;no value to add
S $P(@(G_R_","_N_")"),U,P)=$P($G(@(G_R_","_N_")")),U,P)+V
Q
D(D) ;
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
;
S1(BQITYP,BQIVAL) ; Return data by patient for iCare into global reference BQIGREF
;Input Variables
; BQITYP - Type of value
; D = Denominator
; N = Numerator
; BQIVAL - Value of the type; 0 or 1
;Assumed variables
; BGPVALUE - the measure value
; BQIGREF - global reference where data will be stored temporarily
; BGPIC - Indicator IEN
; BGPI - Individual Indicator IEN
; DFN - Patient IEN
;
; If no value of BQIGREF, then it's the regular GPRA report calling the code
; and nothing needs to be set for iCare.
Q:$G(BQIGREF)=""
;
; If no denominator or numerator value, then it doesn't need to be set for iCare
I '$G(BQIVAL) Q
;
NEW BQITIT,BQILTIT,BQILTIT1,BQILTIT2,BQILTIT3,BQILDTI1,BQILDTI2
NEW BQIDTIT,BQIFTIT,BQITWEN,BQICURR,BQIIDTA,BQIDTA,BQILDTI3
S BQIIDTA=$G(^BGPINDRC(BGPI,17))
S BQIDTA=$G(^BGPINDRC(BGPI,14))
;
; Get the Individual Indicator TITLE (1404)
;S BQITIT=$P(BQIDTA,U,4)
;
; Get the Individual Indicator LINE TITLE 1 (.15)
;S BQILTIT1=$P(BQIIDTA,U,15)
;I BQILTIT1="" Q
; Get the Individual Indicator LINE TITLE 2 and 3 (.16,.19)
;S BQILTIT2=$P(BQIIDTA,U,16)
;S BQILTIT3=$P(BQIIDTA,U,19)
;S BQILTIT=$P(BQIIDTA,U,3)
;
; Get the Individual Indicator LOCAL DENOM TITLE 1, 2, and 3 (.17,.18,.21)
;S BQILDTI1=$P(BQIIDTA,U,17)
;S BQILDTI2=$P(BQIIDTA,U,18)
;S BQILDTI3=$P(BQIIDTA,U,21)
;S BQIDTIT=BQILDTI1_" "_BQILDTI2_" "_BQILDTI3
;
; Full title is all title fields
S BQIFTIT=$P(BQIIDTA,"^",3)
S $P(@BQIGREF@(DFN,BGPIC,BGPI),"^",1)=BQIFTIT
;
; Get the GOAL 2018 value and the GOAL 06 value
S BQITWEN=$P(BQIDTA,U,3)
S BQICURR=$P(BQIDTA,U,8)
;
I BQITYP="N" S $P(@BQIGREF@(DFN,BGPIC,BGPI),"^",2)=$G(BQIVAL)
;
I BQITYP="D" S $P(@BQIGREF@(DFN,BGPIC,BGPI),"^",3)=$G(BQIVAL)
;
; Set the Indicator TITLE (.03)
S $P(@BQIGREF@(DFN,BGPIC),U,1)=$P(^BGPINDR(BGPIC,0),U,3)
S $P(@BQIGREF@(DFN,BGPIC),U,2)=$G(BGPVALUE)
I BQITWEN'="" S $P(@BQIGREF@(DFN,BGPIC),U,3)=BQITWEN
I BQICURR'="" S $P(@BQIGREF@(DFN,BGPIC),U,4)=BQICURR
Q
BGP8DCI ;IHS/CMI/LAB - AREA GPRA;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
CALCIND ;EP - CALCULATE ALL MEASURES
+1 SET BGPIC=0
FOR
SET BGPIC=$ORDER(BGPIND(BGPIC))
IF BGPIC'=+BGPIC
QUIT
Begin DoDot:1
+2 ;national gpra report
IF BGPRTYPE=1
IF $PIECE(^BGPINDR(BGPIC,0),U,7)'=1
QUIT
+3 ;OTHER NATIONAL
IF BGPRTYPE=7
IF $PIECE($GET(^BGPINDR(BGPIC,12)),U,1)'=1
QUIT
+4 KILL BGPSTOP,BGPVAL,BGPVALUE,BGPVALUD,BGPG,BGPC,BGPALLED,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z,BGPSKIP
+5 FOR X=1:1:99
SET Y="BGPN"_X
KILL @Y
+6 FOR X=1:1:99
SET Y="BGPD"_X
KILL @Y
+7 KILL BGPNUMV
+8 KILL ^TMP($JOB)
+9 IF $DATA(^BGPINDR(BGPIC,1))
XECUTE ^BGPINDR(BGPIC,1)
+10 KILL BGPVAL,BGPG,BGPC,BGPALLED,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
+11 KILL ^TMP($JOB)
+12 ;Set up global for iCare
+13 IF $GET(BQIGREF)'=""
IF $DATA(BGPSTOP)
SET @BQIGREF@(DFN,BGPIC)=$PIECE(^BGPINDR(BGPIC,0),U,3)_"^N/A"
QUIT
+14 ;no need to set since no num/denom
IF $DATA(BGPSTOP)
QUIT
+15 ;loop each individual to set numerator and denominator
+16 SET BGPI=0
FOR
SET BGPI=$ORDER(^BGPINDRC("B",BGPIC,BGPI))
IF BGPI'=+BGPI
QUIT
Begin DoDot:2
+17 SET (BGPNUM,BGPDEN)=0
+18 XECUTE ^BGPINDRC(BGPI,1)
+19 ;denominator 1 or 0
XECUTE ^BGPINDRC(BGPI,2)
+20 ;set field counter
+21 SET BGPNF=$PIECE(^BGPINDRC(BGPI,0),U,9)
+22 SET BGPN=$PIECE(^DD(90560.03,BGPNF,0),U,4)
+23 SET N=$PIECE(BGPN,";")
SET P=$PIECE(BGPN,";",2)
+24 DO S(BGPRPT,BGPGBL,N,P,BGPNUM)
DO S1("N",BGPNUM)
+25 SET BGPDF=$PIECE(^BGPINDRC(BGPI,0),U,8)
+26 SET BGPN=$PIECE(^DD(90560.03,BGPDF,0),U,4)
SET N=$PIECE(BGPN,";")
SET P=$PIECE(BGPN,";",2)
+27 IF BGPDEN'="NO"
DO S(BGPRPT,BGPGBL,N,P,BGPDEN)
DO S1("D",BGPDEN)
+28 IF $GET(BGPCPPL)
DO CPL
End DoDot:2
+29 IF $DATA(BGPLIST(BGPIC))
DO STMP^BGP8UTL
+30 IF $GET(BGPNPL)
DO NPL
+31 FOR X=1:1:99
SET Y="BGPN"_X
KILL @Y
+32 FOR X=1:1:99
SET Y="BGPD"_X
KILL @Y
End DoDot:1
+33 QUIT
+34 ;
CPL ;comprehensive pat list check and set xtmp
+1 ;not this provider
IF BGPLIST="P"
IF $PIECE(^AUPNPAT(DFN,0),U,14)'=BGPLPRV
QUIT
+2 IF BGPTIME'=1
QUIT
+3 IF $PIECE($GET(^BGPINDRC(BGPI,12)),U,1)=""
QUIT
+4 XECUTE ^BGPINDRC(BGPI,3)
IF '$TEST
QUIT
+5 SET C=$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN")
+6 SET S=$PIECE(^DPT(DFN,0),U,2)
+7 SET D=$PIECE(BGPVALUE,"|||")
+8 SET F=$PIECE($GET(^XTMP("BGP28CPL",BGPJ,BGPH,"LIST",C,S,BGPAGEB,DFN)),"|||")
+9 IF D["UP"
SET $PIECE(F,"$$",1)="UP"
+10 IF D["AC"
SET $PIECE(F,"$$",2)="AC"
+11 IF D["AD"
SET $PIECE(F,"$$",3)="AD"
+12 IF D["AAD"
SET $PIECE(F,"$$",4)="AAD"
+13 IF D["PREG"
SET $PIECE(F,"$$",5)="PREG"
+14 IF D["IMM"
SET $PIECE(F,"$$",6)="IMM"
+15 IF D["IHD"
SET $PIECE(F,"$$",7)="IHD"
+16 IF '$DATA(^XTMP("BGP28CPL",BGPJ,BGPH,"LIST",C,S,BGPAGEB,DFN))
Begin DoDot:1
+17 SET ^XTMP("BGP28CPL",BGPJ,BGPH,"LIST",C,S,BGPAGEB,DFN)=F_"|||"_$PIECE(^BGPINDRC(BGPI,12),U)
SET BGPCPLC=BGPCPLC+1
End DoDot:1
QUIT
+18 SET $PIECE(^XTMP("BGP28CPL",BGPJ,BGPH,"LIST",C,S,BGPAGEB,DFN),"|||")=F
+19 SET $PIECE(^XTMP("BGP28CPL",BGPJ,BGPH,"LIST",C,S,BGPAGEB,DFN),"|||",2)=$PIECE(^XTMP("BGP28CPL",BGPJ,BGPH,"LIST",C,S,BGPAGEB,DFN),"|||",2)_"#"_$PIECE(^BGPINDRC(BGPI,12),U)
+20 QUIT
NPL ;
+1 IF BGPTIME'=1
QUIT
+2 ;not a selected topic
IF '$DATA(BGPINDL(BGPIC))
QUIT
+3 NEW A
+4 SET BGPX=0
FOR
SET BGPX=$ORDER(BGPINDL(BGPIC,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:1
+5 IF BGPLIST="P"
IF $PIECE(^AUPNPAT(DFN,0),U,14)'=BGPLPRV
QUIT
+6 SET BGPORD=$PIECE($GET(^BGPINDR(BGPIC,12)),U,6)
+7 XECUTE ^BGPNPLR(BGPX,12)
KILL ^TMP($JOB)
IF '$TEST
QUIT
+8 SET BGPINDL(BGPIC,BGPX)=$GET(BGPINDL(BGPIC,BGPX))+1
+9 IF $GET(BGPYNPLT)
SET ^XTMP("BGP8DNP",BGPJ,BGPH,"LIST",BGPORD,BGPIC,BGPX,DFN)=""
QUIT
+10 SET BGPO=$SELECT(BGPRTYPE=7:$PIECE(^BGPNPLR(BGPX,0),U,6),1:$PIECE(^BGPNPLR(BGPX,0),U,5))
+11 SET A=""
+12 IF $PIECE(^BGPINDR(BGPIC,0),U,2)=151
SET A=BGPAGEE
GOTO SL
+13 IF $PIECE(^BGPINDR(BGPIC,0),U,2)=171
SET A=BGPAGEE
GOTO SL
+14 SET A=BGPAGEB
SL IF $PIECE(^BGPNPLR(BGPX,0),U,7)=9
IF $GET(BGPVALUD)]""
SET BGPVALUE=BGPVALUD
+1 SET ^XTMP("BGP8DNP",BGPJ,BGPH,"LIST",BGPORD,BGPIC,BGPO,BGPX,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),A,DFN)=$GET(BGPVALUE)
End DoDot:1
+2 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPX,A
+3 QUIT
S(R,G,N,P,V) ;
+1 ;no value to add
IF 'V
QUIT
+2 SET $PIECE(@(G_R_","_N_")"),U,P)=$PIECE($GET(@(G_R_","_N_")")),U,P)+V
+3 QUIT
D(D) ;
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+$EXTRACT(D,1,3))
+3 ;
S1(BQITYP,BQIVAL) ; Return data by patient for iCare into global reference BQIGREF
+1 ;Input Variables
+2 ; BQITYP - Type of value
+3 ; D = Denominator
+4 ; N = Numerator
+5 ; BQIVAL - Value of the type; 0 or 1
+6 ;Assumed variables
+7 ; BGPVALUE - the measure value
+8 ; BQIGREF - global reference where data will be stored temporarily
+9 ; BGPIC - Indicator IEN
+10 ; BGPI - Individual Indicator IEN
+11 ; DFN - Patient IEN
+12 ;
+13 ; If no value of BQIGREF, then it's the regular GPRA report calling the code
+14 ; and nothing needs to be set for iCare.
+15 IF $GET(BQIGREF)=""
QUIT
+16 ;
+17 ; If no denominator or numerator value, then it doesn't need to be set for iCare
+18 IF '$GET(BQIVAL)
QUIT
+19 ;
+20 NEW BQITIT,BQILTIT,BQILTIT1,BQILTIT2,BQILTIT3,BQILDTI1,BQILDTI2
+21 NEW BQIDTIT,BQIFTIT,BQITWEN,BQICURR,BQIIDTA,BQIDTA,BQILDTI3
+22 SET BQIIDTA=$GET(^BGPINDRC(BGPI,17))
+23 SET BQIDTA=$GET(^BGPINDRC(BGPI,14))
+24 ;
+25 ; Get the Individual Indicator TITLE (1404)
+26 ;S BQITIT=$P(BQIDTA,U,4)
+27 ;
+28 ; Get the Individual Indicator LINE TITLE 1 (.15)
+29 ;S BQILTIT1=$P(BQIIDTA,U,15)
+30 ;I BQILTIT1="" Q
+31 ; Get the Individual Indicator LINE TITLE 2 and 3 (.16,.19)
+32 ;S BQILTIT2=$P(BQIIDTA,U,16)
+33 ;S BQILTIT3=$P(BQIIDTA,U,19)
+34 ;S BQILTIT=$P(BQIIDTA,U,3)
+35 ;
+36 ; Get the Individual Indicator LOCAL DENOM TITLE 1, 2, and 3 (.17,.18,.21)
+37 ;S BQILDTI1=$P(BQIIDTA,U,17)
+38 ;S BQILDTI2=$P(BQIIDTA,U,18)
+39 ;S BQILDTI3=$P(BQIIDTA,U,21)
+40 ;S BQIDTIT=BQILDTI1_" "_BQILDTI2_" "_BQILDTI3
+41 ;
+42 ; Full title is all title fields
+43 SET BQIFTIT=$PIECE(BQIIDTA,"^",3)
+44 SET $PIECE(@BQIGREF@(DFN,BGPIC,BGPI),"^",1)=BQIFTIT
+45 ;
+46 ; Get the GOAL 2018 value and the GOAL 06 value
+47 SET BQITWEN=$PIECE(BQIDTA,U,3)
+48 SET BQICURR=$PIECE(BQIDTA,U,8)
+49 ;
+50 IF BQITYP="N"
SET $PIECE(@BQIGREF@(DFN,BGPIC,BGPI),"^",2)=$GET(BQIVAL)
+51 ;
+52 IF BQITYP="D"
SET $PIECE(@BQIGREF@(DFN,BGPIC,BGPI),"^",3)=$GET(BQIVAL)
+53 ;
+54 ; Set the Indicator TITLE (.03)
+55 SET $PIECE(@BQIGREF@(DFN,BGPIC),U,1)=$PIECE(^BGPINDR(BGPIC,0),U,3)
+56 SET $PIECE(@BQIGREF@(DFN,BGPIC),U,2)=$GET(BGPVALUE)
+57 IF BQITWEN'=""
SET $PIECE(@BQIGREF@(DFN,BGPIC),U,3)=BQITWEN
+58 IF BQICURR'=""
SET $PIECE(@BQIGREF@(DFN,BGPIC),U,4)=BQICURR
+59 QUIT
