BSDX41L ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
;
PTED ; ********** PATIENT EDUCATION * 9000010.16 **********
; <SETUP>
;Q:'$D(^AUPNVPED("AA",APCHSPAT))
K APCHSDEN D DENTED
I '$D(^AUPNVPED("AA",APCHSPAT)),'$D(APCHSDEN) Q ;no ada or v pt ed
;X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D ONEDATE
S APCHSIVD=0 F S APCHSIVD=$O(APCHSDEN(APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)!('APCHSNDM) S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y S APCHSDTU=0 D
.S APCHSDFN=0 F S APCHSDFN=$O(APCHSDEN(APCHSIVD,"PED",APCHSDFN)) Q:APCHSDFN'=+APCHSDFN!($D(APCHSQIT))!('APCHSNDM) D PEDCHK S APCHSNDM=APCHSNDM-APCHSDTU
.S APCHSDFN=0,APCHSCNT=0 F S APCHSDFN=$O(APCHSDEN(APCHSIVD,"DEN",APCHSDFN)) Q:APCHSDFN'=+APCHSDFN!($D(APCHSQIT))!('APCHSNDM) D
..S APCHX=APCHSDEN(APCHSIVD,"DEN",APCHSDFN)
..;X APCHSCKP Q:$D(APCHSQIT)
..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
..S APCHSVDF=$P(^AUPNVDEN(APCHSDFN,0),U,3)
..Q:'$D(^AUPNVSIT(APCHSVDF,0))
..D GETSITEV^BSDX41I
..S:'APCHSCNT BSDXTMP=APCHSDAT_$$FILL^BSDX41(9-$L(APCHSDAT))_APCHSNSH
..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$$FILL^BSDX41(22-$L(BSDXTMP))_"ADA: "_$P(^AUTTADA(APCHX,0),U)_" - "_$E($P(^AUTTADA(APCHX,0),U,2),1,40)_$C(30)
..S APCHSCNT=APCHSCNT+1
..Q
; <CLEANUP>
;now display PTED refusals
S APCHST="EDUCATION",APCHSFN=9999999.09 D DISPREF^BSDX41F
K APCHST,APCHSFN
PTEDX K APCHSIVD,APCHSDAT,APCHSDFN,APCHSFO,APCHSFAC,APCHSN,APCHSDTU,APCHSLVL,APCHSLVT,APCHSPED,APCHSPTB,APCHSQ,Y
K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSVDF,APCHSDEN,APCHSDE1,APCHSDE2,APCHSDE3,APCHX
Q
ONEDATE S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:APCHSDFN="" S APCHSDEN(APCHSIVD,"PED",APCHSDFN)=""
Q
PEDCHK S APCHSN=^AUPNVPED(APCHSDFN,0)
S APCHSVDF=$P(APCHSN,U,3) D GETSITEV^BSDX41I
;X APCHSCKP Q:$D(APCHSQIT)
S:APCHSNPG APCHSDTU=0
I 'APCHSDTU S BSDXTMP=APCHSDAT S APCHSFO=""
I APCHSNSH=APCHSFO S APCHSFAC=""
E S (APCHSFAC,APCHSFO)=APCHSNSH
S APCHSDTU=1
S APCHSPED=$P(APCHSN,U,1),APCHSPEM=$P(^AUTTEDT(APCHSPED,0),U,2),APCHSPED=$P(^AUTTEDT(APCHSPED,0),U,1)
S APCHSLVL=$P(APCHSN,U,6),APCHSLVT=""
I APCHSLVL]"" D
. S APCHSLVT=$P(^DD(9000010.16,.06,0),U,3)
. S APCHSLVT=$P(APCHSLVT,APCHSLVL_":",2)
. S APCHSLVT=$P(APCHSLVT,";",1)
. S:"^GOOD^FAIR^POOR^"[("^"_APCHSLVT_"^") APCHSLVT=APCHSLVT_" UNDERSTANDING"
. ;S APCHSLVT="- "_APCHSLVT
. Q
;X APCHSCKP Q:$D(APCHSQIT)
I APCHSNPG D
.S BSDXTMP=BSDXTMP_APCHSDAT
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(9-$L(BSDXTMP))_APCHSFAC
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$L(BSDXTMP))_$E(APCHSPEM,1,12)
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(34-$L(BSDXTMP))_$E(APCHSPED,1,35)_$S($P(APCHSN,U,7)="":"",$P(APCHSN,U,7)="I":" - (IND)",$P(APCHSN,U,7)="G":" - (GRP)",1:"")
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
.S BSDXTMP=""
I APCHSLVT]"" S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$$FILL^BSDX41(34-$L(BSDXTMP))_APCHSLVT_$C(30)
I $P(APCHSN,U,13)]""!($P(APCHSN,U,14)]"") D
.;X APCHSCKP Q:$D(APCHSQIT)
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$L(BSDXTMP))_"Behavior Code: "_$$VAL^XBDIQ1(9000010.16,APCHSDFN,.13)
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(50-$L(BSDXTMP))_"Objectives Met: "_$P(APCHSN,U,14)
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
.S BSDXTMP=""
I $P($G(^AUPNVPED(APCHSDFN,11)),U)]"" S APCHSTXT=$P(^AUPNVPED(APCHSDFN,11),U),APCHSNRQ="",APCHSICL=23 D PRTTXT^BSDX41F
;cmi/anch/maw 8/27/2007 mods follow for code set versioning
;I $P($G(^AUPNVPED(APCHSDFN,11)),U)="",$P(APCHSN,U,4)]"" S APCHSTXT=$P(^ICD9($P(APCHSN,U,4),0),U,3),APCHSNRQ="",APCHSICL=23 D PRTTXT^BSDX41F
N APCHSVDT
S APCHSVDT=$P($P($G(^AUPNVSIT(APCHSVDF,0)),U),".") ;get visit date
I $P($G(^AUPNVPED(APCHSDFN,11)),U)="",$P(APCHSN,U,4)]"" S APCHSTXT=$P($$ICDDX^ICDCODE($P(APCHSN,U,4),APCHSVDT),U,4),APCHSNRQ="",APCHSICL=23 D PRTTXT^BSDX41F
;cmi/anch/maw 8/27/2007 end of mods
I $P(APCHSN,U,11)]"" S APCHSTXT=$P(APCHSN,U,11),APCHSNRQ="",APCHSICL=23 D PRTTXT^BSDX41F Q
Q
;
MRPTED ; ********** MOST RECENT PATIENT EDUCATION * 9000010.16 **********
; <SETUP>
;Q:'$D(^AUPNVPED("AA",APCHSPAT))
K APCHSDEN D DENTEDL
I '$D(^AUPNVPED("AA",APCHSPAT)),'$D(APCHSDEN) Q ;no ada or v pt ed
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
K APCHSPTB
;S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD)) Q:'APCHSIVD S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y D ONEDAY Q:$D(APCHSQIT)
;IHS/CMI/LAB - PATCH 9 modified this to look at date range and max visit limits
S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D ONEDAY
S APCHSIVD=0 F S APCHSIVD=$O(APCHSDEN(APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)!('APCHSNDM) S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y S APCHSDTU=0 D
.S APCHSDFN=0 F S APCHSDFN=$O(APCHSDEN(APCHSIVD,"PED",APCHSDFN)) Q:APCHSDFN'=+APCHSDFN!($D(APCHSQIT))!('APCHSNDM) D PEDCHK S APCHSNDM=APCHSNDM-APCHSDTU
.S APCHSDFN=0,APCHSCNT=0 F S APCHSDFN=$O(APCHSDEN(APCHSIVD,"DEN",APCHSDFN)) Q:APCHSDFN'=+APCHSDFN!($D(APCHSQIT))!('APCHSNDM) D
..S APCHX=APCHSDEN(APCHSIVD,"DEN",APCHSDFN)
..X APCHSCKP Q:$D(APCHSQIT)
..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=$C(30)
..S APCHSVDF=$P(^AUPNVDEN(APCHSDFN,0),U,3)
..D GETSITEV^BSDX41I
..S:'APCHSCNT BSDXTMP=APCHSDAT_$$FILL^BSDX41(9-$L(APCHSDAT))_APCHSNSH
..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$$FILL^BSDX41(22-$L(BSDXTMP))_"ADA: "_$P(^AUTTADA(APCHX,0),U)_" - "_$E($P(^AUTTADA(APCHX,0),U,2),1,40)_$C(30)
..S APCHSCNT=APCHSCNT+1
..Q
; <CLEANUP>
;now display PTED refusals
S APCHST="EDUCATION",APCHSFN=9999999.09 D DISPREF^BSDX41F
K APCHST,APCHSFN
MRPTEDX K APCHSPTB,APCHSEVT
K APCHSIVD,APCHSDAT,APCHSDFN,APCHSFO,APCHSFAC,APCHSN,APCHSDTU,APCHSLVL,APCHSLVT,APCHSPED
K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSVDF
Q
;
ONEDAY ;
S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:'APCHSDFN S APCHSEVT=+^AUPNVPED(APCHSDFN,0) I '$D(APCHSPTB(APCHSEVT)) S APCHSPTB(APCHSEVT)="",APCHSDEN(APCHSIVD,"PED",APCHSDFN)=""
Q
MRPE ;EP - called from component
; <SETUP>
;Q:'$D(^AUPNVPED("AA",APCHSPAT))
K APCHSDEN D DENTAL
I '$D(^AUPNVPED("AA",APCHSPAT)),'$D(APCHSDEN) Q ;no ada or v pt ed
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
; <DISPLAY>
K APCHSPTB
;S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD)) Q:'APCHSIVD S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y D ONEDAY Q:$D(APCHSQIT)
;IHS/CMI/LAB - PATCH 9 modified this to look at date range and max visit limits
S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM)!('APCHSNDM) D
.S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y S APCHSDTU=0 D MRPEOD Q:$D(APCHSQIT) S APCHSNDM=APCHSNDM-APCHSDTU Q:'APCHSNDM
D REORDER
; <CLEANUP>
;now display PTED refusals
S APCHST="EDUCATION",APCHSFN=9999999.09 D DISPREF^BSDX41F
K APCHST,APCHSFN
MRPEX K APCHSPTB,APCHSEVT,APCHSDSP,APCHSX
K APCHSIVD,APCHSDAT,APCHSDFN,APCHSFO,APCHSFAC,APCHSN,APCHSDTU,APCHSLVL,APCHSLVT,APCHSPED
K APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSVDF
Q
;
MRPEOD ;
S APCHSDFN="" F APCHSQ=0:0 S APCHSDFN=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:'APCHSDFN S APCHSEVT=+^AUPNVPED(APCHSDFN,0) I '$D(APCHSPTB(APCHSEVT)) S APCHSPTB(APCHSEVT)=APCHSIVD_U_APCHSDFN,APCHSDTU=1
Q
REORDER ;reorder by name and print
S APCHSEVT=0 F S APCHSEVT=$O(APCHSPTB(APCHSEVT)) Q:APCHSEVT'=+APCHSEVT I $D(^AUTTEDT(APCHSEVT,0)) S APCHSDSP($P(^AUTTEDT(APCHSEVT,0),U))=APCHSPTB(APCHSEVT)
S APCHSX="" F S APCHSX=$O(APCHSDSP(APCHSX)) Q:APCHSX=""!($D(APCHSQIT)) D
.S APCHSDFN=$P(APCHSDSP(APCHSX),U,2)
.S APCHSIVD=$P(APCHSDSP(APCHSX),U) S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y
.I $P(APCHSDSP(APCHSX),U,3)="D" S APCHSN=^AUPNVDEN(APCHSDFN,0)
.E S APCHSN=^AUPNVPED(APCHSDFN,0)
.S APCHSVDF=$P(APCHSN,U,3) D GETSITEV^BSDX41I
.I $P(APCHSDSP(APCHSX),U,3)="D" D Q
..;X APCHSCKP Q:$D(APCHSQIT)
..S BSDXTMP=$E(APCHSX,1,43)_" ADA Code: "_$P(^AUTTADA($P(^AUPNVDEN(APCHSDFN,0),U),0),U)
..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(56-$L(BSDXTMP))_APCHSDAT
..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(66-$L(BSDXTMP))_APCHSNSH
..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
..S BSDXTMP=""
..Q
.S APCHSLVL=$P(APCHSN,U,6),APCHSLVT=""
.I APCHSLVL]"" D
.. S APCHSLVT=$P(^DD(9000010.16,.06,0),U,3)
.. S APCHSLVT=$P(APCHSLVT,APCHSLVL_":",2)
.. S APCHSLVT=$P(APCHSLVT,";",1)
.. S:"^GOOD^FAIR^POOR^"[("^"_APCHSLVT_"^") APCHSLVT=APCHSLVT_" UNDERSTANDING"
.. S APCHSLVT="- "_APCHSLVT
.;X APCHSCKP Q:$D(APCHSQIT)
.S BSDXTMP=APCHSX_" "_$S($P(APCHSN,U,7)="":"",$P(APCHSN,U,7)="I":" - (IND)",$P(APCHSN,U,7)="G":" - (GRP)",1:"")_" "_APCHSLVT
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(56-$L(BSDXTMP))_APCHSDAT
.S BSDXTMP=BSDXTMP_$$FILL^BSDX41(66-$L(BSDXTMP))_APCHSNSH
.S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
.S BSDXTMP=""
.I $P(APCHSN,U,13)]""!($P(APCHSN,U,14)]"") D
..;X APCHSCKP Q:$D(APCHSQIT)
..S BSDXTMP=$$FILL^BSDX41(22)_"Behavior Code: "_$$VAL^XBDIQ1(9000010.16,APCHSDFN,.13)
..S BSDXTMP=BSDXTMP_$$FILL^BSDX41(50-$L(BSDXTMP))_"Objectives Met: "_$P(APCHSN,U,14)
..S BSDXI=BSDXI+1 S ^BSDXTMP($J,BSDXI)=BSDXTMP_$C(30)
..S BSDXTMP=""
.I $P($G(^AUPNVPED(APCHSDFN,11)),U)]"" S APCHSTXT=$P(^AUPNVPED(APCHSDFN,11),U),APCHSNRQ="",APCHSICL=5 D PRTTXT^BSDX41F
.;cmi/anch/maw 8/27/2007 mods follow for code set versioning
.;I $P($G(^AUPNVPED(APCHSDFN,11)),U)="",$P(APCHSN,U,4)]"" S APCHSTXT=$P(^ICD9($P(APCHSN,U,4),0),U,3),APCHSNRQ="",APCHSICL=5 D PRTTXT^BSDX41F
.N APCHSVDT
.S APCHSVDT=$P($P($G(^AUPNVSIT(APCHSVDF,0)),U),".") ;get visit date
.I $P($G(^AUPNVPED(APCHSDFN,11)),U)="",$P(APCHSN,U,4)]"" S APCHSTXT=$P($$ICDDX^ICDCODE($P(APCHSN,U,4),APCHSVDT),U,4),APCHSNRQ="",APCHSICL=5 D PRTTXT^BSDX41F
.;cmi/anch/maw 8/27/2007 end of mods
.I $P(APCHSN,U,11)]"" S APCHSTXT=$P(APCHSN,U,11),APCHSNRQ="",APCHSICL=5 D PRTTXT^BSDX41F Q
;now print all dental ADA
Q
DENTEDL ;gather up last of each
K APCHSDEN S APCHSDTU=0
S APCHSDE1=$O(^AUTTADA("B",1310,0))
S APCHSDE2=$O(^AUTTADA("B",1320,0))
S APCHSDE3=$O(^AUTTADA("B",1330,0))
S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVDEN("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D
.S APCHSDFN="" F S APCHSDFN=$O(^AUPNVDEN("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:'APCHSDFN D
..S X=$P($G(^AUPNVDEN(APCHSDFN,0)),U) I X=APCHSDE1!(X=APCHSDE2)!(X=APCHSDE3) I '$D(APCHSDEN("DEN",X)) S APCHSDEN(APCHSIVD,"DEN",APCHSDFN)=$P(^AUPNVDEN(APCHSDFN,0),U),APCHSDEN("DEN",X)=""
.Q
Q
DENTED ;gather up all 1310, 1320, 1330
K APCHSDEN S APCHSDTU=0
S APCHSDE1=$O(^AUTTADA("B",1310,0))
S APCHSDE2=$O(^AUTTADA("B",1320,0))
S APCHSDE3=$O(^AUTTADA("B",1330,0))
S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVDEN("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D
.S APCHSDFN="" F S APCHSDFN=$O(^AUPNVDEN("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:'APCHSDFN D
..S X=$P($G(^AUPNVDEN(APCHSDFN,0)),U) I X=APCHSDE1!(X=APCHSDE2)!(X=APCHSDE3) S APCHSDEN(APCHSIVD,"DEN",APCHSDFN)=$P(^AUPNVDEN(APCHSDFN,0),U),APCHSDTU=APCHSDTU+1
.Q
Q
DENTAL ;
K APCHSDEN,APCHSDSP
K APCHSDEN S APCHSDTU=0
S APCHSDE1=$O(^AUTTADA("B",1310,0))
S APCHSDE2=$O(^AUTTADA("B",1320,0))
S APCHSDE3=$O(^AUTTADA("B",1330,0))
S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVDEN("AA",APCHSPAT,APCHSIVD)) Q:APCHSIVD=""!(APCHSIVD>APCHSDLM) D
.S APCHSDFN="" F S APCHSDFN=$O(^AUPNVDEN("AA",APCHSPAT,APCHSIVD,APCHSDFN)) Q:'APCHSDFN D
..S X=$P($G(^AUPNVDEN(APCHSDFN,0)),U) I X=APCHSDE1!(X=APCHSDE2)!(X=APCHSDE3) I '$D(APCHSDEN("DEN",X)) S APCHSDSP($P(^AUTTADA(X,0),U,2))=APCHSIVD_U_APCHSDFN_U_"D",APCHSDEN("DEN",X)=""
.Q
BSDX41L ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
+1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
+2 ;
PTED ; ********** PATIENT EDUCATION * 9000010.16 **********
+1 ; <SETUP>
+2 ;Q:'$D(^AUPNVPED("AA",APCHSPAT))
+3 KILL APCHSDEN
DO DENTED
+4 ;no ada or v pt ed
IF '$DATA(^AUPNVPED("AA",APCHSPAT))
IF '$DATA(APCHSDEN)
QUIT
+5 ;X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
+6 ; <DISPLAY>
+7 SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVPED("AA",APCHSPAT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
DO ONEDATE
+8 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(APCHSDEN(APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)!('APCHSNDM)
QUIT
SET Y=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
SET APCHSDTU=0
Begin DoDot:1
+9 SET APCHSDFN=0
FOR
SET APCHSDFN=$ORDER(APCHSDEN(APCHSIVD,"PED",APCHSDFN))
IF APCHSDFN'=+APCHSDFN!($DATA(APCHSQIT))!('APCHSNDM)
QUIT
DO PEDCHK
SET APCHSNDM=APCHSNDM-APCHSDTU
+10 SET APCHSDFN=0
SET APCHSCNT=0
FOR
SET APCHSDFN=$ORDER(APCHSDEN(APCHSIVD,"DEN",APCHSDFN))
IF APCHSDFN'=+APCHSDFN!($DATA(APCHSQIT))!('APCHSNDM)
QUIT
Begin DoDot:2
+11 SET APCHX=APCHSDEN(APCHSIVD,"DEN",APCHSDFN)
+12 ;X APCHSCKP Q:$D(APCHSQIT)
+13 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+14 SET APCHSVDF=$PIECE(^AUPNVDEN(APCHSDFN,0),U,3)
+15 IF '$DATA(^AUPNVSIT(APCHSVDF,0))
QUIT
+16 DO GETSITEV^BSDX41I
+17 IF 'APCHSCNT
SET BSDXTMP=APCHSDAT_$$FILL^BSDX41(9-$LENGTH(APCHSDAT))_APCHSNSH
+18 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$$FILL^BSDX41(22-$LENGTH(BSDXTMP))_"ADA: "_$PIECE(^AUTTADA(APCHX,0),U)_" - "_$EXTRACT($PIECE(^AUTTADA(APCHX,0),U,2),1,40)_$CHAR(30)
+19 SET APCHSCNT=APCHSCNT+1
+20 QUIT
End DoDot:2
End DoDot:1
+21 ; <CLEANUP>
+22 ;now display PTED refusals
+23 SET APCHST="EDUCATION"
SET APCHSFN=9999999.09
DO DISPREF^BSDX41F
+24 KILL APCHST,APCHSFN
PTEDX KILL APCHSIVD,APCHSDAT,APCHSDFN,APCHSFO,APCHSFAC,APCHSN,APCHSDTU,APCHSLVL,APCHSLVT,APCHSPED,APCHSPTB,APCHSQ,Y
+1 KILL APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSVDF,APCHSDEN,APCHSDE1,APCHSDE2,APCHSDE3,APCHX
+2 QUIT
ONEDATE SET APCHSDFN=""
FOR APCHSQ=0:0
SET APCHSDFN=$ORDER(^AUPNVPED("AA",APCHSPAT,APCHSIVD,APCHSDFN))
IF APCHSDFN=""
QUIT
SET APCHSDEN(APCHSIVD,"PED",APCHSDFN)=""
+1 QUIT
PEDCHK SET APCHSN=^AUPNVPED(APCHSDFN,0)
+1 SET APCHSVDF=$PIECE(APCHSN,U,3)
DO GETSITEV^BSDX41I
+2 ;X APCHSCKP Q:$D(APCHSQIT)
+3 IF APCHSNPG
SET APCHSDTU=0
+4 IF 'APCHSDTU
SET BSDXTMP=APCHSDAT
SET APCHSFO=""
+5 IF APCHSNSH=APCHSFO
SET APCHSFAC=""
+6 IF '$TEST
SET (APCHSFAC,APCHSFO)=APCHSNSH
+7 SET APCHSDTU=1
+8 SET APCHSPED=$PIECE(APCHSN,U,1)
SET APCHSPEM=$PIECE(^AUTTEDT(APCHSPED,0),U,2)
SET APCHSPED=$PIECE(^AUTTEDT(APCHSPED,0),U,1)
+9 SET APCHSLVL=$PIECE(APCHSN,U,6)
SET APCHSLVT=""
+10 IF APCHSLVL]""
Begin DoDot:1
+11 SET APCHSLVT=$PIECE(^DD(9000010.16,.06,0),U,3)
+12 SET APCHSLVT=$PIECE(APCHSLVT,APCHSLVL_":",2)
+13 SET APCHSLVT=$PIECE(APCHSLVT,";",1)
+14 IF "^GOOD^FAIR^POOR^"[("^"_APCHSLVT_"^")
SET APCHSLVT=APCHSLVT_" UNDERSTANDING"
+15 ;S APCHSLVT="- "_APCHSLVT
+16 QUIT
End DoDot:1
+17 ;X APCHSCKP Q:$D(APCHSQIT)
+18 IF APCHSNPG
Begin DoDot:1
+19 SET BSDXTMP=BSDXTMP_APCHSDAT
+20 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(9-$LENGTH(BSDXTMP))_APCHSFAC
+21 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$LENGTH(BSDXTMP))_$EXTRACT(APCHSPEM,1,12)
+22 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(34-$LENGTH(BSDXTMP))_$EXTRACT(APCHSPED,1,35)_$SELECT($PIECE(APCHSN,U,7)="":"",$PIECE(APCHSN,U,7)="I":" - (IND)",$PIECE(APCHSN,U,7)="G":" - (GRP)",1:"")
+23 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+24 SET BSDXTMP=""
End DoDot:1
+25 IF APCHSLVT]""
SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$$FILL^BSDX41(34-$LENGTH(BSDXTMP))_APCHSLVT_$CHAR(30)
+26 IF $PIECE(APCHSN,U,13)]""!($PIECE(APCHSN,U,14)]"")
Begin DoDot:1
+27 ;X APCHSCKP Q:$D(APCHSQIT)
+28 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(22-$LENGTH(BSDXTMP))_"Behavior Code: "_$$VAL^XBDIQ1(9000010.16,APCHSDFN,.13)
+29 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(50-$LENGTH(BSDXTMP))_"Objectives Met: "_$PIECE(APCHSN,U,14)
+30 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+31 SET BSDXTMP=""
End DoDot:1
+32 IF $PIECE($GET(^AUPNVPED(APCHSDFN,11)),U)]""
SET APCHSTXT=$PIECE(^AUPNVPED(APCHSDFN,11),U)
SET APCHSNRQ=""
SET APCHSICL=23
DO PRTTXT^BSDX41F
+33 ;cmi/anch/maw 8/27/2007 mods follow for code set versioning
+34 ;I $P($G(^AUPNVPED(APCHSDFN,11)),U)="",$P(APCHSN,U,4)]"" S APCHSTXT=$P(^ICD9($P(APCHSN,U,4),0),U,3),APCHSNRQ="",APCHSICL=23 D PRTTXT^BSDX41F
+35 NEW APCHSVDT
+36 ;get visit date
SET APCHSVDT=$PIECE($PIECE($GET(^AUPNVSIT(APCHSVDF,0)),U),".")
+37 IF $PIECE($GET(^AUPNVPED(APCHSDFN,11)),U)=""
IF $PIECE(APCHSN,U,4)]""
SET APCHSTXT=$PIECE($$ICDDX^ICDCODE($PIECE(APCHSN,U,4),APCHSVDT),U,4)
SET APCHSNRQ=""
SET APCHSICL=23
DO PRTTXT^BSDX41F
+38 ;cmi/anch/maw 8/27/2007 end of mods
+39 IF $PIECE(APCHSN,U,11)]""
SET APCHSTXT=$PIECE(APCHSN,U,11)
SET APCHSNRQ=""
SET APCHSICL=23
DO PRTTXT^BSDX41F
QUIT
+40 QUIT
+41 ;
MRPTED ; ********** MOST RECENT PATIENT EDUCATION * 9000010.16 **********
+1 ; <SETUP>
+2 ;Q:'$D(^AUPNVPED("AA",APCHSPAT))
+3 KILL APCHSDEN
DO DENTEDL
+4 ;no ada or v pt ed
IF '$DATA(^AUPNVPED("AA",APCHSPAT))
IF '$DATA(APCHSDEN)
QUIT
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+6 ; <DISPLAY>
+7 KILL APCHSPTB
+8 ;S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD)) Q:'APCHSIVD S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y D ONEDAY Q:$D(APCHSQIT)
+9 ;IHS/CMI/LAB - PATCH 9 modified this to look at date range and max visit limits
+10 SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVPED("AA",APCHSPAT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
DO ONEDAY
+11 SET APCHSIVD=0
FOR
SET APCHSIVD=$ORDER(APCHSDEN(APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)!('APCHSNDM)
QUIT
SET Y=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
SET APCHSDTU=0
Begin DoDot:1
+12 SET APCHSDFN=0
FOR
SET APCHSDFN=$ORDER(APCHSDEN(APCHSIVD,"PED",APCHSDFN))
IF APCHSDFN'=+APCHSDFN!($DATA(APCHSQIT))!('APCHSNDM)
QUIT
DO PEDCHK
SET APCHSNDM=APCHSNDM-APCHSDTU
+13 SET APCHSDFN=0
SET APCHSCNT=0
FOR
SET APCHSDFN=$ORDER(APCHSDEN(APCHSIVD,"DEN",APCHSDFN))
IF APCHSDFN'=+APCHSDFN!($DATA(APCHSQIT))!('APCHSNDM)
QUIT
Begin DoDot:2
+14 SET APCHX=APCHSDEN(APCHSIVD,"DEN",APCHSDFN)
+15 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+16 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
+17 SET APCHSVDF=$PIECE(^AUPNVDEN(APCHSDFN,0),U,3)
+18 DO GETSITEV^BSDX41I
+19 IF 'APCHSCNT
SET BSDXTMP=APCHSDAT_$$FILL^BSDX41(9-$LENGTH(APCHSDAT))_APCHSNSH
+20 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$$FILL^BSDX41(22-$LENGTH(BSDXTMP))_"ADA: "_$PIECE(^AUTTADA(APCHX,0),U)_" - "_$EXTRACT($PIECE(^AUTTADA(APCHX,0),U,2),1,40)_$CHAR(30)
+21 SET APCHSCNT=APCHSCNT+1
+22 QUIT
End DoDot:2
End DoDot:1
+23 ; <CLEANUP>
+24 ;now display PTED refusals
+25 SET APCHST="EDUCATION"
SET APCHSFN=9999999.09
DO DISPREF^BSDX41F
+26 KILL APCHST,APCHSFN
MRPTEDX KILL APCHSPTB,APCHSEVT
+1 KILL APCHSIVD,APCHSDAT,APCHSDFN,APCHSFO,APCHSFAC,APCHSN,APCHSDTU,APCHSLVL,APCHSLVT,APCHSPED
+2 KILL APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSVDF
+3 QUIT
+4 ;
ONEDAY ;
+1 SET APCHSDFN=""
FOR APCHSQ=0:0
SET APCHSDFN=$ORDER(^AUPNVPED("AA",APCHSPAT,APCHSIVD,APCHSDFN))
IF 'APCHSDFN
QUIT
SET APCHSEVT=+^AUPNVPED(APCHSDFN,0)
IF '$DATA(APCHSPTB(APCHSEVT))
SET APCHSPTB(APCHSEVT)=""
SET APCHSDEN(APCHSIVD,"PED",APCHSDFN)=""
+2 QUIT
MRPE ;EP - called from component
+1 ; <SETUP>
+2 ;Q:'$D(^AUPNVPED("AA",APCHSPAT))
+3 KILL APCHSDEN
DO DENTAL
+4 ;no ada or v pt ed
IF '$DATA(^AUPNVPED("AA",APCHSPAT))
IF '$DATA(APCHSDEN)
QUIT
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+6 ; <DISPLAY>
+7 KILL APCHSPTB
+8 ;S APCHSIVD="" F APCHSQ=0:0 S APCHSIVD=$O(^AUPNVPED("AA",APCHSPAT,APCHSIVD)) Q:'APCHSIVD S Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y D ONEDAY Q:$D(APCHSQIT)
+9 ;IHS/CMI/LAB - PATCH 9 modified this to look at date range and max visit limits
+10 SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVPED("AA",APCHSPAT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)!('APCHSNDM)
QUIT
Begin DoDot:1
+11 SET Y=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
SET APCHSDTU=0
DO MRPEOD
IF $DATA(APCHSQIT)
QUIT
SET APCHSNDM=APCHSNDM-APCHSDTU
IF 'APCHSNDM
QUIT
End DoDot:1
+12 DO REORDER
+13 ; <CLEANUP>
+14 ;now display PTED refusals
+15 SET APCHST="EDUCATION"
SET APCHSFN=9999999.09
DO DISPREF^BSDX41F
+16 KILL APCHST,APCHSFN
MRPEX KILL APCHSPTB,APCHSEVT,APCHSDSP,APCHSX
+1 KILL APCHSIVD,APCHSDAT,APCHSDFN,APCHSFO,APCHSFAC,APCHSN,APCHSDTU,APCHSLVL,APCHSLVT,APCHSPED
+2 KILL APCHSNFL,APCHSNSH,APCHSNAB,APCHSVSC,APCHSVDF
+3 QUIT
+4 ;
MRPEOD ;
+1 SET APCHSDFN=""
FOR APCHSQ=0:0
SET APCHSDFN=$ORDER(^AUPNVPED("AA",APCHSPAT,APCHSIVD,APCHSDFN))
IF 'APCHSDFN
QUIT
SET APCHSEVT=+^AUPNVPED(APCHSDFN,0)
IF '$DATA(APCHSPTB(APCHSEVT))
SET APCHSPTB(APCHSEVT)=APCHSIVD_U_APCHSDFN
SET APCHSDTU=1
+2 QUIT
REORDER ;reorder by name and print
+1 SET APCHSEVT=0
FOR
SET APCHSEVT=$ORDER(APCHSPTB(APCHSEVT))
IF APCHSEVT'=+APCHSEVT
QUIT
IF $DATA(^AUTTEDT(APCHSEVT,0))
SET APCHSDSP($PIECE(^AUTTEDT(APCHSEVT,0),U))=APCHSPTB(APCHSEVT)
+2 SET APCHSX=""
FOR
SET APCHSX=$ORDER(APCHSDSP(APCHSX))
IF APCHSX=""!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+3 SET APCHSDFN=$PIECE(APCHSDSP(APCHSX),U,2)
+4 SET APCHSIVD=$PIECE(APCHSDSP(APCHSX),U)
SET Y=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
+5 IF $PIECE(APCHSDSP(APCHSX),U,3)="D"
SET APCHSN=^AUPNVDEN(APCHSDFN,0)
+6 IF '$TEST
SET APCHSN=^AUPNVPED(APCHSDFN,0)
+7 SET APCHSVDF=$PIECE(APCHSN,U,3)
DO GETSITEV^BSDX41I
+8 IF $PIECE(APCHSDSP(APCHSX),U,3)="D"
Begin DoDot:2
+9 ;X APCHSCKP Q:$D(APCHSQIT)
+10 SET BSDXTMP=$EXTRACT(APCHSX,1,43)_" ADA Code: "_$PIECE(^AUTTADA($PIECE(^AUPNVDEN(APCHSDFN,0),U),0),U)
+11 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(56-$LENGTH(BSDXTMP))_APCHSDAT
+12 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(66-$LENGTH(BSDXTMP))_APCHSNSH
+13 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+14 SET BSDXTMP=""
+15 QUIT
End DoDot:2
QUIT
+16 SET APCHSLVL=$PIECE(APCHSN,U,6)
SET APCHSLVT=""
+17 IF APCHSLVL]""
Begin DoDot:2
+18 SET APCHSLVT=$PIECE(^DD(9000010.16,.06,0),U,3)
+19 SET APCHSLVT=$PIECE(APCHSLVT,APCHSLVL_":",2)
+20 SET APCHSLVT=$PIECE(APCHSLVT,";",1)
+21 IF "^GOOD^FAIR^POOR^"[("^"_APCHSLVT_"^")
SET APCHSLVT=APCHSLVT_" UNDERSTANDING"
+22 SET APCHSLVT="- "_APCHSLVT
End DoDot:2
+23 ;X APCHSCKP Q:$D(APCHSQIT)
+24 SET BSDXTMP=APCHSX_" "_$SELECT($PIECE(APCHSN,U,7)="":"",$PIECE(APCHSN,U,7)="I":" - (IND)",$PIECE(APCHSN,U,7)="G":" - (GRP)",1:"")_" "_APCHSLVT
+25 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(56-$LENGTH(BSDXTMP))_APCHSDAT
+26 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(66-$LENGTH(BSDXTMP))_APCHSNSH
+27 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+28 SET BSDXTMP=""
+29 IF $PIECE(APCHSN,U,13)]""!($PIECE(APCHSN,U,14)]"")
Begin DoDot:2
+30 ;X APCHSCKP Q:$D(APCHSQIT)
+31 SET BSDXTMP=$$FILL^BSDX41(22)_"Behavior Code: "_$$VAL^XBDIQ1(9000010.16,APCHSDFN,.13)
+32 SET BSDXTMP=BSDXTMP_$$FILL^BSDX41(50-$LENGTH(BSDXTMP))_"Objectives Met: "_$PIECE(APCHSN,U,14)
+33 SET BSDXI=BSDXI+1
SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP_$CHAR(30)
+34 SET BSDXTMP=""
End DoDot:2
+35 IF $PIECE($GET(^AUPNVPED(APCHSDFN,11)),U)]""
SET APCHSTXT=$PIECE(^AUPNVPED(APCHSDFN,11),U)
SET APCHSNRQ=""
SET APCHSICL=5
DO PRTTXT^BSDX41F
+36 ;cmi/anch/maw 8/27/2007 mods follow for code set versioning
+37 ;I $P($G(^AUPNVPED(APCHSDFN,11)),U)="",$P(APCHSN,U,4)]"" S APCHSTXT=$P(^ICD9($P(APCHSN,U,4),0),U,3),APCHSNRQ="",APCHSICL=5 D PRTTXT^BSDX41F
+38 NEW APCHSVDT
+39 ;get visit date
SET APCHSVDT=$PIECE($PIECE($GET(^AUPNVSIT(APCHSVDF,0)),U),".")
+40 IF $PIECE($GET(^AUPNVPED(APCHSDFN,11)),U)=""
IF $PIECE(APCHSN,U,4)]""
SET APCHSTXT=$PIECE($$ICDDX^ICDCODE($PIECE(APCHSN,U,4),APCHSVDT),U,4)
SET APCHSNRQ=""
SET APCHSICL=5
DO PRTTXT^BSDX41F
+41 ;cmi/anch/maw 8/27/2007 end of mods
+42 IF $PIECE(APCHSN,U,11)]""
SET APCHSTXT=$PIECE(APCHSN,U,11)
SET APCHSNRQ=""
SET APCHSICL=5
DO PRTTXT^BSDX41F
QUIT
End DoDot:1
+43 ;now print all dental ADA
+44 QUIT
DENTEDL ;gather up last of each
+1 KILL APCHSDEN
SET APCHSDTU=0
+2 SET APCHSDE1=$ORDER(^AUTTADA("B",1310,0))
+3 SET APCHSDE2=$ORDER(^AUTTADA("B",1320,0))
+4 SET APCHSDE3=$ORDER(^AUTTADA("B",1330,0))
+5 SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVDEN("AA",APCHSPAT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
Begin DoDot:1
+6 SET APCHSDFN=""
FOR
SET APCHSDFN=$ORDER(^AUPNVDEN("AA",APCHSPAT,APCHSIVD,APCHSDFN))
IF 'APCHSDFN
QUIT
Begin DoDot:2
+7 SET X=$PIECE($GET(^AUPNVDEN(APCHSDFN,0)),U)
IF X=APCHSDE1!(X=APCHSDE2)!(X=APCHSDE3)
IF '$DATA(APCHSDEN("DEN",X))
SET APCHSDEN(APCHSIVD,"DEN",APCHSDFN)=$PIECE(^AUPNVDEN(APCHSDFN,0),U)
SET APCHSDEN("DEN",X)=""
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
DENTED ;gather up all 1310, 1320, 1330
+1 KILL APCHSDEN
SET APCHSDTU=0
+2 SET APCHSDE1=$ORDER(^AUTTADA("B",1310,0))
+3 SET APCHSDE2=$ORDER(^AUTTADA("B",1320,0))
+4 SET APCHSDE3=$ORDER(^AUTTADA("B",1330,0))
+5 SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVDEN("AA",APCHSPAT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
Begin DoDot:1
+6 SET APCHSDFN=""
FOR
SET APCHSDFN=$ORDER(^AUPNVDEN("AA",APCHSPAT,APCHSIVD,APCHSDFN))
IF 'APCHSDFN
QUIT
Begin DoDot:2
+7 SET X=$PIECE($GET(^AUPNVDEN(APCHSDFN,0)),U)
IF X=APCHSDE1!(X=APCHSDE2)!(X=APCHSDE3)
SET APCHSDEN(APCHSIVD,"DEN",APCHSDFN)=$PIECE(^AUPNVDEN(APCHSDFN,0),U)
SET APCHSDTU=APCHSDTU+1
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
DENTAL ;
+1 KILL APCHSDEN,APCHSDSP
+2 KILL APCHSDEN
SET APCHSDTU=0
+3 SET APCHSDE1=$ORDER(^AUTTADA("B",1310,0))
+4 SET APCHSDE2=$ORDER(^AUTTADA("B",1320,0))
+5 SET APCHSDE3=$ORDER(^AUTTADA("B",1330,0))
+6 SET APCHSIVD=""
FOR APCHSQ=0:0
SET APCHSIVD=$ORDER(^AUPNVDEN("AA",APCHSPAT,APCHSIVD))
IF APCHSIVD=""!(APCHSIVD>APCHSDLM)
QUIT
Begin DoDot:1
+7 SET APCHSDFN=""
FOR
SET APCHSDFN=$ORDER(^AUPNVDEN("AA",APCHSPAT,APCHSIVD,APCHSDFN))
IF 'APCHSDFN
QUIT
Begin DoDot:2
+8 SET X=$PIECE($GET(^AUPNVDEN(APCHSDFN,0)),U)
IF X=APCHSDE1!(X=APCHSDE2)!(X=APCHSDE3)
IF '$DATA(APCHSDEN("DEN",X))
SET APCHSDSP($PIECE(^AUTTADA(X,0),U,2))=APCHSIVD_U_APCHSDFN_U_"D"
SET APCHSDEN("DEN",X)=""
End DoDot:2
+9 QUIT
End DoDot:1
