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

BHSBH.m

Go to the documentation of this file. 
  1. BHSBH ;IHS/CIA/MGH - Health Summary for Behavioral Health ;27-Aug-2014 14:15;DU
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**2,4,9**;March 17, 2006;Build 16
  1.  ;===================================================================
  1.  ;Taken from AMHHS
  1.  ; IHS/CMI/LAB - BH HEALTH SUMMARY COMPONENT ;
  1.  ;;3.0;IHS BEHAVIORAL HEALTH;;JAN 27, 2003
  1.  ;Conversion of behavioral health over to VA health summary
  1.  ;=====================================================================
  1.  ;
  1. MH ;EP called from health summary
  1.  NEW AMHPATH
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I $P($G(^AMHPATR(BHSPAT,0)),U,9)]"" W ?23,"Patient Flag: ",?38,$P(^AMHPATR(BHSPAT,0),U,9),!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I $P($G(^AMHPATR(BHSPAT,0)),U,11)]"" W ?21,"Flag Narrative: ",?38,$P(^AMHPATR(BHSPAT,0),U,11),!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I $P($G(^AMHPATR(BHSPAT,0)),U,2)]"" W ?2,"Designated Mental Health Provider: ",?38,$P(^VA(200,$P(^AMHPATR(BHSPAT,0),U,2),0),U),!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I $P($G(^AMHPATR(BHSPAT,0)),U,3)]"" W "Designated Social Services Provider: ",?38,$P(^VA(200,$P(^AMHPATR(BHSPAT,0),U,3),0),U),!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I $P($G(^AMHPATR(BHSPAT,0)),U,4)]"" W ?10,"CD Designated Provider: ",?38,$P(^VA(200,$P(^AMHPATR(BHSPAT,0),U,4),0),U),!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I $P($G(^AMHPATR(BHSPAT,0)),U,12)]"" W ?10,"Other Designated Provider: ",?38,$P(^VA(200,$P(^AMHPATR(BHSPAT,0),U,12),0),U),!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I $P($G(^AMHPATR(BHSPAT,0)),U,13)]"" W ?10,"Other (2) Designated Provider: ",?38,$P(^VA(200,$P(^AMHPATR(BHSPAT,0),U,13),0),U),!
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ;output personal history
  1.  I $D(^AMHPPHX("AC",BHSPAT)) D
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)  W !,"** Personal History of:",!
  1.  .S AMHSX=0 F  S AMHSX=$O(^AMHPPHX("AC",BHSPAT,AMHSX)) Q:AMHSX'=+AMHSX  D
  1.  ..S X=$P(^AMHPPHX(AMHSX,0),U,3) D REGDT4^GMTSU S AMHSDAT=X
  1.  ..W !?5,$P(^AMHTPHF($P(^AMHPPHX(AMHSX,0),U),0),U),?30,"(noted: ",AMHSDAT,")"
  1.  ..Q
  1.  .W ! K AMHSX
  1.  .Q
  1. CASE ;output last 3 cases
  1.  K AMHL S D=0,C=0 F  S D=$O(^AMHPCASE("AA",BHSPAT,D)) Q:D'=+D!(C>2)  D
  1.  .S AMHL=0 F  S AMHL=$O(^AMHPCASE("AA",BHSPAT,D,AMHL)) Q:AMHL'=+AMHL!(C>2)  D
  1.  ..S C=C+1
  1.  ..S AMHL(C)=AMHL
  1.  ..Q
  1.  .Q
  1. CASEOUT ;display last 3 cases found
  1.  I $D(AMHL(1)) D
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .S K="21;41;61"
  1.  .W ?4,"Case Open Date:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  S J=$P(K,";",I) W ?J,$$FMTE^XLFDT($P(^AMHPCASE(AMHL(I),0),U),"2E")
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W !?3,"Case Admit Date:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  I $P(^AMHPCASE(AMHL(I),0),U,4)]"" S J=$P(K,";",I) W ?J,$$FMTE^XLFDT($P(^AMHPCASE(AMHL(I),0),U,4),"2E")
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W !?3,"Case Close Date:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  I $P(^AMHPCASE(AMHL(I),0),U,5)]"" S J=$P(K,";",I) W ?J,$$FMTE^XLFDT($P(^AMHPCASE(AMHL(I),0),U,5),"2E")
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W !?5,"Program Affil:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  I $P(^AMHPCASE(AMHL(I),0),U,3)]"" S J=$P(K,";",I) W ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.03)
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W !?7,"Disposition:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  I $P(^AMHPCASE(AMHL(I),0),U,6)]"" S J=$P(K,";",I) W ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.06)
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W !?2,"Next Review Date:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  I $P(^AMHPCASE(AMHL(I),0),U,12)]"" S J=$P(K,";",I) W ?J,$$FMTE^XLFDT($P(^AMHPCASE(AMHL(I),0),U,12),"2E")
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W !?10,"Provider:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  I $P(^AMHPCASE(AMHL(I),0),U,8)]"" S J=$P(K,";",I) W ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.08)
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W !?11,"Problem:"
  1.  .F I=1:1:3 Q:'$D(AMHL(I))  I $P(^AMHPCASE(AMHL(I),0),U,9)]"" S J=$P(K,";",I) W ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.09)
  1.  K AMHL,C,D,L,K
  1.  D PROB^BHSBH1
  1. AXV ;trend and display last 7 AXIS V values
  1.  K AMHAX5 S AMHCNT=0
  1.  S AMHSIVD=0 F  S AMHSIVD=$O(^AMHREC("AE",BHSPAT,AMHSIVD)) Q:AMHSIVD=""!($D(GMTSQIT))!(AMHCNT>6)  D
  1.  .S AMHSX=0 F  S AMHSX=$O(^AMHREC("AE",BHSPAT,AMHSIVD,AMHSX)) Q:AMHSX'=+AMHSX  D
  1.  ..Q:$P($G(^AMHREC(AMHSX,0)),U,14)=""
  1.  ..S AMHCNT=AMHCNT+1,AMHAX5(AMHCNT)=(9999999-AMHSIVD)_U_$P(^AMHREC(AMHSX,0),U,14)
  1.  ..Q
  1.  .Q
  1.  I $D(AMHAX5) D  Q:$D(GMTSQIT)
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W !!?4,"**********  LAST 6 AXIS V VALUES RECORDED.  (GAF SCORES)  **********",!!
  1.  .S AMHJ=2 F AMHCNT=6:-1:1  I $D(AMHAX5(AMHCNT))  W ?AMHJ,$$DATE($P(AMHAX5(AMHCNT),U)) S AMHJ=AMHJ+12
  1.  .W ! S AMHJ=6 F AMHCNT=6:-1:1 I $D(AMHAX5(AMHCNT)) W ?AMHJ,$P(AMHAX5(AMHCNT),U,2) S AMHJ=AMHJ+12
  1.  .W !
  1. OUTPT ; ********** MH PROBLEM CODES AND DESIGNATED PROVIDER
  1.  ; <SETUP>
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  S X="********************  BH ENCOUNTERS  ******************** ",AMHS="",$P(AMHS," ",IOM-1-$L(X)/2)="" W !,AMHS,X,AMHS,!!
  1.  I '$D(^AMHREC("AE",BHSPAT)) D CKP^GMTSUP Q:$D(GMTSQIT)  W !,"No Behavioral Health Records on File.",! Q
  1.  ; <DISPLAY>
  1.  S AMHSPVD=0
  1.  F AMHSIVD=0:0 S AMHSIVD=$O(^AMHREC("AE",BHSPAT,AMHSIVD)) Q:AMHSIVD=""!($P(AMHSIVD,".")>GMTSDLM)  D ONEDATE Q:$D(GMTSQIT)  S:(AMHSDAT'=AMHSPVD)&AMHSDTU GMTSNDM=GMTSNDM-AMHSDTU,AMHSPVD=AMHSDAT Q:GMTSNDM=0
  1. PTED ;display all pt ed (last of each)
  1.  I '$D(^AMHREDU("AC",BHSPAT)) G OUTPTX
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  S X="********************  MH/SS PATIENT EDUCATION  ******************** ",AMHS="",$P(AMHS," ",IOM-1-$L(X)/2)="" W !,AMHS,X,AMHS,!!
  1.  K AMHSN S AMHSX=0 F  S AMHSX=$O(^AMHREDU("AC",BHSPAT,AMHSX)) Q:AMHSX'=+AMHSX!($D(GMTSQIT))  D
  1.  .S X=$P(^AMHREDU(AMHSX,0),U),Y=$P(^AMHREDU(AMHSX,0),U,3) I Y,$D(^AMHREC(Y,0)) S Y=$P($P(^AMHREC(Y,0),U),".") I $P($G(AMHSN(X)),U)<Y S AMHSN(X)=Y_U_AMHSX
  1.  K AMHSD S X=0 F  S X=$O(AMHSN(X)) Q:X'=+X  S Y=$P(AMHSN(X),U),Y=9999999-Y,AMHSD(Y,X)=$P(AMHSN(X),U,2)
  1.  S AMHSD=0 F  S AMHSD=$O(AMHSD(AMHSD)) Q:AMHSD'=+AMHSD!($D(GMTSQIT))  D
  1.  .S AMHSX=0 F  S AMHSX=$O(AMHSD(AMHSD,AMHSX)) Q:AMHSX'=+AMHSX!($D(GMTSQIT))  D
  1.  ..D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ..W !,$$FMTE^XLFDT(9999999-AMHSD),?15,$E($P(^AUTTEDT(AMHSX,0),U),1,30),?47,$$VAL^XBDIQ1(9002011.05,AMHSD(AMHSD,AMHSX),.05)
  1. OUTPTX K AMHS,AMHSX,AMHSDAT,AMHL,AMHAX5,AMHCNT,AMHSIVD,AMHIVD,AMHJ,AMHSPVD,AMHSDTU,AMHSN,AMHSD
  1.  K AMHSIVD,AMHSDTU,AMHSVDF,AMHSFAC,AMHSPFN,AMHSMTX,AMHSPVD,AMHSOVT,AMHSNDT,AMHSCLI,AMHSPDN,AMHSICD,AMHSICL,AMHSDAT,AMHSN,AMHSQ,AMHSR,AMHSX,AMHS,AMHTOC
  1.  K AMHSNFL,AMHSNSH,AMHSNAB,AMHSVSC,AMHSFAC,BHSTXT,BHSNRQ,BHSICL,Y,I,J,X
  1.  K Y
  1.  Q
  1. ONEDATE S X=-AMHSIVD\1+9999999 D REGDT4^GMTSU S AMHSDAT=X S AMHSPFN="",AMHSDTU=0,AMHSNDT=(AMHSDAT'=AMHSPVD)
  1.  S AMHSVDF="" F AMHSQ=0:0 S AMHSVDF=$O(^AMHREC("AE",BHSPAT,AMHSIVD,AMHSVDF)) Q:AMHSVDF=""  S AMHSN=^AMHREC(AMHSVDF,0) D GETSITE,DSPVIS Q:$D(GMTSQIT)
  1.  Q
  1.  ;
  1. GETSITE ;
  1.  S AMHSFAC=$P(AMHSN,U,4) S AMHSFAC=$S(AMHSFAC:$E($P(^AUTTLOC(AMHSFAC,0),U,2),1,8),1:"<missing>")
  1.  I AMHSFAC="" S AMHSFAC=$E($P(^DIC(4,$P(AMHSN,U,4),0),U),1,8)
  1.  S AMHTOC=$P(AMHSN,U,7) I AMHTOC]"" S AMHTOC=$P(^AMHTSET(AMHTOC,0),U,4)
  1.  Q
  1. DSPVIS ;
  1.  S AMHSDTU=1
  1.  I $O(^AMHRPRO("AD",AMHSVDF,""))="" D NOPOV Q
  1.  S AMHSPDN="" F AMHSQ=0:0 S AMHSPDN=$O(^AMHRPRO("AD",AMHSVDF,AMHSPDN)) Q:'AMHSPDN  S AMHSR=^AMHRPRO(AMHSPDN,0) D HASPOV
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  ;I $P(AMHSN,U,13)]"" W ?25,"Axis IV (Stress): ",$P(^AMHTAXIV($P(AMHSN,U,13),0),U,2)," - ",$P(^AMHTAXIV($P(AMHSN,U,13),0),U) W:$P(AMHSN,U,14)="" !
  1.  ;W:$P(AMHSN,U,14)]"" ?50,"Axis V (Function):  ",$P(AMHSN,U,14),!
  1.  I $D(^AMHREC(AMHSVDF,61))!($P(^AMHREC(AMHSVDF,0),U,14)]"") D  Q:$D(GMTSQIT)
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .W ?27,"AXIS IV:  " S Y=0 F  S Y=$O(^AMHREC(AMHSVDF,61,Y)) Q:Y'=+Y  S I=$P(^AMHREC(AMHSVDF,61,Y,0),U) W ?35,$P(^AMHTAXIV(I,0),U)_" - "_$P(^AMHTAXIV(I,0),U,2),!
  1.  .I '$O(^AMHREC(AMHSVDF,61,0)) W !
  1.  .W ?27,"AXIS V:  ",$P(^AMHREC(AMHSVDF,0),U,14),!
  1.  .Q
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  I $P(AMHSN,U,17)]"" W ?27,"Inpatient Disp:  ",$$VAL^XBDIQ1(9002011,AMHSVDF,.17),!?27,"Referred To:  ",$P(AMHSN,U,18),!
  1.  ;I $D(^AMHREC(AMHSVDF,12)) D CKP^GMTSUP Q:$D(GMTSQIT)  S BHSNRQ="COMMENT: "_^AMHREC(AMHSVDF,12),BHSICL=27,BHSTXT="" D PRTTXT^BHSUTL
  1.  Q
  1.  ;
  1. NOPOV ;
  1.  S BHSTXT="",(AMHSICD,BHSNRQ)="<BH problem codes not yet entered>"
  1.  G COMMON
  1.  ;
  1. HASPOV ;
  1.  N CODE,CODEIEN,CHK,FIRST,SEC,CHK,DESCT
  1.  S CODE=$P(AMHSR,U)
  1.  Q:CODE=""
  1.  ;S CODEIEN="" S CODEIEN=$O(^AMHPROB("B",CODE,CODEIEN))
  1.  S CODEIEN=CODE
  1.  S BHSNRQ=$P($G(^AMHPROB(CODEIEN,0)),U)_" - "
  1.  S AMHSICD=$E($P($G(^AMHPROB(CODEIEN,0)),U,2),1,45)
  1.  S Y=$L(BHSNRQ) F X=Y:1:8 S BHSNRQ=BHSNRQ_" "
  1.  S BHSNRQ=BHSNRQ_AMHSICD,BHSTXT="",BHSICL=27
  1.  D COMMON
  1.  S CHK=$P(^AUTNPOV($P(AMHSR,U,4),0),U)
  1.  ;Patch  9 added changes for SNOMED POVs
  1.  I CHK["|" D
  1.  .S FIRST=$P(CHK,"|",1),SEC=$P(CHK,"|",2)
  1.  .S DESCT=$$DESC^BSTSAPI(SEC_"^^1")
  1.  .S CHK=$P(DESCT,U,2)
  1.  .I FIRST'="" S CHK=CHK_" | "_FIRST
  1.  S:$P(AMHSR,U,4) BHSNRQ=BHSNRQ_CHK S BHSTXT="",BHSICL=27 D PRTTXT^BHSUTL
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  Q
  1. COMMON ;
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)  S:GMTSNPG AMHSNDT=1
  1.  I AMHSNDT W AMHSDAT S AMHSPFN="",AMHSNDT=0
  1.  W ?9,AMHSFAC,?18,$$PPINI^AMHUTIL(AMHSVDF),?22,AMHTOC S BHSICL=27 D PRTTXT^BHSUTL
  1.  Q
  1. DATE(D) ;
  1.  I $G(D)="" Q ""
  1.  Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))