- 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