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

APCHPWHT.m

Go to the documentation of this file. 
  1. APCHPWHT ; IHS/CMI/LAB -- create/modify health summary type ; 06 Sep 2011  1:08 PM
  1.  ;;2.0;IHS PCC SUITE;**6,7,11**;MAY 14, 2009;Build 58
  1.  ;; ;
  1.  ;routine to create/modify a health summary type
  1. EP ;EP - called from option
  1.  W !!!,"This option will allow you to create a new or modify an existing"
  1.  W !,"Patient Wellness Handout type.",!!
  1.  D ^XBFMK S DIC="^APCHPWHT(",DIC(0)="AEMQL" D ^DIC K DIC,DA,DR,DD,DO
  1.  I Y=-1 W !!,"Goodbye",! D EOJ Q
  1.  S %=$P(^APCHPWHT(+Y,0),U,2) I %]"",$D(^XUSEC(%,DUZ))[0 W !,"This Patient Wellness handout type is currently locked to prevent alteration.",! G EP
  1.  S APCHPWHT=+Y
  1.  S DIE="^APCHPWHT(",DA=APCHPWHT,DR=".01;.03" D ^DIE D ^XBFMK
  1.  D EN
  1. EOJ ;
  1.  D EN^XBVK("APCH")
  1.  D ^XBFMK
  1.  Q
  1. EN ; -- main entry point for APCH CREATE/MODIFY TYPE
  1.  D EN^VALM("APCH PWH CREATE/MODIFY TYPE")
  1.  D CLEAR^VALM1
  1.  D FULL^VALM1
  1.  W:$D(IOF) @IOF
  1.  D EOJ
  1.  Q
  1.  ;
  1. HDR ;EP -- header code
  1.  S VALMHDR(1)="Patient Wellness Handout: " I $G(APCHPWHT),$D(^APCHPWHT(APCHPWHT)) S VALMHDR(1)=VALMHDR(1)_$P(^APCHPWHT(APCHPWHT,0),U)
  1.  Q
  1.  ;
  1. INIT ;EP -- init variables and list array
  1.  K ^TMP($J,"APCHTYPE")
  1.  S APCHC=0
  1.  NEW X,Y,O,C,M,T,A,I,V,W,B,E
  1.  S A="",T="",I="",B="",E=""
  1.  S X="STRUCTURE: " D S(X)
  1.  S X="Order",$E(X,7)="Component" D S(X)
  1.  S Y=0 F  S Y=$O(^APCHPWHT(APCHPWHT,1,Y)) Q:Y'=+Y  D
  1.  .S A="",T="",I="",B="",E="",O=$P(^APCHPWHT(APCHPWHT,1,Y,0),U),C=$P(^APCHPWHT(APCHPWHT,1,Y,0),U,2),C=$P($G(^APCHPWHC(+C,0)),U,1)
  1.  .I C="ALLERGIES" S A=Y
  1.  .I C["TRANSPAR" S T=Y
  1.  .I C["RECENT LAB" S B=Y
  1.  .I C["INTAKE" S I=Y
  1.  .I C["EDUCATION HANDOUT" S E=Y
  1.  .S X=O,$E(X,7)=C D S(X) ;,$E(X,49)=M,$E(X,57)=T,$E(X,62)=A D S(X)
  1.  .I A K Z S X="Source for Allergy component: " D ENPM^XBDIQ1(9001026.01,APCHPWHT_",0",".03","Z(") S X=X_$G(Z(A,.03)) D S(X)
  1.  .I B K Z S X="Display Comments with Lab component: " D ENPM^XBDIQ1(9001026.01,APCHPWHT_",0",".04","Z(") S X=X_$G(Z(B,.04)) D S(X)
  1.  .I T D
  1.  ..D S("    Measures:")
  1.  ..S V=0 F  S V=$O(^APCHPWHT(APCHPWHT,1,T,11,V)) Q:V'=+V  D
  1.  ...S W=$P(^APCHPWHT(APCHPWHT,1,T,11,V,0),U,2)
  1.  ...I W S W=$P(^APCHPWHE(W,0),U,1)
  1.  ...S X="",$E(X,8)=V,$E(X,12)=W D S(X)
  1.  .I I D
  1.  ..D S("    Intake Forms:")
  1.  ..S V=0 F  S V=$O(^APCHPWHT(APCHPWHT,1,I,12,V)) Q:V'=+V  D
  1.  ...S W=$P(^APCHPWHT(APCHPWHT,1,I,12,V,0),U,2)
  1.  ...I W S W=$P(^APCHPWHF(W,0),U,1)
  1.  ...S X="",$E(X,8)=V,$E(X,12)=W D S(X)
  1.  .I E D
  1.  ..D S("    Education Handouts:")
  1.  ..S V=0 F  S V=$O(^APCHPWHT(APCHPWHT,1,E,13,V)) Q:V'=+V  D
  1.  ...S W=$P(^APCHPWHT(APCHPWHT,1,E,13,V,0),U,2)
  1.  ...I W S W=$P(^APCHPWHF(W,0),U,1)
  1.  ...S X="",$E(X,8)=V,$E(X,12)=W D S(X)
  1. C ;
  1.  S VALMCNT=$O(^TMP($J,"APCHTYPE",""),-1)
  1.  Q
  1.  ;
  1. S(Y,F,C,T) ;EP - set up array
  1.  I '$G(F) S F=0
  1.  I '$G(T) S T=0
  1.  ;blank lines
  1.  F F=1:1:F S X="" D S1
  1.  S X=Y
  1.  I $G(C) S L=$L(Y),T=(80-L)/2 D  D S1 Q
  1.  .F %=1:1:(T-1) S X=" "_X
  1.  F %=1:1:T S X=" "_Y
  1.  D S1
  1.  Q
  1. S1 ;
  1.  S APCHC=APCHC+1
  1.  S ^TMP($J,"APCHTYPE",APCHC,0)=X
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- EXIT code
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1.  ;routine to create/modify a health summary type
  1.  ;
  1. BACK ;go back to listman
  1.  D TERM^VALM0
  1.  S VALMBCK="R"
  1.  D INIT^APCHPWHT
  1.  D HDR^APCHPWHT
  1.  K DIR
  1.  K X,Y,Z,I
  1.  Q
  1.  ;
  1. COMP(S,C) ;EP
  1.  NEW X,Y S Y=0,X=0 F  S X=$O(^APCHPWHT(S,1,X)) Q:X'=+X!(Y)  I $P(^APCHPWHT(S,1,X,0),U,2)=C S Y=1
  1.  Q Y
  1.  ;
  1. DH ;EP called from protocol to generate PWH
  1.  D FULL^VALM1
  1.  S DFN=""
  1.  S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
  1.  I Y<0 W !,"No Patient Selected." D BACK Q
  1.  S DFN=+Y
  1.  S Y=DFN D ^AUPNPAT
  1.  S APCHSDFN=DFN
  1.  S %=$P(^APCHPWHT(APCHPWHT,0),U)_" Patient Wellness Handout for "_$P(^DPT(APCHSDFN,0),U)
  1.  D VIEWR^XBLM("EN1^APCHPWHG(APCHPWHT)",%)
  1.  D BACK
  1.  Q
  1.  ;
  1. PH ;EP called from protocol to generate PWH
  1.  D FULL^VALM1
  1.  S DFN=""
  1.  S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
  1.  I Y<0 W !,"No Patient Selected." D BACK Q
  1.  S DFN=+Y
  1.  S Y=DFN D ^AUPNPAT
  1.  S APCHSDFN=DFN
  1.  S %=$P(^APCHPWHT(APCHPWHT,0),U)_" Patient Wellness Handout for "_$P(^DPT(APCHSDFN,0),U)
  1.  S APCHITST=1
  1.  D EN2^APCHPWHG(APCHPWHT,DFN)
  1.  K APCHITST
  1.  D BACK
  1.  Q
  1.  ;
  1. AS ;EP
  1.  D FULL^VALM1
  1.  I '$$ALG(APCHPWHT) W !!,"You have not added Allergies as a component to this Patient Wellness Handout",!,"type.  Don't forget to do so.",!
  1.  S DA=APCHPWHT,DIE="^APCHPWHT(",DR=".04" D ^DIE,^XBFMK
  1.  D BACK
  1.  Q
  1.  ;
  1. CCIP ;EP - called from protocol entry
  1.  D FULL^VALM1
  1.  I '$$COMP(APCHPWHT,$O(^APCHPWHC("B","CCI MEASURES",0))) W !!,"WARNING:  CCI MEASURES has not been added to the Handout Structure.",!,"CCI MEASURES will not display until they are part of the handout",!,"structure."
  1.  W !!,"You can add a new CCI Measure by entering a new sequence number",!,"and CCI Measure name.  To remove a CCI Measure from this handout type select the measure",!
  1.  W "by sequence number and type an '@',",!
  1.  S DA=APCHPWHT,DIE="^APCHPWHT(",DR=12 D ^DIE,^XBFMK
  1.  D BACK
  1.  Q
  1.  ;
  1. TQMP ;EP - called from protocol entry
  1.  D FULL^VALM1
  1.  I '$$COMP(APCHPWHT,$O(^APCHPWHC("B","QUALITY OF CARE TRANSPARENCY R",0))) D
  1.  .W !!,"WARNING:  QUALITY OF CARE TRANSPARENCY REPORT CARD has not been added to the ",!,"Handout Structure.",!,"Quality Transparency MEASURES will not display until they are part of the",!," handout structure."
  1.  W !!,"You can add a new Quality of Care Transparency Measure by entering a ",!,"new sequence number and measure name. ",!,"To remove a Measure from this handout type select the measure",!
  1.  W "by sequence number and type an '@',",!
  1.  S DA=APCHPWHT,DIE="^APCHPWHT(",DR=11 D ^DIE,^XBFMK
  1.  D BACK
  1.  Q
  1.  ;
  1. MS ;EP - called from protocol entry
  1.  D FULL^VALM1
  1.  W !!,"You can add a new component by entering a new order number and",!,"component name.  To remove a component from this PWH type select the",!,"component by name or order and then enter an '@'.",!
  1.  S DA=APCHPWHT,DIE="^APCHPWHT(",DR="[APCH MODIFY TYPE]" D ^DIE,^XBFMK
  1.  D BACK
  1.  Q
  1. PAUSE ;EP; -- ask user to press ENTER
  1.  Q:IOST'["C-"
  1.  NEW Y S Y=$$READ("E","Press ENTER to continue") D ^XBCLS Q
  1. READ(TYPE,PROMPT,DEFAULT,HELP,SCREEN,DIRA) ;EP; calls reader, returns response
  1.  NEW DIR,X,Y
  1.  S DIR(0)=TYPE
  1.  I $D(SCREEN) S DIR("S")=SCREEN
  1.  I $G(PROMPT)]"" S DIR("A")=PROMPT
  1.  I $G(DEFAULT)]"" S DIR("B")=DEFAULT
  1.  I $D(HELP) S DIR("?")=HELP
  1.  I $D(DIRA(1)) S Y=0 F  S Y=$O(DIRA(Y)) Q:Y=""  S DIR("A",Y)=DIRA(Y)
  1.  D ^DIR
  1.  Q Y
  1.  ;
  1. ALG(P) ;
  1.  NEW A,B,G
  1.  S G=""
  1.  S A=0 F  S A=$O(^APCHPWHT(P,1,A)) Q:A'=+A  S B=$P(^APCHPWHT(P,1,A,0),U,2),B=$P(^APCHPWHC(+B,0),U) I B["ALLERG" S G=1
  1.  Q G
  1.  ;
  1. CCI(P) ;
  1.  NEW A,B,G
  1.  S G=""
  1.  S A=0 F  S A=$O(^APCHPWHT(P,1,A)) Q:A'=+A  S B=$P(^APCHPWHT(P,1,A,0),U,2),B=$P(^APCHPWHC(+B,0),U) I B["CCI" S G=1
  1.  Q G
  1.  ;
  1. TQM(P) ;
  1.  NEW A,B,G
  1.  S G=""
  1.  S A=0 F  S A=$O(^APCHPWHT(P,1,A)) Q:A'=+A  S B=$P(^APCHPWHT(P,1,A,0),U,2),B=$P(^APCHPWHC(+B,0),U) I B["TRANSPAR" S G=1
  1.  Q G
  1.  ;