BUDARP6M ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2013 5:11 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
NDC(A,B) ;
;a is drug ien
;b is taxonomy ien
NEW BUDNDC
S BUDNDC=$P($G(^PSDRUG(A,2)),U,4)
I BUDNDC]"",B,$D(^ATXAX(B,21,"B",BUDNDC)) Q 1
Q 0
J ;EP ;IVD
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUD18RB=($E(BUDBD,1,3)-18)_"1231"
Q:BUDDOB>BUD18RB
Q:BUDMEDV<1
S BUD18TH=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
I '$$VBBD^BUDARP6V(DFN,$$FMADD^XLFDT(BUD18TH,1),BUDED) Q ;quit if no visiT AFTER 18TH BIRTHDAY
K ^TMP($J,"A")
S BUDIVD=$$IVD(DFN,$E(BUDBD,1,3)-1_$E(BUDBD,4,7),BUDED) ;return date of problem list or visit date during report period
K ^TMP($J,"A")
;I BUDIVD="" S X="",X=$$ASPTHER(DFN,BUDBD,BUDED) I X]"" S ^XTMP("BUDARP6B",BUDJ,BUDH,"IVD2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDIVD,U)_U_$P(X,U,2) Q
Q:BUDIVD="" ;no IVD diagnosis
S BUDIVDT=$$ASPTHER(DFN,BUDBD,BUDED)
I BUDIVDT]"" S BUDSECTJ("IVD")=$G(BUDSECTJ("IVD"))+1
;put the rest in demoninator
S BUDSECTJ("PTS")=$G(BUDSECTJ("PTS"))+1 D
.I $G(BUDIVD2L) D
..I BUDIVDT="" S ^XTMP("BUDARP6B",BUDJ,BUDH,"IVD2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDIVD,U)_U_$P(BUDIVDT,U,2)
.I $G(BUDIVD1L) D
..I BUDIVDT]"" S ^XTMP("BUDARP6B",BUDJ,BUDH,"IVD1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDIVD,U)_U_$P(BUDIVDT,U,2)
Q
ASPDALG(P,ED) ;
;allergy tracking
NEW BUDC,X,N,G,Y,T,T1,S,A,B,C
S T=$O(^ATXAX("B","BUD ASPD LOWERING MEDS",0))
S T1=$O(^ATXAX("B","BGPMU ASPD LOWERING NDCS",0))
S BUDC=0
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>ED ;entered after end date
.S N=$P($G(^GMR(120.8,X,0)),U,3)
.;IF PSDRUG CHECK AGAINST MEDS TAXONOMY
.I N["PSDRUG"!(N["PSNDF") D I BUDC Q 1
..S Y=+N
..I T,$D(^ATXAX(T,21,"AA",Y)) S BUDC=1
..S D=$P($G(^PSDRUG(Y,2)),U,4)
..I D,$D(^ATXAX(T1,21,"AA",D)) S BUDC=1
Q BUDC
IVD(P,BDATE,EDATE) ;EP
NEW A,B,E,T,G,X,V,Y,T1,T2
K ^TMP($J,"A")
K G
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S T=$O(^ATXAX("B","BUD IVD DXS",0))
S T1=$O(^ATXAX("B","BUD CABG PTCA DXS",0))
I 'T Q ""
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
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y D
..S D=0
..I $D(^AUPNVPOV(Y,0)) S %=$P(^AUPNVPOV(Y,0),U)
..I $$ICD^ATXCHK(%,T,9) S D=1
..I $$VD^APCLV(V)<($E(BDATE,1,3)_"1102"),$$ICD^ATXCHK(%,T1,9) S D=1
..Q:'D
..S G($$VD^APCLV(V))=$$VAL^XBDIQ1(9000010.07,Y,.01)
..Q
S Y=$O(G(""),-1)
I Y S X=G(Y) Q $$FMTE^XLFDT(Y)_" "_X_U_Y
S Y=$$CPT^BUDADU(P,BDATE,$E(BDATE,1,3)_"1101",$O(^ATXAX("B","BUD IVD CPTS",0)),5)
I Y Q $$FMTE^XLFDT($P(Y,U,1))_" CPT: "_$P(Y,U,2)
S Y=$$LASTPRC^BUDAUTL1(P,"BUD CABG PTCA PROCS",BDATE,$E(BDATE,1,3)_"1101")
I Y]"" Q $$FMTE^XLFDT($P(Y,U,3))_" PROC: "_$P(Y,U,2)
S Y=$$LASTDX^BUDAUTL1(P,"BUD CARDIAC SURGERY DXS",BDATE,$E(BDATE,1,3)_"1101")
I Y]"" Q $$FMTE^XLFDT($P(Y,U,3))_" DX: "_$P(Y,U,2)
Q ""
ASPTHER(P,BD,ED) ;
NEW BUDMEDS1,G,A,C,M,V,V1D
S G=""
D GETMEDS^BUDAUTL2(P,BD,ED,"BUD ANTIPLATELET MEDS","BGPMU IVD ANTIPLATELET NDCS",,,.BUDMEDS1)
I '$D(BUDMEDS1) G ASP ; no meds
S BUDISD=""
S A=0,C="" F S A=$O(BUDMEDS1(A)) Q:A'=+A!(C) D
.S M=$P(BUDMEDS1(A),U,4) ;IEN OF V MED
.Q:'$D(^AUPNVMED(M,0))
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BUDMEDS1(A) Q
.I $$STATDC(M) K BUDMEDS1(A) Q ;d/c'ed BY PROVIDER OR EDIT
.S V=$P(BUDMEDS1(A),U,5)
.S V1D=$$VD^APCLV(V)
.S C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
I C Q C
ASP ;
S G=""
D GETMEDS^BUDAUTL2(P,BD,ED,"DM AUDIT ASPIRIN DRUGS","",,,.BUDMEDS1)
I '$D(BUDMEDS1) Q G ;no aspirin
S BUDISD=""
S A=0,C="" F S A=$O(BUDMEDS1(A)) Q:A'=+A!(C) D
.S M=$P(BUDMEDS1(A),U,4) ;IEN OF V MED
.Q:'$D(^AUPNVMED(M,0))
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BUDMEDS1(A) Q
.I $$STATDC(M) K BUDMEDS1(A) Q ;d/c'ed BY PROVIDER OR EDIT
.S V=$P(BUDMEDS1(A),U,5)
.S V1D=$$VD^APCLV(V)
.S C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
I C Q C
Q ""
;
STATDC(V) ;EP - is the prescription associated with this V MED discontinued?
I '$G(V) Q ""
I '$D(^AUPNVMED(V,0)) Q 0
NEW P,S,X
S P=$S($D(^PSRX("APCC",V)):$O(^(V,0)),1:0)
I 'P Q 0
S X=$P($G(^PSRX(P,0)),U,15)
I X=12 Q 1
I X=13 Q 1
I X=14 Q 1
I X=15 Q 1
S X=$P($G(^PSRX(P,"STA")),U,1)
I X=12 Q 1
I X=13 Q 1
I X=14 Q 1
I X=15 Q 1
Q 0
GETV(P,BD,ED,SITE) ;EP - get all visits for this patient and COUNT MEDICAL VISITS
NEW TV,T35V,T6V,MEDV,MEDVI,LASTV,A,X,VLOC,CLINC,TIEN,VSIT,VDATE,PP,S,LINE,D
S TV=0,T35V=0,T6V=0,MEDV=0,MEDVI="",LASTV=""
S A="A(""VISITS"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED),E=$$START1^APCLDF(B,A)
S X=0 F S X=$O(A("VISITS",X)) Q:X'=+X!(MEDV>1) S VSIT=$P(A("VISITS",X),U,5) D
.Q:'$D(^AUPNVSIT(VSIT,0))
.Q:'$P(^AUPNVSIT(VSIT,0),U,9)
.Q:$P(^AUPNVSIT(VSIT,0),U,11)
.S VLOC=$P(^AUPNVSIT(VSIT,0),U,6)
.Q:VLOC=""
.Q:'$D(^BUDQSITE(SITE,11,VLOC)) ;not valid location
.Q:"AHSORMEI"'[$P(^AUPNVSIT(VSIT,0),U,7)
.S CLINC=$$CLINIC^APCLV(VSIT,"C")
.S TIEN=$O(^BUDQCNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
.I CLINC]"",$D(^BUDQCNTL(TIEN,11,"B",CLINC)) Q ;not a clinic code we want in any table
.;now eliminate subsequent visits to same provider on same day = item 4 in SRD visit definition
.S VDATE=$$VD^APCLV(VSIT)
.S PP=$$PRIMPROV^APCLV(VSIT,"I")
.I $P(^AUPNVSIT(VSIT,0),U,7)="I" Q ;don't count I visits
.I '$D(^AUPNVPOV("AD",VSIT)) Q
.S S=0
.I PP]"" D
..S D=$P($G(A("SAMEPROV",P,VDATE,PP)),U,1)
..I D]"",D'>$P(^AUPNVSIT(VSIT,0),U) S S=1 Q ;already had a visit to this provider on this date
..S A("SAMEPROV",P,VDATE,PP)=$P(^AUPNVSIT(VSIT,0),U)_U_VSIT
.Q:S ;quit if already had a visit to this provider
.S PP=$$PRIMPROV^APCLV(VSIT,"D")
.I PP="" Q
MEDC .;NOW CHECK FOR MEDICAL CARE, CAN ONLY HAVE 1 PER LOCATION OF ENCOUNTER
.S S=0
.S TIEN=$O(^BUDQCNTL("B","MEDICAL CARE LINE NUMBERS",0))
.;S PP=$$PRIMPROV^APCLV(VSIT,"D")
.I $E($$VAL^XBDIQ1(9000010,VSIT,.06),1,3)="CHS",PP=15 S LINE=2 G MEDC1
.S Y=$O(^BUDQTFIV("C",PP,0)) I Y="" S LINE=35 G MEDC1
.S LINE=$O(^BUDQTFIV("AA",PP,""))
MEDC1 .S S=0
.I $D(^BUDQCNTL(TIEN,11,"B",LINE)) D
..S D=$P($G(A("MEDCARE",P,VDATE,VLOC,TIEN)),U,1)
..I D]"",D'>$P(^AUPNVSIT(VSIT,0),U) S S=1 Q ;already have a medical care visit on this date
..S A("MEDCARE",P,VDATE,VLOC,TIEN)=$P(^AUPNVSIT(VSIT,0),U)_U_VSIT
..S MEDV=MEDV+1,MEDVI=VSIT
..Q
Q MEDV
BUDARP6M ; 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
+2 ;
+3 ;
NDC(A,B) ;
+1 ;a is drug ien
+2 ;b is taxonomy ien
+3 NEW BUDNDC
+4 SET BUDNDC=$PIECE($GET(^PSDRUG(A,2)),U,4)
+5 IF BUDNDC]""
IF B
IF $DATA(^ATXAX(B,21,"B",BUDNDC))
QUIT 1
+6 QUIT 0
J ;EP ;IVD
+1 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+2 SET BUD18RB=($EXTRACT(BUDBD,1,3)-18)_"1231"
+3 IF BUDDOB>BUD18RB
QUIT
+4 IF BUDMEDV<1
QUIT
+5 SET BUD18TH=$EXTRACT(BUDDOB,1,3)+18_$EXTRACT(BUDDOB,4,7)
+6 ;quit if no visiT AFTER 18TH BIRTHDAY
IF '$$VBBD^BUDARP6V(DFN,$$FMADD^XLFDT(BUD18TH,1),BUDED)
QUIT
+7 KILL ^TMP($JOB,"A")
+8 ;return date of problem list or visit date during report period
SET BUDIVD=$$IVD(DFN,$EXTRACT(BUDBD,1,3)-1_$EXTRACT(BUDBD,4,7),BUDED)
+9 KILL ^TMP($JOB,"A")
+10 ;I BUDIVD="" S X="",X=$$ASPTHER(DFN,BUDBD,BUDED) I X]"" S ^XTMP("BUDARP6B",BUDJ,BUDH,"IVD2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDIVD,U)_U_$P(X,U,2) Q
+11 ;no IVD diagnosis
IF BUDIVD=""
QUIT
+12 SET BUDIVDT=$$ASPTHER(DFN,BUDBD,BUDED)
+13 IF BUDIVDT]""
SET BUDSECTJ("IVD")=$GET(BUDSECTJ("IVD"))+1
+14 ;put the rest in demoninator
+15 SET BUDSECTJ("PTS")=$GET(BUDSECTJ("PTS"))+1
Begin DoDot:1
+16 IF $GET(BUDIVD2L)
Begin DoDot:2
+17 IF BUDIVDT=""
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"IVD2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDIVD,U)_U_$PIECE(BUDIVDT,U,2)
End DoDot:2
+18 IF $GET(BUDIVD1L)
Begin DoDot:2
+19 IF BUDIVDT]""
SET ^XTMP("BUDARP6B",BUDJ,BUDH,"IVD1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDIVD,U)_U_$PIECE(BUDIVDT,U,2)
End DoDot:2
End DoDot:1
+20 QUIT
ASPDALG(P,ED) ;
+1 ;allergy tracking
+2 NEW BUDC,X,N,G,Y,T,T1,S,A,B,C
+3 SET T=$ORDER(^ATXAX("B","BUD ASPD LOWERING MEDS",0))
+4 SET T1=$ORDER(^ATXAX("B","BGPMU ASPD LOWERING NDCS",0))
+5 SET BUDC=0
+6 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 ;entered after end date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>ED
QUIT
+8 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,3)
+9 ;IF PSDRUG CHECK AGAINST MEDS TAXONOMY
+10 IF N["PSDRUG"!(N["PSNDF")
Begin DoDot:2
+11 SET Y=+N
+12 IF T
IF $DATA(^ATXAX(T,21,"AA",Y))
SET BUDC=1
+13 SET D=$PIECE($GET(^PSDRUG(Y,2)),U,4)
+14 IF D
IF $DATA(^ATXAX(T1,21,"AA",D))
SET BUDC=1
End DoDot:2
IF BUDC
QUIT 1
End DoDot:1
+15 QUIT BUDC
IVD(P,BDATE,EDATE) ;EP
+1 NEW A,B,E,T,G,X,V,Y,T1,T2
+2 KILL ^TMP($JOB,"A")
+3 KILL G
+4 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+5 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+6 SET T=$ORDER(^ATXAX("B","BUD IVD DXS",0))
+7 SET T1=$ORDER(^ATXAX("B","BUD CABG PTCA DXS",0))
+8 IF 'T
QUIT ""
+9 SET X=0
SET G=""
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+10 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+11 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+12 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+13 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+14 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+15 SET D=0
+16 IF $DATA(^AUPNVPOV(Y,0))
SET %=$PIECE(^AUPNVPOV(Y,0),U)
+17 IF $$ICD^ATXCHK(%,T,9)
SET D=1
+18 IF $$VD^APCLV(V)<($EXTRACT(BDATE,1,3)_"1102")
IF $$ICD^ATXCHK(%,T1,9)
SET D=1
+19 IF 'D
QUIT
+20 SET G($$VD^APCLV(V))=$$VAL^XBDIQ1(9000010.07,Y,.01)
+21 QUIT
End DoDot:2
End DoDot:1
+22 SET Y=$ORDER(G(""),-1)
+23 IF Y
SET X=G(Y)
QUIT $$FMTE^XLFDT(Y)_" "_X_U_Y
+24 SET Y=$$CPT^BUDADU(P,BDATE,$EXTRACT(BDATE,1,3)_"1101",$ORDER(^ATXAX("B","BUD IVD CPTS",0)),5)
+25 IF Y
QUIT $$FMTE^XLFDT($PIECE(Y,U,1))_" CPT: "_$PIECE(Y,U,2)
+26 SET Y=$$LASTPRC^BUDAUTL1(P,"BUD CABG PTCA PROCS",BDATE,$EXTRACT(BDATE,1,3)_"1101")
+27 IF Y]""
QUIT $$FMTE^XLFDT($PIECE(Y,U,3))_" PROC: "_$PIECE(Y,U,2)
+28 SET Y=$$LASTDX^BUDAUTL1(P,"BUD CARDIAC SURGERY DXS",BDATE,$EXTRACT(BDATE,1,3)_"1101")
+29 IF Y]""
QUIT $$FMTE^XLFDT($PIECE(Y,U,3))_" DX: "_$PIECE(Y,U,2)
+30 QUIT ""
ASPTHER(P,BD,ED) ;
+1 NEW BUDMEDS1,G,A,C,M,V,V1D
+2 SET G=""
+3 DO GETMEDS^BUDAUTL2(P,BD,ED,"BUD ANTIPLATELET MEDS","BGPMU IVD ANTIPLATELET NDCS",,,.BUDMEDS1)
+4 ; no meds
IF '$DATA(BUDMEDS1)
GOTO ASP
+5 SET BUDISD=""
+6 SET A=0
SET C=""
FOR
SET A=$ORDER(BUDMEDS1(A))
IF A'=+A!(C)
QUIT
Begin DoDot:1
+7 ;IEN OF V MED
SET M=$PIECE(BUDMEDS1(A),U,4)
+8 IF '$DATA(^AUPNVMED(M,0))
QUIT
+9 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BUDMEDS1(A)
QUIT
+10 ;d/c'ed BY PROVIDER OR EDIT
IF $$STATDC(M)
KILL BUDMEDS1(A)
QUIT
+11 SET V=$PIECE(BUDMEDS1(A),U,5)
+12 SET V1D=$$VD^APCLV(V)
+13 SET C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
End DoDot:1
+14 IF C
QUIT C
ASP ;
+1 SET G=""
+2 DO GETMEDS^BUDAUTL2(P,BD,ED,"DM AUDIT ASPIRIN DRUGS","",,,.BUDMEDS1)
+3 ;no aspirin
IF '$DATA(BUDMEDS1)
QUIT G
+4 SET BUDISD=""
+5 SET A=0
SET C=""
FOR
SET A=$ORDER(BUDMEDS1(A))
IF A'=+A!(C)
QUIT
Begin DoDot:1
+6 ;IEN OF V MED
SET M=$PIECE(BUDMEDS1(A),U,4)
+7 IF '$DATA(^AUPNVMED(M,0))
QUIT
+8 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BUDMEDS1(A)
QUIT
+9 ;d/c'ed BY PROVIDER OR EDIT
IF $$STATDC(M)
KILL BUDMEDS1(A)
QUIT
+10 SET V=$PIECE(BUDMEDS1(A),U,5)
+11 SET V1D=$$VD^APCLV(V)
+12 SET C=1_U_$$VAL^XBDIQ1(9000010.14,M,.01)_" on "_$$FMTE^XLFDT(V1D)
End DoDot:1
+13 IF C
QUIT C
+14 QUIT ""
+15 ;
STATDC(V) ;EP - is the prescription associated with this V MED discontinued?
+1 IF '$GET(V)
QUIT ""
+2 IF '$DATA(^AUPNVMED(V,0))
QUIT 0
+3 NEW P,S,X
+4 SET P=$SELECT($DATA(^PSRX("APCC",V)):$ORDER(^(V,0)),1:0)
+5 IF 'P
QUIT 0
+6 SET X=$PIECE($GET(^PSRX(P,0)),U,15)
+7 IF X=12
QUIT 1
+8 IF X=13
QUIT 1
+9 IF X=14
QUIT 1
+10 IF X=15
QUIT 1
+11 SET X=$PIECE($GET(^PSRX(P,"STA")),U,1)
+12 IF X=12
QUIT 1
+13 IF X=13
QUIT 1
+14 IF X=14
QUIT 1
+15 IF X=15
QUIT 1
+16 QUIT 0
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
+2 SET TV=0
SET T35V=0
SET T6V=0
SET MEDV=0
SET MEDVI=""
SET LASTV=""
+3 SET A="A(""VISITS"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED)
SET E=$$START1^APCLDF(B,A)
+4 SET X=0
FOR
SET X=$ORDER(A("VISITS",X))
IF X'=+X!(MEDV>1)
QUIT
SET VSIT=$PIECE(A("VISITS",X),U,5)
Begin DoDot:1
+5 IF '$DATA(^AUPNVSIT(VSIT,0))
QUIT
+6 IF '$PIECE(^AUPNVSIT(VSIT,0),U,9)
QUIT
+7 IF $PIECE(^AUPNVSIT(VSIT,0),U,11)
QUIT
+8 SET VLOC=$PIECE(^AUPNVSIT(VSIT,0),U,6)
+9 IF VLOC=""
QUIT
+10 ;not valid location
IF '$DATA(^BUDQSITE(SITE,11,VLOC))
QUIT
+11 IF "AHSORMEI"'[$PIECE(^AUPNVSIT(VSIT,0),U,7)
QUIT
+12 SET CLINC=$$CLINIC^APCLV(VSIT,"C")
+13 SET TIEN=$ORDER(^BUDQCNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
+14 ;not a clinic code we want in any table
IF CLINC]""
IF $DATA(^BUDQCNTL(TIEN,11,"B",CLINC))
QUIT
+15 ;now eliminate subsequent visits to same provider on same day = item 4 in SRD visit definition
+16 SET VDATE=$$VD^APCLV(VSIT)
+17 SET PP=$$PRIMPROV^APCLV(VSIT,"I")
+18 ;don't count I visits
IF $PIECE(^AUPNVSIT(VSIT,0),U,7)="I"
QUIT
+19 IF '$DATA(^AUPNVPOV("AD",VSIT))
QUIT
+20 SET S=0
+21 IF PP]""
Begin DoDot:2
+22 SET D=$PIECE($GET(A("SAMEPROV",P,VDATE,PP)),U,1)
+23 ;already had a visit to this provider on this date
IF D]""
IF D'>$PIECE(^AUPNVSIT(VSIT,0),U)
SET S=1
QUIT
+24 SET A("SAMEPROV",P,VDATE,PP)=$PIECE(^AUPNVSIT(VSIT,0),U)_U_VSIT
End DoDot:2
+25 ;quit if already had a visit to this provider
IF S
QUIT
+26 SET PP=$$PRIMPROV^APCLV(VSIT,"D")
+27 IF PP=""
QUIT
MEDC ;NOW CHECK FOR MEDICAL CARE, CAN ONLY HAVE 1 PER LOCATION OF ENCOUNTER
+1 SET S=0
+2 SET TIEN=$ORDER(^BUDQCNTL("B","MEDICAL CARE LINE NUMBERS",0))
+3 ;S PP=$$PRIMPROV^APCLV(VSIT,"D")
+4 IF $EXTRACT($$VAL^XBDIQ1(9000010,VSIT,.06),1,3)="CHS"
IF PP=15
SET LINE=2
GOTO MEDC1
+5 SET Y=$ORDER(^BUDQTFIV("C",PP,0))
IF Y=""
SET LINE=35
GOTO MEDC1
+6 SET LINE=$ORDER(^BUDQTFIV("AA",PP,""))
MEDC1 SET S=0
+1 IF $DATA(^BUDQCNTL(TIEN,11,"B",LINE))
Begin DoDot:2
+2 SET D=$PIECE($GET(A("MEDCARE",P,VDATE,VLOC,TIEN)),U,1)
+3 ;already have a medical care visit on this date
IF D]""
IF D'>$PIECE(^AUPNVSIT(VSIT,0),U)
SET S=1
QUIT
+4 SET A("MEDCARE",P,VDATE,VLOC,TIEN)=$PIECE(^AUPNVSIT(VSIT,0),U)_U_VSIT
+5 SET MEDV=MEDV+1
SET MEDVI=VSIT
+6 QUIT
End DoDot:2
End DoDot:1
+7 QUIT MEDV
