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

BUDDRP6U.m

Go to the documentation of this file. 
  1. BUDDRP6U ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
  1.  ;;11.0;IHS/RPMS UNIFORM DATA SYSTEM;;JAN 18, 2017;Build 66
  1.  ;
  1.  ;
  1. H ;EP ; ASTHMA
  1.  S BUDDOB=$P(^DPT(DFN,0),U,3)
  1.  S BUD64RB=($E(BUDBD,1,3)-64)_"0101"
  1.  S BUD5RB=($E(BUDED,1,3)-5)_"1231"
  1.  Q:BUDDOB>BUD5RB
  1.  Q:BUDDOB<BUD64RB
  1.  S Z=($E(BUDDOB,1,3)+5)_$E(BUDDOB,4,7)
  1.  Q:$$VD^APCLV(BUDLASTV)<Z
  1.  S Z=($E(BUDDOB,1,3)+65)_$E(BUDDOB,4,7)
  1.  Q:$$VD^APCLV(BUDLASTV)'<Z
  1.  Q:BUDMEDV<1
  1.  ;
  1.  S BUDAST=$$ASTHMA(DFN,BUDBD,BUDED)  ;no diagnosis of asthma during time period
  1.  I BUDAST="" Q  ;no dx of peristent asthma and no pl entry
  1.  Q:$$EXCL(DFN,$$DOB^AUPNPAT(P),BUDED)  ; had exclusion dx
  1.  Q:$$AST1039(DFN,$P(BUDAST,U,2),BUDED)]""  ;had a 1039f after the asthma dx/1038f
  1.  Q:$$SABA(DFN,BUDBD,BUDED)  ;if only SABA, quit
  1.  ;numerator
  1.  S BUDASTT=$$ASTHTHER(DFN,BUDBD,BUDED)
  1.  I BUDASTT]"" S BUDSECTH("APT")=$G(BUDSECTH("APT"))+1
  1.  ;put the rest in demoninator
  1.  S BUDSECTH("PTS")=$G(BUDSECTH("PTS"))+1 D
  1.  .I $G(BUDAPT2L) D
  1.  ..I BUDASTT="" S ^XTMP("BUDDRP6B",BUDJ,BUDH,"APT2",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDAST,U)_U_$P(BUDASTT,U,2)
  1.  .I $G(BUDAPT1L) D
  1.  ..I BUDASTT]"" S ^XTMP("BUDDRP6B",BUDJ,BUDH,"APT1",BUDAGE,$P(^DPT(DFN,0),U),BUDCCOM,DFN)=$P(BUDAST,U)_U_$P(BUDASTT,U,2)
  1.  Q
  1. SABA(P,BD,ED) ;
  1.  NEW BUDMEDS1,G,A,C,M,V,V1D,BGPHSABA
  1.  S G="",BGPHSABA=""
  1.  D GETMEDS^BUDDUTL2(P,BD,ED,"BGP PQA SABA MEDS","BGP PQA SABA NDC",,,.BUDMEDS1)
  1.  I '$D(BUDMEDS1) Q G  ; no SABA 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 S BGPHSABA=1
  1.  I 'BGPHSABA Q ""
  1.  S G=""
  1.  D GETMEDS^BUDDUTL2(P,BD,ED,"BGP PQA CONTROLLER MEDS","BGP PQA CONTROLLER NDC",,,.BUDMEDS1)
  1.  I '$D(BUDMEDS1) Q 1  ; no CONTROLLER meds BUT HAS SABA
  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 0
  1.  Q 1
  1. ASTALG(P,ED) ;
  1.  ;allergy tracking
  1.  NEW BUDD,X,N,G,Y,T,T1,S,A,B,C
  1.  S T=$O(^ATXAX("B","BGP PQA CONTROLLER MEDS",0))
  1.  S T1=$O(^ATXAX("B","BGP PQA CONTROLLER NDC",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"!(N["PSNDF") D
  1.  ..S Y=+N
  1.  ..I T,$D(^ATXAX(T,21,"AA",Y)) S BUDD=1
  1.  ..S D=$P($G(^PSDRUG(Y,2)),U,4)
  1.  ..I D,$D(^ATXAX(T1,21,"AA",D)) S BUDD=1
  1.  .;check name for the heck of it
  1.  .S S=$P(^GMR(120.8,X,0),U,2)   ;NAME OF THING THEY ARE ALLERGIC TO
  1.  .S A=0 F  S A=$O(^ATXAX(T,21,A)) Q:A'=+A  D
  1.  ..S B=$P($G(^ATXAX(T,21,A,0)),U,1)
  1.  ..I $P($G(^PSDRUG(B,0)),U,1)=S S BUDD=1 Q
  1.  Q BUDD
  1.  ;
  1. PROBAS1(P,BDATE,EDATE) ;EP
  1.  NEW S,A,B,T,X,G,V,Y,Z
  1.  S G=""
  1.  S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))
  1.  S X=0,G="" F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X  D
  1.  .S Z=$P(^AUPNPROB(X,0),U,13)
  1.  .I Z="" S Z=$P(^AUPNPROB(X,0),U,8)
  1.  .Q:Z>EDATE
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1.  .Q:'$$ICD^ATXCHK(Y,T,9)
  1.  .Q:$P(^AUPNPROB(X,0),U,15)=""
  1.  .S G(9999999-$P(^AUPNPROB(X,0),U,3))=$P(^AUPNPROB(X,0),U,15)
  1.  .Q
  1.  S X=$O(G(0)) I X Q G(X)
  1.  S EDATE1=9999999-EDATE-1
  1.  S D=$O(^AUPNVAST("AS",P,EDATE1))
  1.  I 'D Q ""
  1.  S LAST="",E=0 F  S E=$O(^AUPNVAST("AS",P,D,E)) Q:E'=+E  S LAST=E
  1.  I 'LAST Q ""
  1.  S S=^AUPNVAST("AS",P,D,LAST)
  1.  Q S
  1.  ;
  1. ASTHMA(P,BDATE,EDATE) ;EP
  1.  NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDAST
  1.  K BUDAST
  1.  D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
  1.  S TIEN=$O(^BUDDTSSC("B","T6B ASTHMA PERSISTENT CODES",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(^BUDDTSSC("AC",Y,TIEN)) S BUDAST(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE 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(^BUDDTSSC("AC",Y,TIEN)) S BUDAST(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE 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) I $D(^BUDDTSSC("AD",Y,TIEN)) S BUDAST(9999999-VDATE)=$$VAL^XBDIQ1(9000010.07,X,.01)_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1.  ..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
  1.  ..Q:Y=""
  1.  ..I $D(^BUDDTSSC("AS",Y,TIEN)) S BUDAST(9999999-VDATE)=Y_U_$$DATE^BUDDUTL1(VDATE)_U_VDATE Q
  1.  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)
  1.  S Y=$$PLCL^BUDDDU(P,"T6B ASTHMA PERSISTENT CODES",EDATE,1)
  1.  I Y Q "PL "_$P(Y,U,2)_" on "_$$DATE^BUDDUTL1($P(Y,U,3))_U_$P(X,U,3)
  1.  Q ""
  1. EXCL(P,BDATE,EDATE) ;EP - EMPHYSEMA, COPD, CYSTIC FIBROSIS, ARF
  1.  NEW BUDVS,TIEN,CTR,VIEN,VDATE,X,Y,Z,BUDEX
  1.  S BUDEX=0
  1.  D ALLV^APCLAPIU(P,BDATE,EDATE,"BUDVS")
  1.  S TIEN=$O(^BUDDTSSC("B","T6B ASTHMA EXCLUSION CODES",0))
  1.  S CTR=0 F  S CTR=$O(BUDVS(CTR)) Q:CTR'=+CTR!(BUDEX)  D
  1.  .S VIEN=$P(BUDVS(CTR),U,5)
  1.  .S VDATE=$P(BUDVS(CTR),U,1)
  1.  .;POV/SNOMED
  1.  .S X=0 F  S X=$O(^AUPNVPOV("AD",VIEN,X)) Q:X'=+X!(BUDEX)  D
  1.  ..Q:'$D(^AUPNVPOV(X,0))
  1.  ..S Y=$$VALI^XBDIQ1(9000010.07,X,.01) I $D(^BUDDTSSC("AD",Y,TIEN)) S BUDEX=1 Q
  1.  ..S Y=$$VAL^XBDIQ1(9000010.07,X,1101)
  1.  ..Q:Y=""
  1.  ..I $D(^BUDDTSSC("AS",Y,TIEN)) S BUDEX=1 Q
  1.  I BUDEX Q 1
  1.  S Y=$$PLCL^BUDDDU(P,"T6B ASTHMA EXCLUSION CODES",EDATE,1)
  1.  I Y Q 1
  1.  Q ""
  1.  ;
  1. AST1039(P,BDATE,EDATE) ;EP
  1.  I '$D(^AUPNVSIT("AC",P)) Q ""
  1.  NEW A,B,E,T,G,X,V,Y
  1.  K G
  1.  S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1.  I '$D(^TMP($J,"A",1)) Q ""
  1.  S Y=""
  1.  S Y=$$CPTI^BUDDDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("1039F"),U,1))
  1.  I Y S G($P(Y,U,2))="CPT: 1039F"
  1.  S Y=$O(G(""),-1) I Y="" Q ""
  1.  S X=G(Y)
  1.  Q X_" on "_$$FMTE^XLFDT(Y)_U_Y
  1. ASTHTHER(P,BD,ED) ;
  1.  NEW BUDMEDS1,G,A,C,M,V,V1D
  1.  S G=""
  1.  D GETMEDS^BUDDUTL2(P,BD,ED,"BGP PQA CONTROLLER MEDS","BGP PQA CONTROLLER NDC",,,.BUDMEDS1)
  1.  I '$D(BUDMEDS1) Q G  ; no CONTROLLER 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.  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(^BUDDSITE(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(^BUDDCNTL("B","UDS PT/TABLE 5 CLINIC EXCL",0))
  1.  .I CLINC]"",$D(^BUDDCNTL(TIEN,11,"B",CLINC)) Q
  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  ;no primary provider
  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(^BUDDCNTL("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(^BUDDTFIV("C",PP,0)) I Y="" S LINE=35 G MEDC1
  1.  .S LINE=$O(^BUDDTFIV("AA",PP,""))
  1. MEDC1 .S S=0
  1.  .I $D(^BUDDCNTL(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. PREVV(P,BDATE,EDATE) ;EP
  1.  ;GO THROUGH UDS PATIENT VISITS AND CHECK CPT CODES
  1.  NEW X,Y,V,Z,G,T,C
  1.  S T=$O(^BUDDTSSC("B","T6B TOBACCO PREVENTATIVE CODES",0))
  1.  S G="",C=0
  1.  S X=0 F  S X=$O(^TMP($J,"VISITSUDSPT",X)) Q:X'=+X!(G)  D
  1.  .S Z=0 F  S Z=$O(^AUPNVCPT("AD",X,Z)) Q:Z'=+Z!(G)  D
  1.  ..S Y=$$VAL^XBDIQ1(9000010.18,Z,.01)
  1.  ..I $D(^BUDDTSSC("AC",Y,T)) S G=1 Q
  1.  .S Z=0 F  S Z=$O(^AUPNVPOV("AD",X,Z)) Q:Z'=+Z!(G)  D
  1.  ..S Y=$$VALI^XBDIQ1(9000010.07,Z,.01)
  1.  ..I $D(^BUDDTSSC("AD",Y,T)) S G=1 Q
  1.  ..S Y=$$VAL^XBDIQ1(9000010.07,Z,1101)
  1.  ..Q:Y=""
  1.  ..I $D(^BUDDTSSC("AS",Y,T)) S G=1 Q
  1.  .I G S C=C+1
  1.  Q C