BGP7D54 ; IHS/CMI/LAB - measure calc 02 Jul 2010 8:08 AM ;
;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
;
;
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^BGP7UTL($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^BGP7UTL((9999999-D)) Q
..I $E(BGPP,1,2)=44 S BGPC=1,BGPV=1_"^"_(9999999-D)_"^BH "_BGPP_U_"BH POV "_BGPP_U_$$DATE^BGP7UTL((9999999-D)) Q
..I BGPP=995.80 S BGPC=1,BGPV=1_"^"_(9999999-D)_"^BH "_BGPP_U_"BH POV "_BGPP_U_$$DATE^BGP7UTL((9999999-D)) Q
..I BGPP=995.81 S BGPC=1,BGPV=1_"^"_(9999999-D)_"^BH "_BGPP_U_"BH POV "_BGPP_U_$$DATE^BGP7UTL((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 G=$$PLTAXID^BGP7DU(P,"BGP DV DXS",BDATE,EDATE)
I G S BGPDXPLE=$P(G,U,4),G=1_U_$P(G,U,3)
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_$$DATE^BGP7UTL($P(G,U,2))
S G=$$IPLSNOID^BGP7DU(P,"PXRM BGP IPV DV DX",BDATE,EDATE)
I G,$P(BGPLDV,U,2)<$P(G,U,3) S BGPLDV=1_U_$P(G,U,3)_U_"PL"_U_"PL "_$P(G,U,2)_U_$P(G,U,4)
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
BGP7D54 ; IHS/CMI/LAB - measure calc 02 Jul 2010 8:08 AM ;
+1 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
+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^BGP7UTL($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^BGP7UTL((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^BGP7UTL((9999999-D))
QUIT
+14 IF BGPP=995.80
SET BGPC=1
SET BGPV=1_"^"_(9999999-D)_"^BH "_BGPP_U_"BH POV "_BGPP_U_$$DATE^BGP7UTL((9999999-D))
QUIT
+15 IF BGPP=995.81
SET BGPC=1
SET BGPV=1_"^"_(9999999-D)_"^BH "_BGPP_U_"BH POV "_BGPP_U_$$DATE^BGP7UTL((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 G=$$PLTAXID^BGP7DU(P,"BGP DV DXS",BDATE,EDATE)
+21 IF G
SET BGPDXPLE=$PIECE(G,U,4)
SET G=1_U_$PIECE(G,U,3)
+22 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_$$DATE^BGP7UTL($PIECE(G,U,2))
+23 SET G=$$IPLSNOID^BGP7DU(P,"PXRM BGP IPV DV DX",BDATE,EDATE)
+24 IF G
IF $PIECE(BGPLDV,U,2)<$PIECE(G,U,3)
SET BGPLDV=1_U_$PIECE(G,U,3)_U_"PL"_U_"PL "_$PIECE(G,U,2)_U_$PIECE(G,U,4)
+25 SET (X,G)=0
SET BGPDXPLE=""
FOR
SET X=$ORDER(^AMHPPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+26 IF $PIECE(^AMHPPROB(X,0),U,12)'="A"
QUIT
+27 IF $PIECE(^AMHPPROB(X,0),U,3)>EDATE
QUIT
+28 IF $PIECE(^AMHPPROB(X,0),U,3)<BDATE
QUIT
+29 SET Y=$PIECE(^AMHPPROB(X,0),U)
+30 SET Y=$PIECE($GET(^AMHPROB(Y,0)),U)
+31 IF $EXTRACT(Y,1,2)="43"
SET G=1_U_$PIECE(^AMHPPROB(X,0),U,3)
SET BGPDXPLE=X
QUIT
+32 IF $EXTRACT(Y,1,2)="44"
SET G=1_U_$PIECE(^AMHPPROB(X,0),U,3)
SET BGPDXPLE=X
QUIT
+33 IF Y=995.80
SET G=1_U_$PIECE(^AMHPPROB(X,0),U,3)
SET BGPDXPLE=X
QUIT
+34 IF Y=995.81
SET G=1_U_$PIECE(^AMHPPROB(X,0),U,3)
SET BGPDXPLE=X
QUIT
+35 IF Y=995.82
SET G=1_U_$PIECE(^AMHPPROB(X,0),U,3)
SET BGPDXPLE=X
QUIT
+36 IF Y=995.83
SET G=1_U_$PIECE(^AMHPPROB(X,0),U,3)
SET BGPDXPLE=X
QUIT
+37 IF Y=995.85
SET G=1_U_$PIECE(^AMHPPROB(X,0),U,3)
SET BGPDXPLE=X
QUIT
+38 QUIT
End DoDot:1
+39 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)
+40 QUIT BGPLDV
