APCHS3C.m

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)