BHSPED ;IHS/MSC/MGH - Health Summary for patient education;22-Apr-2014 09:31;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,4,9**;March 17,2006;Build 16
;===================================================================
; Copied from PART 10 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 05/04/04 2:12 PM ]
;;2.0;IHS RPMS/PCC Health Summary;**5,6,9,11,15**;JUN 24, 1997
;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)
;Changes for patch 17 added on
;Changes added in patch 3 for date on historical education
PTED ; ********** PATIENT EDUCATION * 9000010.16 **********
; <SETUP>
N BHSPAT
S BHSPAT=DFN
;Q:'$D(^AUPNVPED("AA",BHSPAT))
K BHSDEN D DENTED
I '$D(^AUPNVPED("AA",BHSPAT)),'$D(BHSDEN) Q ;no ada or v pt ed
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVPED("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) D ONEDATE
S BHSIVD=0 F S BHSIVD=$O(BHSDEN(BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM)!('GMTSNDM) S X=(-BHSIVD+9999999)\1 D REGDT4^GMTSU S BHSDAT=X S BHSDTU=0 D
.S BHSDFN=0 F S BHSDFN=$O(BHSDEN(BHSIVD,"PED",BHSDFN)) Q:BHSDFN'=+BHSDFN!($D(GMTSQIT))!('GMTSNDM) D PEDCHK S GMTSNDM=GMTSNDM-BHSDTU
.S BHSDFN=0,BHSCNT=0 F S BHSDFN=$O(BHSDEN(BHSIVD,"DEN",BHSDFN)) Q:BHSDFN'=+BHSDFN!($D(GMTSQIT))!('GMTSNDM) D
..S APCHX=BHSDEN(BHSIVD,"DEN",BHSDFN)
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W ! S BHSVDF=$P(^AUPNVDEN(BHSDFN,0),U,3) D GETSITEV^BHSUTL W:'BHSCNT BHSDAT,?12,BHSNSH W ?25,"ADA: ",$P(^AUTTADA(APCHX,0),U)," - ",$E($P(^AUTTADA(APCHX,0),U,2),1,40),! S BHSCNT=BHSCNT+1
..D GETSITEV^BHSUTL W:'BHSCNT BHSDAT,?10,BHSNSH W ?23,"ADA: ",$P(^AUTTADA(APCHX,0),U)," - ",$E($P(^AUTTADA(APCHX,0),U,2),1,40),! S BHSCNT=BHSCNT+1
..Q
; <CLEANUP>
;now display PTED refusals
S BHST="EDUCATION",BHSFN=9999999.09 D DISPREF^BHSRAD
K BHST,BHSFN
PTEDX K BHSIVD,BHSDAT,BHSDFN,BHSFO,BHSFAC,BHSN,BHSDTU,BHSLVL,BHSLVT,BHSPED,BHSPTB,BHSQ,BHSPEM,Y,X
K BHSNFL,BHSNSH,BHSNAB,BHSTYP,BHSVDT,BHSVSC,BHSVDF,BHSDEN,BHSDE1,BHSDE2,BHSDE3,APCHX,BHSICL,BHSNRQ,BHSCNT,BHSTXT
Q
ONEDATE N BHSDATE,BHSVST,BHSVTYP
S BHSDFN=""
F BHSQ=0:0 S BHSDFN=$O(^AUPNVPED("AA",BHSPAT,BHSIVD,BHSDFN)) Q:BHSDFN="" D
.;Find the entry date. Store this here first
.I $P($G(^AUPNVPED(BHSDFN,12)),U,1)'="" D
..S BHSDATE=$P($G(^AUPNVPED(BHSDFN,12)),U,1)
..;IHS/MSC/MGH updated patch 3 to find visit date for historical education
..S BHSVST=$P($G(^AUPNVPED(BHSDFN,0)),U,3)
..S BHSTYP=$P($G(^AUPNVSIT(BHSVST,0)),U,7)
..I BHSTYP="E" S BHSDATE=$P($G(^AUPNVSIT(BHSVST,0)),U,1)
..S BHSDATE=9999999-BHSDATE
..S BHSDEN(BHSDATE,"PED",BHSDFN)=""
.E S BHSDEN(BHSIVD,"PED",BHSDFN)=""
Q
PEDCHK S BHSN=^AUPNVPED(BHSDFN,0)
S BHSVDF=$P(BHSN,U,3) D GETSITEV^BHSUTL
D CKP^GMTSUP Q:$D(GMTSQIT) S:GMTSNPG BHSDTU=0
I 'BHSDTU W BHSDAT S BHSFO=""
I BHSNSH=BHSFO S BHSFAC=""
E S (BHSFAC,BHSFO)=BHSNSH
S BHSDTU=1
S BHSPED=$P(BHSN,U,1),BHSPEM=$P(^AUTTEDT(BHSPED,0),U,2),BHSPED=$P(^AUTTEDT(BHSPED,0),U,1)
S BHSLVL=$P(BHSN,U,6),BHSLVT=""
I BHSLVL]"" D
. S BHSLVT=$P(^DD(9000010.16,.06,0),U,3)
. S BHSLVT=$P(BHSLVT,BHSLVL_":",2)
. S BHSLVT=$P(BHSLVT,";",1)
. S:"^GOOD^FAIR^POOR^"[("^"_BHSLVT_"^") BHSLVT=BHSLVT_" UNDERSTANDING"
. ;S BHSLVT="- "_BHSLVT
. Q
D CKP^GMTSUP Q:$D(GMTSQIT) W:GMTSNPG BHSDAT W ?12,BHSFAC,?25,$E(BHSPEM,1,12),?37,$E(BHSPED,1,35),$S($P(BHSN,U,7)="":"",$P(BHSN,U,7)="I":" - (IND)",$P(BHSN,U,7)="G":" - (GRP)",1:""),!
I BHSLVT]"" W ?37,BHSLVT,!
I $P(BHSN,U,13)]""!($P(BHSN,U,14)]"") D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.W ?23,"Behavior Code: ",$$VAL^XBDIQ1(9000010.16,BHSDFN,.13),?51,"Objectives Met: ",$P(BHSN,U,14),!
;IHS/MSC/MGH Patch 17 changes added here
;I $P($G(^AUPNVPED(BHSDFN,11)),U)]"" S BHSTXT=$P(^AUPNVPED(BHSDFN,11),U),BHSNRQ="",BHSICL=23 D PRTTXT^BHSUTL
N BHDVDT
S BHSVDT=$P($P($G(^AUPNVSIT(BHSVDF,0)),U),".") ;get visit date
I $P($G(^AUPNVPED(BHSDFN,11)),U)="",$P(BHSN,U,4)]"" D
.;Patch 9 change for ICD-10
.I $$AICD^BHSUTL S BHSTXT=$P($$ICDDX^ICDEX($P(BHSN,U,4),BHSVDT,"","I"),U,4),BHSNRQ="",BHSICL=23 D PRTTXT^BHSUTL
.E S BHSTXT=$P($$ICDDX^ICDCODE($P(BHSN,U,4),BHSVDT),U,4),BHSNRQ="",BHSICL=23 D PRTTXT^BHSUTL
I $P(BHSN,U,11)]"" S BHSTXT=$P(BHSN,U,11),BHSNRQ="",BHSICL=23 D PRTTXT^BHSUTL Q
Q
;
MRPTED ; ********** MOST RECENT PATIENT EDUCATION * 9000010.16 **********
; <SETUP>
;Q:'$D(^AUPNVPED("AA",BHSPAT))
K BHSDEN D DENTEDL
I '$D(^AUPNVPED("AA",BHSPAT)),'$D(BHSDEN) Q ;no ada or v pt ed
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
K BHSPTB
;S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVPED("AA",BHSPAT,BHSIVD)) Q:'BHSIVD S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X D ONEDAY Q:$D(GMTSSQIT)
;IHS/CMI/LAB - PATCH 9 modified this to look at date range and max visit limits
S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVPED("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) D ONEDAY
S BHSIVD=0 F S BHSIVD=$O(BHSDEN(BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM)!('GMTSNDM) S X=(-BHSIVD+9999999)\1 D REGDT4^GMTSU S BHSDAT=X S BHSDTU=0 D
.S BHSDFN=0 F S BHSDFN=$O(BHSDEN(BHSIVD,"PED",BHSDFN)) Q:BHSDFN'=+BHSDFN!($D(GMTSQIT))!('GMTSNDM) D PEDCHK S GMTSNDM=GMTSNDM-BHSDTU
.S BHSDFN=0,BHSCNT=0 F S BHSDFN=$O(BHSDEN(BHSIVD,"DEN",BHSDFN)) Q:BHSDFN'=+BHSDFN!($D(GMTSQIT))!('GMTSNDM) D
..S APCHX=BHSDEN(BHSIVD,"DEN",BHSDFN)
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W ! S BHSVDF=$P(^AUPNVDEN(BHSDFN,0),U,3) D GETSITEV^BHSUTL W:'BHSCNT BHSDAT,?10,BHSNSH W ?23,"ADA: ",$P(^AUTTADA(APCHX,0),U)," - ",$E($P(^AUTTADA(APCHX,0),U,2),1,40),! S BHSCNT=BHSCNT+1
..Q
; <CLEANUP>
;patch 4 now display PTED refusals
S BHST="EDUCATION",BHSFN=9999999.09 D DISPREF^BHSRAD
K BHST,BHSFN
MRPTEDX K BHSPTB,BHSEVT
K BHSIVD,BHSDAT,BHSDFN,BHSFO,BHSFAC,BHSN,BHSDTU,BHSLVL,BHSLVT,BHSPED
K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSVDF
Q
;
ONEDAY ;
N X
S BHSDFN="" F BHSQ=0:0 S BHSDFN=$O(^AUPNVPED("AA",BHSPAT,BHSIVD,BHSDFN)) Q:'BHSDFN D
.S X=$P($G(^AUPNVPED(BHSDFN,0)),U)
.Q:X=""
.Q:'$D(^AUTTEDT(X,0))
.S BHSEVT=+^AUPNVPED(BHSDFN,0) I '$D(BHSPTB(BHSEVT)) S BHSPTB(BHSEVT)="",BHSDEN(BHSIVD,"PED",BHSDFN)=""
Q
MRPE ;EP - called from component
; <SETUP>
;Q:'$D(^AUPNVPED("AA",BHSPAT))
K BHSDEN D DENTAL
I '$D(^AUPNVPED("AA",BHSPAT)),'$D(BHSDEN) Q ;no ada or v pt ed
D CKP^GMTSUP Q:$D(GMTSQIT)
; <DISPLAY>
K BHSPTB
;S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVPED("AA",BHSPAT,BHSIVD)) Q:'BHSIVD S X=(-BHSIVD+9999999)\1 D REGDT4^GMTSU S BHSDAT=X D ONEDAY Q:$D(GMTSQIT)
;IHS/CMI/LAB - PATCH 9 modified this to look at date range and max visit limits
S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVPED("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM)!('GMTSNDM) D
.S X=(-BHSIVD+9999999)\1 D REGDT4^GMTSU S BHSDAT=X S BHSDTU=0 D MRPEOD Q:$D(GMTSQIT) S GMTSNDM=GMTSNDM-BHSDTU Q:'GMTSNDM
D REORDER
; <CLEANUP>
;now display PTED refusals
S BHST="EDUCATION",BHSFN=9999999.09 D DISPREF^BHSRAD
K BHST,BHSFN
MRPEX K BHSPTB,BHSEVT,BHSDSP,BHSX
K BHSIVD,BHSDAT,BHSDFN,BHSFO,BHSFAC,BHSN,BHSDTU,BHSLVL,BHSLVT,BHSPED
K BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSVDF
Q
;
MRPEOD ;
S BHSDFN="" F BHSQ=0:0 S BHSDFN=$O(^AUPNVPED("AA",BHSPAT,BHSIVD,BHSDFN)) Q:'BHSDFN S BHSEVT=+^AUPNVPED(BHSDFN,0) I '$D(BHSPTB(BHSEVT)) S BHSPTB(BHSEVT)=BHSIVD_U_BHSDFN,BHSDTU=1
Q
REORDER ;reorder by name and print
S BHSEVT=0 F S BHSEVT=$O(BHSPTB(BHSEVT)) Q:BHSEVT'=+BHSEVT I $D(^AUTTEDT(BHSEVT,0)) S BHSDSP($P(^AUTTEDT(BHSEVT,0),U))=BHSPTB(BHSEVT)
S BHSX="" F S BHSX=$O(BHSDSP(BHSX)) Q:BHSX=""!($D(GMTSQIT)) D
.S BHSDFN=$P(BHSDSP(BHSX),U,2)
.S BHSIVD=$P(BHSDSP(BHSX),U) S X=(-BHSIVD+9999999)\1 D REGDT4^GMTSU S BHSDAT=X
.I $P(BHSDSP(BHSX),U,3)="D" S BHSN=^AUPNVDEN(BHSDFN,0)
.E S BHSN=^AUPNVPED(BHSDFN,0)
.S BHSVDF=$P(BHSN,U,3) D GETSITEV^BHSUTL
.I $P(BHSDSP(BHSX),U,3)="D" D Q
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W $E(BHSX,1,43)," ADA Code: ",$P(^AUTTADA($P(^AUPNVDEN(BHSDFN,0),U),0),U),?57,BHSDAT,?67,BHSNSH,! Q
.S BHSLVL=$P(BHSN,U,6),BHSLVT=""
.I BHSLVL]"" D
.. S BHSLVT=$P(^DD(9000010.16,.06,0),U,3)
.. S BHSLVT=$P(BHSLVT,BHSLVL_":",2)
.. S BHSLVT=$P(BHSLVT,";",1)
.. S:"^GOOD^FAIR^POOR^"[("^"_BHSLVT_"^") BHSLVT=BHSLVT_" UNDERSTANDING"
.. S BHSLVT="- "_BHSLVT
.D CKP^GMTSUP Q:$D(GMTSQIT) W BHSX," ",$S($P(BHSN,U,7)="":"",$P(BHSN,U,7)="I":" - (IND)",$P(BHSN,U,7)="G":" - (GRP)",1:"")," ",BHSLVT,?57,BHSDAT,?67,BHSNSH,!
.I $P(BHSN,U,13)]""!($P(BHSN,U,14)]"") D
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W ?23,"Behavior Code: ",$$VAL^XBDIQ1(9000010.16,BHSDFN,.13),?51,"Objectives Met: ",$P(BHSN,U,14),!
.I $P($G(^AUPNVPED(BHSDFN,11)),U)]"" S BHSTXT=$P(^AUPNVPED(BHSDFN,11),U),BHSNRQ="",BHSICL=5 D PRTTXT^BHSUTL
.;IHS/MSC/MGH Changes added for patch 17
.N BHDVDT
.S BHSVDT=$P($P($G(^AUPNVSIT(BHSVDF,0)),U),".") ;get visit date
.I $P($G(^AUPNVPED(BHSDFN,11)),U)="",$P(BHSN,U,4)]""
.;Patch 9 change for ICD-10
.I $$AICD^BHSUTL S BHSTXT=$P($$ICDDX^ICDEX($P(BHSN,U,4),BHSVDT,"","I"),U,4),BHSNRQ="",BHSICL=23 D PRTTXT^BHSUTL
.E S BHSTXT=$P($$ICDDX^ICDCODE($P(BHSN,U,4),BHSVDT),U,4),BHSNRQ="",BHSICL=5 D PRTTXT^BHSUTL
.I $P(BHSN,U,11)]"" S BHSTXT=$P(BHSN,U,11),BHSNRQ="",BHSICL=5 D PRTTXT^BHSUTL Q
;now print all dental ADA
Q
DENTEDL ;gather up last of each
K BHSDEN S BHSDTU=0
S BHSDE1=$O(^AUTTADA("B",1310,0))
S BHSDE2=$O(^AUTTADA("B",1320,0))
S BHSDE3=$O(^AUTTADA("B",1330,0))
S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVDEN("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) D
.S BHSDFN="" F S BHSDFN=$O(^AUPNVDEN("AA",BHSPAT,BHSIVD,BHSDFN)) Q:'BHSDFN D
..S X=$P($G(^AUPNVDEN(BHSDFN,0)),U) I X=BHSDE1!(X=BHSDE2)!(X=BHSDE3) I '$D(BHSDEN("DEN",X)) S BHSDEN(BHSIVD,"DEN",BHSDFN)=$P(^AUPNVDEN(BHSDFN,0),U),BHSDEN("DEN",X)=""
.Q
Q
DENTED ;gather up all 1310, 1320, 1330
K BHSDEN S BHSDTU=0
S BHSDE1=$O(^AUTTADA("B",1310,0))
S BHSDE2=$O(^AUTTADA("B",1320,0))
S BHSDE3=$O(^AUTTADA("B",1330,0))
S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVDEN("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) D
.S BHSDFN="" F S BHSDFN=$O(^AUPNVDEN("AA",BHSPAT,BHSIVD,BHSDFN)) Q:'BHSDFN D
..S X=$P($G(^AUPNVDEN(BHSDFN,0)),U) I X=BHSDE1!(X=BHSDE2)!(X=BHSDE3) S BHSDEN(BHSIVD,"DEN",BHSDFN)=$P(^AUPNVDEN(BHSDFN,0),U),BHSDTU=BHSDTU+1
.Q
Q
DENTAL ;
K BHSDEN,BHSDSP
K BHSDEN S BHSDTU=0
S BHSDE1=$O(^AUTTADA("B",1310,0))
S BHSDE2=$O(^AUTTADA("B",1320,0))
S BHSDE3=$O(^AUTTADA("B",1330,0))
S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVDEN("AA",BHSPAT,BHSIVD)) Q:BHSIVD=""!(BHSIVD>GMTSDLM) D
.S BHSDFN="" F S BHSDFN=$O(^AUPNVDEN("AA",BHSPAT,BHSIVD,BHSDFN)) Q:'BHSDFN D
..S X=$P($G(^AUPNVDEN(BHSDFN,0)),U) I X=BHSDE1!(X=BHSDE2)!(X=BHSDE3) I '$D(BHSDEN("DEN",X)) S BHSDSP($P(^AUTTADA(X,0),U,2))=BHSIVD_U_BHSDFN_U_"D",BHSDEN("DEN",X)=""
.Q
BHSPED ;IHS/MSC/MGH - Health Summary for patient education;22-Apr-2014 09:31;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,4,9**;March 17,2006;Build 16
+2 ;===================================================================
+3 ; Copied from PART 10 OF APCHS -- SUMMARY PRODUCTION COMPONENTS ; [ 05/04/04 2:12 PM ]
+4 ;;2.0;IHS RPMS/PCC Health Summary;**5,6,9,11,15**;JUN 24, 1997
+5 ;IHS/CMI/LAB - took screen out of education topics service cat
+6 ;IHS/CMI/LAB - patch 11 added behavior code and obj to pt ed display
+7 ;IHS/CMI/LAB - added dental ada codes for education to pt ed display (1310, 1320, 1330)
+8 ;Changes for patch 17 added on
+9 ;Changes added in patch 3 for date on historical education
PTED ; ********** PATIENT EDUCATION * 9000010.16 **********
+1 ; <SETUP>
+2 NEW BHSPAT
+3 SET BHSPAT=DFN
+4 ;Q:'$D(^AUPNVPED("AA",BHSPAT))
+5 KILL BHSDEN
DO DENTED
+6 ;no ada or v pt ed
IF '$DATA(^AUPNVPED("AA",BHSPAT))
IF '$DATA(BHSDEN)
QUIT
+7 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+8 ; <DISPLAY>
+9 SET BHSIVD=""
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^AUPNVPED("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
DO ONEDATE
+10 SET BHSIVD=0
FOR
SET BHSIVD=$ORDER(BHSDEN(BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)!('GMTSNDM)
QUIT
SET X=(-BHSIVD+9999999)\1
DO REGDT4^GMTSU
SET BHSDAT=X
SET BHSDTU=0
Begin DoDot:1
+11 SET BHSDFN=0
FOR
SET BHSDFN=$ORDER(BHSDEN(BHSIVD,"PED",BHSDFN))
IF BHSDFN'=+BHSDFN!($DATA(GMTSQIT))!('GMTSNDM)
QUIT
DO PEDCHK
SET GMTSNDM=GMTSNDM-BHSDTU
+12 SET BHSDFN=0
SET BHSCNT=0
FOR
SET BHSDFN=$ORDER(BHSDEN(BHSIVD,"DEN",BHSDFN))
IF BHSDFN'=+BHSDFN!($DATA(GMTSQIT))!('GMTSNDM)
QUIT
Begin DoDot:2
+13 SET APCHX=BHSDEN(BHSIVD,"DEN",BHSDFN)
+14 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+15 WRITE !
SET BHSVDF=$PIECE(^AUPNVDEN(BHSDFN,0),U,3)
DO GETSITEV^BHSUTL
IF 'BHSCNT
WRITE BHSDAT,?12,BHSNSH
WRITE ?25,"ADA: ",$PIECE(^AUTTADA(APCHX,0),U)," - ",$EXTRACT($PIECE(^AUTTADA(APCHX,0),U,2),1,40),!
SET BHSCNT=BHSCNT+1
+16 DO GETSITEV^BHSUTL
IF 'BHSCNT
WRITE BHSDAT,?10,BHSNSH
WRITE ?23,"ADA: ",$PIECE(^AUTTADA(APCHX,0),U)," - ",$EXTRACT($PIECE(^AUTTADA(APCHX,0),U,2),1,40),!
SET BHSCNT=BHSCNT+1
+17 QUIT
End DoDot:2
End DoDot:1
+18 ; <CLEANUP>
+19 ;now display PTED refusals
+20 SET BHST="EDUCATION"
SET BHSFN=9999999.09
DO DISPREF^BHSRAD
+21 KILL BHST,BHSFN
PTEDX KILL BHSIVD,BHSDAT,BHSDFN,BHSFO,BHSFAC,BHSN,BHSDTU,BHSLVL,BHSLVT,BHSPED,BHSPTB,BHSQ,BHSPEM,Y,X
+1 KILL BHSNFL,BHSNSH,BHSNAB,BHSTYP,BHSVDT,BHSVSC,BHSVDF,BHSDEN,BHSDE1,BHSDE2,BHSDE3,APCHX,BHSICL,BHSNRQ,BHSCNT,BHSTXT
+2 QUIT
ONEDATE NEW BHSDATE,BHSVST,BHSVTYP
+1 SET BHSDFN=""
+2 FOR BHSQ=0:0
SET BHSDFN=$ORDER(^AUPNVPED("AA",BHSPAT,BHSIVD,BHSDFN))
IF BHSDFN=""
QUIT
Begin DoDot:1
+3 ;Find the entry date. Store this here first
+4 IF $PIECE($GET(^AUPNVPED(BHSDFN,12)),U,1)'=""
Begin DoDot:2
+5 SET BHSDATE=$PIECE($GET(^AUPNVPED(BHSDFN,12)),U,1)
+6 ;IHS/MSC/MGH updated patch 3 to find visit date for historical education
+7 SET BHSVST=$PIECE($GET(^AUPNVPED(BHSDFN,0)),U,3)
+8 SET BHSTYP=$PIECE($GET(^AUPNVSIT(BHSVST,0)),U,7)
+9 IF BHSTYP="E"
SET BHSDATE=$PIECE($GET(^AUPNVSIT(BHSVST,0)),U,1)
+10 SET BHSDATE=9999999-BHSDATE
+11 SET BHSDEN(BHSDATE,"PED",BHSDFN)=""
End DoDot:2
+12 IF '$TEST
SET BHSDEN(BHSIVD,"PED",BHSDFN)=""
End DoDot:1
+13 QUIT
PEDCHK SET BHSN=^AUPNVPED(BHSDFN,0)
+1 SET BHSVDF=$PIECE(BHSN,U,3)
DO GETSITEV^BHSUTL
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
SET BHSDTU=0
+3 IF 'BHSDTU
WRITE BHSDAT
SET BHSFO=""
+4 IF BHSNSH=BHSFO
SET BHSFAC=""
+5 IF '$TEST
SET (BHSFAC,BHSFO)=BHSNSH
+6 SET BHSDTU=1
+7 SET BHSPED=$PIECE(BHSN,U,1)
SET BHSPEM=$PIECE(^AUTTEDT(BHSPED,0),U,2)
SET BHSPED=$PIECE(^AUTTEDT(BHSPED,0),U,1)
+8 SET BHSLVL=$PIECE(BHSN,U,6)
SET BHSLVT=""
+9 IF BHSLVL]""
Begin DoDot:1
+10 SET BHSLVT=$PIECE(^DD(9000010.16,.06,0),U,3)
+11 SET BHSLVT=$PIECE(BHSLVT,BHSLVL_":",2)
+12 SET BHSLVT=$PIECE(BHSLVT,";",1)
+13 IF "^GOOD^FAIR^POOR^"[("^"_BHSLVT_"^")
SET BHSLVT=BHSLVT_" UNDERSTANDING"
+14 ;S BHSLVT="- "_BHSLVT
+15 QUIT
End DoDot:1
+16 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
WRITE BHSDAT
WRITE ?12,BHSFAC,?25,$EXTRACT(BHSPEM,1,12),?37,$EXTRACT(BHSPED,1,35),$SELECT($PIECE(BHSN,U,7)="":"",$PIECE(BHSN,U,7)="I":" - (IND)",$PIECE(BHSN,U,7)="G":" - (GRP)",1:""),!
+17 IF BHSLVT]""
WRITE ?37,BHSLVT,!
+18 IF $PIECE(BHSN,U,13)]""!($PIECE(BHSN,U,14)]"")
Begin DoDot:1
+19 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+20 WRITE ?23,"Behavior Code: ",$$VAL^XBDIQ1(9000010.16,BHSDFN,.13),?51,"Objectives Met: ",$PIECE(BHSN,U,14),!
End DoDot:1
+21 ;IHS/MSC/MGH Patch 17 changes added here
+22 ;I $P($G(^AUPNVPED(BHSDFN,11)),U)]"" S BHSTXT=$P(^AUPNVPED(BHSDFN,11),U),BHSNRQ="",BHSICL=23 D PRTTXT^BHSUTL
+23 NEW BHDVDT
+24 ;get visit date
SET BHSVDT=$PIECE($PIECE($GET(^AUPNVSIT(BHSVDF,0)),U),".")
+25 IF $PIECE($GET(^AUPNVPED(BHSDFN,11)),U)=""
IF $PIECE(BHSN,U,4)]""
Begin DoDot:1
+26 ;Patch 9 change for ICD-10
+27 IF $$AICD^BHSUTL
SET BHSTXT=$PIECE($$ICDDX^ICDEX($PIECE(BHSN,U,4),BHSVDT,"","I"),U,4)
SET BHSNRQ=""
SET BHSICL=23
DO PRTTXT^BHSUTL
+28 IF '$TEST
SET BHSTXT=$PIECE($$ICDDX^ICDCODE($PIECE(BHSN,U,4),BHSVDT),U,4)
SET BHSNRQ=""
SET BHSICL=23
DO PRTTXT^BHSUTL
End DoDot:1
+29 IF $PIECE(BHSN,U,11)]""
SET BHSTXT=$PIECE(BHSN,U,11)
SET BHSNRQ=""
SET BHSICL=23
DO PRTTXT^BHSUTL
QUIT
+30 QUIT
+31 ;
MRPTED ; ********** MOST RECENT PATIENT EDUCATION * 9000010.16 **********
+1 ; <SETUP>
+2 ;Q:'$D(^AUPNVPED("AA",BHSPAT))
+3 KILL BHSDEN
DO DENTEDL
+4 ;no ada or v pt ed
IF '$DATA(^AUPNVPED("AA",BHSPAT))
IF '$DATA(BHSDEN)
QUIT
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 ; <DISPLAY>
+7 KILL BHSPTB
+8 ;S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVPED("AA",BHSPAT,BHSIVD)) Q:'BHSIVD S X=-BHSIVD\1+9999999 D REGDT4^GMTSU S BHSDAT=X D ONEDAY Q:$D(GMTSSQIT)
+9 ;IHS/CMI/LAB - PATCH 9 modified this to look at date range and max visit limits
+10 SET BHSIVD=""
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^AUPNVPED("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
DO ONEDAY
+11 SET BHSIVD=0
FOR
SET BHSIVD=$ORDER(BHSDEN(BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)!('GMTSNDM)
QUIT
SET X=(-BHSIVD+9999999)\1
DO REGDT4^GMTSU
SET BHSDAT=X
SET BHSDTU=0
Begin DoDot:1
+12 SET BHSDFN=0
FOR
SET BHSDFN=$ORDER(BHSDEN(BHSIVD,"PED",BHSDFN))
IF BHSDFN'=+BHSDFN!($DATA(GMTSQIT))!('GMTSNDM)
QUIT
DO PEDCHK
SET GMTSNDM=GMTSNDM-BHSDTU
+13 SET BHSDFN=0
SET BHSCNT=0
FOR
SET BHSDFN=$ORDER(BHSDEN(BHSIVD,"DEN",BHSDFN))
IF BHSDFN'=+BHSDFN!($DATA(GMTSQIT))!('GMTSNDM)
QUIT
Begin DoDot:2
+14 SET APCHX=BHSDEN(BHSIVD,"DEN",BHSDFN)
+15 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+16 WRITE !
SET BHSVDF=$PIECE(^AUPNVDEN(BHSDFN,0),U,3)
DO GETSITEV^BHSUTL
IF 'BHSCNT
WRITE BHSDAT,?10,BHSNSH
WRITE ?23,"ADA: ",$PIECE(^AUTTADA(APCHX,0),U)," - ",$EXTRACT($PIECE(^AUTTADA(APCHX,0),U,2),1,40),!
SET BHSCNT=BHSCNT+1
+17 QUIT
End DoDot:2
End DoDot:1
+18 ; <CLEANUP>
+19 ;patch 4 now display PTED refusals
+20 SET BHST="EDUCATION"
SET BHSFN=9999999.09
DO DISPREF^BHSRAD
+21 KILL BHST,BHSFN
MRPTEDX KILL BHSPTB,BHSEVT
+1 KILL BHSIVD,BHSDAT,BHSDFN,BHSFO,BHSFAC,BHSN,BHSDTU,BHSLVL,BHSLVT,BHSPED
+2 KILL BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSVDF
+3 QUIT
+4 ;
ONEDAY ;
+1 NEW X
+2 SET BHSDFN=""
FOR BHSQ=0:0
SET BHSDFN=$ORDER(^AUPNVPED("AA",BHSPAT,BHSIVD,BHSDFN))
IF 'BHSDFN
QUIT
Begin DoDot:1
+3 SET X=$PIECE($GET(^AUPNVPED(BHSDFN,0)),U)
+4 IF X=""
QUIT
+5 IF '$DATA(^AUTTEDT(X,0))
QUIT
+6 SET BHSEVT=+^AUPNVPED(BHSDFN,0)
IF '$DATA(BHSPTB(BHSEVT))
SET BHSPTB(BHSEVT)=""
SET BHSDEN(BHSIVD,"PED",BHSDFN)=""
End DoDot:1
+7 QUIT
MRPE ;EP - called from component
+1 ; <SETUP>
+2 ;Q:'$D(^AUPNVPED("AA",BHSPAT))
+3 KILL BHSDEN
DO DENTAL
+4 ;no ada or v pt ed
IF '$DATA(^AUPNVPED("AA",BHSPAT))
IF '$DATA(BHSDEN)
QUIT
+5 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+6 ; <DISPLAY>
+7 KILL BHSPTB
+8 ;S BHSIVD="" F BHSQ=0:0 S BHSIVD=$O(^AUPNVPED("AA",BHSPAT,BHSIVD)) Q:'BHSIVD S X=(-BHSIVD+9999999)\1 D REGDT4^GMTSU S BHSDAT=X D ONEDAY Q:$D(GMTSQIT)
+9 ;IHS/CMI/LAB - PATCH 9 modified this to look at date range and max visit limits
+10 SET BHSIVD=""
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^AUPNVPED("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)!('GMTSNDM)
QUIT
Begin DoDot:1
+11 SET X=(-BHSIVD+9999999)\1
DO REGDT4^GMTSU
SET BHSDAT=X
SET BHSDTU=0
DO MRPEOD
IF $DATA(GMTSQIT)
QUIT
SET GMTSNDM=GMTSNDM-BHSDTU
IF 'GMTSNDM
QUIT
End DoDot:1
+12 DO REORDER
+13 ; <CLEANUP>
+14 ;now display PTED refusals
+15 SET BHST="EDUCATION"
SET BHSFN=9999999.09
DO DISPREF^BHSRAD
+16 KILL BHST,BHSFN
MRPEX KILL BHSPTB,BHSEVT,BHSDSP,BHSX
+1 KILL BHSIVD,BHSDAT,BHSDFN,BHSFO,BHSFAC,BHSN,BHSDTU,BHSLVL,BHSLVT,BHSPED
+2 KILL BHSNFL,BHSNSH,BHSNAB,BHSVSC,BHSVDF
+3 QUIT
+4 ;
MRPEOD ;
+1 SET BHSDFN=""
FOR BHSQ=0:0
SET BHSDFN=$ORDER(^AUPNVPED("AA",BHSPAT,BHSIVD,BHSDFN))
IF 'BHSDFN
QUIT
SET BHSEVT=+^AUPNVPED(BHSDFN,0)
IF '$DATA(BHSPTB(BHSEVT))
SET BHSPTB(BHSEVT)=BHSIVD_U_BHSDFN
SET BHSDTU=1
+2 QUIT
REORDER ;reorder by name and print
+1 SET BHSEVT=0
FOR
SET BHSEVT=$ORDER(BHSPTB(BHSEVT))
IF BHSEVT'=+BHSEVT
QUIT
IF $DATA(^AUTTEDT(BHSEVT,0))
SET BHSDSP($PIECE(^AUTTEDT(BHSEVT,0),U))=BHSPTB(BHSEVT)
+2 SET BHSX=""
FOR
SET BHSX=$ORDER(BHSDSP(BHSX))
IF BHSX=""!($DATA(GMTSQIT))
QUIT
Begin DoDot:1
+3 SET BHSDFN=$PIECE(BHSDSP(BHSX),U,2)
+4 SET BHSIVD=$PIECE(BHSDSP(BHSX),U)
SET X=(-BHSIVD+9999999)\1
DO REGDT4^GMTSU
SET BHSDAT=X
+5 IF $PIECE(BHSDSP(BHSX),U,3)="D"
SET BHSN=^AUPNVDEN(BHSDFN,0)
+6 IF '$TEST
SET BHSN=^AUPNVPED(BHSDFN,0)
+7 SET BHSVDF=$PIECE(BHSN,U,3)
DO GETSITEV^BHSUTL
+8 IF $PIECE(BHSDSP(BHSX),U,3)="D"
Begin DoDot:2
+9 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+10 WRITE $EXTRACT(BHSX,1,43)," ADA Code: ",$PIECE(^AUTTADA($PIECE(^AUPNVDEN(BHSDFN,0),U),0),U),?57,BHSDAT,?67,BHSNSH,!
QUIT
End DoDot:2
QUIT
+11 SET BHSLVL=$PIECE(BHSN,U,6)
SET BHSLVT=""
+12 IF BHSLVL]""
Begin DoDot:2
+13 SET BHSLVT=$PIECE(^DD(9000010.16,.06,0),U,3)
+14 SET BHSLVT=$PIECE(BHSLVT,BHSLVL_":",2)
+15 SET BHSLVT=$PIECE(BHSLVT,";",1)
+16 IF "^GOOD^FAIR^POOR^"[("^"_BHSLVT_"^")
SET BHSLVT=BHSLVT_" UNDERSTANDING"
+17 SET BHSLVT="- "_BHSLVT
End DoDot:2
+18 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE BHSX," ",$SELECT($PIECE(BHSN,U,7)="":"",$PIECE(BHSN,U,7)="I":" - (IND)",$PIECE(BHSN,U,7)="G":" - (GRP)",1:"")," ",BHSLVT,?57,BHSDAT,?67,BHSNSH,!
+19 IF $PIECE(BHSN,U,13)]""!($PIECE(BHSN,U,14)]"")
Begin DoDot:2
+20 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+21 WRITE ?23,"Behavior Code: ",$$VAL^XBDIQ1(9000010.16,BHSDFN,.13),?51,"Objectives Met: ",$PIECE(BHSN,U,14),!
End DoDot:2
+22 IF $PIECE($GET(^AUPNVPED(BHSDFN,11)),U)]""
SET BHSTXT=$PIECE(^AUPNVPED(BHSDFN,11),U)
SET BHSNRQ=""
SET BHSICL=5
DO PRTTXT^BHSUTL
+23 ;IHS/MSC/MGH Changes added for patch 17
+24 NEW BHDVDT
+25 ;get visit date
SET BHSVDT=$PIECE($PIECE($GET(^AUPNVSIT(BHSVDF,0)),U),".")
+26 IF $PIECE($GET(^AUPNVPED(BHSDFN,11)),U)=""
IF $PIECE(BHSN,U,4)]""
+27 ;Patch 9 change for ICD-10
+28 IF $$AICD^BHSUTL
SET BHSTXT=$PIECE($$ICDDX^ICDEX($PIECE(BHSN,U,4),BHSVDT,"","I"),U,4)
SET BHSNRQ=""
SET BHSICL=23
DO PRTTXT^BHSUTL
+29 IF '$TEST
SET BHSTXT=$PIECE($$ICDDX^ICDCODE($PIECE(BHSN,U,4),BHSVDT),U,4)
SET BHSNRQ=""
SET BHSICL=5
DO PRTTXT^BHSUTL
+30 IF $PIECE(BHSN,U,11)]""
SET BHSTXT=$PIECE(BHSN,U,11)
SET BHSNRQ=""
SET BHSICL=5
DO PRTTXT^BHSUTL
QUIT
End DoDot:1
+31 ;now print all dental ADA
+32 QUIT
DENTEDL ;gather up last of each
+1 KILL BHSDEN
SET BHSDTU=0
+2 SET BHSDE1=$ORDER(^AUTTADA("B",1310,0))
+3 SET BHSDE2=$ORDER(^AUTTADA("B",1320,0))
+4 SET BHSDE3=$ORDER(^AUTTADA("B",1330,0))
+5 SET BHSIVD=""
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^AUPNVDEN("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
Begin DoDot:1
+6 SET BHSDFN=""
FOR
SET BHSDFN=$ORDER(^AUPNVDEN("AA",BHSPAT,BHSIVD,BHSDFN))
IF 'BHSDFN
QUIT
Begin DoDot:2
+7 SET X=$PIECE($GET(^AUPNVDEN(BHSDFN,0)),U)
IF X=BHSDE1!(X=BHSDE2)!(X=BHSDE3)
IF '$DATA(BHSDEN("DEN",X))
SET BHSDEN(BHSIVD,"DEN",BHSDFN)=$PIECE(^AUPNVDEN(BHSDFN,0),U)
SET BHSDEN("DEN",X)=""
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
DENTED ;gather up all 1310, 1320, 1330
+1 KILL BHSDEN
SET BHSDTU=0
+2 SET BHSDE1=$ORDER(^AUTTADA("B",1310,0))
+3 SET BHSDE2=$ORDER(^AUTTADA("B",1320,0))
+4 SET BHSDE3=$ORDER(^AUTTADA("B",1330,0))
+5 SET BHSIVD=""
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^AUPNVDEN("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
Begin DoDot:1
+6 SET BHSDFN=""
FOR
SET BHSDFN=$ORDER(^AUPNVDEN("AA",BHSPAT,BHSIVD,BHSDFN))
IF 'BHSDFN
QUIT
Begin DoDot:2
+7 SET X=$PIECE($GET(^AUPNVDEN(BHSDFN,0)),U)
IF X=BHSDE1!(X=BHSDE2)!(X=BHSDE3)
SET BHSDEN(BHSIVD,"DEN",BHSDFN)=$PIECE(^AUPNVDEN(BHSDFN,0),U)
SET BHSDTU=BHSDTU+1
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
DENTAL ;
+1 KILL BHSDEN,BHSDSP
+2 KILL BHSDEN
SET BHSDTU=0
+3 SET BHSDE1=$ORDER(^AUTTADA("B",1310,0))
+4 SET BHSDE2=$ORDER(^AUTTADA("B",1320,0))
+5 SET BHSDE3=$ORDER(^AUTTADA("B",1330,0))
+6 SET BHSIVD=""
FOR BHSQ=0:0
SET BHSIVD=$ORDER(^AUPNVDEN("AA",BHSPAT,BHSIVD))
IF BHSIVD=""!(BHSIVD>GMTSDLM)
QUIT
Begin DoDot:1
+7 SET BHSDFN=""
FOR
SET BHSDFN=$ORDER(^AUPNVDEN("AA",BHSPAT,BHSIVD,BHSDFN))
IF 'BHSDFN
QUIT
Begin DoDot:2
+8 SET X=$PIECE($GET(^AUPNVDEN(BHSDFN,0)),U)
IF X=BHSDE1!(X=BHSDE2)!(X=BHSDE3)
IF '$DATA(BHSDEN("DEN",X))
SET BHSDSP($PIECE(^AUTTADA(X,0),U,2))=BHSIVD_U_BHSDFN_U_"D"
SET BHSDEN("DEN",X)=""
End DoDot:2
+9 QUIT
End DoDot:1
