BUDDRP7B ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
;
HTN ;EP - list of HTN
;is patient pregnant during the time period BUDDD and BUDED
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUDDDB=($E(BUDBD,1,3)-85)_"0101"
S BUDDDE=($E(BUDBD,1,3)-18)_"1231"
Q:BUDDOB>BUDDDE
Q:BUDDOB<BUDDDB
Q:BUDMEDV<1
;
S BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDCCAD)
I '$P(BUDP,U) Q ;not dx'ed before june 30
;PREGNANCY
Q:$$PREG^BUDDRP6B(DFN,BUDBD,BUDED,BUDBD)
Q:$$EXCL(DFN,BUDDOB,BUDED)
S BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDED,1)
S BUDRACEX=$$RACE^BUDDRPTC(DFN),BUDRACE=$P(BUDRACEX,U,2),BUDRACEP=$P(BUDRACEX,U,5)
S BUDRACEE=$$RACE^BUDDRP7I(BUDRACE)
S BUDR=""
S BUDETHN=$P($$HISP^BUDDRPTC(DFN),U,1)
I +BUDETHN=1 S BUDETHNN="Hispanic or Latino"
I +BUDETHN=2 S BUDETHNN="Non-Hispanic/Latino"
I +BUDETHN=3 S BUDETHNN="Unreported/Refused to Report"
I BUDRACEP=8,+BUDETHN=3 S BUDR=1 G SETSECTB
I +BUDETHN=1 S BUDR=BUDRACEP G SETSECTB
I +BUDETHN=2 S BUDR=BUDRACEP G SETSECTB
;I +BUDETHN=3,BUDRACEP=8 S BUDR=1
SETSECTB ;
S $P(BUDSECTB(+BUDETHN,BUDR),U,1)=$P($G(BUDSECTB(+BUDETHN,BUDR)),U,1)+1 ;COL 1
S $P(BUDSECTB(+BUDETHN,BUDR),U,2)=$P($G(BUDSECTB(+BUDETHN,BUDR)),U,2)+1 ;COL 2
;TOTAL LINE
S $P(BUDSECTB(4),U,1)=$P($G(BUDSECTB(4)),U,1)+1
S $P(BUDSECTB(4),U,2)=$P($G(BUDSECTB(4)),U,2)+1
;SUBTOTAL LINE
S $P(BUDSECTB(+BUDETHN),U,1)=$P($G(BUDSECTB(+BUDETHN)),U,1)+1
S $P(BUDSECTB(+BUDETHN),U,2)=$P($G(BUDSECTB(+BUDETHN)),U,2)+1
I $G(BUDHTRL) S ^XTMP("BUDDRP7",BUDJ,BUDH,"HTR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
;I $G(BUDHTEL) S ^XTMP("BUDDRP7",BUDJ,BUDH,"HTE",BUDETHNN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
;now check BP
S BUDDP=$$LASTITEM^BUDDDU(DFN,BUDBD,BUDED,"MEASUREMENT","BP")
I BUDDP]"" S BUDV=$$BPCHK(BUDDP) G SET
;now check cpts
S T=$O(^ATXAX("B","BUD SYSTOLIC BP CPTS",0))
S BUDS=$$CPT^BUDDDU(DFN,BUDBD,BUDED,T,6)
S T=$O(^ATXAX("B","BUD DIASTOLIC BP CPTS",0))
S BUDD=$$CPT^BUDDDU(DFN,BUDBD,BUDED,T,6)
I 'BUDS,'BUDD S BUDV=0_U_"NO BP TAKEN DURING THE REPORT PERIOD" G SET ;DIDN'T HAVE BOTH IN TIME PERIOD
S S=$P(BUDS,U,3)
S D=$P(BUDD,U,3)
S G=0
I S="3074F",D="3078F" S G=1
I S="3074F",D="3079F" S G=1
I S="3075F",D="3078F" S G=1
I S="3075F",D="3079F" S G=1
S BUDV=G_U_"CPTs: "_$P(BUDS,U,3)_" on "_$$FMTE^XLFDT($P(BUDS,U,2))_" and "_$P(BUDD,U,3)_" on "_$$FMTE^XLFDT($P(BUDD,U,2))
SET ;
I $P(BUDV,U) D
.S $P(BUDSECTB(+BUDETHN,BUDR),U,3)=$P($G(BUDSECTB(+BUDETHN,BUDR)),U,3)+1
.S $P(BUDSECTB(4),U,3)=$P($G(BUDSECTB(4)),U,3)+1
.S $P(BUDSECTB(+BUDETHN),U,3)=$P($G(BUDSECTB(+BUDETHN)),U,3)+1
;I $P(BUDV,U) S $P(BUDSECTE(8),U,BUDETHN)=$P($G(BUDSECTE(8)),U,BUDETHN)+1,$P(BUDSECTE(8),U,9)=$P($G(BUDSECTE(8)),U,9)+1
I $G(BUDHTCRL),$P(BUDV,U,1) S ^XTMP("BUDDRP7",BUDJ,BUDH,"HTCR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
I $G(BUDHTURL),'$P(BUDV,U,1) S ^XTMP("BUDDRP7",BUDJ,BUDH,"HTUR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"#"_$P(BUDV,U,2)
;I $G(BUDHTCEL),$P(BUDV,U,1) S ^XTMP("BUDDRP7",BUDJ,BUDH,"HTCE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
;I $G(BUDHTUEL),'$P(BUDV,U,1) S ^XTMP("BUDDRP7",BUDJ,BUDH,"HTUE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
Q
;
EXCL(P,BDATE,EDATE) ;EP
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,BDATE
S BDATE=$$DOB^AUPNPAT(P)
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S BUDTOB=0
S TIEN=$O(^BUDDTSSC("B","T7 HTN EXCLUSIONS",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR!(BUDTOB) D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.;POV/SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(BUDTOB) D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDDTSSC("AD",Y,TIEN)) S BUDTOB=1 Q
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDDTSSC("AS",Y,TIEN)) S BUDTOB=1 Q
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X!(BUDTOB) D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB=1 Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X!(BUDTOB) D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDDTSSC("AC",Y,TIEN)) S BUDTOB=1 Q
.;V PROC
.S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X!(BUDTOB) D
..Q:'$D(^AUPNVPRC(X,0))
..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
..I $D(^BUDDTSSC("AP",Y,TIEN)) S BUDTOB=1 Q
I BUDTOB Q 1
S Y=$$PLCL^BUDDDU(P,"T7 HTN EXCLUSIONS",EDATE,0)
I Y Q 1
Q ""
BPCHK(BP) ;
NEW S,D
S S=$P($P(BP,U,4),"/")
S D=$P($P(BP,U,4),"/",2)
I S>139 Q 0_U_$P(BP,U,4)_" "_$$FMTE^XLFDT($P(BP,U,2))
I D>89 Q 0_U_$P(BP,U,4)_" "_$$FMTE^XLFDT($P(BP,U,2))
Q 1_U_$P(BP,U,4)_" "_$$FMTE^XLFDT($P(BP,U,2))
RACE(R) ;EP
I R="Unreported" Q 8
I R="Asian" Q 1
I R="Native Hawaiian" Q 2
I R="Other Pacific Islander" Q 3
I R="Black/African American" Q 4
I R="American Indian/Alaska Native" Q 5
I R="White" Q 6
Q ""
HTNDX(P,BDATE,EDATE,STOP) ;EP
NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL
S STOP=$G(STOP)
S B=0,CNT=0,BUDD="",BUDALL="" ;if there is one before time frame set this to 1
;
;V10.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDDTSSC("B","T7 HTN DIAGNOSES",0))
S X=0,G="" F S X=$O(BUDG(X)) Q:X'=+X!(G) D
.S Y=+$P(BUDG(X),U,4)
.S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
.S V=$P(BUDG(X),U,5)
.S C=$$PRIMPROV^APCLV(V,"D")
.Q:C=53
.Q:$P(^AUPNVSIT(V,0),U,7)="C"
.I $D(^BUDDTSSC("AD",Z,T)) S G=1_"^"_$P(BUDG(X),U,5)_"|"_$P(BUDG(X),U,2) Q
.S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDDTSSC("AS",S,T)) S G=1_"^"_$P(BUDG(X),U,5)_"|"_S Q
I G]"" Q G
PROBDX ;
S G=$$PLCL^BUDDDU(P,"T7 HTN DIAGNOSES",EDATE,0)
I G Q 1_U_"Problem List: "_$P(G,U,2)_" on "_$$DATE^BUDDUTL1($P(G,U,3))
Q ""
BUDDRP7B ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+1 ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
+2 ;
HTN ;EP - list of HTN
+1 ;is patient pregnant during the time period BUDDD and BUDED
+2 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+3 SET BUDDDB=($EXTRACT(BUDBD,1,3)-85)_"0101"
+4 SET BUDDDE=($EXTRACT(BUDBD,1,3)-18)_"1231"
+5 IF BUDDOB>BUDDDE
QUIT
+6 IF BUDDOB<BUDDDB
QUIT
+7 IF BUDMEDV<1
QUIT
+8 ;
+9 SET BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDCCAD)
+10 ;not dx'ed before june 30
IF '$PIECE(BUDP,U)
QUIT
+11 ;PREGNANCY
+12 IF $$PREG^BUDDRP6B(DFN,BUDBD,BUDED,BUDBD)
QUIT
+13 IF $$EXCL(DFN,BUDDOB,BUDED)
QUIT
+14 SET BUDP=$$HTNDX(DFN,$$DOB^AUPNPAT(DFN),BUDED,1)
+15 SET BUDRACEX=$$RACE^BUDDRPTC(DFN)
SET BUDRACE=$PIECE(BUDRACEX,U,2)
SET BUDRACEP=$PIECE(BUDRACEX,U,5)
+16 SET BUDRACEE=$$RACE^BUDDRP7I(BUDRACE)
+17 SET BUDR=""
+18 SET BUDETHN=$PIECE($$HISP^BUDDRPTC(DFN),U,1)
+19 IF +BUDETHN=1
SET BUDETHNN="Hispanic or Latino"
+20 IF +BUDETHN=2
SET BUDETHNN="Non-Hispanic/Latino"
+21 IF +BUDETHN=3
SET BUDETHNN="Unreported/Refused to Report"
+22 IF BUDRACEP=8
IF +BUDETHN=3
SET BUDR=1
GOTO SETSECTB
+23 IF +BUDETHN=1
SET BUDR=BUDRACEP
GOTO SETSECTB
+24 IF +BUDETHN=2
SET BUDR=BUDRACEP
GOTO SETSECTB
+25 ;I +BUDETHN=3,BUDRACEP=8 S BUDR=1
SETSECTB ;
+1 ;COL 1
SET $PIECE(BUDSECTB(+BUDETHN,BUDR),U,1)=$PIECE($GET(BUDSECTB(+BUDETHN,BUDR)),U,1)+1
+2 ;COL 2
SET $PIECE(BUDSECTB(+BUDETHN,BUDR),U,2)=$PIECE($GET(BUDSECTB(+BUDETHN,BUDR)),U,2)+1
+3 ;TOTAL LINE
+4 SET $PIECE(BUDSECTB(4),U,1)=$PIECE($GET(BUDSECTB(4)),U,1)+1
+5 SET $PIECE(BUDSECTB(4),U,2)=$PIECE($GET(BUDSECTB(4)),U,2)+1
+6 ;SUBTOTAL LINE
+7 SET $PIECE(BUDSECTB(+BUDETHN),U,1)=$PIECE($GET(BUDSECTB(+BUDETHN)),U,1)+1
+8 SET $PIECE(BUDSECTB(+BUDETHN),U,2)=$PIECE($GET(BUDSECTB(+BUDETHN)),U,2)+1
+9 IF $GET(BUDHTRL)
SET ^XTMP("BUDDRP7",BUDJ,BUDH,"HTR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)
+10 ;I $G(BUDHTEL) S ^XTMP("BUDDRP7",BUDJ,BUDH,"HTE",BUDETHNN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
+11 ;now check BP
+12 SET BUDDP=$$LASTITEM^BUDDDU(DFN,BUDBD,BUDED,"MEASUREMENT","BP")
+13 IF BUDDP]""
SET BUDV=$$BPCHK(BUDDP)
GOTO SET
+14 ;now check cpts
+15 SET T=$ORDER(^ATXAX("B","BUD SYSTOLIC BP CPTS",0))
+16 SET BUDS=$$CPT^BUDDDU(DFN,BUDBD,BUDED,T,6)
+17 SET T=$ORDER(^ATXAX("B","BUD DIASTOLIC BP CPTS",0))
+18 SET BUDD=$$CPT^BUDDDU(DFN,BUDBD,BUDED,T,6)
+19 ;DIDN'T HAVE BOTH IN TIME PERIOD
IF 'BUDS
IF 'BUDD
SET BUDV=0_U_"NO BP TAKEN DURING THE REPORT PERIOD"
GOTO SET
+20 SET S=$PIECE(BUDS,U,3)
+21 SET D=$PIECE(BUDD,U,3)
+22 SET G=0
+23 IF S="3074F"
IF D="3078F"
SET G=1
+24 IF S="3074F"
IF D="3079F"
SET G=1
+25 IF S="3075F"
IF D="3078F"
SET G=1
+26 IF S="3075F"
IF D="3079F"
SET G=1
+27 SET BUDV=G_U_"CPTs: "_$PIECE(BUDS,U,3)_" on "_$$FMTE^XLFDT($PIECE(BUDS,U,2))_" and "_$PIECE(BUDD,U,3)_" on "_$$FMTE^XLFDT($PIECE(BUDD,U,2))
SET ;
+1 IF $PIECE(BUDV,U)
Begin DoDot:1
+2 SET $PIECE(BUDSECTB(+BUDETHN,BUDR),U,3)=$PIECE($GET(BUDSECTB(+BUDETHN,BUDR)),U,3)+1
+3 SET $PIECE(BUDSECTB(4),U,3)=$PIECE($GET(BUDSECTB(4)),U,3)+1
+4 SET $PIECE(BUDSECTB(+BUDETHN),U,3)=$PIECE($GET(BUDSECTB(+BUDETHN)),U,3)+1
End DoDot:1
+5 ;I $P(BUDV,U) S $P(BUDSECTE(8),U,BUDETHN)=$P($G(BUDSECTE(8)),U,BUDETHN)+1,$P(BUDSECTE(8),U,9)=$P($G(BUDSECTE(8)),U,9)+1
+6 IF $GET(BUDHTCRL)
IF $PIECE(BUDV,U,1)
SET ^XTMP("BUDDRP7",BUDJ,BUDH,"HTCR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)_"^"_$PIECE(BUDV,U,2)
+7 IF $GET(BUDHTURL)
IF '$PIECE(BUDV,U,1)
SET ^XTMP("BUDDRP7",BUDJ,BUDH,"HTUR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)_"#"_$PIECE(BUDV,U,2)
+8 ;I $G(BUDHTCEL),$P(BUDV,U,1) S ^XTMP("BUDDRP7",BUDJ,BUDH,"HTCE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
+9 ;I $G(BUDHTUEL),'$P(BUDV,U,1) S ^XTMP("BUDDRP7",BUDJ,BUDH,"HTUE",BUDETHNN,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDV,U,2)
+10 QUIT
+11 ;
EXCL(P,BDATE,EDATE) ;EP
+1 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDTOB,BDATE
+2 SET BDATE=$$DOB^AUPNPAT(P)
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+4 SET BUDTOB=0
+5 SET TIEN=$ORDER(^BUDDTSSC("B","T7 HTN EXCLUSIONS",0))
+6 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR!(BUDTOB)
QUIT
Begin DoDot:1
+7 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+8 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+9 ;POV/SNOMED
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X!(BUDTOB)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+12 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDDTSSC("AD",Y,TIEN))
SET BUDTOB=1
QUIT
+13 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+14 IF Y=""
QUIT
+15 IF $DATA(^BUDDTSSC("AS",Y,TIEN))
SET BUDTOB=1
QUIT
End DoDot:2
+16 ;CPT
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X!(BUDTOB)
QUIT
Begin DoDot:2
+18 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+19 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+20 IF Y=""
QUIT
+21 IF $DATA(^BUDDTSSC("AC",Y,TIEN))
SET BUDTOB=1
QUIT
End DoDot:2
+22 ;V TRANS
+23 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X!(BUDTOB)
QUIT
Begin DoDot:2
+24 IF '$DATA(^AUPNVTC(X,0))
QUIT
+25 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+26 IF Y=""
QUIT
+27 IF $DATA(^BUDDTSSC("AC",Y,TIEN))
SET BUDTOB=1
QUIT
End DoDot:2
+28 ;V PROC
+29 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X!(BUDTOB)
QUIT
Begin DoDot:2
+30 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+31 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+32 IF $DATA(^BUDDTSSC("AP",Y,TIEN))
SET BUDTOB=1
QUIT
End DoDot:2
End DoDot:1
+33 IF BUDTOB
QUIT 1
+34 SET Y=$$PLCL^BUDDDU(P,"T7 HTN EXCLUSIONS",EDATE,0)
+35 IF Y
QUIT 1
+36 QUIT ""
BPCHK(BP) ;
+1 NEW S,D
+2 SET S=$PIECE($PIECE(BP,U,4),"/")
+3 SET D=$PIECE($PIECE(BP,U,4),"/",2)
+4 IF S>139
QUIT 0_U_$PIECE(BP,U,4)_" "_$$FMTE^XLFDT($PIECE(BP,U,2))
+5 IF D>89
QUIT 0_U_$PIECE(BP,U,4)_" "_$$FMTE^XLFDT($PIECE(BP,U,2))
+6 QUIT 1_U_$PIECE(BP,U,4)_" "_$$FMTE^XLFDT($PIECE(BP,U,2))
RACE(R) ;EP
+1 IF R="Unreported"
QUIT 8
+2 IF R="Asian"
QUIT 1
+3 IF R="Native Hawaiian"
QUIT 2
+4 IF R="Other Pacific Islander"
QUIT 3
+5 IF R="Black/African American"
QUIT 4
+6 IF R="American Indian/Alaska Native"
QUIT 5
+7 IF R="White"
QUIT 6
+8 QUIT ""
HTNDX(P,BDATE,EDATE,STOP) ;EP
+1 NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL
+2 SET STOP=$GET(STOP)
+3 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BUDD=""
SET BUDALL=""
+4 ;
+5 ;V10.0 ICD10
+6 KILL BUDG
SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+7 SET T=$ORDER(^BUDDTSSC("B","T7 HTN DIAGNOSES",0))
+8 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+9 SET Y=+$PIECE(BUDG(X),U,4)
+10 SET Z=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+11 SET V=$PIECE(BUDG(X),U,5)
+12 SET C=$$PRIMPROV^APCLV(V,"D")
+13 IF C=53
QUIT
+14 IF $PIECE(^AUPNVSIT(V,0),U,7)="C"
QUIT
+15 IF $DATA(^BUDDTSSC("AD",Z,T))
SET G=1_"^"_$PIECE(BUDG(X),U,5)_"|"_$PIECE(BUDG(X),U,2)
QUIT
+16 SET S=$$VAL^XBDIQ1(9000010.07,Y,1101)
IF S]""
IF $DATA(^BUDDTSSC("AS",S,T))
SET G=1_"^"_$PIECE(BUDG(X),U,5)_"|"_S
QUIT
End DoDot:1
+17 IF G]""
QUIT G
PROBDX ;
+1 SET G=$$PLCL^BUDDDU(P,"T7 HTN DIAGNOSES",EDATE,0)
+2 IF G
QUIT 1_U_"Problem List: "_$PIECE(G,U,2)_" on "_$$DATE^BUDDUTL1($PIECE(G,U,3))
+3 QUIT ""
