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

BUDHRP7C.m

Go to the documentation of this file. 
  1. BUDHRP7C ;IHS/CMI/LAB - UDS REPORT T7;
  1.  ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
  1.  ;
  1. DM ;EP - list of DM
  1.  S BUDDOB=$P(^DPT(DFN,0),U,3)
  1.  S BUDDDB=($E(BUDBD,1,3)-75)_"0101"
  1.  S BUDDDE=($E(BUDBD,1,3)-19)_"1231"
  1.  Q:BUDDOB>BUDDDE
  1.  Q:BUDDOB<BUDDDB
  1.  Q:BUDMEDV<1
  1.  ;
  1.  S BUDP=$$DMDX(DFN,$$DOB^AUPNPAT(DFN),BUDED)
  1.  I '$P(BUDP,U) Q  ;not dx'ed before end of report period
  1.  ;S BUDOVAR=$$OVAR(DFN,BUDBD,BUDED)
  1.  ;
  1.  ;S BUDX2DM=$$DM2(DFN,($E(BUDBD,1,3)-1)_$E(BUDBD,4,7),BUDED)
  1.  ;I $P(BUDOVAR,U),'$P(BUDX2DM,U) Q  ;DID NOT HAVE had 2 dx of dm during report period and an ovary dx
  1.  I $$GESTDX(DFN,BUDBD,BUDED) Q  ;had gestational dx during report period
  1.  Q:$$HOSPIND^BUDHRP6C(DFN,BUDBD,BUDED)  ;hospice
  1.  S BUDRACEX=$$RACE^BUDHRPTC(DFN),BUDRACE=$P(BUDRACEX,U,2),BUDRACEP=$P(BUDRACEX,U,5)
  1.  S BUDRACEE=$$RACE^BUDHRP7I(BUDRACE)
  1.  S BUDHTHN=$P($$HISP^BUDHRPTC(DFN),U,1)
  1.  I +BUDHTHN=1 S BUDETHNN="Hispanic or Latino"
  1.  I +BUDHTHN=2 S BUDETHNN="Non-Hispanic/Latino"
  1.  I +BUDHTHN=3 S BUDETHNN="Unreported/Refused to Report"
  1.  I BUDRACEP=8,+BUDHTHN=3 S BUDR=1 G SETSECTC
  1.  I +BUDHTHN=1 S BUDR=BUDRACEP G SETSECTC
  1.  I +BUDHTHN=2 S BUDR=BUDRACEP G SETSECTC
  1. SETSECTC ;
  1.  S $P(BUDSECTC(+BUDHTHN,BUDR),U,1)=$P($G(BUDSECTC(+BUDHTHN,BUDR)),U,1)+1  ;COL 1
  1.  S $P(BUDSECTC(+BUDHTHN,BUDR),U,2)=$P($G(BUDSECTC(+BUDHTHN,BUDR)),U,2)+1  ;COL 2
  1.  ;TOTAL LINE
  1.  S $P(BUDSECTC(4),U,1)=$P($G(BUDSECTC(4)),U,1)+1
  1.  S $P(BUDSECTC(4),U,2)=$P($G(BUDSECTC(4)),U,2)+1
  1.  ;SUBTOTAL LINE
  1.  S $P(BUDSECTC(+BUDHTHN),U,1)=$P($G(BUDSECTC(+BUDHTHN)),U,1)+1
  1.  S $P(BUDSECTC(+BUDHTHN),U,2)=$P($G(BUDSECTC(+BUDHTHN)),U,2)+1
  1.  I $G(BUDDMRL) S ^XTMP("BUDHRP7",BUDJ,BUDH,"DMR",BUDRACEP,+BUDHTHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
  1.  ;get last hgba1c value and set counters/lists
  1.  S BUDHGB=$$HGBA1C(DFN,BUDBD,BUDED)
  1. SET ;
  1.  S BUDLINE=$P(BUDHGB,U)
  1.  S BUDPIEC=$S(BUDLINE=13:5,BUDLINE=11:4,1:"")
  1.  S $P(BUDSECTC(+BUDHTHN,BUDR),U,BUDPIEC)=$P($G(BUDSECTC(+BUDHTHN,BUDR)),U,BUDPIEC)+1  ;COL 1
  1.  ;TOTAL LINE
  1.  S $P(BUDSECTC(4),U,BUDPIEC)=$P($G(BUDSECTC(4)),U,BUDPIEC)+1
  1.  S $P(BUDSECTC(+BUDHTHN),U,BUDPIEC)=$P($G(BUDSECTC(+BUDHTHN)),U,BUDPIEC)+1
  1.  I $G(BUDDMR1L),BUDLINE=13 S ^XTMP("BUDHRP7",BUDJ,BUDH,"DMR1",BUDRACEP,+BUDHTHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
  1.  Q
  1.  ;
  1. HGBA1C(P,BDATE,EDATE) ;EP
  1.  NEW BUDG,BUDT,BUDD,E,%,L,T,BUDLT,D,X,J,C,G
  1.  S BUDD=0
  1.  S G=$$CPT^BUDHDU(P,BDATE,EDATE,$O(^ATXAX("B","BUD HGBA1C CPTS",0)),5)
  1.  I G]"" S BUDD=BUDD+1,BUDT((9999999-$P(G,U,1)),BUDD)=U_"CPT "_$P(G,U,2)
  1.  ;now get all loinc/taxonomy tests
  1.  S T=$O(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
  1.  S BUDLT=$O(^ATXLAB("B","DM AUDIT HGB A1C 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.  ...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)_U_"LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01) Q
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,T)
  1.  ...S BUDD=BUDD+1,BUDT(D,BUDD)=$P(^AUPNVLAB(X,0),U,4)_U_"LAB LOINC: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$P(^AUPNVLAB(X,11),U,13)
  1.  ...Q
  1.  ; now got though and set return value of done 1 or 0^numerator 2-7^date^value
  1.  I '$D(BUDT) Q 13_U_"NO A1C TEST DURING THE REPORT PERIOD"  ;no tests so is hit in numerator
  1.  ; now get rid of all on same day where 1 has a result and the other doesn't
  1.  S D=0,BUDD=0 K BUDX  F  S D=$O(BUDT(D)) Q:D'=+D  S C=0,G=0 F  S C=$O(BUDT(D,C)) Q:C'=+C  D
  1.  .;I $P(BUDT(D,C),U,1)]"" S BUDD=BUDD+1
  1.  .;I BUDD>0,$P(BUDT(D,C),U,1)="" K BUDT(D,C)
  1.  .I $P(BUDT(D,C),U,1)="" Q
  1.  .S BUDX(D,C)=BUDT(D,C)
  1.  I '$D(BUDX) D
  1.  .S D=$O(BUDT(0))
  1.  .I D S C=$O(BUDT(D,0))
  1.  .I C S BUDX(D,C)=BUDT(D,C)
  1.  S D=0,G=""
  1.  S D=$O(BUDX(D))
  1.  S C=0,C=$O(BUDX(D,C))
  1.  S X=$P(BUDX(D,C),U,1)
  1.  I $$UP^XLFSTR(X)="COMMENT" Q 13_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDHUTL1(9999999-D)_" (no result) "_X
  1.  I X="" D  Q G
  1.  .S G=""
  1.  .I $P(BUDX(D,C),U,2)="CPT 3046F" S G=13_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDHUTL1(9999999-D) Q
  1.  .;I $P(BUDX(D,C),U,2)="CPT 3045F" S G=12.2_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDHUTL1(9999999-D) Q
  1.  .;I $P(BUDX(D,C),U,2)="CPT 3044F" S G=11_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDHUTL1(9999999-D) Q
  1.  .I $P(BUDX(D,C),U,2)="CPT 83036" S G=13_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDHUTL1(9999999-D) Q
  1.  .I $P(BUDX(D,C),U,2)="CPT 83037" S G=13_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDHUTL1(9999999-D) Q
  1.  .S G=13_U_$P(BUDX(D,C),U,2)_" DID NOT HAVE A RESULT "_$$DATE^BUDHUTL1(9999999-D) Q
  1.  S X=$$STRIP^XLFSTR(X," ")  ;strip spaces
  1.  I X[">9" Q 13_U_$P(BUDX(D,C),U,2)_" "_X_" "_X_$$DATE^BUDHUTL1(9999999-D)
  1.  S X=$$STV(X)
  1.  I X="" Q 13_U_$P(BUDX(D,C),U,2)_" DID NOT HAVE A RESULT "_$$DATE^BUDHUTL1(9999999-D)
  1.  I +X>9 Q 13_U_$P(BUDX(D,C),U,2)_" "_X_" "_$$DATE^BUDHUTL1(9999999-D)
  1.  ;I +X<8 Q 11_U_$P(BUDX(D,C),U,2)_" "_X_" "_$$DATE^BUDHUTL1(9999999-D)
  1.  Q ""  ;12.2_U_$P(BUDX(D,C),U,2)_" "_X_" "_$$DATE^BUDHUTL1(9999999-D)
  1.  ;Q 0_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDHUTL1(9999999-D)_" result: "_X
  1.  ;
  1. RACE(R) ;EP
  1.  I R="Unreported" Q 8
  1.  I R="Asian" Q 1
  1.  I R="Native Hawaiian" Q 2
  1.  I R="Other Pacific Islander" Q 3
  1.  I R="Black/African American" Q 4
  1.  I R="American Indian/Alaska Native" Q 5
  1.  I R="White" Q 6
  1.  Q ""
  1. DMDX(P,BDATE,EDATE,STOP) ;EP
  1.  NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL,Z,Y,T,X
  1.  S STOP=$G(STOP)
  1.  S B=0,CNT=0,BUDD="",BUDALL=""  ;if there is one before time frame set this to 1
  1.  ;
  1.  ;V10.0 ICD10
  1.  K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1.  S T=$O(^BUDHTSSC("B","T7 DIABETES DIAGNOSES",0))
  1.  S X=0,G="" F  S X=$O(BUDG(X)) Q:X'=+X!(G)  D
  1.  .S Y=+$P(BUDG(X),U,4)
  1.  .S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
  1.  .S V=$P(BUDG(X),U,5)
  1.  .S C=$$PRIMPROV^APCLV(V,"D")
  1.  .Q:C=53
  1.  .Q:$P(^AUPNVSIT(V,0),U,7)="C"
  1.  .I $D(^BUDHTSSC("AD",Z,T)) S G=1_"^"_$P(BUDG(X),U,5)_"|"_$P(BUDG(X),U,2) Q
  1.  .S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDHTSSC("AS",S,T)) S G=1_"^"_$P(BUDG(X),U,5)_"|"_S Q
  1.  I G]"" Q G
  1. PROBDX ;
  1.  S G=$$PLCL^BUDHDU(P,"T7 DIABETES DIAGNOSES",EDATE,0)
  1.  I G Q 1_U_"Problem List: "_$P(G,U,2)_" on "_$$DATE^BUDHUTL1($P(G,U,3))
  1. PROBDMM ;now check for med
  1.  K BUDMEDS1 D GETMEDS^BUDHUTL2(P,BDATE,EDATE,"BUD DIABETES MEDS TAX","BUD DIABETES MEDS NDC",,,.BUDMEDS1)
  1.  I $D(BUDMEDS1(1)) Q 1_"^"_$P(BUDMEDS1(1),U,5)_"|"_$E($P(BUDMEDS1(1),U,2),1,15)
  1.  Q ""
  1.  ;
  1. OVAR(P,BDATE,EDATE,STOP) ;EP
  1.  NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL
  1.  S STOP=$G(STOP)
  1.  S B=0,CNT=0,BUDD="",BUDALL=""  ;if there is one before time frame set this to 1
  1.  K BUDG
  1.  S Y="BUDG("
  1.  S X=P_"^LAST DX 256.4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BUDG(1)) Q 1_"^"_$P(BUDG(1),U,5)_"|"_$P(BUDG(1),U,2)
  1.  S X=P_"^LAST DX E28.2;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BUDG(1)) Q 1_"^"_$P(BUDG(1),U,5)_"|"_$P(BUDG(1),U,2)
  1.  I STOP Q ""
  1. PROBOV ;
  1.  S (X,G)=0,Z="" F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1.  .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
  1.  .Q:$P(^AUPNPROB(X,0),U,8)<BDATE
  1.  .S Y=$$VAL^XBDIQ1(9000011,X,.01)
  1.  .I Y'="256.4",Y'="E28.2" Q
  1.  .S G=$P(^AUPNPROB(X,0),U,8),Z=X
  1.  .Q
  1.  I G Q 1
  1.  Q ""
  1. DM2(P,BDATE,EDATE,STOP) ;EP
  1.  NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL
  1.  S STOP=$G(STOP)
  1.  S B=0,CNT=0,BUDD="",BUDALL=""  ;if there is one before time frame set this to 1
  1.  ;
  1.  ;V10.0 ICD10
  1.  K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1.  S T=$O(^BUDHTSSC("B","T7 DIABETES DIAGNOSES",0))
  1.  S X=0,G="" F  S X=$O(BUDG(X)) Q:X'=+X!(CNT>1)  D
  1.  .S Y=+$P(BUDG(X),U,4)
  1.  .S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
  1.  .S V=$P(BUDG(X),U,5)
  1.  .S C=$$PRIMPROV^APCLV(V,"F")
  1.  .Q:C=53
  1.  .Q:$P(^AUPNVSIT(V,0),U,7)="C"
  1.  .I $D(^BUDHTSSC("AD",Z,T)) S CNT=CNT+1 S G=1_"^"_$P(BUDG(X),U,5)_"|"_$P(BUDG(X),U,2) Q
  1.  .S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDHTSSC("AS",S,T)) S CNT=CNT+1 S G=1_"^"_$P(BUDG(X),U,5)_"|"_S Q
  1.  I CNT>1 Q G
  1.  Q ""
  1. GESTDX(P,BDATE,EDATE,STOP) ;EP
  1.  NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL
  1.  S STOP=$G(STOP)
  1.  S B=0,CNT=0,BUDD="",BUDALL=""  ;if there is one before time frame set this to 1
  1.  K BUDG
  1.  S Y="BUDG("
  1.  S X=P_"^LAST DX [BUD GEST/STEROID DM DX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BUDG(1)) Q 1_"^"_$P(BUDG(1),U,5)_"|"_$P(BUDG(1),U,2)
  1.  I STOP Q ""
  1. GESTPL S T=$O(^ATXAX("B","BUD GEST/STEROID DM DX",0))
  1.  S (X,G)=0,Z="" F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1.  .Q:$P(^AUPNPROB(X,0),U,8)>EDATE
  1.  .Q:$P(^AUPNPROB(X,0),U,8)<BDATE
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .Q:'$$ICD^ATXCHK(Y,T,9)
  1.  .S G=$P(^AUPNPROB(X,0),U,8),Z=X
  1.  .Q
  1.  I G Q 1
  1.  Q ""
  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 ""
  1. STV(X) ;EP - strip all characters besides numbers and a "."
  1.  I X="" Q X
  1.  NEW A,B,L
  1.  S L=$L(X)
  1.  F B=1:1:L S A=$E(X,B) Q:A=""  I A'?1N,A'?1"." S X=$$STRIP^XLFSTR(X,A) S B=B-1
  1.  Q X
  1.  ;