Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BUDHRP6O

BUDHRP6O.m

Go to the documentation of this file. 
  1. BUDHRP6O ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
  1.  ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;**1**;OCT 12, 2018;Build 2
  1.  ;
  1.  ;
  1. I ;EP ;CAD
  1.  S BUDDOB=$P(^DPT(DFN,0),U,3)
  1.  S BUD18RB=($E(BUDBD,1,3)-19)_"1231"
  1.  Q:BUDDOB>BUD18RB
  1.  Q:BUDMEDV<1
  1.  S BUD18TH=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
  1.  S X=$$GETV(DFN,BUDDOB,BUDED,BUDSITE)
  1.  Q:X<2  ;MUST HAVE 2 MEDICAL VISITS EVER
  1.  I BUD18TH'=BUDED,'$$VBBD^BUDHRP6V(DFN,BUD18TH,BUDED) Q  ;quit if no visiT AFTER 18TH BIRTHDAY
  1.  I BUD18TH=BUDED,'$$VBBD^BUDHRP6V(DFN,BUD18TH,BUDED) Q  ;quit if no visiT AFTER 18TH BIRTHDAY
  1.  S BUDCADV=$$CAD(DFN,BUDBD,BUDED)  ;return date of problem list or visit date during report period
  1.  Q:BUDCADV=""  ;no CAD diagnosis
  1.  S BUDLDL=$$LDL(DFN,BUDBD,BUDED)
  1.  I BUDLDL]"",$P(BUDLDL,U,1)<130 Q  ;
  1.  ;I BUDLDL="" S BUDLDL=$$LDL(DFN,$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),-365),$$VD^APCLV(BUDLASTV))  ;no LDL per Duane and Chris
  1.  ;I BUDLDL="" Q
  1.  ;I $P(BUDLDL,U,1)<130 Q
  1.  S X=$$LIPIDALG(DFN,BUDED)
  1.  I X Q
  1.  ;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
  1.  ;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
  1.  S BUDCADT=$$LIPITHER(DFN,BUDBD,BUDED)
  1.  I BUDCADT]"" S BUDSECTI("CAD")=$G(BUDSECTI("CAD"))+1
  1.  ;put the rest in demoninator
  1.  S BUDSECTI("PTS")=$G(BUDSECTI("PTS"))+1 D
  1.  .I $G(BUDCAD2L) D
  1.  ..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)
  1.  .I $G(BUDCAD1L) D
  1.  ..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)
  1.  Q
  1. LIPIDALG(P,ED) ;
  1.  ;allergy tracking
  1.  NEW BUDD,X,N,G,Y,T,T1,S,A,B,C
  1.  S T=$O(^ATXAX("B","BUD LIPID LOWERING MEDS",0))
  1.  S T1=$O(^ATXAX("B","BGPMU LIPID LOWERING NDCS",0))
  1.  S BUDD=0
  1.  S X=0 F  S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X!(BUDD)  D
  1.  .;Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>ED  ;entered after end date
  1.  .S N=$P($G(^GMR(120.8,X,0)),U,3)
  1.  .;IF PSDRUG CHECK AGAINST MEDS TAXONOMY
  1.  .I N["PSDRUG" D  Q
  1.  ..S Y=+N
  1.  ..I T,$D(^ATXAX(T,21,"AA",Y)) S BUDD=1_U_"ALG: "_$P(^PSDRUG(Y,0),U,1) Q
  1.  ..S D=$P($G(^PSDRUG(Y,2)),U,4),D=$$STRIP^XLFSTR(D,"-")
  1.  ..I D,$D(^ATXAX(T1,21,"AA",D)) S BUDD=1_U_"ALG: "_$P(^PSDRUG(Y,0),U,1)
  1.  .I N["PSNDF" D
  1.  ..S Y=$P(^GMR(120.8,X,0),U,2)  ;drug name
  1.  ..S Y=$O(^PSDRUG("B",Y,0))  ;drug ien
  1.  ..Q:'Y
  1.  ..I T,$D(^ATXAX(T,21,"AA",Y)) S BUDD=1_U_"ALG: "_$P(^PSDRUG(Y,0),U,1) Q
  1.  ..S D=$P($G(^PSDRUG(Y,2)),U,4),D=$$STRIP^XLFSTR(D,"-")
  1.  ..I D,$D(^ATXAX(T1,21,"AA",D)) S BUDD=1_U_"ALG: "_$P(^PSDRUG(Y,0),U,1)
  1.  ..;CHECK NAME OF DRUG IN DRUG FILE/TAXONOMY
  1.  Q BUDD
  1.  ;
  1. PROBCAD(P,BDATE,EDATE) ;EP
  1.  NEW G
  1.  S G=$$PLCL^BUDHDU(P,"CAD DIAGNOSES")
  1.  I 'G Q ""
  1.  Q $$FMTE^XLFDT($P(G,U,3))_"  Prob: "_$P(G,U,2)_U_G
  1.  ;
  1. CAD(P,BDATE,EDATE) ;EP
  1.  NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDAST,TIEN1
  1.  S BUDAST=""
  1.  ;CHECK DURING REPORT PERIOD FIRST FOR ANY DX/SURGERY
  1.  D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
  1.  S TIEN=$O(^BUDHTSSC("B","T6B CAD DIAGNOSES",0))
  1.  S TIEN1=$O(^BUDHTSSC("B","T6B CAD SURGICAL DIAGNOSES",0))
  1.  S CTR=0 F  S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR  D
  1.  .S VIEN=$P(BUDVS(CTR),U,5)
  1.  .S VDATE=$P(BUDVS(CTR),U,1)
  1.  .;CPT
  1.  .S X=0 F  S X=$O(^AUPNVCPT("AD",VIEN,X)) Q:X'=+X  D
  1.  ..Q:'$D(^AUPNVCPT(X,0))
  1.  ..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
  1.  ..Q:Y=""
  1.  ..I $D(^BUDHTSSC("AC",Y,TIEN)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" CPT: "_Y Q
  1.  ..I $D(^BUDHTSSC("AC",Y,TIEN1)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" CPT: "_Y Q
  1.  .;V TRANS
  1.  .S X=0 F  S X=$O(^AUPNVTC("AD",VIEN,X)) Q:X'=+X  D
  1.  ..Q:'$D(^AUPNVTC(X,0))
  1.  ..S Y=$$VAL^XBDIQ1(9000010.33,X,.07)
  1.  ..Q:Y=""
  1.  ..I $D(^BUDHTSSC("AC",Y,TIEN)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" CPT/TRAN: "_Y Q
  1.  ..I $D(^BUDHTSSC("AC",Y,TIEN1)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" CPT/TRAN: "_Y Q
  1.  .;POV/SNOMED
  1.  .S X=0 F  S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X  D
  1.  ..Q:'$D(^AUPNVPOV(X,0))
  1.  ..S Y=$$VALI^XBDIQ1(9000010.07,X,.01)
  1.  ..I $D(^BUDHTSSC("AD",Y,TIEN)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" DX: "_$$VAL^XBDIQ1(9000010.07,X,.01) Q
  1.  ..I $D(^BUDHTSSC("AD",Y,TIEN1)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" DX: "_$$VAL^XBDIQ1(9000010.07,X,.01) Q
  1.  ..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
  1.  ..Q:Y=""
  1.  ..I $D(^BUDHTSSC("AS",Y,TIEN)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" SNOMED: "_Y Q
  1.  ..I $D(^BUDHTSSC("AS",Y,TIEN1)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" SNOMED: "_Y Q
  1.  .;PROC
  1.  .S X=0 F  S X=$O(^AUPNVPRC("AD",VIEN,X)) Q:X'=+X  D
  1.  ..Q:'$D(^AUPNVPRC(X,0))
  1.  ..S Y=$$VALI^XBDIQ1(9000010.08,X,.01)
  1.  ..Q:Y=""
  1.  ..I $D(^BUDHTSSC("AP",Y,TIEN)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" PROC: "_$$VAL^XBDIQ1(9000010.08,X,.01) Q
  1.  ..I $D(^BUDHTSSC("AP",Y,TIEN1)) S BUDAST=$$DATE^BUDHUTL1(VDATE)_" PROC: "_$$VAL^XBDIQ1(9000010.08,X,.01) Q
  1.  I BUDAST]"" Q BUDAST  ; S X=$O(BUDAST(0)),X=BUDAST(X) Q X
  1.  S Y=$$PLCL^BUDHDU(P,"T6B CAD DIAGNOSES",EDATE,1)
  1.  I Y Q "PL "_$P(Y,U,2)_" on "_$$DATE^BUDHUTL1($P(Y,U,3))_U_$P(X,U,3)
  1.  S Y=$$PLCL^BUDHDU(P,"T6B CAD SURGICAL DIAGNOSES",EDATE,1)
  1.  I Y Q "PL "_$P(Y,U,2)_" on "_$$DATE^BUDHUTL1($P(Y,U,3))_U_$P(X,U,3)
  1.  ;NOW CHECK HISTORICAL PROCS AND CPTS
  1.  S D=9999999-EDATE,D=D-1
  1.  S D=0,G="" F  S D=$O(^AUPNVPRC("AA",P,D)) Q:D'=+D!(G]"")  D
  1.  .S Y=0 F  S Y=$O(^AUPNVPRC("AA",P,D,Y)) Q:Y'=+Y!(G]"")  D
  1.  ..S X=$P($G(^AUPNVPRC(Y,0)),U,1)
  1.  ..Q:'X
  1.  ..Q:'$D(^BUDHTSSC("AP",X,TIEN1))
  1.  ..S G=$$DATE^BUDHUTL1((9999999-D))_" PROC: "_$$VAL^XBDIQ1(9000010.08,Y,.01) Q
  1.  I G]"" Q G
  1.  S X="" F  S X=$O(^BUDHTSSC(TIEN1,14,"B",X)) Q:X=""!(G]"")  D
  1.  .S Y=+$$CODEN^ICPTCOD(X)
  1.  .S Z=$$CPTI^BUDHDU(P,$$DOB^AUPNPAT(P),BUDED,Y) I Z S G=$$DATE^BUDHUTL1($P(Z,U,2))_" CPT: "_X
  1.  Q ""
  1. LIPITHER(P,BD,ED) ;
  1.  NEW BUDMEDS1,G,A,C,M,V,V1D
  1.  S G=""
  1.  D GETMEDS^BUDHUTL2(P,BD,ED,"BUD LIPID LOWERING MEDS","BGPMU LIPID LOWERING NDCS",,,.BUDMEDS1)
  1.  I '$D(BUDMEDS1) G EHRO  ; no meds
  1.  S BUDISD=""
  1.  S A=0,C="" F  S A=$O(BUDMEDS1(A)) Q:A'=+A!(C)  D
  1.  .S M=$P(BUDMEDS1(A),U,4)  ;IEN OF V MED
  1.  .Q:'$D(^AUPNVMED(M,0))
  1.  .I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BUDMEDS1(A) Q
  1.  .I $$STATDC(M) K BUDMEDS1(A) Q  ;d/c'ed BY PROVIDER OR EDIT
  1.  .S V=$P(BUDMEDS1(A),U,5)
  1.  .S V1D=$$VD^APCLV(V)
  1.  .S C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
  1.  I C Q C
  1. EHRO ;EPRES
  1.  ;EHR OUTSIDE
  1.  S C=$$PRES^BUDHRP6W(P,$O(^ATXAX("B","BUD LIPID LOWERING MEDS",0)),BD,ED,$O(^ATXAX("B","BGPMU LIPID LOWERING NDCS",0)))
  1.  I C]"" Q 1_U_$P(C,U,1)_" on "_$$FMTE^XLFDT($P(C,U,3))
  1.  Q ""
  1.  ;
  1. STATDC(V) ;EP - is the prescription associated with this V MED discontinued?
  1.  I '$G(V) Q ""
  1.  I '$D(^AUPNVMED(V,0)) Q 0
  1.  NEW P,S,X
  1.  S P=$S($D(^PSRX("APCC",V)):$O(^(V,0)),1:0)
  1.  I 'P Q 0
  1.  S X=$P($G(^PSRX(P,0)),U,15)
  1.  I X=12 Q 1
  1.  I X=13 Q 1
  1.  I X=14 Q 1
  1.  I X=15 Q 1
  1.  S X=$P($G(^PSRX(P,"STA")),U,1)
  1.  I X=12 Q 1
  1.  I X=13 Q 1
  1.  I X=14 Q 1
  1.  I X=15 Q 1
  1.  Q 0
  1. 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
  1.  S TV=0,T35V=0,T6V=0,MEDV=0,MEDVI="",LASTV=""
  1.  S A="A(""VISITS"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED),E=$$START1^APCLDF(B,A)
  1.  S X=0 F  S X=$O(A("VISITS",X)) Q:X'=+X!(MEDV>1)  S VSIT=$P(A("VISITS",X),U,5) D
  1.  .Q:'$D(^AUPNVSIT(VSIT,0))
  1.  .Q:'$P(^AUPNVSIT(VSIT,0),U,9)
  1.  .Q:$P(^AUPNVSIT(VSIT,0),U,11)
  1.  .S VLOC=$P(^AUPNVSIT(VSIT,0),U,6)
  1.  .Q:VLOC=""
  1.  .Q:'$D(^BUDHSITE(SITE,11,VLOC))  ;not valid location
  1.  .Q:"AHSORMI"'[$P(^AUPNVSIT(VSIT,0),U,7)
  1.  .S CLINC=$$CLINIC^APCLV(VSIT,"C")
  1.  .S TIEN=$O(^BUDHCNTL("B","UDS PT/TABLE 5 CLINIC EXCL",0))
  1.  .I CLINC]"",$D(^BUDHCNTL(TIEN,11,"B",CLINC)) Q  ;not a clinic code we want in any table
  1.  .;now eliminate subsequent visits to same provider on same day  = item 4 in SRD visit definition
  1.  .S VDATE=$$VD^APCLV(VSIT)
  1.  .S PP=$$PRIMPROV^APCLV(VSIT,"I")
  1.  .I PP="" Q
  1.  .I $P(^AUPNVSIT(VSIT,0),U,7)="I" Q  ;don't count I visits
  1.  .I '$D(^AUPNVPOV("AD",VSIT)) Q
  1.  .S S=0
  1.  .I PP]"" D
  1.  ..S D=$P($G(A("SAMEPROV",P,VDATE,PP)),U,1)
  1.  ..I D]"",D'>$P(^AUPNVSIT(VSIT,0),U) S S=1 Q  ;already had a visit to this provider on this date
  1.  ..S A("SAMEPROV",P,VDATE,PP)=$P(^AUPNVSIT(VSIT,0),U)_U_VSIT
  1.  .Q:S  ;quit if already had a visit to this provider
  1.  .S PP=$$PRIMPROV^APCLV(VSIT,"D")
  1.  .I PP="" Q
  1. MEDC .;NOW CHECK FOR MEDICAL CARE, CAN ONLY HAVE 1 PER LOCATION OF ENCOUNTER
  1.  .S S=0
  1.  .S TIEN=$O(^BUDHCNTL("B","MEDICAL CARE LINE NUMBERS",0))
  1.  .;S PP=$$PRIMPROV^APCLV(VSIT,"D")
  1.  .I $E($$VAL^XBDIQ1(9000010,VSIT,.06),1,3)="CHS",PP=15 S LINE=2 G MEDC1
  1.  .S Y=$O(^BUDHTFIV("C",PP,0)) I Y="" S LINE=35 G MEDC1
  1.  .S LINE=$O(^BUDHTFIV("AA",PP,""))
  1. MEDC1 .S S=0
  1.  .I $D(^BUDHCNTL(TIEN,11,"B",LINE)) D
  1.  ..S D=$P($G(A("MEDCARE",P,VDATE,VLOC,TIEN)),U,1)
  1.  ..I D]"",D'>$P(^AUPNVSIT(VSIT,0),U) S S=1 Q  ;already have a medical care visit on this date
  1.  ..S A("MEDCARE",P,VDATE,VLOC,TIEN)=$P(^AUPNVSIT(VSIT,0),U)_U_VSIT
  1.  ..S MEDV=MEDV+1,MEDVI=VSIT
  1.  ..Q
  1.  Q MEDV
  1. LDL(P,BDATE,EDATE,NORES) ;EP
  1.  NEW BUDG,BUDT,BUDD,BUDLT,T,B,E,D,L,X,R,G,C,%
  1.  K BUDG,BUDT,BUDD
  1.  S BUDD=0
  1.  S NORES=$G(NORES)
  1.  ;now get all loinc/taxonomy tests
  1.  S T=$O(^ATXAX("B","BGP LDL LOINC CODES",0))
  1.  S BUDLT=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL TAX",0))
  1.  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
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...Q:$P(^AUPNVLAB(X,0),U,4)=""
  1.  ...S R=$P(^AUPNVLAB(X,0),U,4) I R'=+R Q  ;must be a number
  1.  ...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
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,T)
  1.  ...S R=$P(^AUPNVLAB(X,0),U,4)
  1.  ...I 'R S R=""
  1.  ...S BUDD=BUDD+1,BUDT(D,BUDD)=R
  1.  ...Q
  1.  ; now got though and set return value of done 1 or 0^VALUE^date
  1.  S D=0,G="" F  S D=$O(BUDT(D)) Q:D'=+D!(G]"")  D
  1.  .S C=0 F  S C=$O(BUDT(D,C)) Q:C'=+C!(G]"")  D
  1.  ..S X=BUDT(D,C)
  1.  ..I X="" Q
  1.  ..S G=X_U_(9999999-D)
  1.  ..Q
  1.  Q G
  1.  ;
  1. LOINC(A,B) ;EP
  1.  NEW %
  1.  S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1.  I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1.  S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1.  I $D(^ATXAX(B,21,"B",%)) Q 1
  1.  Q ""