BGP8EL4 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2010 1:44 PM ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
I18 ;EP
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
I BGPAGEB<55 S BGPSTOP=1 Q
I 'BGPACTCL S BGPSTOP=1 Q
S BGPD1=1
I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
I BGPAGEB>84 S BGPD5=1
D CHEL^BGP8D73
S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPLDL
Q
;
PALLCARE ;EP
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10)=0
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
I BGPAGEB<55 S BGPSTOP=1 Q
I 'BGPACTCL S BGPSTOP=1 Q
S BGPD1=1
I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
I BGPAGEB>84 S BGPD5=1
S BGPVAL=$$PCV^BGP8D24(DFN,BGPBDATE,BGPEDATE) ;return #visits^list string
S BGPN1=$P(BGPVAL,U)
;S BGPCANCE=$$CANCER^BGP8D24(DFN,BGPBDATE,BGPEDATE)
;I BGPCANCE S BGPD6=1 D
;.I BGPAGEB>54,BGPAGEB<65 S BGPD7=1
;.I BGPAGEB>64,BGPAGEB<75 S BGPD8=1
;.I BGPAGEB>74,BGPAGEB<85 S BGPD9=1
;.I BGPAGEB>84 S BGPD10=1
;S BGPVAL=$$PCV(DFN,BGPBDATE,BGPEDATE) ;return #visits^list string
S BGPN1=$P(BGPVAL,U)
;I BGPCANCE,BGPN1>1 S BGPN5=1
S BGPVALUE="AC"_"|||"_BGPN1_$S(BGPN1'=1:" visits: ",1:" visit: ")_$P(BGPVAL,U,2)
K BGPVAL
Q
;
FUNCTION(P,BDATE,EDATE) ;EP
S BD=(9999999-BDATE)
S ED=(9999999-EDATE)-1
K BGPG
S (BGP1,BGP2)=0
F S ED=$O(^AUPNVELD("AA",P,ED)) Q:ED=""!(ED>BD) D
.S BGPX=0 F S BGPX=$O(^AUPNVELD("AA",P,ED,BGPX)) Q:BGPX'=+BGPX D
..S Y=^AUPNVELD(BGPX,0)
..I $P(Y,U,4)]"" S:'$O(BGPG("TLT",0)) BGPG("TLT",ED)="",BGP1=1
..I $P(Y,U,5)]"" S:'$O(BGPG("BATH",0)) BGPG("BATH",ED)="",BGP1=1
..I $P(Y,U,6)]"" S:'$O(BGPG("DRES",0)) BGPG("DRES",ED)="",BGP1=1
..I $P(Y,U,7)]"" S:'$O(BGPG("XFER",0)) BGPG("XFER",ED)="",BGP1=1
..I $P(Y,U,8)]"" S:'$O(BGPG("FEED",0)) BGPG("FEED",ED)="",BGP1=1
..I $P(Y,U,9)]"" S:'$O(BGPG("CONT",0)) BGPG("CONT",ED)="",BGP1=1
..I $P(Y,U,11)]"" S:'$O(BGPG("FIN",0)) BGPG("FIN",ED)="",BGP2=1
..I $P(Y,U,12)]"" S:'$O(BGPG("COOK",0)) BGPG("COOK",ED)="",BGP2=1
..I $P(Y,U,13)]"" S:'$O(BGPG("SHOP",0)) BGPG("SHOP",ED)="",BGP2=1
..I $P(Y,U,14)]"" S:'$O(BGPG("HSWK",0)) BGPG("HSWK",ED)="",BGP2=1
..I $P(Y,U,15)]"" S:'$O(BGPG("MEDS",0)) BGPG("MEDS",ED)="",BGP2=1
..I $P(Y,U,16)]"" S:'$O(BGPG("TRNS",0)) BGPG("TRNS",ED)="",BGP2=1
K BGPV
S X="" F S X=$O(BGPG(X)) Q:X="" S ED=$O(BGPG(X,0)) S:$D(BGPV(ED)) BGPV(ED)=BGPV(ED)_", " S BGPV(ED)=$G(BGPV(ED))_X
S BGPQ=""
S BGPQ=$S((BGP1+BGP2)=2:1,1:0)_U
S Y=0 F S Y=$O(BGPV(Y)) Q:Y'=+Y D
.S $P(BGPQ,U,2)=$P(BGPQ,U,2)_$$DATE^BGP8UTL((9999999-Y))_" "_BGPV(Y)_" "
K BGPV,BGPG
Q BGPQ
;
PHNV(P,BDATE,EDATE,HOMELOC) ;EP
S HOMELOC=$G(HOMELOC)
K ^TMP($J,"A") S A="^TMP($J,""A"","
S B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q "0^0^0^0^0^0^0^0^0^0^0^0"
S (X,Y)=0,C="0^0^0^0^0^0^0^0^0^0^0^0" F S X=$O(^TMP($J,"A",X)) Q:X'=+X S V=$P(^TMP($J,"A",X),U,5) D
.;S Y=0 I $$CLINIC^APCLV(V,"C")=45 S Y=1 Q
.S (D,Y,Z)=0
.F S D=$O(^AUPNVPRV("AD",V,D)) Q:D'=+D S Q=$P(^AUPNVPRV(D,0),U) D
..Q:Q=""
..S %=$$VALI^XBDIQ1($S($P(^DD(9000010.06,.01,0),U,2)["200":200,1:6),Q,$S($P(^DD(9000010.06,.01,0),U,2)["200":53.5,1:2))
..I % S %=$P($G(^DIC(7,+%,9999999)),U)
..I %'=13,%'=91 Q ;not a phn or driver
..S $P(C,U,1)=$P(C,U,1)+1
..I %=91 S $P(C,U,6)=$P(C,U,6)+1
..D HOME
..D AGE
Q C
;
HOME ;
S HV=0
I $$CLINIC^APCLV(V,"C")=11 S $P(C,U,7)=$P(C,U,7)+1,HV=1 S:%=91 $P(C,U,12)=$P(C,U,12)+1 Q
Q:HOMELOC=""
I HOMELOC=$P(^AUPNVSIT(V,0),U,6) S $P(C,U,7)=$P(C,U,7)+1,HV=1 S:%=91 $P(C,U,12)=$P(C,U,12)+1 Q
Q
AGE ;
NEW YRS
S YRS=$$AGE^AUPNPAT(P,$P($P(^AUPNVSIT(V,0),U),"."))
I YRS>54,YRS<65 S $P(C,U,2)=$P(C,U,2)+1 S:HV=1 $P(C,U,8)=$P(C,U,8)+1 Q
I YRS>64,YRS<75 S $P(C,U,3)=$P(C,U,3)+1 S:HV=1 $P(C,U,9)=$P(C,U,9)+1 Q
I YRS>74,YRS<85 S $P(C,U,4)=$P(C,U,4)+1 S:HV=1 $P(C,U,10)=$P(C,U,10)+1 Q
I YRS>84 S $P(C,U,5)=$P(C,U,5)+1 S:HV=1 $P(C,U,11)=$P(C,U,11)+1 Q
W BGPBOMB
Q
BGP8EL4 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2010 1:44 PM ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
I18 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
+3 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+5 SET BGPD1=1
+6 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD2=1
+7 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD3=1
+8 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD4=1
+9 IF BGPAGEB>84
SET BGPD5=1
+10 DO CHEL^BGP8D73
+11 SET BGPVALUE="AC|||"_$PIECE(BGPVALUE,"|||",2)
+12 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPLDL
+13 QUIT
+14 ;
PALLCARE ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
+3 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+5 SET BGPD1=1
+6 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD2=1
+7 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD3=1
+8 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD4=1
+9 IF BGPAGEB>84
SET BGPD5=1
+10 ;return #visits^list string
SET BGPVAL=$$PCV^BGP8D24(DFN,BGPBDATE,BGPEDATE)
+11 SET BGPN1=$PIECE(BGPVAL,U)
+12 ;S BGPCANCE=$$CANCER^BGP8D24(DFN,BGPBDATE,BGPEDATE)
+13 ;I BGPCANCE S BGPD6=1 D
+14 ;.I BGPAGEB>54,BGPAGEB<65 S BGPD7=1
+15 ;.I BGPAGEB>64,BGPAGEB<75 S BGPD8=1
+16 ;.I BGPAGEB>74,BGPAGEB<85 S BGPD9=1
+17 ;.I BGPAGEB>84 S BGPD10=1
+18 ;S BGPVAL=$$PCV(DFN,BGPBDATE,BGPEDATE) ;return #visits^list string
+19 SET BGPN1=$PIECE(BGPVAL,U)
+20 ;I BGPCANCE,BGPN1>1 S BGPN5=1
+21 SET BGPVALUE="AC"_"|||"_BGPN1_$SELECT(BGPN1'=1:" visits: ",1:" visit: ")_$PIECE(BGPVAL,U,2)
+22 KILL BGPVAL
+23 QUIT
+24 ;
FUNCTION(P,BDATE,EDATE) ;EP
+1 SET BD=(9999999-BDATE)
+2 SET ED=(9999999-EDATE)-1
+3 KILL BGPG
+4 SET (BGP1,BGP2)=0
+5 FOR
SET ED=$ORDER(^AUPNVELD("AA",P,ED))
IF ED=""!(ED>BD)
QUIT
Begin DoDot:1
+6 SET BGPX=0
FOR
SET BGPX=$ORDER(^AUPNVELD("AA",P,ED,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+7 SET Y=^AUPNVELD(BGPX,0)
+8 IF $PIECE(Y,U,4)]""
IF '$ORDER(BGPG("TLT",0))
SET BGPG("TLT",ED)=""
SET BGP1=1
+9 IF $PIECE(Y,U,5)]""
IF '$ORDER(BGPG("BATH",0))
SET BGPG("BATH",ED)=""
SET BGP1=1
+10 IF $PIECE(Y,U,6)]""
IF '$ORDER(BGPG("DRES",0))
SET BGPG("DRES",ED)=""
SET BGP1=1
+11 IF $PIECE(Y,U,7)]""
IF '$ORDER(BGPG("XFER",0))
SET BGPG("XFER",ED)=""
SET BGP1=1
+12 IF $PIECE(Y,U,8)]""
IF '$ORDER(BGPG("FEED",0))
SET BGPG("FEED",ED)=""
SET BGP1=1
+13 IF $PIECE(Y,U,9)]""
IF '$ORDER(BGPG("CONT",0))
SET BGPG("CONT",ED)=""
SET BGP1=1
+14 IF $PIECE(Y,U,11)]""
IF '$ORDER(BGPG("FIN",0))
SET BGPG("FIN",ED)=""
SET BGP2=1
+15 IF $PIECE(Y,U,12)]""
IF '$ORDER(BGPG("COOK",0))
SET BGPG("COOK",ED)=""
SET BGP2=1
+16 IF $PIECE(Y,U,13)]""
IF '$ORDER(BGPG("SHOP",0))
SET BGPG("SHOP",ED)=""
SET BGP2=1
+17 IF $PIECE(Y,U,14)]""
IF '$ORDER(BGPG("HSWK",0))
SET BGPG("HSWK",ED)=""
SET BGP2=1
+18 IF $PIECE(Y,U,15)]""
IF '$ORDER(BGPG("MEDS",0))
SET BGPG("MEDS",ED)=""
SET BGP2=1
+19 IF $PIECE(Y,U,16)]""
IF '$ORDER(BGPG("TRNS",0))
SET BGPG("TRNS",ED)=""
SET BGP2=1
End DoDot:2
End DoDot:1
+20 KILL BGPV
+21 SET X=""
FOR
SET X=$ORDER(BGPG(X))
IF X=""
QUIT
SET ED=$ORDER(BGPG(X,0))
IF $DATA(BGPV(ED))
SET BGPV(ED)=BGPV(ED)_", "
SET BGPV(ED)=$GET(BGPV(ED))_X
+22 SET BGPQ=""
+23 SET BGPQ=$SELECT((BGP1+BGP2)=2:1,1:0)_U
+24 SET Y=0
FOR
SET Y=$ORDER(BGPV(Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+25 SET $PIECE(BGPQ,U,2)=$PIECE(BGPQ,U,2)_$$DATE^BGP8UTL((9999999-Y))_" "_BGPV(Y)_" "
End DoDot:1
+26 KILL BGPV,BGPG
+27 QUIT BGPQ
+28 ;
PHNV(P,BDATE,EDATE,HOMELOC) ;EP
+1 SET HOMELOC=$GET(HOMELOC)
+2 KILL ^TMP($JOB,"A")
SET A="^TMP($J,""A"","
+3 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 "0^0^0^0^0^0^0^0^0^0^0^0"
+5 SET (X,Y)=0
SET C="0^0^0^0^0^0^0^0^0^0^0^0"
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+6 ;S Y=0 I $$CLINIC^APCLV(V,"C")=45 S Y=1 Q
+7 SET (D,Y,Z)=0
+8 FOR
SET D=$ORDER(^AUPNVPRV("AD",V,D))
IF D'=+D
QUIT
SET Q=$PIECE(^AUPNVPRV(D,0),U)
Begin DoDot:2
+9 IF Q=""
QUIT
+10 SET %=$$VALI^XBDIQ1($SELECT($PIECE(^DD(9000010.06,.01,0),U,2)["200":200,1:6),Q,$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)["200":53.5,1:2))
+11 IF %
SET %=$PIECE($GET(^DIC(7,+%,9999999)),U)
+12 ;not a phn or driver
IF %'=13
IF %'=91
QUIT
+13 SET $PIECE(C,U,1)=$PIECE(C,U,1)+1
+14 IF %=91
SET $PIECE(C,U,6)=$PIECE(C,U,6)+1
+15 DO HOME
+16 DO AGE
End DoDot:2
End DoDot:1
+17 QUIT C
+18 ;
HOME ;
+1 SET HV=0
+2 IF $$CLINIC^APCLV(V,"C")=11
SET $PIECE(C,U,7)=$PIECE(C,U,7)+1
SET HV=1
IF %=91
SET $PIECE(C,U,12)=$PIECE(C,U,12)+1
QUIT
+3 IF HOMELOC=""
QUIT
+4 IF HOMELOC=$PIECE(^AUPNVSIT(V,0),U,6)
SET $PIECE(C,U,7)=$PIECE(C,U,7)+1
SET HV=1
IF %=91
SET $PIECE(C,U,12)=$PIECE(C,U,12)+1
QUIT
+5 QUIT
AGE ;
+1 NEW YRS
+2 SET YRS=$$AGE^AUPNPAT(P,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+3 IF YRS>54
IF YRS<65
SET $PIECE(C,U,2)=$PIECE(C,U,2)+1
IF HV=1
SET $PIECE(C,U,8)=$PIECE(C,U,8)+1
QUIT
+4 IF YRS>64
IF YRS<75
SET $PIECE(C,U,3)=$PIECE(C,U,3)+1
IF HV=1
SET $PIECE(C,U,9)=$PIECE(C,U,9)+1
QUIT
+5 IF YRS>74
IF YRS<85
SET $PIECE(C,U,4)=$PIECE(C,U,4)+1
IF HV=1
SET $PIECE(C,U,10)=$PIECE(C,U,10)+1
QUIT
+6 IF YRS>84
SET $PIECE(C,U,5)=$PIECE(C,U,5)+1
IF HV=1
SET $PIECE(C,U,11)=$PIECE(C,U,11)+1
QUIT
+7 WRITE BGPBOMB
+8 QUIT
