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

BUDCRP7C.m

Go to the documentation of this file. 
  1. BUDCRP7C ; IHS/CMI/LAB - UDS REPORT PROCESSOR ; 02 Feb 2016  10:27 AM
  1.  ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1.  ;
  1. DM ;EP - list of DM
  1.  S BUDDOB=$P(^DPT(DFN,0),U,3)
  1.  S BUDCDB=($E(BUDBD,1,3)-85)_"0101"
  1.  S BUDCDE=($E(BUDBD,1,3)-18)_"1231"
  1.  Q:BUDDOB>BUDCDE
  1.  Q:BUDDOB<BUDCDB
  1.  Q:BUDMEDV<2
  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.  S BUDX2DM=$$DM2(DFN,BUDBD,BUDED)
  1.  I $P(BUDOVAR,U),$P(BUDX2DM,U) Q  ;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.  S BUDRACEX=$$RACE^BUDCRPTC(DFN),BUDRACE=$P(BUDRACEX,U,2),BUDRACEP=$P(BUDRACEX,U,5)
  1.  S BUDRACEE=$$RACE^BUDCRP7I(BUDRACE)
  1.  ;S BUDRACE=$$RACE^BUDCRP7I(BUDRACE)
  1.  S BUDETHN=$P($$HISP^BUDCRPTC(DFN),U,1)
  1.  I +BUDETHN=1 S BUDETHNN="Hispanic or Latino"
  1.  I +BUDETHN=2 S BUDETHNN="Non-Hispanic/Latino"
  1.  I +BUDETHN=3 S BUDETHNN="Unreported/Refused to Report"
  1.  I BUDRACEP=8,+BUDETHN=3 S BUDR=1 G SETSECTC
  1.  I +BUDETHN=1 S BUDR=BUDRACEP G SETSECTC
  1.  I +BUDETHN=2 S BUDR=BUDRACEP G SETSECTC
  1. SETSECTC ;
  1.  S $P(BUDSECTC(+BUDETHN,BUDR),U,1)=$P($G(BUDSECTC(+BUDETHN,BUDR)),U,1)+1  ;COL 1
  1.  S $P(BUDSECTC(+BUDETHN,BUDR),U,2)=$P($G(BUDSECTC(+BUDETHN,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(+BUDETHN),U,1)=$P($G(BUDSECTC(+BUDETHN)),U,1)+1
  1.  S $P(BUDSECTC(+BUDETHN),U,2)=$P($G(BUDSECTC(+BUDETHN)),U,2)+1
  1.  I $G(BUDDMRL) S ^XTMP("BUDCRP7",BUDJ,BUDH,"DMR",BUDRACEP,+BUDETHN,BUDCOM,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.  ;W !,DFN,"  ",BUDLINE
  1.  S $P(BUDSECTC(+BUDETHN,BUDR),U,BUDPIEC)=$P($G(BUDSECTC(+BUDETHN,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(+BUDETHN),U,BUDPIEC)=$P($G(BUDSECTC(+BUDETHN)),U,BUDPIEC)+1
  1.  I $G(BUDDMR1L),BUDLINE=11 S ^XTMP("BUDCRP7",BUDJ,BUDH,"DMR1",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
  1.  I $G(BUDDMR2L),BUDLINE=13 S ^XTMP("BUDCRP7",BUDJ,BUDH,"DMR2",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
  1.  ;I $G(BUDDMR3L),BUDLINE=12.2 S ^XTMP("BUDCRP7",BUDJ,BUDH,"DMR3",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
  1.  ;I $G(BUDDMR3L),BUDLINE=13 S ^XTMP("BUDCRP7",BUDJ,BUDH,"DMR3",BUDRACEP,+BUDETHN,BUDCOM,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,BUDC,E,%,L,T,BUDLT,D,X,J,C,G
  1.  S BUDC=0
  1.  S G=$$CPT^BUDCDU(P,BDATE,EDATE,$O(^ATXAX("B","BUD HGBA1C CPTS",0)),5)
  1.  I G]"" S BUDC=BUDC+1,BUDT((9999999-$P(G,U,1)),BUDC)=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 BUDC=BUDC+1,BUDT(D,BUDC)=$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 BUDC=BUDC+1,BUDT(D,BUDC)=$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,BUDC=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 BUDC=BUDC+1
  1.  .;I BUDC>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^BUDCUTL1(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^BUDCUTL1(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^BUDCUTL1(9999999-D) Q
  1.  .I $P(BUDX(D,C),U,2)="CPT 3044F" S G=11_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDCUTL1(9999999-D) Q
  1.  .I $P(BUDX(D,C),U,2)="CPT 83036" S G=13_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDCUTL1(9999999-D) Q
  1.  .I $P(BUDX(D,C),U,2)="CPT 83037" S G=13_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDCUTL1(9999999-D) Q
  1.  .S G=13_U_$P(BUDX(D,C),U,2)_" DID NOT HAVE A RESULT "_$$DATE^BUDCUTL1(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^BUDCUTL1(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^BUDCUTL1(9999999-D)
  1.  I +X>9 Q 13_U_$P(BUDX(D,C),U,2)_" "_X_" "_$$DATE^BUDCUTL1(9999999-D)
  1.  I +X<8 Q 11_U_$P(BUDX(D,C),U,2)_" "_X_" "_$$DATE^BUDCUTL1(9999999-D)
  1.  Q ""  ;12.2_U_$P(BUDX(D,C),U,2)_" "_X_" "_$$DATE^BUDCUTL1(9999999-D)
  1.  ;Q 0_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDCUTL1(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,BUDMEDS1,BUD1,G,C,T,V,I
  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 DIABETES DXS FOR TABLE 7;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 BUD1=0,G=""
  1.  ;F  S BUD1=$O(BUDG(BUD1)) Q:BUD1'=+BUD1!(G)  D
  1.  ;.S V=$P(BUDG(BUD1),U,5)
  1.  ;.;Q:$$VD^APCLV(V)>BUDED
  1.  ;.S C=$$CLINIC^APCLV(V,"C")
  1.  ;.S T=$O(^BUDCCNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
  1.  ;.I C]"",$D(^BUDCCNTL(T,11,"B",C)) Q
  1.  ;;.S G=1_U_$P(BUDG(BUD1),U,5)_"|"_$P(BUDG(1),U,2)
  1.  ;I G Q G
  1.  I STOP Q ""
  1. PROBDX S T=$O(^ATXAX("B","BUD DIABETES DXS FOR TABLE 7",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_U_"Problem List: "_$$VAL^XBDIQ1(9000011,Z,.01)_" on "_$$FMTE^XLFDT($P(^AUPNPROB(Z,0),U,8))
  1. PROBDMM ;now check for med
  1.  K BUDMEDS1 D GETMEDS^BUDCUTL2(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.  K BUDG
  1.  S Y="BUDG("
  1.  S X=P_"^LAST 2 DX [BUD DIABETES DXS FOR TABLE 7;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BUDG(2)) Q 1_"^"_$P(BUDG(1),U,5)_"|"_$P(BUDG(1),U,2)
  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.  ;