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

BHSEXAM.m

Go to the documentation of this file. 
  1. BHSEXAM ;IHS/CIA/MGH - Health Summary for V EXAM file ;10-Dec-2010 17:44;MGH
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**2,4**;March 17, 2006;Build 13
  1.  ;===================================================================
  1.  ;Taken from APCH3C
  1.  ; IHS/TUCSON/LAB - PART 3C OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;  [ 01/20/04  8:04 PM ]
  1.  ;;2.0;IHS RPMS/PCC Health Summary;**11,12**;JUN 24, 1997
  1.  ;IHS/MSC/MGH Patch 2 update to patch 17
  1.  ; MOST RECENT EXAMINATION OF EACH TYPE WITHIN DATE RANGE
  1.  ;
  1. MRE ; ******************** EP MOST RECENT EXAMINATION * 9000010.13 *******
  1.  N BHSPAT,BHSICD,BHSICL,BHSQ,X
  1.  S BHSPAT=DFN
  1.  ;Q:'$D(^AUPNVXAM("AA",BHSPAT))
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ; <SETUP>
  1.  ; <PROCESS>
  1.  D EBLDNEW,EPRTNEW
  1.  ;Now display refusals (patch 2)
  1.  Q:'$D(^AUPNPREF("AA",BHSPAT,9999999.15))
  1.  S BHSFN=9999999.15,BHST="EXAM"
  1.  D DISPREF
  1.  ; <CLEANUP>
  1. MREX K %,BHSET,BHSER,BHSEIEN,BHSECOD,BHSETX,BHSERT,BHSMXL,BHSRL,BHSRW,BHSNMX,BHSDFN,BHSIVD,BHSETD,BHSN,Y
  1.  Q
  1. DISPREF ;EP added in patch 2
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  S BHSRC=0
  1.  S BHSX="" F  S BHSX=$O(^AUPNPREF("AA",BHSPAT,BHSFN,BHSX)) Q:BHSX=""!($D(GMTSQIT))  D
  1.  .S BHSD=0 F  S BHSD=$O(^AUPNPREF("AA",BHSPAT,BHSFN,BHSX,BHSD)) Q:BHSD=""!(BHSD>GMTSDLM)!($D(GMTSQIT))  D
  1.  ..S BHSI=0 F  S BHSI=$O(^AUPNPREF("AA",BHSPAT,BHSFN,BHSX,BHSD,BHSI)) Q:BHSI=""!($D(GMTSQIT))  D
  1.  ...I $D(BHSS) X BHSS Q:'%
  1.  ...S BHSRC=BHSRC+1
  1.  ...I BHSRC=1 I BHST]"" W !,BHST," Refusals "
  1.  ...D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ...W !,$$VAL^XBDIQ1(9000022,BHSI,.04)," -- ",$$VAL^XBDIQ1(9000022,BHSI,.07),?60,"(",$$DATE^APCHSMU(9999999-BHSD),")"
  1.  ..Q
  1.  .Q
  1.  W !
  1.  K BHST,BHSX,BHSD,BHSS,BHSFN,BHSI,BHSRC
  1.  Q
  1.  ; <BUILD>
  1. EBLDNEW ;new exam section that looks at dx, procedures,cpts in addition to exams
  1.  K BHSERT S BHSMXL=0
  1.  S BHSEIEN=0 F  S BHSEIEN=$O(^AUTTEXAM(BHSEIEN)) Q:BHSEIEN'=+BHSEIEN  D
  1.  .S BHSECOD=$P(^AUTTEXAM(BHSEIEN,0),U,2)
  1.  .I BHSECOD="" S Y=$$VXAM(BHSPAT,(9999999-GMTSDLM),DT,BHSEIEN) D SEXAM Q  ;just V EXAM
  1.  .;now see if there is a special routine to get the last of this code
  1.  .I BHSECOD="01" S Y=$$LASTEX01(BHSPAT,(9999999-GMTSDLM),DT) D SEXAM Q
  1.  .I BHSECOD="02" S Y=$$LASTEX02(BHSPAT,(9999999-GMTSDLM),DT) D SEXAM Q
  1.  .I BHSECOD="04" S Y=$$LASTEX04(BHSPAT,(9999999-GMTSDLM),DT) D SEXAM Q
  1.  .I BHSECOD="06" S Y=$$LASTEX06(BHSPAT,(9999999-GMTSDLM),DT) D SEXAM Q
  1.  .I BHSECOD="07" S Y=$$LASTEX07(BHSPAT,(9999999-GMTSDLM),DT) D SEXAM Q
  1.  .I BHSECOD="08" S Y=$$LASTEX08(BHSPAT,(9999999-GMTSDLM),DT) D SEXAM Q
  1.  .I BHSECOD="11" S Y=$$LASTEX11(BHSPAT,(9999999-GMTSDLM),DT) D SEXAM Q
  1.  .I BHSECOD="12" S Y=$$LASTEX12(BHSPAT,(9999999-GMTSDLM),DT) D SEXAM Q
  1.  .I BHSECOD="14" S Y=$$LASTEX14(BHSPAT,(9999999-GMTSDLM),DT) D SEXAM Q
  1.  .I BHSECOD="15" S Y=$$LASTEX15(BHSPAT,(9999999-GMTSDLM),DT) D SEXAM Q
  1.  .I BHSECOD="16" S Y=$$LASTEX16(BHSPAT,(9999999-GMTSDLM),DT) D SEXAM Q
  1.  .I BHSECOD="17" S Y=$$LASTEX17(BHSPAT,(9999999-GMTSDLM),DT) D SEXAM Q
  1.  .I BHSECOD="19" S Y=$$LASTEX19(BHSPAT,(9999999-GMTSDLM),DT) D SEXAM Q
  1.  .I BHSECOD="21" S Y=$$LASTEX21(BHSPAT,(9999999-GMTSDLM),DT) D SEXAM Q
  1.  .I BHSECOD="23" S Y=$$LASTEX23(BHSPAT,(9999999-GMTSDLM),DT) D SEXAM Q
  1.  .S Y=$$VXAM(BHSPAT,(9999999-GMTSDLM),DT,BHSEIEN) D SEXAM
  1.  .Q
  1.  Q
  1. EPRTNEW ;<PRINT>
  1.  N BHSEXT,BHSER,BHS,BHSN,BHSD,BHSHP
  1.  W "Exam",?32,"Date",?45,"Result",?65,"Provider",!
  1.  S BHSEXT=0 F  S BHSEXT=$O(BHSERT(BHSEXT)) Q:BHSEXT=""!($D(GMTSQIT))  D
  1.  .S BHSN=$S($P($G(^AUTTEXAM(BHSEXT,0)),U,2)=34:"DOMESTIC VIOLENCE SCREENING",1:$E($P($G(^AUTTEXAM(BHSEXT,0)),U),1,28))
  1.  .I $P(BHSERT(BHSEXT),U,2)'["Exam" S BHSN=$E(BHSN,1,22)_"["_$P(BHSERT(BHSEXT),U,2)_"]"
  1.  .S X=$P(BHSERT(BHSEXT),U,1) D REGDT4^GMTSU S BHSD=X
  1.  .S BHSER=$P(BHSERT(BHSEXT),U,3)
  1.  .S BHSHP=$E($P(BHSERT(BHSEXT),U,4),1,15)
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W $E(BHSN,1,30),?32,BHSD,?45,$E(BHSER,1,15),?65,BHSHP,!
  1.  .Q
  1.  Q
  1. VXAM(P,BD,ED,E) ;
  1.  S ED=$G(ED)
  1.  NEW D,I
  1.  S D=$O(^AUPNVXAM("AA",P,E,0))
  1.  I D="" Q ""
  1.  I (9999999-D)<BD Q ""  ;before date limits
  1.  S I=$O(^AUPNVXAM("AA",P,E,D,0))
  1.  Q (9999999-D)_"^"_"Exam code "_$P(^AUTTEXAM(E,0),U,2)_"^"_$$VAL^XBDIQ1(9000010.13,I,.04)_"^"_$$VAL^XBDIQ1(9000010.13,I,1204)_"^"_$$VAL^XBDIQ1(9000010.13,I,81101)
  1. SEXAM ;
  1.  I Y="" Q
  1.  S BHSERT(BHSEIEN)=Y
  1.  Q
  1.  ;
  1. LASTEX01(P,BD,ED) ;
  1.  NEW LBE,D
  1.  K LBE
  1.  S ED=$G(ED)
  1.  S D=$$LASTEXAM(P,"01",BD,ED)
  1.  I D]"" S LBE(9999999-$P(D,U,1))="Exam code 01^"_$P(D,U,2,99)
  1.  S D=$$LASTDXI^APCHSMU2(P,"V70.0",BD,DT)
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V70.0"
  1.  S D=$$LASTDXI^APCHSMU2(P,"V70.3")
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V70.3"
  1.  S D=$$LASTDXI^APCHSMU2(P,"V70.9")
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V70.9"
  1.  S D=$$CPT^APCHSMU2(P,BD,DT,$O(^ATXAX("B","APCH GENERAL EXAM CPTS",0)),5)
  1.  I D S LBE(9999999-$P(D,U,1))="CPT: "_$P(D,U,2)
  1.  I '$D(LBE) Q ""
  1.  S D=$O(LBE(0))
  1.  Q (9999999-D)_"^"_LBE(D)
  1.  ;
  1. LASTEX02(P,BD,ED) ;
  1.  NEW LBE,D
  1.  K LBE
  1.  S ED=$G(ED)
  1.  S D=$$LASTEXAM(P,"02",BD,ED)
  1.  I D]"" S LBE(9999999-$P(D,U,1))="Exam code 02^"_$P(D,U,2,99)
  1.  S D=$$LASTDXI^APCHSMU2(P,"V72.1",BD,DT)
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V72.1"
  1.  S D=$$LASTDXI^APCHSMU2(P,"V72.19")
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V72.19"
  1.  S D=$$LASTDXI^APCHSMU2(P,"V80.3")
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V80.3"
  1.  S D=$$LASTPRCI^APCHSMU2(P,"18.11")
  1.  I D S LBE(9999999-$P(D,U,3))="ICD: 18.11"
  1.  S D=$$LASTCPTI^APCHSMU2(P,92700)
  1.  I D S LBE(9999999-$P(D,U,3))="CPT: 92700"
  1.  I '$D(LBE) Q ""
  1.  S D=$O(LBE(0))
  1.  Q (9999999-D)_"^"_LBE(D)
  1.  ;
  1. LASTEX04(P,BD,ED) ;
  1.  NEW LBE,D
  1.  K LBE
  1.  S ED=$G(ED)
  1.  S D=$$LASTEXAM(P,"04",BD,ED)
  1.  I D]"" S LBE(9999999-$P(D,U,1))="Exam code 04^"_$P(D,U,2,99)
  1.  S D=$$LASTDXI^APCHSMU2(P,"V76.42",BD,DT)
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V76.42"
  1.  S D=$$LASTPRCI^APCHSMU2(P,"89.31")
  1.  I D S LBE(9999999-$P(D,U,3))="ICD: 89.31"
  1.  I '$D(LBE) Q ""
  1.  S D=$O(LBE(0))
  1.  Q (9999999-D)_"^"_LBE(D)
  1.  ;
  1. LASTEX06(P,BD,ED) ;
  1.  NEW Y
  1.  S Y=$$LASTBRST^APCLAPI3(P)
  1.  I $P(Y,U)<BD S Y=""
  1.  Q Y
  1.  ;
  1. LASTEX07(P,BD,ED) ;
  1.  NEW LBE,D
  1.  K LBE
  1.  S ED=$G(ED)
  1.  S D=$$LASTEXAM(P,"07",BD,ED)
  1.  I D]"" S LBE(9999999-$P(D,U,1))="Exam code 07^"_$P(D,U,2,99)
  1.  S D=$$LASTDXI^APCHSMU2(P,"V72.82",BD,DT)
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V72.82"
  1.  I '$D(LBE) Q ""
  1.  S D=$O(LBE(0))
  1.  Q (9999999-D)_"^"_LBE(D)
  1.  ;
  1. LASTEX08(P,BD,ED) ;
  1.  NEW LBE,D
  1.  K LBE
  1.  S ED=$G(ED)
  1.  S D=$$LASTEXAM(P,"08",BD,ED)
  1.  I D]"" S LBE(9999999-$P(D,U,1))="Exam code 08^"_$P(D,U,2,99)
  1.  S D=$$LASTDXI^APCHSMU2(P,"V72.81",BD,DT)
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V72.81"
  1.  S D=$$LASTDXI^APCHSMU2(P,"V81.0")
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V81.0"
  1.  S D=$$LASTDXI^APCHSMU2(P,"V81.2")
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V81.2"
  1.  S D=$$LASTCPTI^APCHSMU2(P,"G0367")
  1.  I D S LBE(9999999-$P(D,U,3))="CPT: G0367"
  1.  I '$D(LBE) Q ""
  1.  S D=$O(LBE(0))
  1.  Q (9999999-D)_"^"_LBE(D)
  1.  ;
  1. LASTEX11(P,BD,ED) ;
  1.  NEW LBE,D
  1.  K LBE
  1.  S ED=$G(ED)
  1.  S D=$$LASTEXAM(P,"11",BD,ED)
  1.  I D]"" S LBE(9999999-$P(D,U,1))="Exam code 11^"_$P(D,U,2,99)
  1.  S D=$$LASTDXI^APCHSMU2(P,"V80.0",BD,DT)
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V80.0"
  1.  S D=$$LASTPRCI^APCHSMU2(P,"89.13")
  1.  I D S LBE(9999999-$P(D,U,3))="ICD: 89.13"
  1.  I '$D(LBE) Q ""
  1.  S D=$O(LBE(0))
  1.  Q (9999999-D)_"^"_LBE(D)
  1. LASTEX12(P,BD,ED) ;
  1.  NEW LBE,D
  1.  K LBE
  1.  S ED=$G(ED)
  1.  S D=$$LASTEXAM(P,"12",BD,ED)
  1.  I D]"" S LBE(9999999-$P(D,U,1))="Exam code 12^"_$P(D,U,2,99)
  1.  S D=$$LASTPRCI^APCHSMU2(P,"89,39")
  1.  I D S LBE(9999999-$P(D,U,3))="ICD: 89.39"
  1.  S D=$$LASTCPTI^APCHSMU2(P,95851)
  1.  I D S LBE(9999999-$P(D,U,3))="CPT: 95851"
  1.  I '$D(LBE) Q ""
  1.  S D=$O(LBE(0))
  1.  Q (9999999-D)_"^"_LBE(D)
  1. LASTEX14(P,BD,ED) ;
  1.  NEW Y
  1.  S Y=$$LASTRECT^APCLAPI2(P)
  1.  I $P(Y,U)<BD S Y=""
  1.  Q Y
  1.  ;
  1. LASTEX15(P,BD,ED) ;
  1.  NEW Y
  1.  S Y=$$LASTPELV^APCLAPI2(P)
  1.  I $P(Y,U)<BD S Y=""
  1.  Q Y
  1.  ;
  1. LASTEX16(P,BD,ED) ;
  1.  NEW LBE,D
  1.  K LBE
  1.  S ED=$G(ED)
  1.  S D=$$LASTEXAM(P,16,BD,ED)
  1.  I D]"" S LBE(9999999-$P(D,U,1))="Exam code 16^"_$P(D,U,2,99)
  1.  S D=$$LASTDXI^APCHSMU2(P,"V20.2",BD,DT)
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V20.2"
  1.  S D=$$LASTDXI^APCHSMU2(P,"V79.3",BD,DT)
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V79.3"
  1.  I '$D(LBE) Q ""
  1.  S D=$O(LBE(0))
  1.  Q (9999999-D)_"^"_LBE(D)
  1.  ;
  1. LASTEX17(P,BD,ED) ;
  1.  NEW LBE,D
  1.  K LBE
  1.  S ED=$G(ED)
  1.  S D=$$LASTEXAM(P,17,BD,ED)
  1.  I D]"" S LBE(9999999-$P(D,U,1))="Exam code 17^"_$P(D,U,2,99)
  1.  S D=$$LASTDXI^APCHSMU2(P,"V72.11",BD,DT)
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V72.11"
  1.  S D=$$LASTDXI^APCHSMU2(P,"V72.19",BD,DT)
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V72.19"
  1.  I '$D(LBE) Q ""
  1.  S D=$O(LBE(0))
  1.  Q (9999999-D)_"^"_LBE(D)
  1.  ;
  1. LASTEX19(P,BD,ED) ;
  1.  NEW LBE,D
  1.  K LBE
  1.  S ED=$G(ED)
  1.  S D=$$LASTEXAM(P,19,BD,ED)
  1.  I D]"" S LBE(9999999-$P(D,U,1))="Exam code 19^"_$P(D,U,2,99)
  1.  S D=$$LASTDXI^APCHSMU2(P,"V72.0",BD,DT)
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V72.0"
  1.  S D=$$LASTPRCI^APCHSMU2(P,"95.09")
  1.  I D S LBE(9999999-$P(D,U,3))="ICD: 95.09"
  1.  S D=$$LASTPRCI^APCHSMU2(P,"95.05")
  1.  I D S LBE(9999999-$P(D,U,3))="ICD: 95.05"
  1.  S D=$$LASTCPTI^APCHSMU2(P,99172)
  1.  I D S LBE(9999999-$P(D,U,3))="CPT: 99172"
  1.  S D=$$LASTCPTI^APCHSMU2(P,99173)
  1.  I D S LBE(9999999-$P(D,U,3))="CPT: 99173"
  1.  I '$D(LBE) Q ""
  1.  S D=$O(LBE(0))
  1.  Q (9999999-D)_"^"_LBE(D)
  1. LASTEX21(P,BD,ED) ;
  1.  NEW LBE,D
  1.  K LBE
  1.  S ED=$G(ED)
  1.  S D=$$LASTEXAM(P,21,BD,ED)
  1.  I D]"" S LBE(9999999-$P(D,U,1))="Exam code 21^"_$P(D,U,2,99)
  1.  S D=$$LASTDXI^APCHSMU2(P,"V72.1",BD,DT)
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V72.1"
  1.  S D=$$LASTDXI^APCHSMU2(P,"V72.19")
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V72.19"
  1.  S D=$$LASTDXI^APCHSMU2(P,"V80.3")
  1.  I D S LBE(9999999-$P(D,U,3))="Dx: V80.3"
  1.  S D=$$LASTPRCI^APCHSMU2(P,"18.11")
  1.  I D S LBE(9999999-$P(D,U,3))="ICD: 18.11"
  1.  S D=$$LASTCPTI^APCHSMU2(P,92700)
  1.  I D S LBE(9999999-$P(D,U,3))="CPT: 92700"
  1.  I '$D(LBE) Q ""
  1.  S D=$O(LBE(0))
  1.  Q (9999999-D)_"^"_LBE(D)
  1. LASTEX23(P,BD,ED) ;
  1.  NEW LBE,D
  1.  K LBE
  1.  S ED=$G(ED)
  1.  S D=$$LASTEXAM(P,23,BD,ED)
  1.  I D]"" S LBE(9999999-$P(D,U,1))="Exam code 23^"_$P(D,U,2,99)
  1.  S D=$$LASTCPTI^APCHSMU2(P,92551)
  1.  I D S LBE(9999999-$P(D,U,3))="CPT: 92551"
  1.  I '$D(LBE) Q ""
  1.  S D=$O(LBE(0))
  1.  Q (9999999-D)_"^"_LBE(D)
  1.  ;
  1. LASTEXAM(P,C,B,E) ;
  1.  I '$G(P) Q ""
  1.  I $G(C)="" Q ""
  1.  S B=$G(B)
  1.  S E=$G(E)
  1.  NEW D,I
  1.  S C=$O(^AUTTEXAM("C",C,0))
  1.  I C="" Q ""
  1.  S D=$O(^AUPNVXAM("AA",P,C,0))
  1.  I D="" Q ""
  1.  I (9999999-D)<B Q ""  ;before date limits
  1.  S I=$O(^AUPNVXAM("AA",P,C,D,0))
  1.  Q (9999999-D)_"^"_$$VAL^XBDIQ1(9000010.13,I,.04)_"^"_$$VAL^XBDIQ1(9000010.13,I,1204)_"^"_$$VAL^XBDIQ1(9000010.13,I,81101)