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