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

BUD2RP6D.m

Go to the documentation of this file. 
  1. BUD2RP6D ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2012 5:11 PM ;
  1.  ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1.  ;
  1.  ;
  1. PAPD ;EP - called from xbdbque
  1.  ;must have DOB between 1/1/06 and 12/31/06
  1.  Q:$P(^DPT(DFN,0),U,2)'="F"
  1.  S BUDDOB=$P(^DPT(DFN,0),U,3)
  1.  S BUD64RB=($E(BUDBD,1,3)-64)_"0101"
  1.  S BUD24RB=($E(BUDED,1,3)-24)_"1231"
  1.  S BUDDOB=$P(^DPT(DFN,0),U,3)
  1.  Q:BUDDOB<BUD64RB
  1.  Q:BUDDOB>BUD24RB
  1.  Q:BUDMEDV<1
  1.  S BUD65TH=$E(BUDDOB,1,3)+65_$E(BUDDOB,4,7)
  1.  I '$$VBBD(DFN,BUDDOB,$$FMADD^XLFDT(BUD65TH,-1)) Q  ;quit if no visiT before 65TH birthday
  1.  K BUDPAP
  1.  S BUDPD=$E(BUDBD,1,3)-2_$E(BUDBD,4,7)
  1.  S BUDPAP=$$PAP(DFN,BUDDOB,BUDED)
  1.  S BUDPAPD=$P(BUDPAP,U,2)
  1.  I BUDPAPD<BUDBD&($$HYSTER(DFN,BUDED)) Q  ;IF HAD NO PAP AT ALL OR IT IS BEFORE REPT PERIOD AND HAD HYSTER QUIT
  1.  I BUDPAPD'<BUDPD S BUDSECTD("PAP")=$G(BUDSECTD("PAP"))+1,BUDSECTD("PTS")=$G(BUDSECTD("PTS"))+1 D  Q
  1.  .I $G(BUDPAP1L) D
  1.  ..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")
  1.  ..S ^XTMP("BUD2RP6B",BUDJ,BUDH,"PAP1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=Y
  1.  ..Q
  1.  Q:$$HYSTER(DFN,BUDED)  ;if no pap and has hysterectomy don't put in denominator or numerator
  1.  ;put the rest in demoninator
  1.  S BUDSECTD("PTS")=$G(BUDSECTD("PTS"))+1 D
  1.  .I $G(BUDPAP2L) D
  1.  ..S Y="" I BUDPAP="" S Y="Never"
  1.  ..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")
  1.  ..S ^XTMP("BUD2RP6B",BUDJ,BUDH,"PAP2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=Y
  1.  Q
  1.  ;
  1.  ;
  1. VBBD(P,BDATE,EDATE) ;EP
  1.  NEW BUDVL,G
  1.  K BUDVL
  1.  S G=""
  1.  S A="BUDVL(",B=DFN_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1.  I '$D(BUDVL) Q ""
  1.  S X=0 F  S X=$O(BUDVL(X)) Q:X'=+X  S V=$P(BUDVL(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:'$D(^AUPNVPRV("AD",V))
  1.  .Q:'$D(^AUPNVPOV("AD",V))
  1.  .S L=$P(^AUPNVSIT(V,0),U,6)
  1.  .Q:L=""
  1.  .Q:'$D(^BUDRSITE(BUDSITE,11,L))  ;not valid location
  1.  .Q:$P(^AUPNVSIT(V,0),U,7)="C"
  1.  .Q:$P(^AUPNVSIT(V,0),U,7)="T"
  1.  .Q:$P(^AUPNVSIT(V,0),U,7)="N"
  1.  .Q:$P(^AUPNVSIT(V,0),U,7)="D"
  1.  .Q:$P(^AUPNVSIT(V,0),U,7)="X"
  1.  .Q:$P(^AUPNVSIT(V,0),U,7)="E"
  1.  .S G=V
  1.  .Q
  1.  Q G
  1.  ;
  1. PAP(P,BDATE,EDATE) ;EP
  1.  NEW BUDC,BUDLPAP,T,BUDLT,B,E,D,L,X,Z,J,T,BUD
  1.  K BUDC
  1.  S BUDC=""
  1.  S BUDLPAP=""
  1.  S T=$O(^ATXAX("B","BGP PAP LOINC CODES",0))
  1.  S BUDLT=$O(^ATXLAB("B","BGP PAP SMEAR TAX",0))
  1.  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
  1.  .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BUDC]"")  D
  1.  ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BUDC]"")  D
  1.  ...Q:'$D(^AUPNVLAB(X,0))
  1.  ...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
  1.  ...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
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,T)
  1.  ...S BUDC="1^"_(9999999-D)_"^Lab-loinc"_U_$P(^AUPNVLAB(X,0),U,3) Q
  1.  ...Q
  1.  S BUDLPAP=BUDC
  1.  K BUD
  1.  ;S T="BUD PAP SMEAR DXS"
  1.  ;S X=$$LASTDX^BUD2UTL1(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)
  1.  K BUD S %=P_"^LAST PROCEDURE 91.46;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BUD(")
  1.  I $D(BUD(1)),$P(BUDLPAP,U,2)<$P(BUD(1),U,1) S BUDLPAP="1^"_$P(BUD(1),U)_"^Proc:: 91.46^"_$P(BUD(1),U,5)
  1.  S T=$O(^ATXAX("B","BUD CPT PAP TABLE 6B 10",0))
  1.  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)
  1.  .S X=$$CPT^BUD2DU(P,BDATE,EDATE,T,6) I X]"" Q
  1.  .S X=$$TRAN^BUD2DU(P,BDATE,EDATE,T,6)
  1.  S T="PAP SMEAR",T=$O(^BWPN("B",T,0))
  1.  I T D  I X]"",$P(BUDLPAP,U,2)<X S BUDLPAP="1^"_X_"^WH PAP SMEAR"
  1.  .S X=$$WH^BUD2DU(P,BDATE,EDATE,T,3)
  1.  Q BUDLPAP
  1.  ;
  1. LOINC(A,B) ;
  1.  NEW %
  1.  S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1.  I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1.  S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1.  I $D(^ATXAX(B,21,"B",%)) Q 1
  1.  Q ""
  1.  ;
  1. HYSTER(P,EDATE) ;EP 
  1.  I '$G(P) Q ""
  1.  S X=$$LASTPRC^BUD2UTL1(P,"BUD HYSTERECTOMY PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
  1.  I X Q 1
  1.  S T="HYSTERECTOMY",T=$O(^BWPN("B",T,0))
  1.  I T D  I X]"" Q 1
  1.  .S X=$$WH^BUD2DU(P,$$DOB^AUPNPAT(P),EDATE,T,2)
  1.  S T=$O(^ATXAX("B","BUD HYSTERECTOMY CPTS",0))
  1.  I T D  I X]"" Q 1
  1.  .S X=$$CPT^BUD2DU(P,$P(^DPT(P,0),U,3),EDATE,T,3) I X]"" Q
  1.  .S X=$$TRAN^BUD2DU(P,$P(^DPT(P,0),U,3),EDATE,T,3)
  1.  S X=$$LASTDXI^BUD2UTL1(P,618.5,$$DOB^AUPNPAT(P),EDATE,1)
  1.  I X Q 1
  1.  Q ""