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

BHSPWHG.m

Go to the documentation of this file. 
  1. BHSPWHG ;IHS/MSC/MGH  - Health summmary for patient wellness handout;04-Aug-2009 16:52;MGH
  1.  ;;1.0;HEALTH SUMMARY COMONENTS;**3**;March 17, 2006
  1.  ;-----------------------------------------------------------
  1.  ;Copy of APCHPWHG
  1.  ;IHS/CMI/LAB - PCC HEALTH SUMMARY ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;------------------------------------------------------------
  1. EHR ;EP - CMI/GRL support for EHR
  1.  N BHSPAT,BHSPHT
  1.  S BHSPAT=DFN
  1.  S BHPWHT=$P($G(^APCCCTRL(DUZ(2),0)),U,16)
  1.  I BHPWHT="" S BHPWHT=$O(^APCHPWHT("B","ADULT REGULAR",0))
  1.  D PRINT
  1.  Q
  1.  ;
  1. SEL ;EP -Selected type of handout
  1.  N BHSPAT,BHSFOR,BHSCVD
  1.  S BHSPAT=DFN
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  S BHSFOR=0 F  S BHSFOR=$O(GMTSEG(GMTSEGN,9001026,BHSFOR)) Q:BHSFOR'=+BHSFOR!($D(GMTSQIT))  D  Q:$D(GMTSQIT)
  1.  .S BHPWHT=$G(GMTSEG(GMTSEGN,9001026,BHSFOR))
  1.  .Q:BHPWHT=""
  1.  .Q:'$D(^APCHPWHT(BHPWHT))
  1.  .Q:$G(^ACHPWHT(BHPWHT,1))=""
  1.  D PRINT
  1.  Q
  1. EN1(APCHPWHT) ;EP
  1.  NEW APCHOLD
  1.  D PRINT
  1.  Q
  1. PRINT ;EP
  1.  S BHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"
  1.  K ^TMP($J,"BHPWH")
  1.  D UPDLOG(DFN,BHPWHT,DUZ)
  1.  D EP^APCHPWH1(DFN,BHPWHT,1) ;gather up data in ^TMP
  1. W ;write out array
  1.  ;W:$D(IOF) @IOF
  1.  K BHSQUIT
  1.  ;S BHPG=0 D HEADER
  1.  Q:$D(BHSQUIT)
  1.  S BHX=0 F  S BHX=$O(^TMP($J,"APCHPWH",BHX)) Q:BHX'=+BHX!($D(GMTSQIT))  D
  1.  .;find number of lines until next component
  1.  .D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  .S C=0 I ^TMP($J,"APCHPWH",BHX)["________________" S A=BHX F  S A=$O(^TMP($J,"APCHPWH",A)) Q:A'=+A  Q:^TMP($J,"APCHPWH",A)["_______________"  S C=C+1
  1.  .;I $Y>(IOSL-$S(C<7:(C+3),1:3)) D HEADER Q:$D(BHSQUIT)
  1.  .W !,^TMP($J,"APCHPWH",BHX)
  1.  .Q
  1.  D CKP^GMTSUP Q:$D(GMTSQIT)
  1.  Q
  1.  ;footer
  1.  ;I $E(IOST)="C",IO=IO(0) W ! K DIR S DIR(0)="EO",DIR("A")="End of Report.  Press Enter." D ^DIR K DIR Q
  1.  ;D EOJ
  1.  ;Q
  1.  ;
  1. EOJ ;
  1.  ;
  1.  K ^TMP($J,"BHPWH")
  1.  ;D EN^XBVK("APCH")
  1.  ;D EN^XBVK("APCD")
  1.  ;D ^XBFMK
  1.  K BIDLLID,BIDLLPRO,BIDLLRUN,BIRESULT,BISITE,BHX,BHPG
  1.  K AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX
  1.  K N,%,T,F,X,Y,B,C,E,F,H,J,L,N,P,T,W,ST,ST0,A
  1.  Q
  1.  ;G:BHPG=0 HEAD1
  1.  ;I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQUIT="" Q
  1. HEAD1 ;
  1.  ;W:$D(IOF) @IOF
  1.  ;S BHPG=BHPG+1
  1.  ;W !,"My Wellness Handout",?45,"Report Date: ",$$FMTE^XLFDT(DT),?72,"Page: ",BHPG,!,$TR($J("",(IOM-2))," ","-"),!
  1.  I BHPG>1 W "********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" **********",!
  1.  Q
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------
  1.  ;
  1. UPDLOG(P,T,D) ;EP - update pwh log
  1.  I $G(P)="" Q
  1.  I $G(T)="" Q
  1.  NEW DIC,X,DD,DO,D0
  1.  S X=P,DIC="^APCHPWHL(",DIC(0)="L",DIADD=1,DLAYGO=9001027
  1.  S DIC("DR")=".02////"_T_";.03////"_D_";.04////"_DT_";.05///"_$$NOW^XLFDT_";.06////"_DUZ(2)
  1.  K DD,D0,D0
  1.  D FILE^DICN
  1.  D ^XBFMK
  1.  K DIADD,DLAYGO
  1.  Q
  1.  ;