BUDHRP6U ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
;
;
H ;EP ; ASTHMA
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUD64RB=($E(BUDBD,1,3)-64)_"0101"
S BUD5RB=($E(BUDED,1,3)-6)_"1231"
Q:BUDDOB>BUD5RB
Q:BUDDOB<BUD64RB
S Z=($E(BUDDOB,1,3)+5)_$E(BUDDOB,4,7)
Q:$$VD^APCLV(BUDLASTV)<Z
S Z=($E(BUDDOB,1,3)+65)_$E(BUDDOB,4,7)
Q:$$VD^APCLV(BUDLASTV)'<Z
Q:BUDMEDV<1
;
S BUDAST=$$ASTHMA(DFN,BUDBD,BUDED) ;no diagnosis of asthma during time period
I BUDAST="" Q ;no dx of peristent asthma and no pl entry
Q:$$EXCL(DFN,$$DOB^AUPNPAT(P),BUDED) ; had exclusion dx
Q:$$AST1039(DFN,$P(BUDAST,U,2),BUDED)]"" ;had a 1039f after the asthma dx/1038f
Q:$$SABA(DFN,BUDBD,BUDED) ;if only SABA, quit
;numerator
S BUDASTT=$$ASTHTHER(DFN,BUDBD,BUDED)
I BUDASTT]"" S BUDSECTH("APT")=$G(BUDSECTH("APT"))+1
;put the rest in demoninator
S BUDSECTH("PTS")=$G(BUDSECTH("PTS"))+1 D
.I $G(BUDAPT2L) D
..I BUDASTT="" S ^XTMP("BUDHRP6B",BUDJ,BUDH,"APT2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDAST,U)_U_$P(BUDASTT,U,2)
.I $G(BUDAPT1L) D
..I BUDASTT]"" S ^XTMP("BUDHRP6B",BUDJ,BUDH,"APT1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDAST,U)_U_$P(BUDASTT,U,2)
Q
SABA(P,BD,ED) ;
NEW BUDMEDS1,G,A,C,M,V,V1D,BUDHSABA
S G="",BUDHSABA=""
D GETMEDS^BUDHUTL2(P,BD,ED,"BGP PQA SABA MEDS","BGP PQA SABA NDC",,,.BUDMEDS1)
I '$D(BUDMEDS1) Q G ; no SABA meds
S BUDISD=""
S A=0,C="" F S A=$O(BUDMEDS1(A)) Q:A'=+A!(C) D
.S M=$P(BUDMEDS1(A),U,4) ;IEN OF V MED
.Q:'$D(^AUPNVMED(M,0))
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BUDMEDS1(A) Q
.I $$STATDC(M) K BUDMEDS1(A) Q ;d/c'ed BY PROVIDER OR EDIT
.S V=$P(BUDMEDS1(A),U,5)
.S V1D=$$VD^APCLV(V)
.S C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
I C S BUDHSABA=1
I 'BUDHSABA Q ""
S G=""
D GETMEDS^BUDHUTL2(P,BD,ED,"BGP PQA CONTROLLER MEDS","BGP PQA CONTROLLER NDC",,,.BUDMEDS1)
I '$D(BUDMEDS1) Q 1 ; no CONTROLLER meds BUT HAS SABA
S BUDISD=""
S A=0,C="" F S A=$O(BUDMEDS1(A)) Q:A'=+A!(C) D
.S M=$P(BUDMEDS1(A),U,4) ;IEN OF V MED
.Q:'$D(^AUPNVMED(M,0))
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BUDMEDS1(A) Q
.I $$STATDC(M) K BUDMEDS1(A) Q ;d/c'ed BY PROVIDER OR EDIT
.S V=$P(BUDMEDS1(A),U,5)
.S V1D=$$VD^APCLV(V)
.S C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
I C Q 0
Q 1
ASTALG(P,ED) ;
;allergy tracking
NEW BUDD,X,N,G,Y,T,T1,S,A,B,C
S T=$O(^ATXAX("B","BGP PQA CONTROLLER MEDS",0))
S T1=$O(^ATXAX("B","BGP PQA CONTROLLER NDC",0))
S BUDD=0
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X!(BUDD) D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>ED ;entered after end date
.S N=$P($G(^GMR(120.8,X,0)),U,3)
.;IF PSDRUG CHECK AGAINST MEDS TAXONOMY
.I N["PSDRUG"!(N["PSNDF") D
..S Y=+N
..I T,$D(^ATXAX(T,21,"AA",Y)) S BUDD=1
..S D=$P($G(^PSDRUG(Y,2)),U,4)
..I D,$D(^ATXAX(T1,21,"AA",D)) S BUDD=1
.;check name for the heck of it
.S S=$P(^GMR(120.8,X,0),U,2) ;NAME OF THING THEY ARE ALLERGIC TO
.S A=0 F S A=$O(^ATXAX(T,21,A)) Q:A'=+A D
..S B=$P($G(^ATXAX(T,21,A,0)),U,1)
..I $P($G(^PSDRUG(B,0)),U,1)=S S BUDD=1 Q
Q BUDD
;
PROBAS1(P,BDATE,EDATE) ;EP
NEW S,A,B,T,X,G,V,Y,Z
S G=""
S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))
S X=0,G="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.S Z=$P(^AUPNPROB(X,0),U,13)
.I Z="" S Z=$P(^AUPNPROB(X,0),U,8)
.Q:Z>EDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:'$$ICD^ATXCHK(Y,T,9)
.Q:$P(^AUPNPROB(X,0),U,15)=""
.S G(9999999-$P(^AUPNPROB(X,0),U,3))=$P(^AUPNPROB(X,0),U,15)
.Q
S X=$O(G(0)) I X Q G(X)
S EDATE1=9999999-EDATE-1
S D=$O(^AUPNVAST("AS",P,EDATE1))
I 'D Q ""
S LAST="",E=0 F S E=$O(^AUPNVAST("AS",P,D,E)) Q:E'=+E S LAST=E
I 'LAST Q ""
S S=^AUPNVAST("AS",P,D,LAST)
Q S
;
ASTHMA(P,BDATE,EDATE) ;EP
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDAST
K BUDAST
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S TIEN=$O(^BUDHTSSC("B","T6B ASTHMA PERSISTENT CODES",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR D
.S VIEN=$P(BUDVS(CTR),U,5)
.S VDATE=$P(BUDVS(CTR),U,1)
.;CPT
.S X=0 F S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVCPT(X,0))
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..Q:Y=""
..I $D(^BUDHTSSC("AC",Y,TIEN)) S BUDAST(9999999-VDATE)=Y_U_$$DATE^BUDHUTL1(VDATE)_U_VDATE Q
.;V TRANS
.S X=0 F S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVTC(X,0))
..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
..Q:Y=""
..I $D(^BUDHTSSC("AC",Y,TIEN)) S BUDAST(9999999-VDATE)=Y_U_$$DATE^BUDHUTL1(VDATE)_U_VDATE Q
.;POV/SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDHTSSC("AD",Y,TIEN)) S BUDAST(9999999-VDATE)=$$VAL^XBDIQ1(9000010.07,X,.01)_U_$$DATE^BUDHUTL1(VDATE)_U_VDATE Q
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDHTSSC("AS",Y,TIEN)) S BUDAST(9999999-VDATE)=Y_U_$$DATE^BUDHUTL1(VDATE)_U_VDATE Q
I $O(BUDAST(0)) S X=$O(BUDAST(0)),X=BUDAST(X) Q $P(X,U,1)_" on "_$P(X,U,2)_U_$P(X,U,3)
S Y=$$PLCL^BUDHDU(P,"T6B ASTHMA PERSISTENT CODES",EDATE,1)
I Y Q "PL "_$P(Y,U,2)_" on "_$$DATE^BUDHUTL1($P(Y,U,3))_U_$P(X,U,3)
Q ""
EXCL(P,BDATE,EDATE) ;EP - EMPHYSEMA, COPD, CYSTIC FIBROSIS, ARF
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDHX
S BUDHX=0
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S TIEN=$O(^BUDHTSSC("B","T6B ASTHMA EXCLUSION CODES",0))
S CTR=0 F S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR!(BUDHX) 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!(BUDHX) D
..Q:'$D(^AUPNVPOV(X,0))
..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDHTSSC("AD",Y,TIEN)) S BUDHX=1 Q
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDHTSSC("AS",Y,TIEN)) S BUDHX=1 Q
I BUDHX Q 1
S Y=$$PLCL^BUDHDU(P,"T6B ASTHMA EXCLUSION CODES",EDATE,1)
I Y Q 1
Q ""
;
AST1039(P,BDATE,EDATE) ;EP
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW A,B,E,T,G,X,V,Y
K G
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S Y=""
S Y=$$CPTI^BUDHDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("1039F"),U,1))
I Y S G($P(Y,U,2))="CPT: 1039F"
S Y=$O(G(""),-1) I Y="" Q ""
S X=G(Y)
Q X_" on "_$$FMTE^XLFDT(Y)_U_Y
ASTHTHER(P,BD,ED) ;
NEW BUDMEDS1,G,A,C,M,V,V1D
S G=""
D GETMEDS^BUDHUTL2(P,BD,ED,"BGP PQA CONTROLLER MEDS","BGP PQA CONTROLLER NDC",,,.BUDMEDS1)
I '$D(BUDMEDS1) G EHRO ; no CONTROLLER meds
S BUDISD=""
S A=0,C="" F S A=$O(BUDMEDS1(A)) Q:A'=+A!(C) D
.S M=$P(BUDMEDS1(A),U,4) ;IEN OF V MED
.Q:'$D(^AUPNVMED(M,0))
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BUDMEDS1(A) Q
.I $$STATDC(M) K BUDMEDS1(A) Q ;d/c'ed BY PROVIDER OR EDIT
.S V=$P(BUDMEDS1(A),U,5)
.S V1D=$$VD^APCLV(V)
.S C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
I C Q C
EHRO ;EPRES
;EHR OUTSIDE
S C=$$PRES^BUDHRP6W(P,$O(^ATXAX("B","BGP PQA CONTROLLER MEDS",0)),BD,ED,$O(^ATXAX("B","BGP PQA CONTROLLER NDC",0)))
I C]"" Q 1_U_$P(C,U,1)_" on "_$$FMTE^XLFDT($P(C,U,3))
Q ""
;
STATDC(V) ;EP - is the prescription associated with this V MED discontinued?
I '$G(V) Q ""
I '$D(^AUPNVMED(V,0)) Q 0
NEW P,S,X
S P=$S($D(^PSRX("APCC",V)):$O(^(V,0)),1:0)
I 'P Q 0
S X=$P($G(^PSRX(P,0)),U,15)
I X=12 Q 1
I X=13 Q 1
I X=14 Q 1
I X=15 Q 1
S X=$P($G(^PSRX(P,"STA")),U,1)
I X=12 Q 1
I X=13 Q 1
I X=14 Q 1
I X=15 Q 1
Q 0
GETV(P,BD,ED,SITE) ;EP - get all visits for this patient and COUNT MEDICAL VISITS
NEW TV,T35V,T6V,MEDV,MEDVI,LASTV,A,X,VLOC,CLINC,TIEN,VSIT,VDATE,PP,S,LINE,D
S TV=0,T35V=0,T6V=0,MEDV=0,MEDVI="",LASTV=""
S A="A(""VISITS"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED),E=$$START1^APCLDF(B,A)
S X=0 F S X=$O(A("VISITS",X)) Q:X'=+X!(MEDV>1) S VSIT=$P(A("VISITS",X),U,5) D
.Q:'$D(^AUPNVSIT(VSIT,0))
.Q:'$P(^AUPNVSIT(VSIT,0),U,9)
.Q:$P(^AUPNVSIT(VSIT,0),U,11)
.S VLOC=$P(^AUPNVSIT(VSIT,0),U,6)
.Q:VLOC=""
.Q:'$D(^BUDHSITE(SITE,11,VLOC)) ;not valid location
.Q:"AHSORMI"'[$P(^AUPNVSIT(VSIT,0),U,7)
.S CLINC=$$CLINIC^APCLV(VSIT,"C")
.S TIEN=$O(^BUDHCNTL("B","UDS PT/TABLE 5 CLINIC EXCL",0))
.I CLINC]"",$D(^BUDHCNTL(TIEN,11,"B",CLINC)) Q
.;now eliminate subsequent visits to same provider on same day = item 4 in SRD visit definition
.S VDATE=$$VD^APCLV(VSIT)
.S PP=$$PRIMPROV^APCLV(VSIT,"I")
.I PP="" Q ;no primary provider
.I $P(^AUPNVSIT(VSIT,0),U,7)="I" Q ;don't count I visits
.I '$D(^AUPNVPOV("AD",VSIT)) Q
.S S=0
.I PP]"" D
..S D=$P($G(A("SAMEPROV",P,VDATE,PP)),U,1)
..I D]"",D'>$P(^AUPNVSIT(VSIT,0),U) S S=1 Q ;already had a visit to this provider on this date
..S A("SAMEPROV",P,VDATE,PP)=$P(^AUPNVSIT(VSIT,0),U)_U_VSIT
.Q:S ;quit if already had a visit to this provider
.S PP=$$PRIMPROV^APCLV(VSIT,"D")
.I PP="" Q
MEDC .;NOW CHECK FOR MEDICAL CARE, CAN ONLY HAVE 1 PER LOCATION OF ENCOUNTER
.S S=0
.S TIEN=$O(^BUDHCNTL("B","MEDICAL CARE LINE NUMBERS",0))
.;S PP=$$PRIMPROV^APCLV(VSIT,"D")
.I $E($$VAL^XBDIQ1(9000010,VSIT,.06),1,3)="CHS",PP=15 S LINE=2 G MEDC1
.S Y=$O(^BUDHTFIV("C",PP,0)) I Y="" S LINE=35 G MEDC1
.S LINE=$O(^BUDHTFIV("AA",PP,""))
MEDC1 .S S=0
.I $D(^BUDHCNTL(TIEN,11,"B",LINE)) D
..S D=$P($G(A("MEDCARE",P,VDATE,VLOC,TIEN)),U,1)
..I D]"",D'>$P(^AUPNVSIT(VSIT,0),U) S S=1 Q ;already have a medical care visit on this date
..S A("MEDCARE",P,VDATE,VLOC,TIEN)=$P(^AUPNVSIT(VSIT,0),U)_U_VSIT
..S MEDV=MEDV+1,MEDVI=VSIT
..Q
Q MEDV
PREVV(P,BDATE,EDATE) ;EP
;GO THROUGH UDS PATIENT VISITS AND CHECK CPT CODES
NEW X,Y,V,Z,G,T,C
S T=$O(^BUDHTSSC("B","T6B TOBACCO PREVENTATIVE CODES",0))
S G="",C=0
S X=0 F S X=$O(^TMP($J,"VISITSUDSPT",X)) Q:X'=+X!(G) D
.S Z=0 F S Z=$O(^AUPNVCPT("AD",X,Z)) Q:Z'=+Z!(G) D
..S Y=$$VAL^XBDIQ1(9000010.18,Z,.01)
..I $D(^BUDHTSSC("AC",Y,T)) S G=1 Q
.S Z=0 F S Z=$O(^AUPNVPOV("AD",X,Z)) Q:Z'=+Z!(G) D
..S Y=$$VALI^XBDIQ1(9000010.07,Z,.01)
..I $D(^BUDHTSSC("AD",Y,T)) S G=1 Q
..S Y=$$VAL^XBDIQ1(9000010.07,Z,1101)
..Q:Y=""
..I $D(^BUDHTSSC("AS",Y,T)) S G=1 Q
.I G S C=C+1
Q C
BUDHRP6U ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
+2 ;
+3 ;
H ;EP ; ASTHMA
+1 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+2 SET BUD64RB=($EXTRACT(BUDBD,1,3)-64)_"0101"
+3 SET BUD5RB=($EXTRACT(BUDED,1,3)-6)_"1231"
+4 IF BUDDOB>BUD5RB
QUIT
+5 IF BUDDOB<BUD64RB
QUIT
+6 SET Z=($EXTRACT(BUDDOB,1,3)+5)_$EXTRACT(BUDDOB,4,7)
+7 IF $$VD^APCLV(BUDLASTV)<Z
QUIT
+8 SET Z=($EXTRACT(BUDDOB,1,3)+65)_$EXTRACT(BUDDOB,4,7)
+9 IF $$VD^APCLV(BUDLASTV)'<Z
QUIT
+10 IF BUDMEDV<1
QUIT
+11 ;
+12 ;no diagnosis of asthma during time period
SET BUDAST=$$ASTHMA(DFN,BUDBD,BUDED)
+13 ;no dx of peristent asthma and no pl entry
IF BUDAST=""
QUIT
+14 ; had exclusion dx
IF $$EXCL(DFN,$$DOB^AUPNPAT(P),BUDED)
QUIT
+15 ;had a 1039f after the asthma dx/1038f
IF $$AST1039(DFN,$PIECE(BUDAST,U,2),BUDED)]""
QUIT
+16 ;if only SABA, quit
IF $$SABA(DFN,BUDBD,BUDED)
QUIT
+17 ;numerator
+18 SET BUDASTT=$$ASTHTHER(DFN,BUDBD,BUDED)
+19 IF BUDASTT]""
SET BUDSECTH("APT")=$GET(BUDSECTH("APT"))+1
+20 ;put the rest in demoninator
+21 SET BUDSECTH("PTS")=$GET(BUDSECTH("PTS"))+1
Begin DoDot:1
+22 IF $GET(BUDAPT2L)
Begin DoDot:2
+23 IF BUDASTT=""
SET ^XTMP("BUDHRP6B",BUDJ,BUDH,"APT2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=$PIECE(BUDAST,U)_U_$PIECE(BUDASTT,U,2)
End DoDot:2
+24 IF $GET(BUDAPT1L)
Begin DoDot:2
+25 IF BUDASTT]""
SET ^XTMP("BUDHRP6B",BUDJ,BUDH,"APT1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=$PIECE(BUDAST,U)_U_$PIECE(BUDASTT,U,2)
End DoDot:2
End DoDot:1
+26 QUIT
SABA(P,BD,ED) ;
+1 NEW BUDMEDS1,G,A,C,M,V,V1D,BUDHSABA
+2 SET G=""
SET BUDHSABA=""
+3 DO GETMEDS^BUDHUTL2(P,BD,ED,"BGP PQA SABA MEDS","BGP PQA SABA NDC",,,.BUDMEDS1)
+4 ; no SABA meds
IF '$DATA(BUDMEDS1)
QUIT G
+5 SET BUDISD=""
+6 SET A=0
SET C=""
FOR
SET A=$ORDER(BUDMEDS1(A))
IF A'=+A!(C)
QUIT
Begin DoDot:1
+7 ;IEN OF V MED
SET M=$PIECE(BUDMEDS1(A),U,4)
+8 IF '$DATA(^AUPNVMED(M,0))
QUIT
+9 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BUDMEDS1(A)
QUIT
+10 ;d/c'ed BY PROVIDER OR EDIT
IF $$STATDC(M)
KILL BUDMEDS1(A)
QUIT
+11 SET V=$PIECE(BUDMEDS1(A),U,5)
+12 SET V1D=$$VD^APCLV(V)
+13 SET C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
End DoDot:1
+14 IF C
SET BUDHSABA=1
+15 IF 'BUDHSABA
QUIT ""
+16 SET G=""
+17 DO GETMEDS^BUDHUTL2(P,BD,ED,"BGP PQA CONTROLLER MEDS","BGP PQA CONTROLLER NDC",,,.BUDMEDS1)
+18 ; no CONTROLLER meds BUT HAS SABA
IF '$DATA(BUDMEDS1)
QUIT 1
+19 SET BUDISD=""
+20 SET A=0
SET C=""
FOR
SET A=$ORDER(BUDMEDS1(A))
IF A'=+A!(C)
QUIT
Begin DoDot:1
+21 ;IEN OF V MED
SET M=$PIECE(BUDMEDS1(A),U,4)
+22 IF '$DATA(^AUPNVMED(M,0))
QUIT
+23 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BUDMEDS1(A)
QUIT
+24 ;d/c'ed BY PROVIDER OR EDIT
IF $$STATDC(M)
KILL BUDMEDS1(A)
QUIT
+25 SET V=$PIECE(BUDMEDS1(A),U,5)
+26 SET V1D=$$VD^APCLV(V)
+27 SET C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
End DoDot:1
+28 IF C
QUIT 0
+29 QUIT 1
ASTALG(P,ED) ;
+1 ;allergy tracking
+2 NEW BUDD,X,N,G,Y,T,T1,S,A,B,C
+3 SET T=$ORDER(^ATXAX("B","BGP PQA CONTROLLER MEDS",0))
+4 SET T1=$ORDER(^ATXAX("B","BGP PQA CONTROLLER NDC",0))
+5 SET BUDD=0
+6 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X!(BUDD)
QUIT
Begin DoDot:1
+7 ;entered after end date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>ED
QUIT
+8 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,3)
+9 ;IF PSDRUG CHECK AGAINST MEDS TAXONOMY
+10 IF N["PSDRUG"!(N["PSNDF")
Begin DoDot:2
+11 SET Y=+N
+12 IF T
IF $DATA(^ATXAX(T,21,"AA",Y))
SET BUDD=1
+13 SET D=$PIECE($GET(^PSDRUG(Y,2)),U,4)
+14 IF D
IF $DATA(^ATXAX(T1,21,"AA",D))
SET BUDD=1
End DoDot:2
+15 ;check name for the heck of it
+16 ;NAME OF THING THEY ARE ALLERGIC TO
SET S=$PIECE(^GMR(120.8,X,0),U,2)
+17 SET A=0
FOR
SET A=$ORDER(^ATXAX(T,21,A))
IF A'=+A
QUIT
Begin DoDot:2
+18 SET B=$PIECE($GET(^ATXAX(T,21,A,0)),U,1)
+19 IF $PIECE($GET(^PSDRUG(B,0)),U,1)=S
SET BUDD=1
QUIT
End DoDot:2
End DoDot:1
+20 QUIT BUDD
+21 ;
PROBAS1(P,BDATE,EDATE) ;EP
+1 NEW S,A,B,T,X,G,V,Y,Z
+2 SET G=""
+3 SET T=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
+4 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET Z=$PIECE(^AUPNPROB(X,0),U,13)
+6 IF Z=""
SET Z=$PIECE(^AUPNPROB(X,0),U,8)
+7 IF Z>EDATE
QUIT
+8 SET Y=$PIECE(^AUPNPROB(X,0),U)
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+10 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+11 IF $PIECE(^AUPNPROB(X,0),U,15)=""
QUIT
+12 SET G(9999999-$PIECE(^AUPNPROB(X,0),U,3))=$PIECE(^AUPNPROB(X,0),U,15)
+13 QUIT
End DoDot:1
+14 SET X=$ORDER(G(0))
IF X
QUIT G(X)
+15 SET EDATE1=9999999-EDATE-1
+16 SET D=$ORDER(^AUPNVAST("AS",P,EDATE1))
+17 IF 'D
QUIT ""
+18 SET LAST=""
SET E=0
FOR
SET E=$ORDER(^AUPNVAST("AS",P,D,E))
IF E'=+E
QUIT
SET LAST=E
+19 IF 'LAST
QUIT ""
+20 SET S=^AUPNVAST("AS",P,D,LAST)
+21 QUIT S
+22 ;
ASTHMA(P,BDATE,EDATE) ;EP
+1 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDAST
+2 KILL BUDAST
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+4 SET TIEN=$ORDER(^BUDHTSSC("B","T6B ASTHMA PERSISTENT CODES",0))
+5 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+6 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+7 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+8 ;CPT
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+10 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+11 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+12 IF Y=""
QUIT
+13 IF $DATA(^BUDHTSSC("AC",Y,TIEN))
SET BUDAST(9999999-VDATE)=Y_U_$$DATE^BUDHUTL1(VDATE)_U_VDATE
QUIT
End DoDot:2
+14 ;V TRANS
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+16 IF '$DATA(^AUPNVTC(X,0))
QUIT
+17 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+18 IF Y=""
QUIT
+19 IF $DATA(^BUDHTSSC("AC",Y,TIEN))
SET BUDAST(9999999-VDATE)=Y_U_$$DATE^BUDHUTL1(VDATE)_U_VDATE
QUIT
End DoDot:2
+20 ;POV/SNOMED
+21 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+22 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+23 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDHTSSC("AD",Y,TIEN))
SET BUDAST(9999999-VDATE)=$$VAL^XBDIQ1(9000010.07,X,.01)_U_$$DATE^BUDHUTL1(VDATE)_U_VDATE
QUIT
+24 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+25 IF Y=""
QUIT
+26 IF $DATA(^BUDHTSSC("AS",Y,TIEN))
SET BUDAST(9999999-VDATE)=Y_U_$$DATE^BUDHUTL1(VDATE)_U_VDATE
QUIT
End DoDot:2
End DoDot:1
+27 IF $ORDER(BUDAST(0))
SET X=$ORDER(BUDAST(0))
SET X=BUDAST(X)
QUIT $PIECE(X,U,1)_" on "_$PIECE(X,U,2)_U_$PIECE(X,U,3)
+28 SET Y=$$PLCL^BUDHDU(P,"T6B ASTHMA PERSISTENT CODES",EDATE,1)
+29 IF Y
QUIT "PL "_$PIECE(Y,U,2)_" on "_$$DATE^BUDHUTL1($PIECE(Y,U,3))_U_$PIECE(X,U,3)
+30 QUIT ""
EXCL(P,BDATE,EDATE) ;EP - EMPHYSEMA, COPD, CYSTIC FIBROSIS, ARF
+1 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDHX
+2 SET BUDHX=0
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+4 SET TIEN=$ORDER(^BUDHTSSC("B","T6B ASTHMA EXCLUSION CODES",0))
+5 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR!(BUDHX)
QUIT
Begin DoDot:1
+6 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+7 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+8 ;POV/SNOMED
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X!(BUDHX)
QUIT
Begin DoDot:2
+10 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+11 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
IF $DATA(^BUDHTSSC("AD",Y,TIEN))
SET BUDHX=1
QUIT
+12 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+13 IF Y=""
QUIT
+14 IF $DATA(^BUDHTSSC("AS",Y,TIEN))
SET BUDHX=1
QUIT
End DoDot:2
End DoDot:1
+15 IF BUDHX
QUIT 1
+16 SET Y=$$PLCL^BUDHDU(P,"T6B ASTHMA EXCLUSION CODES",EDATE,1)
+17 IF Y
QUIT 1
+18 QUIT ""
+19 ;
AST1039(P,BDATE,EDATE) ;EP
+1 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+2 NEW A,B,E,T,G,X,V,Y
+3 KILL G
+4 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+5 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+6 SET Y=""
+7 SET Y=$$CPTI^BUDHDU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("1039F"),U,1))
+8 IF Y
SET G($PIECE(Y,U,2))="CPT: 1039F"
+9 SET Y=$ORDER(G(""),-1)
IF Y=""
QUIT ""
+10 SET X=G(Y)
+11 QUIT X_" on "_$$FMTE^XLFDT(Y)_U_Y
ASTHTHER(P,BD,ED) ;
+1 NEW BUDMEDS1,G,A,C,M,V,V1D
+2 SET G=""
+3 DO GETMEDS^BUDHUTL2(P,BD,ED,"BGP PQA CONTROLLER MEDS","BGP PQA CONTROLLER NDC",,,.BUDMEDS1)
+4 ; no CONTROLLER meds
IF '$DATA(BUDMEDS1)
GOTO EHRO
+5 SET BUDISD=""
+6 SET A=0
SET C=""
FOR
SET A=$ORDER(BUDMEDS1(A))
IF A'=+A!(C)
QUIT
Begin DoDot:1
+7 ;IEN OF V MED
SET M=$PIECE(BUDMEDS1(A),U,4)
+8 IF '$DATA(^AUPNVMED(M,0))
QUIT
+9 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BUDMEDS1(A)
QUIT
+10 ;d/c'ed BY PROVIDER OR EDIT
IF $$STATDC(M)
KILL BUDMEDS1(A)
QUIT
+11 SET V=$PIECE(BUDMEDS1(A),U,5)
+12 SET V1D=$$VD^APCLV(V)
+13 SET C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
End DoDot:1
+14 IF C
QUIT C
EHRO ;EPRES
+1 ;EHR OUTSIDE
+2 SET C=$$PRES^BUDHRP6W(P,$ORDER(^ATXAX("B","BGP PQA CONTROLLER MEDS",0)),BD,ED,$ORDER(^ATXAX("B","BGP PQA CONTROLLER NDC",0)))
+3 IF C]""
QUIT 1_U_$PIECE(C,U,1)_" on "_$$FMTE^XLFDT($PIECE(C,U,3))
+4 QUIT ""
+5 ;
STATDC(V) ;EP - is the prescription associated with this V MED discontinued?
+1 IF '$GET(V)
QUIT ""
+2 IF '$DATA(^AUPNVMED(V,0))
QUIT 0
+3 NEW P,S,X
+4 SET P=$SELECT($DATA(^PSRX("APCC",V)):$ORDER(^(V,0)),1:0)
+5 IF 'P
QUIT 0
+6 SET X=$PIECE($GET(^PSRX(P,0)),U,15)
+7 IF X=12
QUIT 1
+8 IF X=13
QUIT 1
+9 IF X=14
QUIT 1
+10 IF X=15
QUIT 1
+11 SET X=$PIECE($GET(^PSRX(P,"STA")),U,1)
+12 IF X=12
QUIT 1
+13 IF X=13
QUIT 1
+14 IF X=14
QUIT 1
+15 IF X=15
QUIT 1
+16 QUIT 0
GETV(P,BD,ED,SITE) ;EP - get all visits for this patient and COUNT MEDICAL VISITS
+1 NEW TV,T35V,T6V,MEDV,MEDVI,LASTV,A,X,VLOC,CLINC,TIEN,VSIT,VDATE,PP,S,LINE,D
+2 SET TV=0
SET T35V=0
SET T6V=0
SET MEDV=0
SET MEDVI=""
SET LASTV=""
+3 SET A="A(""VISITS"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED)
SET E=$$START1^APCLDF(B,A)
+4 SET X=0
FOR
SET X=$ORDER(A("VISITS",X))
IF X'=+X!(MEDV>1)
QUIT
SET VSIT=$PIECE(A("VISITS",X),U,5)
Begin DoDot:1
+5 IF '$DATA(^AUPNVSIT(VSIT,0))
QUIT
+6 IF '$PIECE(^AUPNVSIT(VSIT,0),U,9)
QUIT
+7 IF $PIECE(^AUPNVSIT(VSIT,0),U,11)
QUIT
+8 SET VLOC=$PIECE(^AUPNVSIT(VSIT,0),U,6)
+9 IF VLOC=""
QUIT
+10 ;not valid location
IF '$DATA(^BUDHSITE(SITE,11,VLOC))
QUIT
+11 IF "AHSORMI"'[$PIECE(^AUPNVSIT(VSIT,0),U,7)
QUIT
+12 SET CLINC=$$CLINIC^APCLV(VSIT,"C")
+13 SET TIEN=$ORDER(^BUDHCNTL("B","UDS PT/TABLE 5 CLINIC EXCL",0))
+14 IF CLINC]""
IF $DATA(^BUDHCNTL(TIEN,11,"B",CLINC))
QUIT
+15 ;now eliminate subsequent visits to same provider on same day = item 4 in SRD visit definition
+16 SET VDATE=$$VD^APCLV(VSIT)
+17 SET PP=$$PRIMPROV^APCLV(VSIT,"I")
+18 ;no primary provider
IF PP=""
QUIT
+19 ;don't count I visits
IF $PIECE(^AUPNVSIT(VSIT,0),U,7)="I"
QUIT
+20 IF '$DATA(^AUPNVPOV("AD",VSIT))
QUIT
+21 SET S=0
+22 IF PP]""
Begin DoDot:2
+23 SET D=$PIECE($GET(A("SAMEPROV",P,VDATE,PP)),U,1)
+24 ;already had a visit to this provider on this date
IF D]""
IF D'>$PIECE(^AUPNVSIT(VSIT,0),U)
SET S=1
QUIT
+25 SET A("SAMEPROV",P,VDATE,PP)=$PIECE(^AUPNVSIT(VSIT,0),U)_U_VSIT
End DoDot:2
+26 ;quit if already had a visit to this provider
IF S
QUIT
+27 SET PP=$$PRIMPROV^APCLV(VSIT,"D")
+28 IF PP=""
QUIT
MEDC ;NOW CHECK FOR MEDICAL CARE, CAN ONLY HAVE 1 PER LOCATION OF ENCOUNTER
+1 SET S=0
+2 SET TIEN=$ORDER(^BUDHCNTL("B","MEDICAL CARE LINE NUMBERS",0))
+3 ;S PP=$$PRIMPROV^APCLV(VSIT,"D")
+4 IF $EXTRACT($$VAL^XBDIQ1(9000010,VSIT,.06),1,3)="CHS"
IF PP=15
SET LINE=2
GOTO MEDC1
+5 SET Y=$ORDER(^BUDHTFIV("C",PP,0))
IF Y=""
SET LINE=35
GOTO MEDC1
+6 SET LINE=$ORDER(^BUDHTFIV("AA",PP,""))
MEDC1 SET S=0
+1 IF $DATA(^BUDHCNTL(TIEN,11,"B",LINE))
Begin DoDot:2
+2 SET D=$PIECE($GET(A("MEDCARE",P,VDATE,VLOC,TIEN)),U,1)
+3 ;already have a medical care visit on this date
IF D]""
IF D'>$PIECE(^AUPNVSIT(VSIT,0),U)
SET S=1
QUIT
+4 SET A("MEDCARE",P,VDATE,VLOC,TIEN)=$PIECE(^AUPNVSIT(VSIT,0),U)_U_VSIT
+5 SET MEDV=MEDV+1
SET MEDVI=VSIT
+6 QUIT
End DoDot:2
End DoDot:1
+7 QUIT MEDV
PREVV(P,BDATE,EDATE) ;EP
+1 ;GO THROUGH UDS PATIENT VISITS AND CHECK CPT CODES
+2 NEW X,Y,V,Z,G,T,C
+3 SET T=$ORDER(^BUDHTSSC("B","T6B TOBACCO PREVENTATIVE CODES",0))
+4 SET G=""
SET C=0
+5 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"VISITSUDSPT",X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+6 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",X,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+7 SET Y=$$VAL^XBDIQ1(9000010.18,Z,.01)
+8 IF $DATA(^BUDHTSSC("AC",Y,T))
SET G=1
QUIT
End DoDot:2
+9 SET Z=0
FOR
SET Z=$ORDER(^AUPNVPOV("AD",X,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+10 SET Y=$$VALI^XBDIQ1(9000010.07,Z,.01)
+11 IF $DATA(^BUDHTSSC("AD",Y,T))
SET G=1
QUIT
+12 SET Y=$$VAL^XBDIQ1(9000010.07,Z,1101)
+13 IF Y=""
QUIT
+14 IF $DATA(^BUDHTSSC("AS",Y,T))
SET G=1
QUIT
End DoDot:2
+15 IF G
SET C=C+1
End DoDot:1
+16 QUIT C
