APCHS10 ; IHS/CMI/LAB - PART 10 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
;;2.0;IHS PCC SUITE;**2,11**;MAY 14, 2009;Build 58
;IHS/CMI/LAB - took screen out of education topics service cat
;IHS/CMI/LAB - patch 11 added behavior code and obj to pt ed display
;IHS/CMI/LAB - added dental ada codes for education to pt ed display (1310, 1320, 1330)
;cmi/anch/maw 8/27/2007 code set versioning in PEDCHK and REORDER
;
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)
..W ! S APCHSVDF=$P(^AUPNVDEN(APCHSDFN,0),U,3)
..Q:'$D(^AUPNVSIT(APCHSVDF,0))
..D GETSITEV^APCHSUTL W:'APCHSCNT APCHSDAT,?10,APCHSNSH W ?23,"ADA: ",$P(^AUTTADA(APCHX,0),U)," - ",$E($P(^AUTTADA(APCHX,0),U,2),1,40),! S APCHSCNT=APCHSCNT+1
..Q
; <CLEANUP>
;now display PTED refusals
S APCHST="EDUCATION",APCHSFN=9999999.09 D DISPREF^APCHS3C
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="" D
.S X=$P($G(^AUPNVPED(APCHSDFN,0)),U)
.Q:'X
.Q:'$D(^AUTTEDT(X,0))
.S APCHSDEN(APCHSIVD,"PED",APCHSDFN)=""
Q
PEDCHK S APCHSN=^AUPNVPED(APCHSDFN,0)
S APCHSVDF=$P(APCHSN,U,3) D GETSITEV^APCHSUTL
X APCHSCKP Q:$D(APCHSQIT) S:APCHSNPG APCHSDTU=0
I 'APCHSDTU W 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) W:APCHSNPG APCHSDAT W ?10,APCHSFAC,?23,$E(APCHSPEM,1,12),?35,$E(APCHSPED,1,35),$S($P(APCHSN,U,7)="":"",$P(APCHSN,U,7)="I":" - (IND)",$P(APCHSN,U,7)="G":" - (GRP)",1:""),!
I APCHSLVT]"" W ?35,APCHSLVT,!
I $P(APCHSN,U,13)]""!($P(APCHSN,U,14)]"") D
.X APCHSCKP Q:$D(APCHSQIT)
.W ?23,"Behavior Code: ",$$VAL^XBDIQ1(9000010.16,APCHSDFN,.13),?51,"Objectives Met: ",$P(APCHSN,U,14),!
I $P($G(^AUPNVPED(APCHSDFN,11)),U)]"" S APCHSTXT=$P(^AUPNVPED(APCHSDFN,11),U),APCHSNRQ="",APCHSICL=23 D PRTTXT^APCHSUTL
;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^APCHSUTL
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^ICDEX($P(APCHSN,U,4),APCHSVDT),U,4),APCHSNRQ="",APCHSICL=23 D PRTTXT^APCHSUTL
;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^APCHSUTL 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)
..W ! S APCHSVDF=$P(^AUPNVDEN(APCHSDFN,0),U,3) D GETSITEV^APCHSUTL W:'APCHSCNT APCHSDAT,?10,APCHSNSH W ?23,"ADA: ",$P(^AUTTADA(APCHX,0),U)," - ",$E($P(^AUTTADA(APCHX,0),U,2),1,40),! S APCHSCNT=APCHSCNT+1
..Q
; <CLEANUP>
;now display PTED refusals
S APCHST="EDUCATION",APCHSFN=9999999.09 D DISPREF^APCHS3C
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 D
.S X=$P($G(^AUPNVPED(APCHSDFN,0)),U)
.Q:X=""
.Q:'$D(^AUTTEDT(X,0))
.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^APCHS3C
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^APCHSUTL
.I $P(APCHSDSP(APCHSX),U,3)="D" D Q
..X APCHSCKP Q:$D(APCHSQIT)
..W $E(APCHSX,1,43)," ADA Code: ",$P(^AUTTADA($P(^AUPNVDEN(APCHSDFN,0),U),0),U),?57,APCHSDAT,?67,APCHSNSH,! 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) W APCHSX," ",$S($P(APCHSN,U,7)="":"",$P(APCHSN,U,7)="I":" - (IND)",$P(APCHSN,U,7)="G":" - (GRP)",1:"")," ",APCHSLVT,?57,APCHSDAT,?67,APCHSNSH,!
.I $P(APCHSN,U,13)]""!($P(APCHSN,U,14)]"") D
..X APCHSCKP Q:$D(APCHSQIT)
..W ?23,"Behavior Code: ",$$VAL^XBDIQ1(9000010.16,APCHSDFN,.13),?51,"Objectives Met: ",$P(APCHSN,U,14),!
.I $P($G(^AUPNVPED(APCHSDFN,11)),U)]"" S APCHSTXT=$P(^AUPNVPED(APCHSDFN,11),U),APCHSNRQ="",APCHSICL=5 D PRTTXT^APCHSUTL
.;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^APCHSUTL
.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^ICDEX($P(APCHSN,U,4),APCHSVDT),U,4),APCHSNRQ="",APCHSICL=5 D PRTTXT^APCHSUTL
.;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^APCHSUTL 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
APCHS10 ; IHS/CMI/LAB - PART 10 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ;
+1 ;;2.0;IHS PCC SUITE;**2,11**;MAY 14, 2009;Build 58
+2 ;IHS/CMI/LAB - took screen out of education topics service cat
+3 ;IHS/CMI/LAB - patch 11 added behavior code and obj to pt ed display
+4 ;IHS/CMI/LAB - added dental ada codes for education to pt ed display (1310, 1320, 1330)
+5 ;cmi/anch/maw 8/27/2007 code set versioning in PEDCHK and REORDER
+6 ;
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 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE 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 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+13 WRITE !
SET APCHSVDF=$PIECE(^AUPNVDEN(APCHSDFN,0),U,3)
+14 IF '$DATA(^AUPNVSIT(APCHSVDF,0))
QUIT
+15 DO GETSITEV^APCHSUTL
IF 'APCHSCNT
WRITE APCHSDAT,?10,APCHSNSH
WRITE ?23,"ADA: ",$PIECE(^AUTTADA(APCHX,0),U)," - ",$EXTRACT($PIECE(^AUTTADA(APCHX,0),U,2),1,40),!
SET APCHSCNT=APCHSCNT+1
+16 QUIT
End DoDot:2
End DoDot:1
+17 ; <CLEANUP>
+18 ;now display PTED refusals
+19 SET APCHST="EDUCATION"
SET APCHSFN=9999999.09
DO DISPREF^APCHS3C
+20 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
Begin DoDot:1
+1 SET X=$PIECE($GET(^AUPNVPED(APCHSDFN,0)),U)
+2 IF 'X
QUIT
+3 IF '$DATA(^AUTTEDT(X,0))
QUIT
+4 SET APCHSDEN(APCHSIVD,"PED",APCHSDFN)=""
End DoDot:1
+5 QUIT
PEDCHK SET APCHSN=^AUPNVPED(APCHSDFN,0)
+1 SET APCHSVDF=$PIECE(APCHSN,U,3)
DO GETSITEV^APCHSUTL
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
SET APCHSDTU=0
+3 IF 'APCHSDTU
WRITE APCHSDAT
SET APCHSFO=""
+4 IF APCHSNSH=APCHSFO
SET APCHSFAC=""
+5 IF '$TEST
SET (APCHSFAC,APCHSFO)=APCHSNSH
+6 SET APCHSDTU=1
+7 SET APCHSPED=$PIECE(APCHSN,U,1)
SET APCHSPEM=$PIECE(^AUTTEDT(APCHSPED,0),U,2)
SET APCHSPED=$PIECE(^AUTTEDT(APCHSPED,0),U,1)
+8 SET APCHSLVL=$PIECE(APCHSN,U,6)
SET APCHSLVT=""
+9 IF APCHSLVL]""
Begin DoDot:1
+10 SET APCHSLVT=$PIECE(^DD(9000010.16,.06,0),U,3)
+11 SET APCHSLVT=$PIECE(APCHSLVT,APCHSLVL_":",2)
+12 SET APCHSLVT=$PIECE(APCHSLVT,";",1)
+13 IF "^GOOD^FAIR^POOR^"[("^"_APCHSLVT_"^")
SET APCHSLVT=APCHSLVT_" UNDERSTANDING"
+14 ;S APCHSLVT="- "_APCHSLVT
+15 QUIT
End DoDot:1
+16 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
WRITE APCHSDAT
WRITE ?10,APCHSFAC,?23,$EXTRACT(APCHSPEM,1,12),?35,$EXTRACT(APCHSPED,1,35),$SELECT($PIECE(APCHSN,U,7)="":"",$PIECE(APCHSN,U,7)="I":" - (IND)",$PIECE(APCHSN,U,7)="G":" - (GRP)",1:""),!
+17 IF APCHSLVT]""
WRITE ?35,APCHSLVT,!
+18 IF $PIECE(APCHSN,U,13)]""!($PIECE(APCHSN,U,14)]"")
Begin DoDot:1
+19 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+20 WRITE ?23,"Behavior Code: ",$$VAL^XBDIQ1(9000010.16,APCHSDFN,.13),?51,"Objectives Met: ",$PIECE(APCHSN,U,14),!
End DoDot:1
+21 IF $PIECE($GET(^AUPNVPED(APCHSDFN,11)),U)]""
SET APCHSTXT=$PIECE(^AUPNVPED(APCHSDFN,11),U)
SET APCHSNRQ=""
SET APCHSICL=23
DO PRTTXT^APCHSUTL
+22 ;cmi/anch/maw 8/27/2007 mods follow for code set versioning
+23 ;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^APCHSUTL
+24 NEW APCHSVDT
+25 ;get visit date
SET APCHSVDT=$PIECE($PIECE($GET(^AUPNVSIT(APCHSVDF,0)),U),".")
+26 IF $PIECE($GET(^AUPNVPED(APCHSDFN,11)),U)=""
IF $PIECE(APCHSN,U,4)]""
SET APCHSTXT=$PIECE($$ICDDX^ICDEX($PIECE(APCHSN,U,4),APCHSVDT),U,4)
SET APCHSNRQ=""
SET APCHSICL=23
DO PRTTXT^APCHSUTL
+27 ;cmi/anch/maw 8/27/2007 end of mods
+28 IF $PIECE(APCHSN,U,11)]""
SET APCHSTXT=$PIECE(APCHSN,U,11)
SET APCHSNRQ=""
SET APCHSICL=23
DO PRTTXT^APCHSUTL
QUIT
+29 QUIT
+30 ;
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 WRITE !
SET APCHSVDF=$PIECE(^AUPNVDEN(APCHSDFN,0),U,3)
DO GETSITEV^APCHSUTL
IF 'APCHSCNT
WRITE APCHSDAT,?10,APCHSNSH
WRITE ?23,"ADA: ",$PIECE(^AUTTADA(APCHX,0),U)," - ",$EXTRACT($PIECE(^AUTTADA(APCHX,0),U,2),1,40),!
SET APCHSCNT=APCHSCNT+1
+17 QUIT
End DoDot:2
End DoDot:1
+18 ; <CLEANUP>
+19 ;now display PTED refusals
+20 SET APCHST="EDUCATION"
SET APCHSFN=9999999.09
DO DISPREF^APCHS3C
+21 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
Begin DoDot:1
+2 SET X=$PIECE($GET(^AUPNVPED(APCHSDFN,0)),U)
+3 IF X=""
QUIT
+4 IF '$DATA(^AUTTEDT(X,0))
QUIT
+5 SET APCHSEVT=+^AUPNVPED(APCHSDFN,0)
IF '$DATA(APCHSPTB(APCHSEVT))
SET APCHSPTB(APCHSEVT)=""
SET APCHSDEN(APCHSIVD,"PED",APCHSDFN)=""
End DoDot:1
+6 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^APCHS3C
+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^APCHSUTL
+8 IF $PIECE(APCHSDSP(APCHSX),U,3)="D"
Begin DoDot:2
+9 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+10 WRITE $EXTRACT(APCHSX,1,43)," ADA Code: ",$PIECE(^AUTTADA($PIECE(^AUPNVDEN(APCHSDFN,0),U),0),U),?57,APCHSDAT,?67,APCHSNSH,!
QUIT
End DoDot:2
QUIT
+11 SET APCHSLVL=$PIECE(APCHSN,U,6)
SET APCHSLVT=""
+12 IF APCHSLVL]""
Begin DoDot:2
+13 SET APCHSLVT=$PIECE(^DD(9000010.16,.06,0),U,3)
+14 SET APCHSLVT=$PIECE(APCHSLVT,APCHSLVL_":",2)
+15 SET APCHSLVT=$PIECE(APCHSLVT,";",1)
+16 IF "^GOOD^FAIR^POOR^"[("^"_APCHSLVT_"^")
SET APCHSLVT=APCHSLVT_" UNDERSTANDING"
+17 SET APCHSLVT="- "_APCHSLVT
End DoDot:2
+18 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE APCHSX," ",$SELECT($PIECE(APCHSN,U,7)="":"",$PIECE(APCHSN,U,7)="I":" - (IND)",$PIECE(APCHSN,U,7)="G":" - (GRP)",1:"")," ",APCHSLVT,?57,APCHSDAT,?67,APCHSNSH,!
+19 IF $PIECE(APCHSN,U,13)]""!($PIECE(APCHSN,U,14)]"")
Begin DoDot:2
+20 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+21 WRITE ?23,"Behavior Code: ",$$VAL^XBDIQ1(9000010.16,APCHSDFN,.13),?51,"Objectives Met: ",$PIECE(APCHSN,U,14),!
End DoDot:2
+22 IF $PIECE($GET(^AUPNVPED(APCHSDFN,11)),U)]""
SET APCHSTXT=$PIECE(^AUPNVPED(APCHSDFN,11),U)
SET APCHSNRQ=""
SET APCHSICL=5
DO PRTTXT^APCHSUTL
+23 ;cmi/anch/maw 8/27/2007 mods follow for code set versioning
+24 ;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^APCHSUTL
+25 NEW APCHSVDT
+26 ;get visit date
SET APCHSVDT=$PIECE($PIECE($GET(^AUPNVSIT(APCHSVDF,0)),U),".")
+27 IF $PIECE($GET(^AUPNVPED(APCHSDFN,11)),U)=""
IF $PIECE(APCHSN,U,4)]""
SET APCHSTXT=$PIECE($$ICDDX^ICDEX($PIECE(APCHSN,U,4),APCHSVDT),U,4)
SET APCHSNRQ=""
SET APCHSICL=5
DO PRTTXT^APCHSUTL
+28 ;cmi/anch/maw 8/27/2007 end of mods
+29 IF $PIECE(APCHSN,U,11)]""
SET APCHSTXT=$PIECE(APCHSN,U,11)
SET APCHSNRQ=""
SET APCHSICL=5
DO PRTTXT^APCHSUTL
QUIT
End DoDot:1
+30 ;now print all dental ADA
+31 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
