BUD8RP6D ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2008 5:11 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
PAPD ;EP - called from xbdbque
;must have DOB between 1/1/06 and 12/31/06
Q:$P(^DPT(DFN,0),U,2)'="F"
S BUDDOB=$P(^DPT(DFN,0),U,3)
;Q:BUDDOB<2440101
;Q:BUDDOB>2871231
Q:BUDDOB<2390101
Q:BUDDOB>2821231
Q:BUDMEDV<1
S BUD65TH=$E(BUDDOB,1,3)+65_$E(BUDDOB,4,7)
I '$$VBBD(DFN,BUDDOB,$$FMADD^XLFDT(BUD65TH,-1)) Q ;quit if no visiT before 65TH birthday
K BUDPAP
S BUDPD=$E(BUDBD,1,3)-2_$E(BUDBD,4,7)
S BUDPAP=$$PAP(DFN,BUDDOB,BUDED)
S BUDPAPD=$P(BUDPAP,U,2)
I BUDPAPD'<BUDPD S BUDSECTD("PAP")=$G(BUDSECTD("PAP"))+1,BUDSECTD("PTS")=$G(BUDSECTD("PTS"))+1 D Q
.I $G(BUDPAP1L) D
..S Y=$$FMTE^XLFDT($P(BUDPAP,U,2))_U_$P(BUDPAP,U,3)_U I $P(BUDPAP,U,4) S Y=Y_$$PRIMPROV^APCLV($P(BUDPAP,U,4),"D")_U_$P(^AUPNVSIT($P(BUDPAP,U,4),0),U,7)_U_$$CLINIC^APCLV($P(BUDPAP,U,4),"E")_U_$$LOCENC^APCLV($P(BUDPAP,U,4),"E")
..S ^XTMP("BUD8RP6B",BUDJ,BUDH,"PAP1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=Y
..Q
Q:$$HYSTER(DFN,BUDED) ;if no pap and has hysterectomy don't put in denominator or numerator
;put the rest in demoninator
S BUDSECTD("PTS")=$G(BUDSECTD("PTS"))+1 D
.I $G(BUDPAP2L) D
..S Y="" I BUDPAP="" S Y="Never"
..I Y="" S Y=$$FMTE^XLFDT($P(BUDPAP,U,2))_U_$P(BUDPAP,U,3)_U I $P(BUDPAP,U,4) S Y=Y_$$PRIMPROV^APCLV($P(BUDPAP,U,4),"D")_U_$P(^AUPNVSIT($P(BUDPAP,U,4),0),U,7)_U_$$CLINIC^APCLV($P(BUDPAP,U,4),"E")_U_$$LOCENC^APCLV($P(BUDPAP,U,4),"E")
..S ^XTMP("BUD8RP6B",BUDJ,BUDH,"PAP2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=Y
Q
;
;
VBBD(P,BDATE,EDATE) ;EP
NEW BUDVL,G
K BUDVL
S G=""
S A="BUDVL(",B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(BUDVL) Q ""
S X=0 F S X=$O(BUDVL(X)) Q:X'=+X S V=$P(BUDVL(X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:'$D(^AUPNVPRV("AD",V))
.Q:'$D(^AUPNVPOV("AD",V))
.S L=$P(^AUPNVSIT(V,0),U,6)
.Q:L=""
.Q:'$D(^BUDGSITE(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"
.Q:$P(^AUPNVSIT(V,0),U,7)="E"
.S G=V
.Q
Q G
;
PAP(P,BDATE,EDATE) ;EP
NEW BUDC,BUDLPAP,T,BUDLT,B,E,D,L,X,Z,J,T,BUD
K BUDC
S BUDC=""
S BUDLPAP=""
S T=$O(^ATXAX("B","BGP PAP LOINC CODES",0))
S BUDLT=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BUDC]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BUDC]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BUDC]"") D
...Q:'$D(^AUPNVLAB(X,0))
...S Z=$P(^AUPNVLAB(X,0),U),Z=$P($G(^LAB(60,Z,0)),U) I Z="PAP SMEAR" S BUDC="1^"_(9999999-D)_"^Lab "_Z_U_$P(^AUPNVLAB(X,0),U,3) Q
...I BUDLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BUDLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BUDC="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_$P(^AUPNVLAB(X,0),U,3) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BUDC="1^"_(9999999-D)_"^Lab-loinc"_U_$P(^AUPNVLAB(X,0),U,3) Q
...Q
S BUDLPAP=BUDC
K BUD
S T="BUD PAP SMEAR DXS"
S X=$$LASTDX^BUD8UTL1(P,T,BDATE,EDATE) I X,$P(BUDLPAP,U,2)<$P(X,U,3) S BUDLPAP="1^"_$P(X,U,3)_"^DX: "_$P(X,U,2)_"^"_$P(^AUPNVPOV($P(X,U,5),0),U,3)
K BUD S %=P_"^LAST PROCEDURE 91.46;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BUD(")
I $D(BUD(1)),$P(BUDLPAP,U,2)<$P(BUD(1),U,1) S BUDLPAP="1^"_$P(BUD(1),U)_"^Procedures: 91.46^"_$P(BUD(1),U,5)
S T=$O(^ATXAX("B","BUD CPT PAP 08",0))
I T D I X]"",$P(BUDLPAP,U,2)<$P(X,U,2) S BUDLPAP="1^"_$P(X,U,2)_"^CPT: "_$P(X,U,3)_"^"_$P(X,U,5)
.S X=$$CPT^BUD8DU(P,BDATE,EDATE,T,6) I X]"" Q
.S X=$$TRAN^BUD8DU(P,BDATE,EDATE,T,6)
S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
I T D I X]"",$P(BUDLPAP,U,2)<X S BUDLPAP="1^"_X_"^WH PAP SMEAR"
.S X=$$WH^BUD8DU(P,BDATE,EDATE,T,3)
Q BUDLPAP
;
LOINC(A,B) ;
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
;
HYSTER(P,EDATE) ;EP
I '$G(P) Q ""
S X=$$LASTPRC^BUD8UTL1(P,"BUD HYSTERECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
I X Q 1
S T="HYSTERECTOMY",T=$O(^BWPN("B",T,0))
I T D I X]"" Q 1
.S X=$$WH^BUD8DU(P,$$DOB^AUPNPAT(P),EDATE,T,2)
S T=$O(^ATXAX("B","BUD HYSTERECTOMY CPTS",0))
I T D I X]"" Q 1
.S X=$$CPT^BUD8DU(P,$P(^DPT(P,0),U,3),EDATE,T,3) I X]"" Q
.S X=$$TRAN^BUD8DU(P,$P(^DPT(P,0),U,3),EDATE,T,3)
S X=$$LASTDXI^BUD8UTL1(P,618.5,$$DOB^AUPNPAT(P),EDATE,1)
I X Q 1
Q ""
BUD8RP6D ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2008 5:11 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
PAPD ;EP - called from xbdbque
+1 ;must have DOB between 1/1/06 and 12/31/06
+2 IF $PIECE(^DPT(DFN,0),U,2)'="F"
QUIT
+3 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+4 ;Q:BUDDOB<2440101
+5 ;Q:BUDDOB>2871231
+6 IF BUDDOB<2390101
QUIT
+7 IF BUDDOB>2821231
QUIT
+8 IF BUDMEDV<1
QUIT
+9 SET BUD65TH=$EXTRACT(BUDDOB,1,3)+65_$EXTRACT(BUDDOB,4,7)
+10 ;quit if no visiT before 65TH birthday
IF '$$VBBD(DFN,BUDDOB,$$FMADD^XLFDT(BUD65TH,-1))
QUIT
+11 KILL BUDPAP
+12 SET BUDPD=$EXTRACT(BUDBD,1,3)-2_$EXTRACT(BUDBD,4,7)
+13 SET BUDPAP=$$PAP(DFN,BUDDOB,BUDED)
+14 SET BUDPAPD=$PIECE(BUDPAP,U,2)
+15 IF BUDPAPD'<BUDPD
SET BUDSECTD("PAP")=$GET(BUDSECTD("PAP"))+1
SET BUDSECTD("PTS")=$GET(BUDSECTD("PTS"))+1
Begin DoDot:1
+16 IF $GET(BUDPAP1L)
Begin DoDot:2
+17 SET Y=$$FMTE^XLFDT($PIECE(BUDPAP,U,2))_U_$PIECE(BUDPAP,U,3)_U
IF $PIECE(BUDPAP,U,4)
SET Y=Y_$$PRIMPROV^APCLV($PIECE(BUDPAP,U,4),"D")_U_$PIECE(^AUPNVSIT($PIECE(BUDPAP,U,4),0),U,7)_U_$$CLINIC^APCLV($PIECE(BUDPAP,U,4),"E")_U_$$LOCENC^APCLV($PIECE(BUDPAP,U,4),"E")
+18 SET ^XTMP("BUD8RP6B",BUDJ,BUDH,"PAP1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=Y
+19 QUIT
End DoDot:2
End DoDot:1
QUIT
+20 ;if no pap and has hysterectomy don't put in denominator or numerator
IF $$HYSTER(DFN,BUDED)
QUIT
+21 ;put the rest in demoninator
+22 SET BUDSECTD("PTS")=$GET(BUDSECTD("PTS"))+1
Begin DoDot:1
+23 IF $GET(BUDPAP2L)
Begin DoDot:2
+24 SET Y=""
IF BUDPAP=""
SET Y="Never"
+25 IF Y=""
SET Y=$$FMTE^XLFDT($PIECE(BUDPAP,U,2))_U_$PIECE(BUDPAP,U,3)_U
IF $PIECE(BUDPAP,U,4)
SET Y=Y_$$PRIMPROV^APCLV($PIECE(BUDPAP,U,4),"D")_U_$PIECE(^AUPNVSIT($PIECE(BUDPAP,U,4),0),U,7)_U_$$CLINIC^APCLV($PIECE(BUDPAP,U,4),"E")_U_$$LOCENC^APCLV($PIECE(BUDPAP,U,4),"E")
+26 SET ^XTMP("BUD8RP6B",BUDJ,BUDH,"PAP2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=Y
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
+29 ;
VBBD(P,BDATE,EDATE) ;EP
+1 NEW BUDVL,G
+2 KILL BUDVL
+3 SET G=""
+4 SET A="BUDVL("
SET B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+5 IF '$DATA(BUDVL)
QUIT ""
+6 SET X=0
FOR
SET X=$ORDER(BUDVL(X))
IF X'=+X
QUIT
SET V=$PIECE(BUDVL(X),U,5)
Begin DoDot:1
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+11 IF '$DATA(^AUPNVPOV("AD",V))
QUIT
+12 SET L=$PIECE(^AUPNVSIT(V,0),U,6)
+13 IF L=""
QUIT
+14 ;not valid location
IF '$DATA(^BUDGSITE(BUDSITE,11,L))
QUIT
+15 IF $PIECE(^AUPNVSIT(V,0),U,7)="C"
QUIT
+16 IF $PIECE(^AUPNVSIT(V,0),U,7)="T"
QUIT
+17 IF $PIECE(^AUPNVSIT(V,0),U,7)="N"
QUIT
+18 IF $PIECE(^AUPNVSIT(V,0),U,7)="D"
QUIT
+19 IF $PIECE(^AUPNVSIT(V,0),U,7)="X"
QUIT
+20 IF $PIECE(^AUPNVSIT(V,0),U,7)="E"
QUIT
+21 SET G=V
+22 QUIT
End DoDot:1
+23 QUIT G
+24 ;
PAP(P,BDATE,EDATE) ;EP
+1 NEW BUDC,BUDLPAP,T,BUDLT,B,E,D,L,X,Z,J,T,BUD
+2 KILL BUDC
+3 SET BUDC=""
+4 SET BUDLPAP=""
+5 SET T=$ORDER(^ATXAX("B","BGP PAP LOINC CODES",0))
+6 SET BUDLT=$ORDER(^ATXLAB("B","BGP PAP SMEAR TAX",0))
+7 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BUDC]"")
QUIT
Begin DoDot:1
+8 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BUDC]"")
QUIT
Begin DoDot:2
+9 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BUDC]"")
QUIT
Begin DoDot:3
+10 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+11 SET Z=$PIECE(^AUPNVLAB(X,0),U)
SET Z=$PIECE($GET(^LAB(60,Z,0)),U)
IF Z="PAP SMEAR"
SET BUDC="1^"_(9999999-D)_"^Lab "_Z_U_$PIECE(^AUPNVLAB(X,0),U,3)
QUIT
+12 IF BUDLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BUDLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BUDC="1^"_(9999999-D)_"^Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_$PIECE(^AUPNVLAB(X,0),U,3)
QUIT
+13 IF 'T
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC(J,T)
QUIT
+16 SET BUDC="1^"_(9999999-D)_"^Lab-loinc"_U_$PIECE(^AUPNVLAB(X,0),U,3)
QUIT
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 SET BUDLPAP=BUDC
+19 KILL BUD
+20 SET T="BUD PAP SMEAR DXS"
+21 SET X=$$LASTDX^BUD8UTL1(P,T,BDATE,EDATE)
IF X
IF $PIECE(BUDLPAP,U,2)<$PIECE(X,U,3)
SET BUDLPAP="1^"_$PIECE(X,U,3)_"^DX: "_$PIECE(X,U,2)_"^"_$PIECE(^AUPNVPOV($PIECE(X,U,5),0),U,3)
+22 KILL BUD
SET %=P_"^LAST PROCEDURE 91.46;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BUD(")
+23 IF $DATA(BUD(1))
IF $PIECE(BUDLPAP,U,2)<$PIECE(BUD(1),U,1)
SET BUDLPAP="1^"_$PIECE(BUD(1),U)_"^Procedures: 91.46^"_$PIECE(BUD(1),U,5)
+24 SET T=$ORDER(^ATXAX("B","BUD CPT PAP 08",0))
+25 IF T
Begin DoDot:1
+26 SET X=$$CPT^BUD8DU(P,BDATE,EDATE,T,6)
IF X]""
QUIT
+27 SET X=$$TRAN^BUD8DU(P,BDATE,EDATE,T,6)
End DoDot:1
IF X]""
IF $PIECE(BUDLPAP,U,2)<$PIECE(X,U,2)
SET BUDLPAP="1^"_$PIECE(X,U,2)_"^CPT: "_$PIECE(X,U,3)_"^"_$PIECE(X,U,5)
+28 SET T="PAP SMEAR"
SET T=$ORDER(^BWPN("B",T,0))
+29 IF T
Begin DoDot:1
+30 SET X=$$WH^BUD8DU(P,BDATE,EDATE,T,3)
End DoDot:1
IF X]""
IF $PIECE(BUDLPAP,U,2)<X
SET BUDLPAP="1^"_X_"^WH PAP SMEAR"
+31 QUIT BUDLPAP
+32 ;
LOINC(A,B) ;
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
+7 ;
HYSTER(P,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 SET X=$$LASTPRC^BUD8UTL1(P,"BUD HYSTERECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
+3 IF X
QUIT 1
+4 SET T="HYSTERECTOMY"
SET T=$ORDER(^BWPN("B",T,0))
+5 IF T
Begin DoDot:1
+6 SET X=$$WH^BUD8DU(P,$$DOB^AUPNPAT(P),EDATE,T,2)
End DoDot:1
IF X]""
QUIT 1
+7 SET T=$ORDER(^ATXAX("B","BUD HYSTERECTOMY CPTS",0))
+8 IF T
Begin DoDot:1
+9 SET X=$$CPT^BUD8DU(P,$PIECE(^DPT(P,0),U,3),EDATE,T,3)
IF X]""
QUIT
+10 SET X=$$TRAN^BUD8DU(P,$PIECE(^DPT(P,0),U,3),EDATE,T,3)
End DoDot:1
IF X]""
QUIT 1
+11 SET X=$$LASTDXI^BUD8UTL1(P,618.5,$$DOB^AUPNPAT(P),EDATE,1)
+12 IF X
QUIT 1
+13 QUIT ""
