BUDHRP6O ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;**1**;OCT 12, 2018;Build 2
;
;
I ;EP ;CAD
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUD18RB=($E(BUDBD,1,3)-19)_"1231"
Q:BUDDOB>BUD18RB
Q:BUDMEDV<1
S BUD18TH=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
S X=$$GETV(DFN,BUDDOB,BUDED,BUDSITE)
Q:X<2 ;MUST HAVE 2 MEDICAL VISITS EVER
I BUD18TH'=BUDED,'$$VBBD^BUDHRP6V(DFN,BUD18TH,BUDED) Q ;quit if no visiT AFTER 18TH BIRTHDAY
I BUD18TH=BUDED,'$$VBBD^BUDHRP6V(DFN,BUD18TH,BUDED) Q ;quit if no visiT AFTER 18TH BIRTHDAY
S BUDCADV=$$CAD(DFN,BUDBD,BUDED) ;return date of problem list or visit date during report period
Q:BUDCADV="" ;no CAD diagnosis
S BUDLDL=$$LDL(DFN,BUDBD,BUDED)
I BUDLDL]"",$P(BUDLDL,U,1)<130 Q ;
;I BUDLDL="" S BUDLDL=$$LDL(DFN,$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-365),$$VD^APCLV(BUDLASTV)) ;no LDL per Duane and Chris
;I BUDLDL="" Q
;I $P(BUDLDL,U,1)<130 Q
S X=$$LIPIDALG(DFN,BUDED)
I X Q
;I X S ^XTMP("BUDHRP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDCADV,U)_U_$P(X,U,2)_U_BUDLDL Q ;eliminate those with an allergy to a LIPID LOWERING DRUG
;I BUDCCADVU="" S X="",X=$$LIPITHER(DFN,BUDBD,BUDED) I X]"" S ^XTMP("BUDHRP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDCCADVU,U)_U_$P(X,U,2) Q
S BUDCADT=$$LIPITHER(DFN,BUDBD,BUDED)
I BUDCADT]"" S BUDSECTI("CAD")=$G(BUDSECTI("CAD"))+1
;put the rest in demoninator
S BUDSECTI("PTS")=$G(BUDSECTI("PTS"))+1 D
.I $G(BUDCAD2L) D
..I BUDCADT="" S ^XTMP("BUDHRP6B",BUDJ,BUDH,"CAD2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDCADV,U)_U_$P(BUDCADV,U,2)_U_$P(BUDLDL,U,1)_" "_$$DATE^BUDHUTL1($P(BUDLDL,U,2))_U_$P(BUDCADT,U,2)
.I $G(BUDCAD1L) D
..I BUDCADT]"" S ^XTMP("BUDHRP6B",BUDJ,BUDH,"CAD1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDCADV,U)_U_$P(BUDCADV,U,2)_U_$P(BUDLDL,U,1)_" "_$$DATE^BUDHUTL1($P(BUDLDL,U,2))_U_$P(BUDCADT,U,2)
Q
LIPIDALG(P,ED) ;
;allergy tracking
NEW BUDD,X,N,G,Y,T,T1,S,A,B,C
S T=$O(^ATXAX("B","BUD LIPID LOWERING MEDS",0))
S T1=$O(^ATXAX("B","BGPMU LIPID LOWERING NDCS",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" D Q
..S Y=+N
..I T,$D(^ATXAX(T,21,"AA",Y)) S BUDD=1_U_"ALG: "_$P(^PSDRUG(Y,0),U,1) Q
..S D=$P($G(^PSDRUG(Y,2)),U,4),D=$$STRIP^XLFSTR(D,"-")
..I D,$D(^ATXAX(T1,21,"AA",D)) S BUDD=1_U_"ALG: "_$P(^PSDRUG(Y,0),U,1)
.I N["PSNDF" D
..S Y=$P(^GMR(120.8,X,0),U,2) ;drug name
..S Y=$O(^PSDRUG("B",Y,0)) ;drug ien
..Q:'Y
..I T,$D(^ATXAX(T,21,"AA",Y)) S BUDD=1_U_"ALG: "_$P(^PSDRUG(Y,0),U,1) Q
..S D=$P($G(^PSDRUG(Y,2)),U,4),D=$$STRIP^XLFSTR(D,"-")
..I D,$D(^ATXAX(T1,21,"AA",D)) S BUDD=1_U_"ALG: "_$P(^PSDRUG(Y,0),U,1)
..;CHECK NAME OF DRUG IN DRUG FILE/TAXONOMY
Q BUDD
;
PROBCAD(P,BDATE,EDATE) ;EP
NEW G
S G=$$PLCL^BUDHDU(P,"CAD DIAGNOSES")
I 'G Q ""
Q $$FMTE^XLFDT($P(G,U,3))_" Prob: "_$P(G,U,2)_U_G
;
CAD(P,BDATE,EDATE) ;EP
NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDAST,TIEN1
S BUDAST=""
;CHECK DURING REPORT PERIOD FIRST FOR ANY DX/SURGERY
D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
S TIEN=$O(^BUDHTSSC("B","T6B CAD DIAGNOSES",0))
S TIEN1=$O(^BUDHTSSC("B","T6B CAD SURGICAL DIAGNOSES",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=$$DATE^BUDHUTL1(VDATE)_" CPT: "_Y Q
..I $D(^BUDHTSSC("AC",Y,TIEN1)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" CPT: "_Y 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=$$DATE^BUDHUTL1(VDATE)_" CPT/TRAN: "_Y Q
..I $D(^BUDHTSSC("AC",Y,TIEN1)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" CPT/TRAN: "_Y 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=$$DATE^BUDHUTL1(VDATE)_" DX: "_$$VAL^XBDIQ1(9000010.07,X,.01) Q
..I $D(^BUDHTSSC("AD",Y,TIEN1)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" DX: "_$$VAL^XBDIQ1(9000010.07,X,.01) Q
..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
..Q:Y=""
..I $D(^BUDHTSSC("AS",Y,TIEN)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" SNOMED: "_Y Q
..I $D(^BUDHTSSC("AS",Y,TIEN1)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" SNOMED: "_Y Q
.;PROC
.S X=0 F S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X D
..Q:'$D(^AUPNVPRC(X,0))
..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
..Q:Y=""
..I $D(^BUDHTSSC("AP",Y,TIEN)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" PROC: "_$$VAL^XBDIQ1(9000010.08,X,.01) Q
..I $D(^BUDHTSSC("AP",Y,TIEN1)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" PROC: "_$$VAL^XBDIQ1(9000010.08,X,.01) Q
I BUDAST]"" Q BUDAST ; S X=$O(BUDAST(0)),X=BUDAST(X) Q X
S Y=$$PLCL^BUDHDU(P,"T6B CAD DIAGNOSES",EDATE,1)
I Y Q "PL "_$P(Y,U,2)_" on "_$$DATE^BUDHUTL1($P(Y,U,3))_U_$P(X,U,3)
S Y=$$PLCL^BUDHDU(P,"T6B CAD SURGICAL DIAGNOSES",EDATE,1)
I Y Q "PL "_$P(Y,U,2)_" on "_$$DATE^BUDHUTL1($P(Y,U,3))_U_$P(X,U,3)
;NOW CHECK HISTORICAL PROCS AND CPTS
S D=9999999-EDATE,D=D-1
S D=0,G="" F S D=$O(^AUPNVPRC("AA",P,D)) Q:D'=+D!(G]"") D
.S Y=0 F S Y=$O(^AUPNVPRC("AA",P,D,Y)) Q:Y'=+Y!(G]"") D
..S X=$P($G(^AUPNVPRC(Y,0)),U,1)
..Q:'X
..Q:'$D(^BUDHTSSC("AP",X,TIEN1))
..S G=$$DATE^BUDHUTL1((9999999-D))_" PROC: "_$$VAL^XBDIQ1(9000010.08,Y,.01) Q
I G]"" Q G
S X="" F S X=$O(^BUDHTSSC(TIEN1,14,"B",X)) Q:X=""!(G]"") D
.S Y=+$$CODEN^ICPTCOD(X)
.S Z=$$CPTI^BUDHDU(P,$$DOB^AUPNPAT(P),BUDED,Y) I Z S G=$$DATE^BUDHUTL1($P(Z,U,2))_" CPT: "_X
Q ""
LIPITHER(P,BD,ED) ;
NEW BUDMEDS1,G,A,C,M,V,V1D
S G=""
D GETMEDS^BUDHUTL2(P,BD,ED,"BUD LIPID LOWERING MEDS","BGPMU LIPID LOWERING NDCS",,,.BUDMEDS1)
I '$D(BUDMEDS1) G EHRO ; no 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","BUD LIPID LOWERING MEDS",0)),BD,ED,$O(^ATXAX("B","BGPMU LIPID LOWERING NDCS",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 ;not a clinic code we want in any table
.;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
.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
LDL(P,BDATE,EDATE,NORES) ;EP
NEW BUDG,BUDT,BUDD,BUDLT,T,B,E,D,L,X,R,G,C,%
K BUDG,BUDT,BUDD
S BUDD=0
S NORES=$G(NORES)
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP LDL LOINC CODES",0))
S BUDLT=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...Q:$P(^AUPNVLAB(X,0),U,4)=""
...S R=$P(^AUPNVLAB(X,0),U,4) I R'=+R Q ;must be a number
...I BUDLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BUDLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BUDD=BUDD+1,BUDT(D,BUDD)=$P(^AUPNVLAB(X,0),U,4) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S R=$P(^AUPNVLAB(X,0),U,4)
...I 'R S R=""
...S BUDD=BUDD+1,BUDT(D,BUDD)=R
...Q
; now got though and set return value of done 1 or 0^VALUE^date
S D=0,G="" F S D=$O(BUDT(D)) Q:D'=+D!(G]"") D
.S C=0 F S C=$O(BUDT(D,C)) Q:C'=+C!(G]"") D
..S X=BUDT(D,C)
..I X="" Q
..S G=X_U_(9999999-D)
..Q
Q G
;
LOINC(A,B) ;EP
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
BUDHRP6O ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;**1**;OCT 12, 2018;Build 2
+2 ;
+3 ;
I ;EP ;CAD
+1 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+2 SET BUD18RB=($EXTRACT(BUDBD,1,3)-19)_"1231"
+3 IF BUDDOB>BUD18RB
QUIT
+4 IF BUDMEDV<1
QUIT
+5 SET BUD18TH=$EXTRACT(BUDDOB,1,3)+18_$EXTRACT(BUDDOB,4,7)
+6 SET X=$$GETV(DFN,BUDDOB,BUDED,BUDSITE)
+7 ;MUST HAVE 2 MEDICAL VISITS EVER
IF X<2
QUIT
+8 ;quit if no visiT AFTER 18TH BIRTHDAY
IF BUD18TH'=BUDED
IF '$$VBBD^BUDHRP6V(DFN,BUD18TH,BUDED)
QUIT
+9 ;quit if no visiT AFTER 18TH BIRTHDAY
IF BUD18TH=BUDED
IF '$$VBBD^BUDHRP6V(DFN,BUD18TH,BUDED)
QUIT
+10 ;return date of problem list or visit date during report period
SET BUDCADV=$$CAD(DFN,BUDBD,BUDED)
+11 ;no CAD diagnosis
IF BUDCADV=""
QUIT
+12 SET BUDLDL=$$LDL(DFN,BUDBD,BUDED)
+13 ;
IF BUDLDL]""
IF $PIECE(BUDLDL,U,1)<130
QUIT
+14 ;I BUDLDL="" S BUDLDL=$$LDL(DFN,$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-365),$$VD^APCLV(BUDLASTV)) ;no LDL per Duane and Chris
+15 ;I BUDLDL="" Q
+16 ;I $P(BUDLDL,U,1)<130 Q
+17 SET X=$$LIPIDALG(DFN,BUDED)
+18 IF X
QUIT
+19 ;I X S ^XTMP("BUDHRP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDCADV,U)_U_$P(X,U,2)_U_BUDLDL Q ;eliminate those with an allergy to a LIPID LOWERING DRUG
+20 ;I BUDCCADVU="" S X="",X=$$LIPITHER(DFN,BUDBD,BUDED) I X]"" S ^XTMP("BUDHRP6B",BUDJ,BUDH,"ALG","CAD2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDCCADVU,U)_U_$P(X,U,2) Q
+21 SET BUDCADT=$$LIPITHER(DFN,BUDBD,BUDED)
+22 IF BUDCADT]""
SET BUDSECTI("CAD")=$GET(BUDSECTI("CAD"))+1
+23 ;put the rest in demoninator
+24 SET BUDSECTI("PTS")=$GET(BUDSECTI("PTS"))+1
Begin DoDot:1
+25 IF $GET(BUDCAD2L)
Begin DoDot:2
+26 IF BUDCADT=""
SET ^XTMP("BUDHRP6B",BUDJ,BUDH,"CAD2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=$PIECE(BUDCADV,U)_U_$PIECE(BUDCADV,U,2)_U_$PIECE(BUDLDL,U,1)_" "_$$DATE^BUDHUTL1($PIECE(BUDLDL,U,2))_U_$PIECE(BUDCADT,U,2)
End DoDot:2
+27 IF $GET(BUDCAD1L)
Begin DoDot:2
+28 IF BUDCADT]""
SET ^XTMP("BUDHRP6B",BUDJ,BUDH,"CAD1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCCOM,DFN)=$PIECE(BUDCADV,U)_U_$PIECE(BUDCADV,U,2)_U_$PIECE(BUDLDL,U,1)_" "_$$DATE^BUDHUTL1($PIECE(BUDLDL,U,2))_U_$PIECE(BUDCADT,U,2)
End DoDot:2
End DoDot:1
+29 QUIT
LIPIDALG(P,ED) ;
+1 ;allergy tracking
+2 NEW BUDD,X,N,G,Y,T,T1,S,A,B,C
+3 SET T=$ORDER(^ATXAX("B","BUD LIPID LOWERING MEDS",0))
+4 SET T1=$ORDER(^ATXAX("B","BGPMU LIPID LOWERING NDCS",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 ;Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>ED ;entered after end date
+8 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,3)
+9 ;IF PSDRUG CHECK AGAINST MEDS TAXONOMY
+10 IF N["PSDRUG"
Begin DoDot:2
+11 SET Y=+N
+12 IF T
IF $DATA(^ATXAX(T,21,"AA",Y))
SET BUDD=1_U_"ALG: "_$PIECE(^PSDRUG(Y,0),U,1)
QUIT
+13 SET D=$PIECE($GET(^PSDRUG(Y,2)),U,4)
SET D=$$STRIP^XLFSTR(D,"-")
+14 IF D
IF $DATA(^ATXAX(T1,21,"AA",D))
SET BUDD=1_U_"ALG: "_$PIECE(^PSDRUG(Y,0),U,1)
End DoDot:2
QUIT
+15 IF N["PSNDF"
Begin DoDot:2
+16 ;drug name
SET Y=$PIECE(^GMR(120.8,X,0),U,2)
+17 ;drug ien
SET Y=$ORDER(^PSDRUG("B",Y,0))
+18 IF 'Y
QUIT
+19 IF T
IF $DATA(^ATXAX(T,21,"AA",Y))
SET BUDD=1_U_"ALG: "_$PIECE(^PSDRUG(Y,0),U,1)
QUIT
+20 SET D=$PIECE($GET(^PSDRUG(Y,2)),U,4)
SET D=$$STRIP^XLFSTR(D,"-")
+21 IF D
IF $DATA(^ATXAX(T1,21,"AA",D))
SET BUDD=1_U_"ALG: "_$PIECE(^PSDRUG(Y,0),U,1)
+22 ;CHECK NAME OF DRUG IN DRUG FILE/TAXONOMY
End DoDot:2
End DoDot:1
+23 QUIT BUDD
+24 ;
PROBCAD(P,BDATE,EDATE) ;EP
+1 NEW G
+2 SET G=$$PLCL^BUDHDU(P,"CAD DIAGNOSES")
+3 IF 'G
QUIT ""
+4 QUIT $$FMTE^XLFDT($PIECE(G,U,3))_" Prob: "_$PIECE(G,U,2)_U_G
+5 ;
CAD(P,BDATE,EDATE) ;EP
+1 NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDAST,TIEN1
+2 SET BUDAST=""
+3 ;CHECK DURING REPORT PERIOD FIRST FOR ANY DX/SURGERY
+4 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
+5 SET TIEN=$ORDER(^BUDHTSSC("B","T6B CAD DIAGNOSES",0))
+6 SET TIEN1=$ORDER(^BUDHTSSC("B","T6B CAD SURGICAL DIAGNOSES",0))
+7 SET CTR=0
FOR
SET CTR=$ORDER(BUDVS(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+8 SET VIEN=$PIECE(BUDVS(CTR),U,5)
+9 SET VDATE=$PIECE(BUDVS(CTR),U,1)
+10 ;CPT
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+12 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+13 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+14 IF Y=""
QUIT
+15 IF $DATA(^BUDHTSSC("AC",Y,TIEN))
SET BUDAST=$$DATE^BUDHUTL1(VDATE)_" CPT: "_Y
QUIT
+16 IF $DATA(^BUDHTSSC("AC",Y,TIEN1))
SET BUDAST=$$DATE^BUDHUTL1(VDATE)_" CPT: "_Y
QUIT
End DoDot:2
+17 ;V TRANS
+18 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+19 IF '$DATA(^AUPNVTC(X,0))
QUIT
+20 SET Y=$$VAL^XBDIQ1(9000010.33,X,.07)
+21 IF Y=""
QUIT
+22 IF $DATA(^BUDHTSSC("AC",Y,TIEN))
SET BUDAST=$$DATE^BUDHUTL1(VDATE)_" CPT/TRAN: "_Y
QUIT
+23 IF $DATA(^BUDHTSSC("AC",Y,TIEN1))
SET BUDAST=$$DATE^BUDHUTL1(VDATE)_" CPT/TRAN: "_Y
QUIT
End DoDot:2
+24 ;POV/SNOMED
+25 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+26 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+27 SET Y=$$VALI^XBDIQ1(9000010.07,X,.01)
+28 IF $DATA(^BUDHTSSC("AD",Y,TIEN))
SET BUDAST=$$DATE^BUDHUTL1(VDATE)_" DX: "_$$VAL^XBDIQ1(9000010.07,X,.01)
QUIT
+29 IF $DATA(^BUDHTSSC("AD",Y,TIEN1))
SET BUDAST=$$DATE^BUDHUTL1(VDATE)_" DX: "_$$VAL^XBDIQ1(9000010.07,X,.01)
QUIT
+30 SET Y=$$VAL^XBDIQ1(9000010.07,X,1101)
+31 IF Y=""
QUIT
+32 IF $DATA(^BUDHTSSC("AS",Y,TIEN))
SET BUDAST=$$DATE^BUDHUTL1(VDATE)_" SNOMED: "_Y
QUIT
+33 IF $DATA(^BUDHTSSC("AS",Y,TIEN1))
SET BUDAST=$$DATE^BUDHUTL1(VDATE)_" SNOMED: "_Y
QUIT
End DoDot:2
+34 ;PROC
+35 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AD",VIEN,X))
IF X'=+X
QUIT
Begin DoDot:2
+36 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+37 SET Y=$$VALI^XBDIQ1(9000010.08,X,.01)
+38 IF Y=""
QUIT
+39 IF $DATA(^BUDHTSSC("AP",Y,TIEN))
SET BUDAST=$$DATE^BUDHUTL1(VDATE)_" PROC: "_$$VAL^XBDIQ1(9000010.08,X,.01)
QUIT
+40 IF $DATA(^BUDHTSSC("AP",Y,TIEN1))
SET BUDAST=$$DATE^BUDHUTL1(VDATE)_" PROC: "_$$VAL^XBDIQ1(9000010.08,X,.01)
QUIT
End DoDot:2
End DoDot:1
+41 ; S X=$O(BUDAST(0)),X=BUDAST(X) Q X
IF BUDAST]""
QUIT BUDAST
+42 SET Y=$$PLCL^BUDHDU(P,"T6B CAD DIAGNOSES",EDATE,1)
+43 IF Y
QUIT "PL "_$PIECE(Y,U,2)_" on "_$$DATE^BUDHUTL1($PIECE(Y,U,3))_U_$PIECE(X,U,3)
+44 SET Y=$$PLCL^BUDHDU(P,"T6B CAD SURGICAL DIAGNOSES",EDATE,1)
+45 IF Y
QUIT "PL "_$PIECE(Y,U,2)_" on "_$$DATE^BUDHUTL1($PIECE(Y,U,3))_U_$PIECE(X,U,3)
+46 ;NOW CHECK HISTORICAL PROCS AND CPTS
+47 SET D=9999999-EDATE
SET D=D-1
+48 SET D=0
SET G=""
FOR
SET D=$ORDER(^AUPNVPRC("AA",P,D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:1
+49 SET Y=0
FOR
SET Y=$ORDER(^AUPNVPRC("AA",P,D,Y))
IF Y'=+Y!(G]"")
QUIT
Begin DoDot:2
+50 SET X=$PIECE($GET(^AUPNVPRC(Y,0)),U,1)
+51 IF 'X
QUIT
+52 IF '$DATA(^BUDHTSSC("AP",X,TIEN1))
QUIT
+53 SET G=$$DATE^BUDHUTL1((9999999-D))_" PROC: "_$$VAL^XBDIQ1(9000010.08,Y,.01)
QUIT
End DoDot:2
End DoDot:1
+54 IF G]""
QUIT G
+55 SET X=""
FOR
SET X=$ORDER(^BUDHTSSC(TIEN1,14,"B",X))
IF X=""!(G]"")
QUIT
Begin DoDot:1
+56 SET Y=+$$CODEN^ICPTCOD(X)
+57 SET Z=$$CPTI^BUDHDU(P,$$DOB^AUPNPAT(P),BUDED,Y)
IF Z
SET G=$$DATE^BUDHUTL1($PIECE(Z,U,2))_" CPT: "_X
End DoDot:1
+58 QUIT ""
LIPITHER(P,BD,ED) ;
+1 NEW BUDMEDS1,G,A,C,M,V,V1D
+2 SET G=""
+3 DO GETMEDS^BUDHUTL2(P,BD,ED,"BUD LIPID LOWERING MEDS","BGPMU LIPID LOWERING NDCS",,,.BUDMEDS1)
+4 ; no 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","BUD LIPID LOWERING MEDS",0)),BD,ED,$ORDER(^ATXAX("B","BGPMU LIPID LOWERING NDCS",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 ;not a clinic code we want in any table
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 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
LDL(P,BDATE,EDATE,NORES) ;EP
+1 NEW BUDG,BUDT,BUDD,BUDLT,T,B,E,D,L,X,R,G,C,%
+2 KILL BUDG,BUDT,BUDD
+3 SET BUDD=0
+4 SET NORES=$GET(NORES)
+5 ;now get all loinc/taxonomy tests
+6 SET T=$ORDER(^ATXAX("B","BGP LDL LOINC CODES",0))
+7 SET BUDLT=$ORDER(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
+8 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:1
+9 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+11 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+12 IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+13 ;must be a number
SET R=$PIECE(^AUPNVLAB(X,0),U,4)
IF R'=+R
QUIT
+14 IF BUDLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BUDLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BUDD=BUDD+1
SET BUDT(D,BUDD)=$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+15 IF 'T
QUIT
+16 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+17 IF '$$LOINC(J,T)
QUIT
+18 SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+19 IF 'R
SET R=""
+20 SET BUDD=BUDD+1
SET BUDT(D,BUDD)=R
+21 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+22 ; now got though and set return value of done 1 or 0^VALUE^date
+23 SET D=0
SET G=""
FOR
SET D=$ORDER(BUDT(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:1
+24 SET C=0
FOR
SET C=$ORDER(BUDT(D,C))
IF C'=+C!(G]"")
QUIT
Begin DoDot:2
+25 SET X=BUDT(D,C)
+26 IF X=""
QUIT
+27 SET G=X_U_(9999999-D)
+28 QUIT
End DoDot:2
End DoDot:1
+29 QUIT G
+30 ;
LOINC(A,B) ;EP
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
