BUD7RPTD ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
GETV ;EP - get all visits for this patient and tally in BUDTV
;^TMP($J,"VISITSLIST") has all visits, including orphans that will be needed for either table
;3, 5 or 6 dx or 6 services
;^TMP($J,"VISITS35") has all visits to count for tables 3,5 which excludes 2 visits to the same provider
;on the same day
;^TMP($J,"VISITSLIST") is used for table 6 services only
;^TMP($J,"VISITS35") is used for table 3 and 5
;^TMP($J,"VISITS6DX") is used for table 6 dxs and includes 2 visits on same day to same provider
K ^TMP($J)
S BUDTV=0,BUDT35V=0,BUDT6V=0
S A="^TMP($J,""VISITS"",",B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BUDBD)_"-"_$$FMTE^XLFDT(BUDED),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"VISITS",1)) Q
S X=0 F S X=$O(^TMP($J,"VISITS",X)) Q:X'=+X S V=$P(^TMP($J,"VISITS",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.S L=$P(^AUPNVSIT(V,0),U,6)
.Q:L=""
.Q:'$D(^BUDESITE(BUDSITE,11,L)) ;not valid location
.Q:$P(^AUPNVSIT(V,0),U,7)="C"
.Q:$P(^AUPNVSIT(V,0),U,7)="T"
.Q:$P(^AUPNVSIT(V,0),U,7)="N"
.Q:$P(^AUPNVSIT(V,0),U,7)="D"
.Q:$P(^AUPNVSIT(V,0),U,7)="X"
.S C=$$CLINIC^APCLV(V,"C")
.S BUDTIEN=$O(^BUDECNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
.I C]"",$D(^BUDECNTL(BUDTIEN,11,"B",C)) Q ;not a clinic code we want in any table
.S BUDTV=BUDTV+1
.S ^TMP($J,"VISITSLIST",V)=""
;now set up ^TMP($J,"VISITS35") must have at least 1 of these to be in the report at all
;loop through all visits and eliminate all from clinics, and eliminate orphans
S V=0 F S V=$O(^TMP($J,"VISITSLIST",V)) Q:V'=+V D
.I '$D(^AUPNVPRV("AD",V)) Q
.I $$PRIMPROV^APCLV(V,"D")="" Q ;no prim prov disc
.I '$D(^AUPNVPOV("AD",V)) Q
.;must have a primary dx other than .9999
.S Y=$$PRIMPOV^APCLV(V,"C") I Y=".9999" Q
.;the above make it a "complete" visit
.S BUDTIEN=$O(^BUDECNTL("B","CLINIC EXCLUSIONS",0))
.S C=$$CLINIC^APCLV(V,"C")
.I C]"",$D(^BUDECNTL(BUDTIEN,11,"B",C)) Q ;exclude these clinics
.Q:"AHSORI"'[$P(^AUPNVSIT(V,0),U,7) ;new in 07 to exclude these from tables 3,5
.I $D(^TMP($J,"SAMEPROV",$$PRIMPROV^APCLV(V,"I"),$P($P(^AUPNVSIT(V,0),U),"."))) Q ;already got one on this day, this provider
.S ^TMP($J,"SAMEPROV",$$PRIMPROV^APCLV(V,"I"),$P($P(^AUPNVSIT(V,0),U),"."))=V
.S BUDT35V=BUDT35V+1
.S ^TMP($J,"VISITS35",V)=""
;NOW get all for table 6 dxs, same list but include duplicates
S V=0 F S V=$O(^TMP($J,"VISITSLIST",V)) Q:V'=+V D
.I '$D(^AUPNVPRV("AD",V)) Q
.I $$PRIMPROV^APCLV(V,"D")="" Q ;no prim prov disc
.I '$D(^AUPNVPOV("AD",V)) Q
.;must have a primary dx other than .9999
.S Y=$$PRIMPOV^APCLV(V,"C") I Y=".9999" Q
.S BUDTIEN=$O(^BUDECNTL("B","CLINIC EXCLUSIONS",0))
.S C=$$CLINIC^APCLV(V,"C")
.I C]"",$D(^BUDECNTL(BUDTIEN,11,"B",C)) Q ;exclude these clinics
.Q:$P(^AUPNVSIT(V,0),U,7)="E"
.S BUDT6V=BUDT6V+1
.S ^TMP($J,"VISITS6DX",V)=""
.Q
;now get all mamms and paps in date range and count as orphans if at this facility and no mam on that date in pcc
Q:BUDT35V=0 ;not a patient of interest
;Q:'$D(^BWP(DFN))
S T="MAMMOGRAM SCREENING",T=$O(^BWPN("B",T,0))
S T1="MAMMOGRAM DX BILAT",T1=$O(^BWPN("B",T1,0))
S T2="MAMMOGRAM DX UNILAT",T2=$O(^BWPN("B",T2,0))
I $$VERSION^XPDUTL("BW")<3 D
.S (G,V)=0 F S V=$O(^BWPCD("C",DFN,V)) Q:V="" D
..Q:'$D(^BWPCD(V,0))
..S D=$P(^BWPCD(V,0),U,12)
..S J=$P(^BWPCD(V,0),U,4) I J=T!(J=T1)!(J=T2) D Q
...Q:D<BUDBD
...Q:D>BUDED
...Q:$P($G(^BWPCD(V,"PCC")),U,1)]"" ;already in pcc
...S L=$P(^BWPCD(V,0),U,10)
...Q:L=""
...Q:'$D(^BUDESITE(BUDSITE,11,L)) ;not valid location
...S ^TMP($J,"MAMMS",V)="WH "_$$VAL^XBDIQ1(9002086.1,V,.04)_U_$$FMTE^XLFDT(D)
.Q
;;E D
;.S T="MAMMOGRAM SCREENING",T=$O(^BWVPDT("B",T,0))
;.S T1="MAMMOGRAM DX BILAT",T1=$O(^BWVPDT("B",T1,0))
;.S T2="MAMMOGRAM DX UNILAT",T2=$O(^BWVPDT("B",T2,0))
;.S D=$$FINDLSTD^BWVPRD(DFN,T_"^"_T1_"^"_T2,BUDBD,BUDED)
;.Q:D=0
;.Q:D=""
;.;check location here
;.S ^TMP($J,"MAMMS",1)="WH MAMMOGRAM "_U_$$FMTE^XLFDT(D)_U_D
S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
I $$VERSION^XPDUTL("BW")<3 D
.S (G,V)=0 F S V=$O(^BWPCD("C",DFN,V)) Q:V="" D
..Q:'$D(^BWPCD(V,0))
..S D=$P(^BWPCD(V,0),U,12)
..S J=$P(^BWPCD(V,0),U,4) I J=T D Q
...Q:D<BUDBD
...Q:D>BUDED
...Q:$P($G(^BWPCD(V,"PCC")),U,1)]"" ;already in pcc
...S L=$P(^BWPCD(V,0),U,10)
...Q:L=""
...Q:'$D(^BUDESITE(BUDSITE,11,L)) ;not valid location
...S ^TMP($J,"PAPS",V)="WH PAP SMEAR"_U_$$FMTE^XLFDT(D)
.Q
;E D
;.S T="PAP SMEAR",T=$O(^BWVPDT("B",T,0))
;.S D=$$FINDLSTD^BWVPRD(DFN,T,BUDBD,BUDED)
;.Q:D=0
;.Q:D=""
;.;check location here
;.S ^TMP($J,"PAPS",1)="WH PAP SMEAR "_U_$$FMTE^XLFDT(D)_U_D
;.S ^DIBT(4370,1,DFN)=""
;.Q
Q
BUD7RPTD ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
GETV ;EP - get all visits for this patient and tally in BUDTV
+1 ;^TMP($J,"VISITSLIST") has all visits, including orphans that will be needed for either table
+2 ;3, 5 or 6 dx or 6 services
+3 ;^TMP($J,"VISITS35") has all visits to count for tables 3,5 which excludes 2 visits to the same provider
+4 ;on the same day
+5 ;^TMP($J,"VISITSLIST") is used for table 6 services only
+6 ;^TMP($J,"VISITS35") is used for table 3 and 5
+7 ;^TMP($J,"VISITS6DX") is used for table 6 dxs and includes 2 visits on same day to same provider
+8 KILL ^TMP($JOB)
+9 SET BUDTV=0
SET BUDT35V=0
SET BUDT6V=0
+10 SET A="^TMP($J,""VISITS"","
SET B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BUDBD)_"-"_$$FMTE^XLFDT(BUDED)
SET E=$$START1^APCLDF(B,A)
+11 IF '$DATA(^TMP($JOB,"VISITS",1))
QUIT
+12 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"VISITS",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"VISITS",X),U,5)
Begin DoDot:1
+13 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+14 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+15 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+16 SET L=$PIECE(^AUPNVSIT(V,0),U,6)
+17 IF L=""
QUIT
+18 ;not valid location
IF '$DATA(^BUDESITE(BUDSITE,11,L))
QUIT
+19 IF $PIECE(^AUPNVSIT(V,0),U,7)="C"
QUIT
+20 IF $PIECE(^AUPNVSIT(V,0),U,7)="T"
QUIT
+21 IF $PIECE(^AUPNVSIT(V,0),U,7)="N"
QUIT
+22 IF $PIECE(^AUPNVSIT(V,0),U,7)="D"
QUIT
+23 IF $PIECE(^AUPNVSIT(V,0),U,7)="X"
QUIT
+24 SET C=$$CLINIC^APCLV(V,"C")
+25 SET BUDTIEN=$ORDER(^BUDECNTL("B","FIRST LEVEL CLINIC EXCLUSIONS",0))
+26 ;not a clinic code we want in any table
IF C]""
IF $DATA(^BUDECNTL(BUDTIEN,11,"B",C))
QUIT
+27 SET BUDTV=BUDTV+1
+28 SET ^TMP($JOB,"VISITSLIST",V)=""
End DoDot:1
+29 ;now set up ^TMP($J,"VISITS35") must have at least 1 of these to be in the report at all
+30 ;loop through all visits and eliminate all from clinics, and eliminate orphans
+31 SET V=0
FOR
SET V=$ORDER(^TMP($JOB,"VISITSLIST",V))
IF V'=+V
QUIT
Begin DoDot:1
+32 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+33 ;no prim prov disc
IF $$PRIMPROV^APCLV(V,"D")=""
QUIT
+34 IF '$DATA(^AUPNVPOV("AD",V))
QUIT
+35 ;must have a primary dx other than .9999
+36 SET Y=$$PRIMPOV^APCLV(V,"C")
IF Y=".9999"
QUIT
+37 ;the above make it a "complete" visit
+38 SET BUDTIEN=$ORDER(^BUDECNTL("B","CLINIC EXCLUSIONS",0))
+39 SET C=$$CLINIC^APCLV(V,"C")
+40 ;exclude these clinics
IF C]""
IF $DATA(^BUDECNTL(BUDTIEN,11,"B",C))
QUIT
+41 ;new in 07 to exclude these from tables 3,5
IF "AHSORI"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+42 ;already got one on this day, this provider
IF $DATA(^TMP($JOB,"SAMEPROV",$$PRIMPROV^APCLV(V,"I"),$PIECE($PIECE(^AUPNVSIT(V,0),U),".")))
QUIT
+43 SET ^TMP($JOB,"SAMEPROV",$$PRIMPROV^APCLV(V,"I"),$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))=V
+44 SET BUDT35V=BUDT35V+1
+45 SET ^TMP($JOB,"VISITS35",V)=""
End DoDot:1
+46 ;NOW get all for table 6 dxs, same list but include duplicates
+47 SET V=0
FOR
SET V=$ORDER(^TMP($JOB,"VISITSLIST",V))
IF V'=+V
QUIT
Begin DoDot:1
+48 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+49 ;no prim prov disc
IF $$PRIMPROV^APCLV(V,"D")=""
QUIT
+50 IF '$DATA(^AUPNVPOV("AD",V))
QUIT
+51 ;must have a primary dx other than .9999
+52 SET Y=$$PRIMPOV^APCLV(V,"C")
IF Y=".9999"
QUIT
+53 SET BUDTIEN=$ORDER(^BUDECNTL("B","CLINIC EXCLUSIONS",0))
+54 SET C=$$CLINIC^APCLV(V,"C")
+55 ;exclude these clinics
IF C]""
IF $DATA(^BUDECNTL(BUDTIEN,11,"B",C))
QUIT
+56 IF $PIECE(^AUPNVSIT(V,0),U,7)="E"
QUIT
+57 SET BUDT6V=BUDT6V+1
+58 SET ^TMP($JOB,"VISITS6DX",V)=""
+59 QUIT
End DoDot:1
+60 ;now get all mamms and paps in date range and count as orphans if at this facility and no mam on that date in pcc
+61 ;not a patient of interest
IF BUDT35V=0
QUIT
+62 ;Q:'$D(^BWP(DFN))
+63 SET T="MAMMOGRAM SCREENING"
SET T=$ORDER(^BWPN("B",T,0))
+64 SET T1="MAMMOGRAM DX BILAT"
SET T1=$ORDER(^BWPN("B",T1,0))
+65 SET T2="MAMMOGRAM DX UNILAT"
SET T2=$ORDER(^BWPN("B",T2,0))
+66 IF $$VERSION^XPDUTL("BW")<3
Begin DoDot:1
+67 SET (G,V)=0
FOR
SET V=$ORDER(^BWPCD("C",DFN,V))
IF V=""
QUIT
Begin DoDot:2
+68 IF '$DATA(^BWPCD(V,0))
QUIT
+69 SET D=$PIECE(^BWPCD(V,0),U,12)
+70 SET J=$PIECE(^BWPCD(V,0),U,4)
IF J=T!(J=T1)!(J=T2)
Begin DoDot:3
+71 IF D<BUDBD
QUIT
+72 IF D>BUDED
QUIT
+73 ;already in pcc
IF $PIECE($GET(^BWPCD(V,"PCC")),U,1)]""
QUIT
+74 SET L=$PIECE(^BWPCD(V,0),U,10)
+75 IF L=""
QUIT
+76 ;not valid location
IF '$DATA(^BUDESITE(BUDSITE,11,L))
QUIT
+77 SET ^TMP($JOB,"MAMMS",V)="WH "_$$VAL^XBDIQ1(9002086.1,V,.04)_U_$$FMTE^XLFDT(D)
End DoDot:3
QUIT
End DoDot:2
+78 QUIT
End DoDot:1
+79 ;;E D
+80 ;.S T="MAMMOGRAM SCREENING",T=$O(^BWVPDT("B",T,0))
+81 ;.S T1="MAMMOGRAM DX BILAT",T1=$O(^BWVPDT("B",T1,0))
+82 ;.S T2="MAMMOGRAM DX UNILAT",T2=$O(^BWVPDT("B",T2,0))
+83 ;.S D=$$FINDLSTD^BWVPRD(DFN,T_"^"_T1_"^"_T2,BUDBD,BUDED)
+84 ;.Q:D=0
+85 ;.Q:D=""
+86 ;.;check location here
+87 ;.S ^TMP($J,"MAMMS",1)="WH MAMMOGRAM "_U_$$FMTE^XLFDT(D)_U_D
+88 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+89 IF $$VERSION^XPDUTL("BW")<3
Begin DoDot:1
+90 SET (G,V)=0
FOR
SET V=$ORDER(^BWPCD("C",DFN,V))
IF V=""
QUIT
Begin DoDot:2
+91 IF '$DATA(^BWPCD(V,0))
QUIT
+92 SET D=$PIECE(^BWPCD(V,0),U,12)
+93 SET J=$PIECE(^BWPCD(V,0),U,4)
IF J=T
Begin DoDot:3
+94 IF D<BUDBD
QUIT
+95 IF D>BUDED
QUIT
+96 ;already in pcc
IF $PIECE($GET(^BWPCD(V,"PCC")),U,1)]""
QUIT
+97 SET L=$PIECE(^BWPCD(V,0),U,10)
+98 IF L=""
QUIT
+99 ;not valid location
IF '$DATA(^BUDESITE(BUDSITE,11,L))
QUIT
+100 SET ^TMP($JOB,"PAPS",V)="WH PAP SMEAR"_U_$$FMTE^XLFDT(D)
End DoDot:3
QUIT
End DoDot:2
+101 QUIT
End DoDot:1
+102 ;E D
+103 ;.S T="PAP SMEAR",T=$O(^BWVPDT("B",T,0))
+104 ;.S D=$$FINDLSTD^BWVPRD(DFN,T,BUDBD,BUDED)
+105 ;.Q:D=0
+106 ;.Q:D=""
+107 ;.;check location here
+108 ;.S ^TMP($J,"PAPS",1)="WH PAP SMEAR "_U_$$FMTE^XLFDT(D)_U_D
+109 ;.S ^DIBT(4370,1,DFN)=""
+110 ;.Q
+111 QUIT
