- BGP7EL4 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2010 1:44 PM ;
- ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
- ;
- 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^BGP7D73
- 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^BGP7D24(DFN,BGPBDATE,BGPEDATE) ;return #visits^list string
- S BGPN1=$P(BGPVAL,U)
- ;S BGPCANCE=$$CANCER^BGP7D24(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^BGP7UTL((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
- BGP7EL4 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2010 1:44 PM ;
- +1 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
- +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^BGP7D73
- +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^BGP7D24(DFN,BGPBDATE,BGPEDATE)
- +11 SET BGPN1=$PIECE(BGPVAL,U)
- +12 ;S BGPCANCE=$$CANCER^BGP7D24(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^BGP7UTL((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
