- BUDBRP6M ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
- ;;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^BUDBRP6V(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("BUDBRP6B",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("BUDBRP6B",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("BUDBRP6B",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^BUDBDU(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^BUDBUTL1(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^BUDBUTL1(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^BUDBUTL2(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^BUDBUTL2(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(^BUDBSITE(SITE,11,VLOC)) ;not valid location
- .Q:"AHSORMEI"'[$P(^AUPNVSIT(VSIT,0),U,7)
- .S CLINC=$$CLINIC^APCLV(VSIT,"C")
- .S TIEN=$O(^BUDBCNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
- .I CLINC]"",$D(^BUDBCNTL(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(^BUDBCNTL("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(^BUDBTFIV("C",PP,0)) I Y="" S LINE=35 G MEDC1
- .S LINE=$O(^BUDBTFIV("AA",PP,""))
- MEDC1 .S S=0
- .I $D(^BUDBCNTL(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
- BUDBRP6M ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
- +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^BUDBRP6V(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("BUDBRP6B",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("BUDBRP6B",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("BUDBRP6B",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^BUDBDU(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^BUDBUTL1(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^BUDBUTL1(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^BUDBUTL2(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^BUDBUTL2(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(^BUDBSITE(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(^BUDBCNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
- +14 ;not a clinic code we want in any table
- IF CLINC]""
- IF $DATA(^BUDBCNTL(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(^BUDBCNTL("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(^BUDBTFIV("C",PP,0))
- IF Y=""
- SET LINE=35
- GOTO MEDC1
- +6 SET LINE=$ORDER(^BUDBTFIV("AA",PP,""))
- MEDC1 SET S=0
- +1 IF $DATA(^BUDBCNTL(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