Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BHSPED

BHSPED.m

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