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

BUDARP6U.m

Go to the documentation of this file.
  1. BUDARP6U ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2013 5:11 PM ;
  1. ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1. ;
  1. ;
  1. G2 ;EP
  1. S BUDDOB=$P(^DPT(DFN,0),U,3)
  1. S BUDX28RB=($E(BUDBD,1,3)-18)_"1231"
  1. Q:BUDDOB>BUDX28RB
  1. Q:BUDMEDV<1
  1. S BUDX28TH=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
  1. I '$$VBBD^BUDARP6V(DFN,$$FMADD^XLFDT(BUDX28TH,1),BUDED) Q ;quit if no visiT before 17TH birthday
  1. S X=$$GETV^BUDARP6U(DFN,BUDDOB,BUDED,BUDSITE)
  1. Q:X<2
  1. K BUDTOBS,BUDTOBD,BUDTOBC
  1. S BUDTOBDD=$E(BUDBD,1,3)-1_$E(BUDBD,4,7)
  1. S BUDTOBS=$$TOBACCO(DFN,BUDTOBDD,BUDED)
  1. I BUDTOBS="" S BUDTOBC=$$TOBCESS(DFN,BUDTOBDD,BUDED) I BUDTOBC]"" S ^XTMP("BUDARP6B",BUDJ,BUDH,"TCI2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDTOBS,U,1)_U_$P(BUDTOBC,U,1) Q
  1. I BUDTOBS="" Q ;COUNSELING??
  1. S BUDTOBC=$$TOBCESS(DFN,BUDTOBDD,BUDED)
  1. I BUDTOBC]"" S BUDSECG2("ATOB")=$G(BUDSECG2("ATOB"))+1
  1. ;put the rest in demoninator
  1. S BUDSECG2("PTS")=$G(BUDSECG2("PTS"))+1 D
  1. .I $G(BUDTCI2L) D
  1. ..I BUDTOBC="" S ^XTMP("BUDARP6B",BUDJ,BUDH,"TCI2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDTOBS,U,1)_U_$P(BUDTOBC,U,1)
  1. .I $G(BUDTCI1L) D
  1. ..I BUDTOBC]"" S ^XTMP("BUDARP6B",BUDJ,BUDH,"TCI1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDTOBS,U,1)_U_$P(BUDTOBC,U,1)
  1. Q
  1. ;
  1. TOBACCO(P,BDATE,EDATE) ;
  1. NEW H,D,O,X,Y,V,F,C
  1. S X=0,Y="" F S X=$O(^AUPNVHF("AC",P,X)) Q:X'=+X!(Y]"") D
  1. .Q:'$D(^AUPNVHF(X,0))
  1. .S V=$P(^AUPNVHF(X,0),U,3)
  1. .S D=$$VD^APCLV(V)
  1. .Q:D>EDATE ;after time frame
  1. .Q:D<BDATE ;before time frame
  1. .S H=$P(^AUPNVHF(X,0),U,1)
  1. .S F=$P($G(^AUTTHF(H,0)),U,1)
  1. .S G=0
  1. .I F="CURRENT SMOKELESS" S G=1
  1. .I F="CESSATION-SMOKER" S G=1
  1. .I F="CESSATION-SMOKELESS" S G=1
  1. .I F="CURRENT SMOKER, STATUS UNKNOWN" S G=1
  1. .I F="CURRENT SMOKER, EVERY DAY" S G=1
  1. .I F="CURRENT SMOKER, SOME DAY" S G=1
  1. .Q:'G
  1. .S Y=F_U_D
  1. .Q
  1. I Y]"" Q Y
  1. ;NOW CHECK DX
  1. S Y=$$LASTDX^BUDAUTL1(P,"BUD TOBACCO SCREEN DXS",BDATE,EDATE)
  1. I Y S Y=$P(Y,U,2)_U_$P(Y,U,3) Q Y
  1. S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("1034F"),U,1))
  1. I Y S Y="1034F"_U_$P(Y,U,2) Q Y
  1. S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("1035F"),U,1))
  1. I Y S Y="1035F"_U_$P(Y,U,2) Q Y
  1. Q ""
  1. ;
  1. TOBCESS(P,BDATE,EDATE,PDATE) ;EP
  1. NEW Y,X,E,D,T,%,BUDG
  1. S Y="BUDG("
  1. S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. ;I '$D(BUDG) Q ""
  1. S (X,D)=0,%="",T="" F S X=$O(BUDG(X)) Q:X'=+X!(%]"") D
  1. .S T=$P(^AUPNVPED(+$P(BUDG(X),U,4),0),U)
  1. .Q:'T
  1. .Q:'$D(^AUTTEDT(T,0))
  1. .S T=$P(^AUTTEDT(T,0),U,2)
  1. .I $P(T,"-")="TO" S %=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
  1. .I $P(T,"-",2)="TO" S %=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
  1. .I $P(T,"-",2)="SHS" S %=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
  1. .I $P(T,"-")="99406" S %=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
  1. .I $P(T,"-")="99407" S %=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
  1. .I $P(T,"-")="4000F" S %=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
  1. .I $P(T,"-")="4001F" S %=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
  1. I %]"" Q %
  1. S Y=""
  1. S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("99406"),U,1))
  1. I Y S Y="99406"_U_$P(Y,U,2) Q Y
  1. S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("99407"),U,1))
  1. I Y S Y="99407"_U_$P(Y,U,2) Q Y
  1. S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("4000F"),U,1))
  1. I Y S Y="4000F"_U_$P(Y,U,2) Q Y
  1. S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("4001F"),U,1))
  1. I Y S Y="4001F"_U_$P(Y,U,2) Q Y
  1. NEW BUDMEDS1,T1,M,E,G,Z,N,C,BUDLPED
  1. S BUDLPED=""
  1. D GETMEDS^BUDAUTL2(P,BDATE,EDATE,,,,,.BUDMEDS1)
  1. ;I '$D(BUDMEDS1) G PEDREF
  1. S T=$O(^ATXAX("B","BGP CMS SMOKING CESSATION MEDS",0))
  1. S T1=$O(^ATXAX("B","BGP CMS SMOKING CESSATION NDC",0))
  1. S (X,G,M,E)=0,D="" F S X=$O(BUDMEDS1(X)) Q:X'=+X S V=$P(BUDMEDS1(X),U,5),Y=+$P(BUDMEDS1(X),U,4) D
  1. .Q:'$D(^AUPNVSIT(V,0))
  1. .Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
  1. .S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
  1. .Q:'Z
  1. .S N=$P($G(^PSDRUG(Z,0)),U)
  1. .I $D(^ATXAX(T,21,"B",Z)) I $P(BUDLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BUDLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N Q
  1. .I $D(^ATXAX(T,21,"B",Z))!(N["NICOTINE PATCH")!(N["NICOTINE POLACRILEX")!(N["NICOTINE INHALER")!(N["NICOTINE NASAL SPRAY") D
  1. ..I $P(BUDLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BUDLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
  1. .S C=$P($G(^PSDRUG(Z,2)),U,4)
  1. .I C]"",$D(^ATXAX(T1,21,"B",C)) I $P(BUDLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BUDLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
  1. I BUDLPED]"" Q $P(BUDLPED,U,2)_U_$P(BUDLPED,U,1) ;BUDLPED
  1. Q ""
  1. NDC(A,B) ;
  1. ;a is drug ien
  1. ;b is taxonomy ien
  1. NEW BUDNDC
  1. S BUDNDC=$P($G(^PSDRUG(A,2)),U,4)
  1. I BUDNDC]"",B,$D(^ATXAX(B,21,"B",BUDNDC)) Q 1
  1. Q 0
  1. H ;EP ; ASTHMA
  1. S BUDDOB=$P(^DPT(DFN,0),U,3)
  1. S BUD40RB=($E(BUDBD,1,3)-40)_"0101"
  1. S BUD5RB=($E(BUDED,1,3)-5)_"1231"
  1. Q:BUDDOB>BUD5RB
  1. Q:BUDDOB<BUD40RB
  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)+40)_$E(BUDDOB,4,7)
  1. Q:$$VD^APCLV(BUDLASTV)>Z
  1. ;S B=$$FMADD^XLFDT($$VD^APCLV(BUDLASTV),1)
  1. ;S A=$$AGE^AUPNPAT(DFN,B)
  1. ;I A<5 Q
  1. ;I A>40 Q
  1. Q:BUDMEDV<1
  1. S X=$$GETV(DFN,BUDDOB,BUDED,BUDSITE)
  1. Q:X<2
  1. Q:$$PROBAS1(DFN,BUDDOB,BUDED)=1 ;eliminate anyone with severity 1 on PL
  1. Q:$$ASTALG(DFN,BUDED) ;eliminate those with an allergy to a controller
  1. Q:$$SABA(DFN,BUDBD,BUDED) ;if only SABA, quit
  1. ;eliminate those with an allergy to a drug in the BUD PQA CONTROLLERS or NDC
  1. K ^TMP($J,"A")
  1. S BUDAST=$$ASTHMA(DFN,BUDBD,BUDED) ;no diagnosis of asthma during time period
  1. K ^TMP($J,"A")
  1. I BUDAST="" S X="",X=$$ASTHTHER(DFN,BUDBD,BUDED) I X]"" S ^XTMP("BUDARP6B",BUDJ,BUDH,"APT2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDAST,U)_U_$P(X,U,2) Q
  1. Q:BUDAST="" ;no asthma diagnosis
  1. Q:$$AST1039(DFN,$P(BUDAST,U,2),BUDED)]"" ;had a 1039f after the asthma dx/1038f
  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("BUDARP6B",BUDJ,BUDH,"APT2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDAST,U)_U_$P(BUDASTT,U,2)
  1. .I $G(BUDAPT1L) D
  1. ..I BUDASTT]"" S ^XTMP("BUDARP6B",BUDJ,BUDH,"APT1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,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^BUDAUTL2(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^BUDAUTL2(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 BUDC,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 BUDC=0
  1. S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X 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 I BUDC Q 1
  1. ..S Y=+N
  1. ..I T,$D(^ATXAX(T,21,"AA",Y)) S BUDC=1
  1. ..S D=$P($G(^PSDRUG(Y,2)),U,4)
  1. ..I D,$D(^ATXAX(T1,21,"AA",D)) S BUDC=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 BUDC=1 Q
  1. Q BUDC
  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","BUD 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)'="A"
  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. ;I D>(9999999-BDATE) 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. 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 T=$O(^ATXAX("B","BUD ASTHMA DXS",0))
  1. I 'T Q ""
  1. S X=0,G="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X S V=$P(^TMP($J,"A",X),U,5) D
  1. .Q:'$D(^AUPNVSIT(V,0))
  1. .Q:'$P(^AUPNVSIT(V,0),U,9)
  1. .Q:$P(^AUPNVSIT(V,0),U,11)
  1. .Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1. .S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y D
  1. ..S D=0
  1. ..I $D(^AUPNVPOV(Y,0)) S %=$P(^AUPNVPOV(Y,0),U)
  1. ..I $$ICD^ATXCHK(%,T,9) S D=1
  1. ..Q:'D
  1. ..S G($$VD^APCLV(V))=$$VAL^XBDIQ1(9000010.07,Y,.01)
  1. ..Q
  1. ;NOW CHECK FOR A CPT OF 1038F
  1. S Y=""
  1. S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("1038F"),U,1))
  1. I Y S G($P(Y,U,2))="CPT: 1038F"
  1. S Y=$$CPTI^BUDADU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("4015F"),U,1))
  1. I Y S G($P(Y,U,2))="CPT: 4015F"
  1. S Y=$O(G(""),-1)
  1. ;W !,P," ",Y," " ZW G
  1. I Y="" Q ""
  1. S X=G(Y)
  1. Q X_" on "_$$FMTE^XLFDT(Y)_U_Y
  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^BUDADU(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^BUDAUTL2(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(^BUDQSITE(SITE,11,VLOC)) ;not valid location
  1. .Q:"AHSORMEI"'[$P(^AUPNVSIT(VSIT,0),U,7)
  1. .S CLINC=$$CLINIC^APCLV(VSIT,"C")
  1. .S TIEN=$O(^BUDQCNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
  1. .I CLINC]"",$D(^BUDQCNTL(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 $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(^BUDQCNTL("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(^BUDQTFIV("C",PP,0)) I Y="" S LINE=35 G MEDC1
  1. .S LINE=$O(^BUDQTFIV("AA",PP,""))
  1. MEDC1 .S S=0
  1. .I $D(^BUDQCNTL(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