APCHS3C ; IHS/CMI/LAB - PART 3C OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**2,7,11,20**;MAY 14, 2009;Build 25
;IHS/CMI/LAB - patch 12 added new rad component
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^APCHS3C
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) W !,APCHSRTX,?APCHSRW,"(",$S(APCHSEDT]"":APCHSEDT,1:APCHSRTD),") "
I $P(APCHSRRT(APCHSRT),U,4)]"" W "RESULT: " S APCHSDCD=$P(APCHSRRT(APCHSRT),U,4) W $S(APCHSDCD]"":APCHSDCD,1:"<none recorded>"),!
I $P(APCHSRRT(APCHSRT),U,5)]"" W !?3,"Diagnostic Code: ",$P(APCHSRRT(APCHSRT),U,5)
W !?3,"IMPRESSION: " S APCHSICL=16,APCHSNRQ=APCHSRR,APCHSTXT="",APCHSICD="" D PRTTXT^APCHSUTL
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]"" W !,APCHST," Refusals/Declined Services "
...X APCHSCKP Q:$D(APCHSQIT)
...W !,$$VAL^XBDIQ1(9000022,APCHSI,.04)," -- ",$$VAL^XBDIQ1(9000022,APCHSI,.07),?60,"(",$$DATE^APCHSMU(9999999-APCHSD),")"
...I $P($G(^AUPNPREF(APCHSI,11)),U,1)]"",$P(^APCHSCTL(APCHSTYP,0),U,8) D
....;display comments using DIWP
....K ^UTILITY($J,"W")
....S X="Comments: "_$P(^AUPNPREF(APCHSI,11),U,1)
....S DIWL=0,DIWR=74
....D ^DIWP
....W !
....S APCHSZ=0 F S APCHSZ=$O(^UTILITY($J,"W",DIWL,APCHSZ)) Q:APCHSZ'=+APCHSZ!($D(APCHSQIT)) D
.....X APCHSCKP Q:$D(APCHSQIT)
.....W ?5,^UTILITY($J,"W",DIWL,APCHSZ,0),!
K ^UTILITY($J,"W")
W !
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)
.W APCHSN,?37,APCHSD,?47,APCHSER,?65,APCHP,!
.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=$$LASTDX^APCHSMU2(P,"APCH EXAM 01 GENERAL",BD,DT)
I D S LBE(9999999-$P(D,U,3))="Dx: "_$P(D,U,2)
;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=$$LASTDX^APCHSMU2(P,"APCH EXAM 02 EAR",BD,DT)
I D S LBE(9999999-$P(D,U,3))="Dx: "_$P(D,U,2)
S D=$$LASTPRC^APCHSMU2(P,"APCH EXAM 02 PROCS",BD,DT)
I D S LBE(9999999-$P(D,U,3))="ICD: "_$P(D,U,2)
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=$$LASTDX^APCHSMU2(P,"APCH EXAM 04 MOUTH",BD,DT)
I D S LBE(9999999-$P(D,U,3))="Dx: "_$P(D,U,2)
S D=$$LASTPRC^APCHSMU2(P,"APCH EXAM 04 MOUTH PROCS",BD,DT)
I D S LBE(9999999-$P(D,U,3))="ICD: "_$P(D,U,2)
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,,,"A")
I Y="" Q Y
I $P(Y,U)<BD S Y=""
Q $P(Y,U,1)_"^"_$P(Y,U,2)
;
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=$$LASTDX^APCHSMU2(P,"APCH EXAM 07 CHEST",BD,DT)
I D S LBE(9999999-$P(D,U,3))="Dx: "_$P(D,U,2)
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=$$LASTDX^APCHSMU2(P,"APCH EXAM 08 HEART",BD,DT)
I D S LBE(9999999-$P(D,U,3))="Dx: "_$P(D,U,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=$$LASTDX^APCHSMU2(P,"APCH EXAM 11 NEURO",BD,DT)
I D S LBE(9999999-$P(D,U,3))="Dx: "_$P(D,U,2)
S D=$$LASTPRC^APCHSMU2(P,"APCH EXAM 11 NEURO PROCS",BD,DT)
I D S LBE(9999999-$P(D,U,3))="ICD: "_$P(D,U,2)
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=$$LASTPRC^APCHSMU2(P,"APCH EXAM 12 ORTHO PROCS")
I D S LBE(9999999-$P(D,U,3))="ICD: "_$P(D,U,2)
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,,,"A")
I Y="" Q Y
I $P(Y,U)<BD S Y=""
Q $P(Y,U,1)_"^"_$P(Y,U,2)
;
LASTEX15(P,BD,ED) ;
NEW Y
S Y=$$LASTPELV^APCLAPI2(P,,,"A")
I Y="" Q Y
I $P(Y,U)<BD S Y=""
Q $P(Y,U,1)_"^"_$P(Y,U,2)
;
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=$$LASTDX^APCHSMU2(P,"APCH EXAM 16 GENDEV",BD,DT)
I D S LBE(9999999-$P(D,U,3))="Dx: "_$P(D,U,2)
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=$$LASTDX^APCHSMU2(P,"APCH EXAM 17 HEARING",BD,DT)
I D S LBE(9999999-$P(D,U,3))="Dx: "_$P(D,U,2)
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=$$LASTDX^APCHSMU2(P,"APCH EXAM 19 VISION",BD,DT)
I D S LBE(9999999-$P(D,U,3))="Dx: "_$P(D,U,2)
S D=$$LASTPRC^APCHSMU2(P,"APCH EXAM 19 VISION PROCS",BD,DT)
I D S LBE(9999999-$P(D,U,3))="ICD: "_$P(D,U,2)
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=$$LASTDX^APCHSMU2(P,"APCH EXAM 21 OTO",BD,DT)
I D S LBE(9999999-$P(D,U,3))="Dx: "_$P(D,U,2)
S D=$$LASTPRC^APCHSMU2(P,"APCH EXAM 21 OTO PROCS")
I D S LBE(9999999-$P(D,U,3))="ICD: "_$P(D,U,2)
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 *******
; <SETUP>
Q:'$D(^AUPNVRAD("AA",APCHSPAT))
K APCHSRRT
X APCHSBRK
; <DISPLAY>
S APCHST="" F APCHSQ=0:0 S APCHST=$O(^AUPNVRAD("AA",APCHSPAT,APCHST)) Q:APCHST="" S APCHSTX=$P(^RAMIS(71,APCHST,0),U,1),APCHSTL=$L(APCHSTX) X APCHSCKP Q:$D(APCHSQIT) D RADBLD
; <CLEANUP>
;now display RAD refusals
S APCHST="RADIOLOGY EXAM",APCHSFN=71 D DISPREF^APCHS3C
K APCHST,APCHSFN
RADX K APCHST,APCHSTX,APCHSTL,APCHSIVD,APCHSDFN,APCHSRDG,APCHSVDF,APCHSDAT,X,Y
K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE
Q
RADBLD S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVRAD("AA",APCHSPAT,APCHST,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D RADBLD1
Q
RADBLD1 ;S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
X APCHSCKP Q:$D(APCHSQIT) S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y W !,APCHSDAT
S APCHSDFN=0 F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVRAD("AA",APCHSPAT,APCHST,APCHSIVD,APCHSDFN)) Q:'APCHSDFN D
.Q:'$D(^AUPNVRAD(APCHSDFN,0))
.S APCHSEDT=$P($P($G(^AUPNVRAD(APCHSDFN,12)),U,1),".")
.D RADDSP
Q
RADDSP ;
S APCHS0=$P(^AUPNVRAD(APCHSDFN,0),U,1)
S APCHSRTX=$P(^RAMIS(71,$P(APCHS0,U),0),U,1) W ?11,APCHSRTX I APCHSEDT]"",APCHSEDT'=9999999-APCHSIVD W " ("_$$FMTE^XLFDT(APCHSEDT,5)_")"
I $P(APCHS0,U,5)]"" W !?11,"RESULT: " S APCHSDCD=$P(APCHS0,U,5) W $S(APCHSDCD]"":APCHSDCD,1:"<none recorded>")
I $P(APCHS0,U,6)]"" W !?3,"Diagnostic Code: ",$$VAL^XBDIQ1(9000010.22,APCHSDFN,.06)
I $G(^AUPNVRAD(APCHSDFN,11))]"" W !?11,"IMPRESSION: " S APCHSICL=12,APCHSNRQ=$G(^AUPNVRAD(APCHSDFN,11)),APCHSTXT="",APCHSICD="" D PRTTXT^APCHSUTL
I $G(^AUPNVRAD(APCHSDFN,11))="" W !
K APCHSTXT,APCHSNRQ
Q
;
APCHS3C ; IHS/CMI/LAB - PART 3C OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**2,7,11,20**;MAY 14, 2009;Build 25
+2 ;IHS/CMI/LAB - patch 12 added new rad component
MRR ; ******************** MOST RECENT RADIOLOGY * 9000010.22 *******
+1 IF '$DATA(^AUPNVRAD("AA",APCHSPAT))
QUIT
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+3 IF 'APCHSNPG
XECUTE 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^APCHS3C
+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)
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !,APCHSRTX,?APCHSRW,"(",$SELECT(APCHSEDT]"":APCHSEDT,1:APCHSRTD),") "
+5 IF $PIECE(APCHSRRT(APCHSRT),U,4)]""
WRITE "RESULT: "
SET APCHSDCD=$PIECE(APCHSRRT(APCHSRT),U,4)
WRITE $SELECT(APCHSDCD]"":APCHSDCD,1:"<none recorded>"),!
+6 IF $PIECE(APCHSRRT(APCHSRT),U,5)]""
WRITE !?3,"Diagnostic Code: ",$PIECE(APCHSRRT(APCHSRT),U,5)
+7 WRITE !?3,"IMPRESSION: "
SET APCHSICL=16
SET APCHSNRQ=APCHSRR
SET APCHSTXT=""
SET APCHSICD=""
DO PRTTXT^APCHSUTL
+8 KILL APCHSTXT,APCHSNRQ
+9 QUIT
+10 ;
+11 ; MOST RECENT EXAMINATION OF EACH TYPE WITHIN DATE RANGE
+12 ;
MRE ; ******************** MOST RECENT EXAMINATION * 9000010.13 *******
+1 ;I '$D(^AUPNVXAM("AA",APCHSPAT)),'$D(^AUPNPREF("AA",APCHSPAT,9999999.15)) Q
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+3 IF 'APCHSNPG
XECUTE 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 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+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 ;I $D(APCHSS) X APCHSS Q:'%
+7 SET APCHSRC=APCHSRC+1
+8 IF APCHSRC=1
IF APCHST]""
WRITE !,APCHST," Refusals/Declined Services "
+9 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+10 WRITE !,$$VAL^XBDIQ1(9000022,APCHSI,.04)," -- ",$$VAL^XBDIQ1(9000022,APCHSI,.07),?60,"(",$$DATE^APCHSMU(9999999-APCHSD),")"
+11 IF $PIECE($GET(^AUPNPREF(APCHSI,11)),U,1)]""
IF $PIECE(^APCHSCTL(APCHSTYP,0),U,8)
Begin DoDot:4
+12 ;display comments using DIWP
+13 KILL ^UTILITY($JOB,"W")
+14 SET X="Comments: "_$PIECE(^AUPNPREF(APCHSI,11),U,1)
+15 SET DIWL=0
SET DIWR=74
+16 DO ^DIWP
+17 WRITE !
+18 SET APCHSZ=0
FOR
SET APCHSZ=$ORDER(^UTILITY($JOB,"W",DIWL,APCHSZ))
IF APCHSZ'=+APCHSZ!($DATA(APCHSQIT))
QUIT
Begin DoDot:5
+19 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+20 WRITE ?5,^UTILITY($JOB,"W",DIWL,APCHSZ,0),!
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 KILL ^UTILITY($JOB,"W")
+22 WRITE !
+23 KILL APCHST,APCHSX,APCHSD,APCHSS,APCHSFN,APCHSI
+24 QUIT
+25 ; <BUILD>
+26 ;
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 XECUTE APCHSCKP
+8 IF $DATA(APCHSQIT)
QUIT
+9 WRITE APCHSN,?37,APCHSD,?47,APCHSER,?65,APCHP,!
+10 QUIT
End DoDot:1
+11 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=$$LASTDX^APCHSMU2(P,"APCH EXAM 01 GENERAL",BD,DT)
+7 IF D
SET LBE(9999999-$PIECE(D,U,3))="Dx: "_$PIECE(D,U,2)
+8 ;S D=$$LASTDXI^APCHSMU2(P,"V70.3")
+9 ;I D S LBE(9999999-$P(D,U,3))="Dx: V70.3"
+10 ;S D=$$LASTDXI^APCHSMU2(P,"V70.9")
+11 ;I D S LBE(9999999-$P(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=$$LASTDX^APCHSMU2(P,"APCH EXAM 02 EAR",BD,DT)
+7 IF D
SET LBE(9999999-$PIECE(D,U,3))="Dx: "_$PIECE(D,U,2)
+8 SET D=$$LASTPRC^APCHSMU2(P,"APCH EXAM 02 PROCS",BD,DT)
+9 IF D
SET LBE(9999999-$PIECE(D,U,3))="ICD: "_$PIECE(D,U,2)
+10 SET D=$$LASTCPTI^APCHSMU2(P,92700)
+11 IF D
SET LBE(9999999-$PIECE(D,U,3))="CPT: 92700"
+12 IF '$DATA(LBE)
QUIT ""
+13 SET D=$ORDER(LBE(0))
+14 QUIT (9999999-D)_"^"_LBE(D)
+15 ;
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=$$LASTDX^APCHSMU2(P,"APCH EXAM 04 MOUTH",BD,DT)
+7 IF D
SET LBE(9999999-$PIECE(D,U,3))="Dx: "_$PIECE(D,U,2)
+8 SET D=$$LASTPRC^APCHSMU2(P,"APCH EXAM 04 MOUTH PROCS",BD,DT)
+9 IF D
SET LBE(9999999-$PIECE(D,U,3))="ICD: "_$PIECE(D,U,2)
+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,,,"A")
+3 IF Y=""
QUIT Y
+4 IF $PIECE(Y,U)<BD
SET Y=""
+5 QUIT $PIECE(Y,U,1)_"^"_$PIECE(Y,U,2)
+6 ;
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=$$LASTDX^APCHSMU2(P,"APCH EXAM 07 CHEST",BD,DT)
+7 IF D
SET LBE(9999999-$PIECE(D,U,3))="Dx: "_$PIECE(D,U,2)
+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=$$LASTDX^APCHSMU2(P,"APCH EXAM 08 HEART",BD,DT)
+7 IF D
SET LBE(9999999-$PIECE(D,U,3))="Dx: "_$PIECE(D,U,2)
+8 SET D=$$LASTCPTI^APCHSMU2(P,"G0367")
+9 IF D
SET LBE(9999999-$PIECE(D,U,3))="CPT: G0367"
+10 IF '$DATA(LBE)
QUIT ""
+11 SET D=$ORDER(LBE(0))
+12 QUIT (9999999-D)_"^"_LBE(D)
+13 ;
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=$$LASTDX^APCHSMU2(P,"APCH EXAM 11 NEURO",BD,DT)
+7 IF D
SET LBE(9999999-$PIECE(D,U,3))="Dx: "_$PIECE(D,U,2)
+8 SET D=$$LASTPRC^APCHSMU2(P,"APCH EXAM 11 NEURO PROCS",BD,DT)
+9 IF D
SET LBE(9999999-$PIECE(D,U,3))="ICD: "_$PIECE(D,U,2)
+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=$$LASTPRC^APCHSMU2(P,"APCH EXAM 12 ORTHO PROCS")
+7 IF D
SET LBE(9999999-$PIECE(D,U,3))="ICD: "_$PIECE(D,U,2)
+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,,,"A")
+3 IF Y=""
QUIT Y
+4 IF $PIECE(Y,U)<BD
SET Y=""
+5 QUIT $PIECE(Y,U,1)_"^"_$PIECE(Y,U,2)
+6 ;
LASTEX15(P,BD,ED) ;
+1 NEW Y
+2 SET Y=$$LASTPELV^APCLAPI2(P,,,"A")
+3 IF Y=""
QUIT Y
+4 IF $PIECE(Y,U)<BD
SET Y=""
+5 QUIT $PIECE(Y,U,1)_"^"_$PIECE(Y,U,2)
+6 ;
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=$$LASTDX^APCHSMU2(P,"APCH EXAM 16 GENDEV",BD,DT)
+7 IF D
SET LBE(9999999-$PIECE(D,U,3))="Dx: "_$PIECE(D,U,2)
+8 IF '$DATA(LBE)
QUIT ""
+9 SET D=$ORDER(LBE(0))
+10 QUIT (9999999-D)_"^"_LBE(D)
+11 ;
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=$$LASTDX^APCHSMU2(P,"APCH EXAM 17 HEARING",BD,DT)
+7 IF D
SET LBE(9999999-$PIECE(D,U,3))="Dx: "_$PIECE(D,U,2)
+8 IF '$DATA(LBE)
QUIT ""
+9 SET D=$ORDER(LBE(0))
+10 QUIT (9999999-D)_"^"_LBE(D)
+11 ;
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=$$LASTDX^APCHSMU2(P,"APCH EXAM 19 VISION",BD,DT)
+7 IF D
SET LBE(9999999-$PIECE(D,U,3))="Dx: "_$PIECE(D,U,2)
+8 SET D=$$LASTPRC^APCHSMU2(P,"APCH EXAM 19 VISION PROCS",BD,DT)
+9 IF D
SET LBE(9999999-$PIECE(D,U,3))="ICD: "_$PIECE(D,U,2)
+10 SET D=$$LASTCPTI^APCHSMU2(P,99172)
+11 IF D
SET LBE(9999999-$PIECE(D,U,3))="CPT: 99172"
+12 SET D=$$LASTCPTI^APCHSMU2(P,99173)
+13 IF D
SET LBE(9999999-$PIECE(D,U,3))="CPT: 99173"
+14 IF '$DATA(LBE)
QUIT ""
+15 SET D=$ORDER(LBE(0))
+16 QUIT (9999999-D)_"^"_LBE(D)
+17 ;
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=$$LASTDX^APCHSMU2(P,"APCH EXAM 21 OTO",BD,DT)
+7 IF D
SET LBE(9999999-$PIECE(D,U,3))="Dx: "_$PIECE(D,U,2)
+8 SET D=$$LASTPRC^APCHSMU2(P,"APCH EXAM 21 OTO PROCS")
+9 IF D
SET LBE(9999999-$PIECE(D,U,3))="ICD: "_$PIECE(D,U,2)
+10 SET D=$$LASTCPTI^APCHSMU2(P,92700)
+11 IF D
SET LBE(9999999-$PIECE(D,U,3))="CPT: 92700"
+12 IF '$DATA(LBE)
QUIT ""
+13 SET D=$ORDER(LBE(0))
+14 QUIT (9999999-D)_"^"_LBE(D)
+15 ;
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 ; <SETUP>
+2 IF '$DATA(^AUPNVRAD("AA",APCHSPAT))
QUIT
+3 KILL APCHSRRT
+4 XECUTE APCHSBRK
+5 ; <DISPLAY>
+6 SET APCHST=""
FOR APCHSQ=0:0
SET APCHST=$ORDER(^AUPNVRAD("AA",APCHSPAT,APCHST))
IF APCHST=""
QUIT
SET APCHSTX=$PIECE(^RAMIS(71,APCHST,0),U,1)
SET APCHSTL=$LENGTH(APCHSTX)
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
DO RADBLD
+7 ; <CLEANUP>
+8 ;now display RAD refusals
+9 SET APCHST="RADIOLOGY EXAM"
SET APCHSFN=71
DO DISPREF^APCHS3C
+10 KILL APCHST,APCHSFN
RADX KILL APCHST,APCHSTX,APCHSTL,APCHSIVD,APCHSDFN,APCHSRDG,APCHSVDF,APCHSDAT,X,Y
+1 KILL APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSITE
+2 QUIT
RADBLD SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVRAD("AA",APCHSPAT,APCHST,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
DO RADBLD1
+1 QUIT
RADBLD1 ;S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
+1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
SET Y=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
WRITE !,APCHSDAT
+2 SET APCHSDFN=0
FOR APCHSQ=0:0
SET APCHSDFN=$ORDER(^AUPNVRAD("AA",APCHSPAT,APCHST,APCHSIVD,APCHSDFN))
IF 'APCHSDFN
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNVRAD(APCHSDFN,0))
QUIT
+4 SET APCHSEDT=$PIECE($PIECE($GET(^AUPNVRAD(APCHSDFN,12)),U,1),".")
+5 DO RADDSP
End DoDot:1
+6 QUIT
RADDSP ;
+1 SET APCHS0=$PIECE(^AUPNVRAD(APCHSDFN,0),U,1)
+2 SET APCHSRTX=$PIECE(^RAMIS(71,$PIECE(APCHS0,U),0),U,1)
WRITE ?11,APCHSRTX
IF APCHSEDT]""
IF APCHSEDT'=9999999-APCHSIVD
WRITE " ("_$$FMTE^XLFDT(APCHSEDT,5)_")"
+3 IF $PIECE(APCHS0,U,5)]""
WRITE !?11,"RESULT: "
SET APCHSDCD=$PIECE(APCHS0,U,5)
WRITE $SELECT(APCHSDCD]"":APCHSDCD,1:"<none recorded>")
+4 IF $PIECE(APCHS0,U,6)]""
WRITE !?3,"Diagnostic Code: ",$$VAL^XBDIQ1(9000010.22,APCHSDFN,.06)
+5 IF $GET(^AUPNVRAD(APCHSDFN,11))]""
WRITE !?11,"IMPRESSION: "
SET APCHSICL=12
SET APCHSNRQ=$GET(^AUPNVRAD(APCHSDFN,11))
SET APCHSTXT=""
SET APCHSICD=""
DO PRTTXT^APCHSUTL
+6 IF $GET(^AUPNVRAD(APCHSDFN,11))=""
WRITE !
+7 KILL APCHSTXT,APCHSNRQ
+8 QUIT
+9 ;
