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

BUDBRP6N.m

Go to the documentation of this file. 
  1. BUDBRP6N ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
  1.  ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
  1.  ;
  1. K ;EP ;CRC
  1.  S BUDDOB=$P(^DPT(DFN,0),U,3)
  1.  S BUD50RB=($E(BUDBD,1,3)-51)_"1231"
  1.  S BUD75RB=($E(BUDBD,1,3)-74)_"0101"
  1.  Q:BUDDOB<BUD75RB
  1.  Q:BUDDOB>BUD50RB
  1.  Q:BUDMEDV<1
  1.  Q:$$CRC(DFN,BUDED)  ;has crc dx
  1.  S BUDCRCT=$$SCREEN(DFN,,$$VD^APCLV(BUDLASTV))
  1.  I BUDCRCT]"" S BUDSECTK("CRC")=$G(BUDSECTK("CRC"))+1
  1.  ;put the rest in demoninator
  1.  S BUDCRCL=""
  1.  S BUDSECTK("PTS")=$G(BUDSECTK("PTS"))+1 D
  1.  .I $G(BUDCRC2L) D
  1.  ..I BUDCRCT="" D LAST S ^XTMP("BUDBRP6B",BUDJ,BUDH,"CRC2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDCRCL,U)  ;_U_$P(BUDCRCT,U,2)
  1.  .I $G(BUDCRC1L) D
  1.  ..I BUDCRCT]"" S ^XTMP("BUDBRP6B",BUDJ,BUDH,"CRC1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDCRCT,U)  ;_U_$P(BUDCRCT,U,2)
  1.  Q
  1. LAST ;
  1.  NEW LAST,COLO,SIG,FOBT
  1.  S BUDCRCL=""
  1.  S COLO=$$COLO(DFN,$$DOB^AUPNPAT(DFN),BUDED)  ;get last one ever
  1.  S BUDCRCL=COLO
  1.  S SIG=$$SIG(DFN,$$DOB^AUPNPAT(DFN),BUDED)  ;get last sig
  1.  I $P(SIG,U,2)>$P(BUDCRCL,U,2) S BUDCRCL=SIG
  1.  S FOBT=$$FOB(DFN,$$DOB^AUPNPAT(DFN),BUDED)
  1.  I $P(FOBT,U,2)>$P(BUDCRCL,U,2) S BUDCRCL=FOBT
  1.  Q
  1. SCREEN(P,BDATE,EDATE) ;
  1.  NEW BUDCOLO,BUDSIG,BUDFOB
  1.  S BUDCOLO=$$COLO(DFN,,EDATE)
  1.  I BUDCOLO]"" Q BUDCOLO
  1.  S BUDSIG=$$SIG(DFN,,EDATE)
  1.  I BUDSIG]"" Q BUDSIG
  1.  S BUDFOB=$$FOB(P,,EDATE)
  1.  I BUDFOB]"" Q BUDFOB
  1.  Q ""
  1. CRC(P,EDATE) ;EP
  1.  NEW BUDG,X,E,Y,T
  1.  K BUDG
  1.  S Y="BUDG("
  1.  S X=P_"^LAST DX [BUD COLORECTAL CANCER DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BUDG(1)) Q 1  ;has a dx
  1.  S T=$O(^ATXAX("B","BUD COLORECTAL CANCER CPTS",0))
  1.  I T D  I X]"" Q 1
  1.  .S X=$$CPT^BUDBDU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BUDBDU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
  1.  S BUDG=$$LASTPRC^BUDBUTL1(P,"BUD COLORECTAL CANCER PROCS",$$DOB^AUPNPAT(P),EDATE)
  1.  I BUDG Q 1
  1.  S X=$$PLTAX^BUDBDU(P,"BUD COLORECTAL CANCER DXS")
  1.  I X Q 1
  1.  ;S T=$O(^ATXAX("B","BUD COLORECTAL CANCER PROCS",0))
  1.  ;I T D  I X]"" Q 1
  1.  ;.S X=$$CPT^BUDBDU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
  1.  ;.S X=$$TRAN^BUDBDU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
  1.  Q 0
  1. SIG(P,BDATE,EDATE) ;EP
  1.  NEW BUDLSIG
  1.  S BUDLSIG=""
  1.  I $G(BDATE)="" S BDATE=$E(EDATE,1,3)-6_$E(EDATE,4,7) ;$$FMADD^XLFDT(EDATE,6*(-365))
  1.  S BUDG=$$LASTPRC^BUDBUTL1(P,"BGP SIG PROCS",BDATE,EDATE)
  1.  I $P(BUDG,U)=1 S BUDLSIG="SIG: Proc "_$P(BUDG,U,2)_":"_$$DATE^BUDBDU($P(BUDG,U,3))_U_$P(BUDG,U,3)
  1.  ;
  1.  S T=$O(^ATXAX("B","BUD SIG CPTS",0))
  1.  I T D  I X]"",$P(BUDLSIG,U,3)<$P(X,U,1) S BUDLSIG="SIG: CPT "_$P(X,U,2)_":"_$$DATE^BUDBDU($P(X,U,1))_U_$P(X,U,1)
  1.  .S X=$$CPT^BUDBDU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BUDBDU(P,BDATE,EDATE,T,5)
  1.  Q BUDLSIG
  1. COLO(P,BDATE,EDATE) ;EP
  1.  K BUDG
  1.  S BUDLCOLO=""
  1.  I $G(BDATE)="" S BDATE=$E(EDATE,1,3)-10_$E(EDATE,4,7) ;$$FMADD^XLFDT(EDATE,10*(-365))
  1.  S BUDG=$$LASTPRC^BUDBUTL1(P,"BGP COLO PROCS",BDATE,EDATE)
  1.  I $P(BUDG,U)=1 S BUDLCOLO="COLO: Proc "_$P(BUDG,U,2)_":"_$$DATE^BUDBDU($P(BUDG,U,3))_U_$P(BUDG,U,3)
  1.  K BUDG
  1.  S %=P_"^LAST DIAGNOSIS [BGP COLO DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BUDG(")
  1.  I $D(BUDG(1)),$P(BUDLCOLO,U,3)<$P(BUDG(1),U,1) S BUDLCOLO="COLO: DX V76.51"_":"_$$DATE^BUDBDU($P(BUDG(1),U))
  1.  S T=$O(^ATXAX("B","BUD COLO CPTS",0))
  1.  I T D  I X]"",$P(BUDLCOLO,U,3)<$P(X,U,1) S BUDLCOLO="COLO: CPT "_$P(X,U,2)_":"_$$DATE^BUDBDU($P(X,U,1))_U_$P(X,U,1)
  1.  .S X=$$CPT^BUDBDU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  .S X=$$TRAN^BUDBDU(P,BDATE,EDATE,T,5)
  1.  Q BUDLCOLO
  1. FOB(P,BDATE,EDATE) ;EP
  1.  I $G(BDATE)="" S BDATE=$E(EDATE,1,3)-2_$E(EDATE,4,7) ;$$FMADD^XLFDT(EDATE,2*(-365))
  1.  S BUDC="",BUDLFOB=""
  1.  S T=$O(^ATXAX("B","BGP FOBT LOINC CODES",0))
  1.  S BUDLT=$O(^ATXLAB("B","BGP GPRA FOB TESTS",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.  ...I BUDLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BUDLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BUDC="FOB: Lab "_$$VAL^XBDIQ1(9000010.09,X,.01)_":"_$$DATE^BUDBDU(9999999-D)_U_(9999999-D) Q
  1.  ...Q:'T
  1.  ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,T)
  1.  ...S BUDC="FOB: LAB LOINC "_$$VAL^XBDIQ1(9000010.09,X,.01)_":"_$$DATE^BUDBDU(9999999-D)_U_(9999999-D) Q
  1.  ...Q
  1.  S BUDLFOB=BUDC
  1.  S T=$O(^ATXAX("B","BUD FOBT CPTS",0))
  1.  I T D  I X]"",$P(BUDLFOB,U,2)<$P(X,U,1) S BUDLFOB="FOB: CPT "_$P(X,"^",2)_":"_$$DATE^BUDBDU($P(X,U,1))_"^"_$P(X,U,1)
  1.  .S X=$$CPT^BUDBDU(P,BDATE,EDATE,T,5) I X]"" Q
  1.  Q BUDLFOB
  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 ""