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

APCHPWHG.m

Go to the documentation of this file. 
  1. APCHPWHG ; IHS/CMI/LAB - PCC HEALTH SUMMARY ;
  1.  ;;2.0;IHS PCC SUITE;**2,7,10**;MAY 14, 2009;Build 88
  1. EN ;
  1.  W !!,$$CTR("*** Patient Wellness Handout ***"),!!
  1. SELTYP ;
  1.  K DIADD,DLAYGO
  1.  D ^XBFMK
  1.  K DIC S DIC="^APCHPWHT(",DIC("A")="Select Patient Wellness Handout type: ",DIC(0)="AEQM"
  1.  S X="" I DUZ(2),$D(^APCCCTRL(DUZ(2),0))#2 S X=$P(^(0),U,16)
  1.  I $D(^DISV(DUZ,"^APCHPWHT(")) S Y=^("^APCHPWHT(") I $D(^APCHPWHT(Y,0)) S X=$P(^(0),U,1)
  1.  S:X="" X="ADULT REGULAR"
  1.  S DIC("B")=X
  1.  D ^DIC K DIC
  1.  I Y=-1 D EXIT Q
  1.  S APCHPWHT=+Y
  1. SELPT ;
  1.  W !
  1.  S DFN=""
  1.  K DIC S DIC=9000001,DIC("A")="Select patient: ",DIC(0)="AEQM" D ^DIC K DIC
  1.  I Y=-1 G SELTYP
  1.  S DFN=+Y W:$D(^AUPNPAT(DFN,41,DUZ(2),0)) !,"Patient's chart number is ",$P(^(0),U,2),!
  1.  ;I $$AGE^AUPNPAT(DFN,DT)<18 W !,"Warning:  This handout is designed for patients 18 and older.  This",!,"patient is under 18.  Please select a different patient." K DFN G SELPT
  1.  ;.S APCHSQ=""
  1.  ;.K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue and print the handout",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  ;.I 'Y S APCHSQ=1
  1.  ;.Q
  1.  D ZIS
  1.  D EXIT
  1.  Q
  1.  ;
  1. EN2(APCHPWHT,P) ;EP
  1.  NEW DFN
  1.  S DFN=P
  1.  D ZIS
  1.  Q
  1.  ;
  1. ZIS ;EP
  1.  W !! S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to",DIR("B")="P" K DA D ^DIR K DIR
  1.  I $D(DIRUT) D EXIT Q
  1.  S APCHOPT=Y
  1.  I Y="B" D BROWSE,EXIT Q
  1.  S XBRP="PRINT^APCHPWHG",XBRC="",XBRX="EXIT^APCHPWHG",XBNS="APCH;DFN"
  1.  D ^XBDBQUE
  1.  D EXIT
  1.  Q
  1.  ;
  1. EHR(DFN,APCHPWHT)  ;EP - CMI/GRL support for EHR
  1.  I '$G(APCHPWHT) S APCHPWHT=$P($G(^APCCCTRL(DUZ(2),0)),U,16)
  1.  I APCHPWHT="" S APCHPWHT=$O(^APCHPWHT("B","ADULT REGULAR",0))
  1.  D EN^XBNEW("PRINT^APCHPWHG","DFN;APCHPWHT")
  1.  Q
  1. BROWSE ;
  1.  S XBRP="VIEWR^XBLM(""PRINT^APCHPWHG"")"
  1.  S XBRC="",XBRX="EXIT1^APCHPWHG",XBIOP=0 D ^XBDBQUE
  1.  Q
  1. EXIT ;
  1.  D EN^XBVK("APCH")
  1.  K DFN
  1.  D ^XBFMK
  1.  Q
  1.  ;
  1.  ;
  1. EXIT1 ;
  1.  D CLEAR^VALM1
  1.  D FULL^VALM1
  1.  K DFN
  1.  D ^XBFMK
  1.  Q
  1.  ;
  1. ENCOMP ;EP
  1.  NEW T,APCHPWHT
  1.  S APCHPWHT=$P($G(^APCCCTRL(DUZ(2),0)),U,16)
  1.  I 'APCHPWHT S APCHPWHT=$O(^APCHPWHT("B","ADULT REGULAR",0))
  1.  I 'APCHPWHT Q
  1.  W:$D(IOF) @IOF
  1.  D EHR(APCHSPAT,APCHPWHT)
  1.  Q
  1.  ;
  1. EN1(APCHPWHT) ;EP
  1.  NEW APCHOLD
  1.  D PRINT
  1.  Q
  1. PRINT ;EP
  1.  S APCHSCVD="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,"APCHPWH")
  1.  I '$G(APCHITST) D UPDLOG(DFN,APCHPWHT,DUZ)  ;D UPDLOG(DFN,APCHPWHT,DUZ)
  1.  D EP^APCHPWH1(DFN,APCHPWHT,1) ;gather up data in ^TMP
  1. W ;write out array
  1.  ;W:$D(IOF) @IOF
  1.  K APCHQUIT
  1.  S APCHPG=0 D HEADER
  1.  Q:$D(APCHQUIT)
  1.  S APCHX=0 F  S APCHX=$O(^TMP($J,"APCHPWH",APCHX)) Q:APCHX'=+APCHX!($D(APCHQUIT))  D
  1.  .;find number of lines until next component
  1.  .S C=0 I ^TMP($J,"APCHPWH",APCHX)["________________" S A=APCHX 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(APCHQUIT)
  1.  .;I ^TMP($J,"APCHPWH",APCHX)[" INTAKE FORM" D HEADER Q:$D(APCHQUIT)
  1.  .W !,^TMP($J,"APCHPWH",APCHX)
  1.  .Q
  1.  I $D(APCHQUIT) S APCHSQIT=1
  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,"APCHPWH")
  1.  D EN^XBVK("APCH")
  1.  D EN^XBVK("APCD")
  1.  D ^XBFMK
  1.  K BIDLLID,BIDLLPRO,BIDLLRUN,BIRESULT,BISITE
  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
  1.  Q
  1.  G:APCHPG=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 APCHPG=APCHPG+1
  1.  W !,"My Wellness Handout",?45,"Report Date: ",$$FMTE^XLFDT(DT),?72,"Page: ",APCHPG,!,$TR($J("",(IOM-2))," ","-"),!
  1.  I APCHPG>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.  I $T(LOG^BQINOTR)]"" D LOG^BQINOTR(P,"LETTER","","",T,"PWH","")  ;PER EMAIL 6/10/13
  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.  ;
  1. UPDDEF ;EP - called from option to update default PWH for the site
  1.  W !!,"This option is used to set the default Patient Wellness Handout"
  1.  W !,"for a site."
  1.  W !!
  1.  K DIC S DIC="^APCCCTRL(",DIC("B")=$P(^DIC(4,DUZ(2),0),U),DIC(0)="AEMQ" D ^DIC K DIC
  1.  I Y=-1 Q
  1.  S DA=+Y,DIE="^APCCCTRL(",DR="[APCH PWH PARAMETERS]" D ^DIE
  1.  D ^XBFMK
  1.  Q
  1.  ;