BSDX41K ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
MRR ; ******************** MOST RECENT RADIOLOGY * 9000010.22 *******
Q:'$D(^AUPNVRAD("AA",APCHSPAT))
;X APCHSCKP Q:$D(APCHSQIT)
;X:'APCHSNPG APCHSBRK
; <SETUP>
; <PROCESS>
D RBLD,RPRT
; <CLEANUP>
;now display RAD refusals
S APCHST="RADIOLOGY EXAM",APCHSFN=71 D DISPREF^BSDX41F
K APCHST,APCHSFN
MRRX K APCHSRT,APCHSRR,APCHSRTX,APCHSRRT,APCHSMXL,APCHSRL,APCHSRW,APCHSNMX,APCHSDFN,APCHSIVD,APCHSRTD,APCHSN,APCHSDCD,APCHSEDT,Y
Q
; <BUILD>
RBLD K APCHSRRT S APCHSMXL=0
S APCHSRRT="" F APCHSQ=0:0 S APCHSRRT=$O(^AUPNVRAD("AA",APCHSPAT,APCHSRRT)) Q:APCHSRRT="" D RDATE
Q
RDATE S APCHSIVD=$O(^AUPNVRAD("AA",APCHSPAT,APCHSRRT,0)) S APCHSDFN=$O(^(APCHSIVD,0)) D:APCHSIVD&(APCHSIVD'>APCHSDLM) RSET
Q
RSET S APCHSN=^AUPNVRAD(APCHSDFN,0),APCHSRR=$G(^AUPNVRAD(APCHSDFN,11))
;I APCHSRR]"",$P(APCHSN,U,5)=1 S APCHSRR=APCHSRR_" (ABNORMAL)"
;I APCHSRR="",$P(APCHSN,U,5)=1 S APCHSRR="(ABNORMAL)"
S APCHSEDT=$P($G(^AUPNVRAD(APCHSDFN,12)),U) ;NEW LINE!
S X=$P(APCHSN,U,5),X=$$EXTSET^XBFUNC(9000010.22,.05,X) S APCHSDCD=X
;S APCHSRRT(APCHSRRT)=(-APCHSIVD\1+9999999)_U_APCHSRR S APCHSRTX=$P(^RAMIS(71,APCHSRRT,0),U,1) S:$L(APCHSRTX)>APCHSMXL APCHSMXL=$L(APCHSRTX) ;ORIG LINE
S APCHSRRT(APCHSRRT)=(-APCHSIVD\1+9999999)_U_APCHSRR_U_APCHSEDT_U_APCHSDCD_U_$$VAL^XBDIQ1(9000010.22,APCHSDFN,.06)
S APCHSRTX=$P(^RAMIS(71,APCHSRRT,0),U,1) S:$L(APCHSRTX)>APCHSMXL APCHSMXL=$L(APCHSRTX)
Q
; <PRINT>
RPRT S APCHSRW=APCHSMXL+1,APCHSRL=10,APCHSNMX=(IOM-1-APCHSRW)\APCHSRL
S APCHSRT="" F APCHSQ=0:0 S APCHSRT=$O(APCHSRRT(APCHSRT)) Q:APCHSRT="" D RPRT2
Q
RPRT2 ;
S Y=$P(APCHSRRT(APCHSRT),U,1),APCHSRR=$P(APCHSRRT(APCHSRT),U,2) X APCHSCVD S APCHSRTD=Y
S APCHSEDT=$P($G(APCHSRRT(APCHSRT)),U,3) I APCHSEDT]"" S Y=$P(APCHSEDT,".") X APCHSCVD S APCHSEDT=Y
;S APCHSRTX=$P(^RAMIS(71,APCHSRT,0),U,1) X APCHSCKP Q:$D(APCHSQIT) W APCHSRTX,?APCHSRW,"(",APCHSRTD,") ",APCHSRR,!
S APCHSRTX=$P(^RAMIS(71,APCHSRT,0),U,1)
;X APCHSCKP Q:$D(APCHSQIT)
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
S BSDXTMP=APCHSRTX_$$FILL^BSDX41(APCHSRW-$L(APCHSRTX))_"("_$S(APCHSEDT]"":APCHSEDT,1:APCHSRTD)_") "
I $P(APCHSRRT(APCHSRT),U,4)]"" S BSDXTMP=BSDXTMP_"RESULT: " S APCHSDCD=$P(APCHSRRT(APCHSRT),U,4) S BSDXTMP=BSDXTMP_$S(APCHSDCD]"":APCHSDCD,1:"<none recorded>")
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
I $P(APCHSRRT(APCHSRT),U,5)]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=" "_"Diagnostic Code: "_$P(APCHSRRT(APCHSRT),U,5)_$C(30)
S BSDXTMP=" "_"IMPRESSION: " S APCHSICL=16,APCHSNRQ=APCHSRR,APCHSTXT="",APCHSICD="" D PRTTXT^BSDX41F
K APCHSTXT,APCHSNRQ
Q
;
; MOST RECENT EXAMINATION OF EACH TYPE WITHIN DATE RANGE
;
MRE ; ******************** MOST RECENT EXAMINATION * 9000010.13 *******
;I '$D(^AUPNVXAM("AA",APCHSPAT)),'$D(^AUPNPREF("AA",APCHSPAT,9999999.15)) Q
;X APCHSCKP Q:$D(APCHSQIT)
;X:'APCHSNPG APCHSBRK
; <SETUP>
; <PROCESS>
;D EBLD,EPRT
D EBLDNEW,EPRTNEW
; <CLEANUP>
;NOW DISPLAY EXAM REFUSALS
Q:'$D(^AUPNPREF("AA",APCHSPAT,9999999.15))
;X APCHSCKP Q:$D(APCHSQIT)
S APCHSFN=9999999.15,APCHST="EXAM"
D DISPREF
MREX K APCHSET,APCHSER,APCHSETX,APCHSERT,APCHSMXL,APCHSRL,APCHSRW,APCHSNMX,APCHSDFN,APCHSIVD,APCHSETD,APCHSN,Y
K APCHEIEN,APCHP,APCHSD
Q
DISPREF ;EP
;X APCHSCKP Q:$D(APCHSQIT)
S APCHSRC=0
S APCHSX="" F S APCHSX=$O(^AUPNPREF("AA",APCHSPAT,APCHSFN,APCHSX)) Q:APCHSX=""!($D(APCHSQIT)) D
.S APCHSD=0 F S APCHSD=$O(^AUPNPREF("AA",APCHSPAT,APCHSFN,APCHSX,APCHSD)) Q:APCHSD=""!(APCHSD>APCHSDLM)!($D(APCHSQIT)) D
..S APCHSI=0 F S APCHSI=$O(^AUPNPREF("AA",APCHSPAT,APCHSFN,APCHSX,APCHSD,APCHSI)) Q:APCHSI=""!($D(APCHSQIT)) D
...I $D(APCHSS) X APCHSS Q:'%
...S APCHSRC=APCHSRC+1
...I APCHSRC=1 I APCHST]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30) S BSDXTMP=APCHST_" Refusals "_$C(30)
...;X APCHSCKP Q:$D(APCHSQIT)
...S BSDXTMP=$$VAL^XBDIQ1(9000022,APCHSI,.04)_" -- "_$$VAL^XBDIQ1(9000022,APCHSI,.07)
...S BSDXTMP=BSDXTMP_$$FILL^BSDX41(59-$L(BSDXTMP))_"("_$$DATE^APCHSMU(9999999-APCHSD)_")"
..Q
.Q
S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
K APCHST,APCHSX,APCHSD,APCHSS,APCHSFN,APCHSI
Q
; <BUILD>
;
EBLDNEW ;new exam section that looks at dx, procedures, cpts in addition to exam
K APCHSERT
S APCHEIEN=0 F S APCHEIEN=$O(^AUTTEXAM(APCHEIEN)) Q:APCHEIEN'=+APCHEIEN D
.S APCHECOD=$P(^AUTTEXAM(APCHEIEN,0),U,2)
.I APCHECOD="" S Y=$$VXAM(APCHSPAT,(9999999-APCHSDLM),DT,APCHEIEN) D SEXAM Q ;just V EXAM
.;now see if there is a special routine to get the last of this code
.I APCHECOD="01" S Y=$$LASTEX01(APCHSPAT,(9999999-APCHSDLM),DT) D SEXAM Q
.I APCHECOD="02" S Y=$$LASTEX02(APCHSPAT,(9999999-APCHSDLM),DT) D SEXAM Q
.I APCHECOD="04" S Y=$$LASTEX04(APCHSPAT,(9999999-APCHSDLM),DT) D SEXAM Q
.I APCHECOD="06" S Y=$$LASTEX06(APCHSPAT,(9999999-APCHSDLM),DT) D SEXAM Q
.I APCHECOD="07" S Y=$$LASTEX07(APCHSPAT,(9999999-APCHSDLM),DT) D SEXAM Q
.I APCHECOD="08" S Y=$$LASTEX08(APCHSPAT,(9999999-APCHSDLM),DT) D SEXAM Q
.I APCHECOD="11" S Y=$$LASTEX11(APCHSPAT,(9999999-APCHSDLM),DT) D SEXAM Q
.I APCHECOD="12" S Y=$$LASTEX12(APCHSPAT,(9999999-APCHSDLM),DT) D SEXAM Q
.I APCHECOD="14" S Y=$$LASTEX14(APCHSPAT,(9999999-APCHSDLM),DT) D SEXAM Q
.I APCHECOD="15" S Y=$$LASTEX15(APCHSPAT,(9999999-APCHSDLM),DT) D SEXAM Q
.I APCHECOD="16" S Y=$$LASTEX16(APCHSPAT,(9999999-APCHSDLM),DT) D SEXAM Q
.I APCHECOD="17" S Y=$$LASTEX17(APCHSPAT,(9999999-APCHSDLM),DT) D SEXAM Q
.I APCHECOD="19" S Y=$$LASTEX19(APCHSPAT,(9999999-APCHSDLM),DT) D SEXAM Q
.I APCHECOD="21" S Y=$$LASTEX21(APCHSPAT,(9999999-APCHSDLM),DT) D SEXAM Q
.I APCHECOD="23" S Y=$$LASTEX23(APCHSPAT,(9999999-APCHSDLM),DT) D SEXAM Q
.S Y=$$VXAM(APCHSPAT,(9999999-APCHSDLM),DT,APCHEIEN) D SEXAM
.Q
Q
;
EPRTNEW ;
S APCHEXT=0 F S APCHEXT=$O(APCHSERT(APCHEXT)) Q:APCHEXT=""!($D(APCHSQIT)) D
.S APCHSN=$S($P($G(^AUTTEXAM(APCHEXT,0)),U,2)=34:"DOMESTIC VIOLENCE SCREENING",1:$E($P($G(^AUTTEXAM(APCHEXT,0)),U),1,28))
.I $P(APCHSERT(APCHEXT),U,2)'["Exam" S APCHSN=$E(APCHSN,1,22)_" ["_$P(APCHSERT(APCHEXT),U,2)_"]"
.S Y=$P(APCHSERT(APCHEXT),U,1) X APCHSCVD S APCHSD=Y
.S APCHSER=$P(APCHSERT(APCHEXT),U,3)
.S APCHP=$E($P(APCHSERT(APCHEXT),U,4),1,15)
.;X APCHSCKP
.;Q:$D(APCHSQIT)
.S BSDXTMP=APCHSN_$$FILL^BSDX41(36-$L(APCHSN))_APCHSD
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(46-$L(BSDXTMP))_APCHSER
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(64-$L(BSDXTMP))_APCHP
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
.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 APCHSERT(APCHEIEN)=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)
;
RAD ; ******************* RAD TESTS - ALL * 9000010.12 *******
G RAD^BSDX41P
BSDX41K ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
+1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
MRR ; ******************** MOST RECENT RADIOLOGY * 9000010.22 *******
+1 IF '$DATA(^AUPNVRAD("AA",APCHSPAT))
QUIT
+2 ;X APCHSCKP Q:$D(APCHSQIT)
+3 ;X:'APCHSNPG APCHSBRK
+4 ; <SETUP>
+5 ; <PROCESS>
+6 DO RBLD
DO RPRT
+7 ; <CLEANUP>
+8 ;now display RAD refusals
+9 SET APCHST="RADIOLOGY EXAM"
SET APCHSFN=71
DO DISPREF^BSDX41F
+10 KILL APCHST,APCHSFN
MRRX KILL APCHSRT,APCHSRR,APCHSRTX,APCHSRRT,APCHSMXL,APCHSRL,APCHSRW,APCHSNMX,APCHSDFN,APCHSIVD,APCHSRTD,APCHSN,APCHSDCD,APCHSEDT,Y
+1 QUIT
+2 ; <BUILD>
RBLD KILL APCHSRRT
SET APCHSMXL=0
+1 SET APCHSRRT=""
FOR APCHSQ=0:0
SET APCHSRRT=$ORDER(^AUPNVRAD("AA",APCHSPAT,APCHSRRT))
IF APCHSRRT=""
QUIT
DO RDATE
+2 QUIT
RDATE SET APCHSIVD=$ORDER(^AUPNVRAD("AA",APCHSPAT,APCHSRRT,0))
SET APCHSDFN=$ORDER(^(APCHSIVD,0))
IF APCHSIVD&(APCHSIVD'>APCHSDLM)
DO RSET
+1 QUIT
RSET SET APCHSN=^AUPNVRAD(APCHSDFN,0)
SET APCHSRR=$GET(^AUPNVRAD(APCHSDFN,11))
+1 ;I APCHSRR]"",$P(APCHSN,U,5)=1 S APCHSRR=APCHSRR_" (ABNORMAL)"
+2 ;I APCHSRR="",$P(APCHSN,U,5)=1 S APCHSRR="(ABNORMAL)"
+3 ;NEW LINE!
SET APCHSEDT=$PIECE($GET(^AUPNVRAD(APCHSDFN,12)),U)
+4 SET X=$PIECE(APCHSN,U,5)
SET X=$$EXTSET^XBFUNC(9000010.22,.05,X)
SET APCHSDCD=X
+5 ;S APCHSRRT(APCHSRRT)=(-APCHSIVD\1+9999999)_U_APCHSRR S APCHSRTX=$P(^RAMIS(71,APCHSRRT,0),U,1) S:$L(APCHSRTX)>APCHSMXL APCHSMXL=$L(APCHSRTX) ;ORIG LINE
+6 SET APCHSRRT(APCHSRRT)=(-APCHSIVD\1+9999999)_U_APCHSRR_U_APCHSEDT_U_APCHSDCD_U_$$VAL^XBDIQ1(9000010.22,APCHSDFN,.06)
+7 SET APCHSRTX=$PIECE(^RAMIS(71,APCHSRRT,0),U,1)
IF $LENGTH(APCHSRTX)>APCHSMXL
SET APCHSMXL=$LENGTH(APCHSRTX)
+8 QUIT
+9 ; <PRINT>
RPRT SET APCHSRW=APCHSMXL+1
SET APCHSRL=10
SET APCHSNMX=(IOM-1-APCHSRW)\APCHSRL
+1 SET APCHSRT=""
FOR APCHSQ=0:0
SET APCHSRT=$ORDER(APCHSRRT(APCHSRT))
IF APCHSRT=""
QUIT
DO RPRT2
+2 QUIT
RPRT2 ;
+1 SET Y=$PIECE(APCHSRRT(APCHSRT),U,1)
SET APCHSRR=$PIECE(APCHSRRT(APCHSRT),U,2)
XECUTE APCHSCVD
SET APCHSRTD=Y
+2 SET APCHSEDT=$PIECE($GET(APCHSRRT(APCHSRT)),U,3)
IF APCHSEDT]""
SET Y=$PIECE(APCHSEDT,".")
XECUTE APCHSCVD
SET APCHSEDT=Y
+3 ;S APCHSRTX=$P(^RAMIS(71,APCHSRT,0),U,1) X APCHSCKP Q:$D(APCHSQIT) W APCHSRTX,?APCHSRW,"(",APCHSRTD,") ",APCHSRR,!
+4 SET APCHSRTX=$PIECE(^RAMIS(71,APCHSRT,0),U,1)
+5 ;X APCHSCKP Q:$D(APCHSQIT)
+6 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+7 SET BSDXTMP=APCHSRTX_$$FILL^BSDX41(APCHSRW-$LENGTH(APCHSRTX))_"("_$SELECT(APCHSEDT]"":APCHSEDT,1:APCHSRTD)_") "
+8 IF $PIECE(APCHSRRT(APCHSRT),U,4)]""
SET BSDXTMP=BSDXTMP_"RESULT: "
SET APCHSDCD=$PIECE(APCHSRRT(APCHSRT),U,4)
SET BSDXTMP=BSDXTMP_$SELECT(APCHSDCD]"":APCHSDCD,1:"<none recorded>")
+9 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+10 IF $PIECE(APCHSRRT(APCHSRT),U,5)]""
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=" "_"Diagnostic Code: "_$PIECE(APCHSRRT(APCHSRT),U,5)_$CHAR(30)
+11 SET BSDXTMP=" "_"IMPRESSION: "
SET APCHSICL=16
SET APCHSNRQ=APCHSRR
SET APCHSTXT=""
SET APCHSICD=""
DO PRTTXT^BSDX41F
+12 KILL APCHSTXT,APCHSNRQ
+13 QUIT
+14 ;
+15 ; MOST RECENT EXAMINATION OF EACH TYPE WITHIN DATE RANGE
+16 ;
MRE ; ******************** MOST RECENT EXAMINATION * 9000010.13 *******
+1 ;I '$D(^AUPNVXAM("AA",APCHSPAT)),'$D(^AUPNPREF("AA",APCHSPAT,9999999.15)) Q
+2 ;X APCHSCKP Q:$D(APCHSQIT)
+3 ;X:'APCHSNPG APCHSBRK
+4 ; <SETUP>
+5 ; <PROCESS>
+6 ;D EBLD,EPRT
+7 DO EBLDNEW
DO EPRTNEW
+8 ; <CLEANUP>
+9 ;NOW DISPLAY EXAM REFUSALS
+10 IF '$DATA(^AUPNPREF("AA",APCHSPAT,9999999.15))
QUIT
+11 ;X APCHSCKP Q:$D(APCHSQIT)
+12 SET APCHSFN=9999999.15
SET APCHST="EXAM"
+13 DO DISPREF
MREX KILL APCHSET,APCHSER,APCHSETX,APCHSERT,APCHSMXL,APCHSRL,APCHSRW,APCHSNMX,APCHSDFN,APCHSIVD,APCHSETD,APCHSN,Y
+1 KILL APCHEIEN,APCHP,APCHSD
+2 QUIT
DISPREF ;EP
+1 ;X APCHSCKP Q:$D(APCHSQIT)
+2 SET APCHSRC=0
+3 SET APCHSX=""
FOR
SET APCHSX=$ORDER(^AUPNPREF("AA",APCHSPAT,APCHSFN,APCHSX))
IF APCHSX=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+4 SET APCHSD=0
FOR
SET APCHSD=$ORDER(^AUPNPREF("AA",APCHSPAT,APCHSFN,APCHSX,APCHSD))
IF APCHSD=""!(APCHSD>APCHSDLM)!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+5 SET APCHSI=0
FOR
SET APCHSI=$ORDER(^AUPNPREF("AA",APCHSPAT,APCHSFN,APCHSX,APCHSD,APCHSI))
IF APCHSI=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:3
+6 IF $DATA(APCHSS)
XECUTE APCHSS
IF '%
QUIT
+7 SET APCHSRC=APCHSRC+1
+8 IF APCHSRC=1
IF APCHST]""
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
SET BSDXTMP=APCHST_" Refusals "_$CHAR(30)
+9 ;X APCHSCKP Q:$D(APCHSQIT)
+10 SET BSDXTMP=$$VAL^XBDIQ1(9000022,APCHSI,.04)_" -- "_$$VAL^XBDIQ1(9000022,APCHSI,.07)
+11 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(59-$LENGTH(BSDXTMP))_"("_$$DATE^APCHSMU(9999999-APCHSD)_")"
End DoDot:3
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+15 KILL APCHST,APCHSX,APCHSD,APCHSS,APCHSFN,APCHSI
+16 QUIT
+17 ; <BUILD>
+18 ;
EBLDNEW ;new exam section that looks at dx, procedures, cpts in addition to exam
+1 KILL APCHSERT
+2 SET APCHEIEN=0
FOR
SET APCHEIEN=$ORDER(^AUTTEXAM(APCHEIEN))
IF APCHEIEN'=+APCHEIEN
QUIT
Begin DoDot:1
+3 SET APCHECOD=$PIECE(^AUTTEXAM(APCHEIEN,0),U,2)
+4 ;just V EXAM
IF APCHECOD=""
SET Y=$$VXAM(APCHSPAT,(9999999-APCHSDLM),DT,APCHEIEN)
DO SEXAM
QUIT
+5 ;now see if there is a special routine to get the last of this code
+6 IF APCHECOD="01"
SET Y=$$LASTEX01(APCHSPAT,(9999999-APCHSDLM),DT)
DO SEXAM
QUIT
+7 IF APCHECOD="02"
SET Y=$$LASTEX02(APCHSPAT,(9999999-APCHSDLM),DT)
DO SEXAM
QUIT
+8 IF APCHECOD="04"
SET Y=$$LASTEX04(APCHSPAT,(9999999-APCHSDLM),DT)
DO SEXAM
QUIT
+9 IF APCHECOD="06"
SET Y=$$LASTEX06(APCHSPAT,(9999999-APCHSDLM),DT)
DO SEXAM
QUIT
+10 IF APCHECOD="07"
SET Y=$$LASTEX07(APCHSPAT,(9999999-APCHSDLM),DT)
DO SEXAM
QUIT
+11 IF APCHECOD="08"
SET Y=$$LASTEX08(APCHSPAT,(9999999-APCHSDLM),DT)
DO SEXAM
QUIT
+12 IF APCHECOD="11"
SET Y=$$LASTEX11(APCHSPAT,(9999999-APCHSDLM),DT)
DO SEXAM
QUIT
+13 IF APCHECOD="12"
SET Y=$$LASTEX12(APCHSPAT,(9999999-APCHSDLM),DT)
DO SEXAM
QUIT
+14 IF APCHECOD="14"
SET Y=$$LASTEX14(APCHSPAT,(9999999-APCHSDLM),DT)
DO SEXAM
QUIT
+15 IF APCHECOD="15"
SET Y=$$LASTEX15(APCHSPAT,(9999999-APCHSDLM),DT)
DO SEXAM
QUIT
+16 IF APCHECOD="16"
SET Y=$$LASTEX16(APCHSPAT,(9999999-APCHSDLM),DT)
DO SEXAM
QUIT
+17 IF APCHECOD="17"
SET Y=$$LASTEX17(APCHSPAT,(9999999-APCHSDLM),DT)
DO SEXAM
QUIT
+18 IF APCHECOD="19"
SET Y=$$LASTEX19(APCHSPAT,(9999999-APCHSDLM),DT)
DO SEXAM
QUIT
+19 IF APCHECOD="21"
SET Y=$$LASTEX21(APCHSPAT,(9999999-APCHSDLM),DT)
DO SEXAM
QUIT
+20 IF APCHECOD="23"
SET Y=$$LASTEX23(APCHSPAT,(9999999-APCHSDLM),DT)
DO SEXAM
QUIT
+21 SET Y=$$VXAM(APCHSPAT,(9999999-APCHSDLM),DT,APCHEIEN)
DO SEXAM
+22 QUIT
End DoDot:1
+23 QUIT
+24 ;
EPRTNEW ;
+1 SET APCHEXT=0
FOR
SET APCHEXT=$ORDER(APCHSERT(APCHEXT))
IF APCHEXT=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+2 SET APCHSN=$SELECT($PIECE($GET(^AUTTEXAM(APCHEXT,0)),U,2)=34:"DOMESTIC VIOLENCE SCREENING",1:$EXTRACT($PIECE($GET(^AUTTEXAM(APCHEXT,0)),U),1,28))
+3 IF $PIECE(APCHSERT(APCHEXT),U,2)'["Exam"
SET APCHSN=$EXTRACT(APCHSN,1,22)_" ["_$PIECE(APCHSERT(APCHEXT),U,2)_"]"
+4 SET Y=$PIECE(APCHSERT(APCHEXT),U,1)
XECUTE APCHSCVD
SET APCHSD=Y
+5 SET APCHSER=$PIECE(APCHSERT(APCHEXT),U,3)
+6 SET APCHP=$EXTRACT($PIECE(APCHSERT(APCHEXT),U,4),1,15)
+7 ;X APCHSCKP
+8 ;Q:$D(APCHSQIT)
+9 SET BSDXTMP=APCHSN_$$FILL^BSDX41(36-$LENGTH(APCHSN))_APCHSD
+10 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(46-$LENGTH(BSDXTMP))_APCHSER
+11 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(64-$LENGTH(BSDXTMP))_APCHP
+12 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+13 QUIT
End DoDot:1
+14 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)
+8 ;
SEXAM ;
+1 IF Y=""
QUIT
+2 SET APCHSERT(APCHEIEN)=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)
+19 ;
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)
+19 ;
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)
+13 ;
RAD ; ******************* RAD TESTS - ALL * 9000010.12 *******
+1 GOTO RAD^BSDX41P
