- BGP4D54 ; IHS/CMI/LAB - measure calc 02 Jul 2010 8:08 AM ;
- ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
- ;
- ;
- DVDX ;EP
- I $G(P)="" Q ""
- NEW BGPG,Y,X,BGPLDV,E,BGPC,BGPV,BGPP,G,Y
- K BGPG
- S Y="BGPG(",BGPLDV=""
- S X=P_"^LAST DX [BGP DV DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
- I $D(BGPG(1)) S BGPLDV=1_"^"_$P(BGPG(1),U)_"^Dv Dx "_$P(BGPG(1),U,2)_U_"POV "_$P(BGPG(1),U,2)_U_$$DATE^BGP4UTL($P(BGPG(1),U,1))
- S BGPC=0,BGPV="" ;I $D(BGPG(1)) S BGPC=1
- S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC) D
- .S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPC) S BGPP=$P($G(^AMHRPRO(X,0)),U) D
- ..Q:'BGPP
- ..S BGPP=$P($G(^AMHPROB(BGPP,0)),U)
- ..I $E(BGPP,1,2)=43 S BGPC=1,BGPV=1_"^"_(9999999-D)_"^BH "_BGPP_U_"BH POV "_BGPP_U_$$DATE^BGP4UTL((9999999-D)) Q
- ..I $E(BGPP,1,2)=44 S BGPC=1,BGPV=1_"^"_(9999999-D)_"^BH "_BGPP_U_"BH POV "_BGPP_U_$$DATE^BGP4UTL((9999999-D)) Q
- ..I BGPP=995.80 S BGPC=1,BGPV=1_"^"_(9999999-D)_"^BH "_BGPP_U_"BH POV "_BGPP_U_$$DATE^BGP4UTL((9999999-D)) Q
- ..I BGPP=995.81 S BGPC=1,BGPV=1_"^"_(9999999-D)_"^BH "_BGPP_U_"BH POV "_BGPP_U_$$DATE^BGP4UTL((9999999-D)) Q
- ..Q
- I BGPV,$P(BGPLDV,U,2)<$P(BGPV,U,2) S BGPLDV=BGPV
- ;now check pcc problem list
- S T=$O(^ATXAX("B","BGP DV DXS",0))
- S (X,G)=0,BGPDXPLE="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
- .Q:$P(^AUPNPROB(X,0),U,12)="D"
- .Q:$P(^AUPNPROB(X,0),U,12)="I"
- .Q:$P(^AUPNPROB(X,0),U,3)>EDATE
- .Q:$P(^AUPNPROB(X,0),U,3)<BDATE
- .S Y=$P(^AUPNPROB(X,0),U)
- .Q:'$$ICD^BGP4UTL2(Y,T,9)
- .S G=1_U_$P(^AUPNPROB(X,0),U,3),BGPDXPLE=X
- .Q
- I G,$P(BGPLDV,U,2)<$P(G,U,2) S BGPLDV=1_U_$P(G,U,2)_U_"PL"_U_"PL "_$$VAL^XBDIQ1(9000011,BGPDXPLE,.01)_U_$$VAL^XBDIQ1(9000011,BGPDXPLE,.03)
- S (X,G)=0,BGPDXPLE="" F S X=$O(^AMHPPROB("AC",P,X)) Q:X'=+X!(G) D
- .Q:$P(^AMHPPROB(X,0),U,12)'="A"
- .Q:$P(^AMHPPROB(X,0),U,3)>EDATE
- .Q:$P(^AMHPPROB(X,0),U,3)<BDATE
- .S Y=$P(^AMHPPROB(X,0),U)
- .S Y=$P($G(^AMHPROB(Y,0)),U)
- .I $E(Y,1,2)="43" S G=1_U_$P(^AMHPPROB(X,0),U,3),BGPDXPLE=X Q
- .I $E(Y,1,2)="44" S G=1_U_$P(^AMHPPROB(X,0),U,3),BGPDXPLE=X Q
- .I Y=995.80 S G=1_U_$P(^AMHPPROB(X,0),U,3),BGPDXPLE=X Q
- .I Y=995.81 S G=1_U_$P(^AMHPPROB(X,0),U,3),BGPDXPLE=X Q
- .I Y=995.82 S G=1_U_$P(^AMHPPROB(X,0),U,3),BGPDXPLE=X Q
- .I Y=995.83 S G=1_U_$P(^AMHPPROB(X,0),U,3),BGPDXPLE=X Q
- .I Y=995.85 S G=1_U_$P(^AMHPPROB(X,0),U,3),BGPDXPLE=X Q
- .Q
- I G,$P(BGPLDV,U,2)<$P(G,U,2) S BGPLDV=1_U_$P(G,U,2)_U_"PL"_U_"BH PL "_$$VAL^XBDIQ1(9002011.51,BGPDXPLE,.01)_U_$$VAL^XBDIQ1(9002011.51,BGPDXPLE,.03)
- Q BGPLDV
- BGP4D54 ; IHS/CMI/LAB - measure calc 02 Jul 2010 8:08 AM ;
- +1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
- +2 ;
- +3 ;
- DVDX ;EP
- +1 IF $GET(P)=""
- QUIT ""
- +2 NEW BGPG,Y,X,BGPLDV,E,BGPC,BGPV,BGPP,G,Y
- +3 KILL BGPG
- +4 SET Y="BGPG("
- SET BGPLDV=""
- +5 SET X=P_"^LAST DX [BGP DV DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
- SET E=$$START1^APCLDF(X,Y)
- +6 IF $DATA(BGPG(1))
- SET BGPLDV=1_"^"_$PIECE(BGPG(1),U)_"^Dv Dx "_$PIECE(BGPG(1),U,2)_U_"POV "_$PIECE(BGPG(1),U,2)_U_$$DATE^BGP4UTL($PIECE(BGPG(1),U,1))
- +7 ;I $D(BGPG(1)) S BGPC=1
- SET BGPC=0
- SET BGPV=""
- +8 SET E=9999999-BDATE
- SET D=9999999-EDATE-1_".99"
- FOR
- SET D=$ORDER(^AMHREC("AE",P,D))
- IF D'=+D!($PIECE(D,".")>E)!(BGPC)
- QUIT
- SET V=0
- FOR
- SET V=$ORDER(^AMHREC("AE",P,D,V))
- IF V'=+V!(BGPC)
- QUIT
- Begin DoDot:1
- +9 SET X=0
- FOR
- SET X=$ORDER(^AMHRPRO("AD",V,X))
- IF X'=+X!(BGPC)
- QUIT
- SET BGPP=$PIECE($GET(^AMHRPRO(X,0)),U)
- Begin DoDot:2
- +10 IF 'BGPP
- QUIT
- +11 SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)
- +12 IF $EXTRACT(BGPP,1,2)=43
- SET BGPC=1
- SET BGPV=1_"^"_(9999999-D)_"^BH "_BGPP_U_"BH POV "_BGPP_U_$$DATE^BGP4UTL((9999999-D))
- QUIT
- +13 IF $EXTRACT(BGPP,1,2)=44
- SET BGPC=1
- SET BGPV=1_"^"_(9999999-D)_"^BH "_BGPP_U_"BH POV "_BGPP_U_$$DATE^BGP4UTL((9999999-D))
- QUIT
- +14 IF BGPP=995.80
- SET BGPC=1
- SET BGPV=1_"^"_(9999999-D)_"^BH "_BGPP_U_"BH POV "_BGPP_U_$$DATE^BGP4UTL((9999999-D))
- QUIT
- +15 IF BGPP=995.81
- SET BGPC=1
- SET BGPV=1_"^"_(9999999-D)_"^BH "_BGPP_U_"BH POV "_BGPP_U_$$DATE^BGP4UTL((9999999-D))
- QUIT
- +16 QUIT
- End DoDot:2
- End DoDot:1
- +17 IF BGPV
- IF $PIECE(BGPLDV,U,2)<$PIECE(BGPV,U,2)
- SET BGPLDV=BGPV
- +18 ;now check pcc problem list
- +19 SET T=$ORDER(^ATXAX("B","BGP DV DXS",0))
- +20 SET (X,G)=0
- SET BGPDXPLE=""
- FOR
- SET X=$ORDER(^AUPNPROB("AC",P,X))
- IF X'=+X!(G)
- QUIT
- Begin DoDot:1
- +21 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
- QUIT
- +22 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
- QUIT
- +23 IF $PIECE(^AUPNPROB(X,0),U,3)>EDATE
- QUIT
- +24 IF $PIECE(^AUPNPROB(X,0),U,3)<BDATE
- QUIT
- +25 SET Y=$PIECE(^AUPNPROB(X,0),U)
- +26 IF '$$ICD^BGP4UTL2(Y,T,9)
- QUIT
- +27 SET G=1_U_$PIECE(^AUPNPROB(X,0),U,3)
- SET BGPDXPLE=X
- +28 QUIT
- End DoDot:1
- +29 IF G
- IF $PIECE(BGPLDV,U,2)<$PIECE(G,U,2)
- SET BGPLDV=1_U_$PIECE(G,U,2)_U_"PL"_U_"PL "_$$VAL^XBDIQ1(9000011,BGPDXPLE,.01)_U_$$VAL^XBDIQ1(9000011,BGPDXPLE,.03)
- +30 SET (X,G)=0
- SET BGPDXPLE=""
- FOR
- SET X=$ORDER(^AMHPPROB("AC",P,X))
- IF X'=+X!(G)
- QUIT
- Begin DoDot:1
- +31 IF $PIECE(^AMHPPROB(X,0),U,12)'="A"
- QUIT
- +32 IF $PIECE(^AMHPPROB(X,0),U,3)>EDATE
- QUIT
- +33 IF $PIECE(^AMHPPROB(X,0),U,3)<BDATE
- QUIT
- +34 SET Y=$PIECE(^AMHPPROB(X,0),U)
- +35 SET Y=$PIECE($GET(^AMHPROB(Y,0)),U)
- +36 IF $EXTRACT(Y,1,2)="43"
- SET G=1_U_$PIECE(^AMHPPROB(X,0),U,3)
- SET BGPDXPLE=X
- QUIT
- +37 IF $EXTRACT(Y,1,2)="44"
- SET G=1_U_$PIECE(^AMHPPROB(X,0),U,3)
- SET BGPDXPLE=X
- QUIT
- +38 IF Y=995.80
- SET G=1_U_$PIECE(^AMHPPROB(X,0),U,3)
- SET BGPDXPLE=X
- QUIT
- +39 IF Y=995.81
- SET G=1_U_$PIECE(^AMHPPROB(X,0),U,3)
- SET BGPDXPLE=X
- QUIT
- +40 IF Y=995.82
- SET G=1_U_$PIECE(^AMHPPROB(X,0),U,3)
- SET BGPDXPLE=X
- QUIT
- +41 IF Y=995.83
- SET G=1_U_$PIECE(^AMHPPROB(X,0),U,3)
- SET BGPDXPLE=X
- QUIT
- +42 IF Y=995.85
- SET G=1_U_$PIECE(^AMHPPROB(X,0),U,3)
- SET BGPDXPLE=X
- QUIT
- +43 QUIT
- End DoDot:1
- +44 IF G
- IF $PIECE(BGPLDV,U,2)<$PIECE(G,U,2)
- SET BGPLDV=1_U_$PIECE(G,U,2)_U_"PL"_U_"BH PL "_$$VAL^XBDIQ1(9002011.51,BGPDXPLE,.01)_U_$$VAL^XBDIQ1(9002011.51,BGPDXPLE,.03)
- +45 QUIT BGPLDV
