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

APCHAAP1.m

Go to the documentation of this file. 
  1. APCHAAP1 ; IHS/CMI/LAB - ;
  1.  ;;2.0;IHS PCC SUITE;**2,8**;MAY 14, 2009;Build 2
  1.  ;
  1. EN ;
  1.  W:$D(IOF) @IOF
  1.  W !!,$$CTR("*** Print ASTHMA ACTION PLAN ***"),!!
  1.  W "This option will produce an Asthma Action Plan that",!,"can be given to the patient.",!!
  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 D EXIT Q
  1.  S DFN=+Y W:$D(^AUPNPAT(DFN,41,DUZ(2),0)) !,"Patient's chart number is ",$P(^(0),U,2),! W !
  1. RELMED ;
  1.  S APCHRELM=$P($$REDZONE(DFN),U)  ;get last recorded red zone instructions
  1.  W !!,"Please enter the RED ZONE Plan for this patient, including medication name(s)"
  1.  W !,"and instructions.",!
  1.  I APCHRELM]"" W !,"Red Zone Instructions currently recorded:",!?2,APCHRELM,!
  1.  S DIR(0)="S^B:Display a Blank line for the Instructions to be Hand Written;N:Enter a New Set of Red Zone Instructions"_$S(APCHRELM]"":";E:Use Existing Red Zone Instructions shown above",1:"")
  1.  S DIR("A")="Red Zone Instructions" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G SELPT
  1.  I Y="" G SELPT
  1.  S APCHRZC=Y
  1.  I APCHRZC="B" S APCHRELM="" G RESMED
  1.  I APCHRZC="E" G RESMED
  1.  ;S DIR(0)="FO^2:200",DIR("A")="Enter Patient's Red Zone instructions" KILL DA D ^DIR KILL DIR
  1.  S DIR(0)="9000010.41,1301",DIR("A")="Enter Red Zone Instructions" KILL DA D ^DIR KILL DIR
  1.  I X="^" G SELPT
  1.  I $D(DIRUT) G SELPT
  1.  S APCHRELM=Y ;I APCHRELM="" S APCHRELM="________________________________________________________________"
  1. RESMED ;
  1.  S APCHRESM=$P($$YELZONE(DFN),U)  ;get last recorded YELLOW zone instructions
  1.  W !!,"Please enter the YELLOW ZONE Plan for this patient, including medication name(s)"
  1.  W !,"and instructions.",!
  1.  I APCHRESM]"" W !,"Red Zone Instructions currently recorded:",!?2,APCHRESM,!
  1.  S DIR(0)="S^B:Display a Blank line for the Instructions to be Hand Written;N:Enter a New Set of Yellow Zone Instructions"_$S(APCHRESM]"":";E:Use Existing Yellow Zone Instructions on File",1:"")
  1.  S DIR("A")="Yellow Zone Instructions" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G RELMED
  1.  I Y="" G RELMED
  1.  S APCHRZY=Y
  1.  I APCHRZY="B" S APCHRESM="" G VISIT
  1.  I APCHRZY="E" G VISIT
  1.  ;S DIR(0)="FO^2:200",DIR("A")="Enter Patient's Red Zone instructions" KILL DA D ^DIR KILL DIR
  1.  S DIR(0)="9000010.41,1101",DIR("A")="Enter Yellow Zone Instructions" KILL DA D ^DIR KILL DIR
  1.  I X="^" G RESMED
  1.  I $D(DIRUT) G RESMED
  1.  S APCHRESM=Y ;I APCHRELM="" S APCHRELM="________________________________________________________________"
  1.  ;
  1. VISIT ;
  1.  I APCHRZY="B",APCHRZC="B" G ZIS  ;if 2 blank lines then don't ask for visit as there is nothing to store in V ASTHMA
  1.  ;CHECK TO SEE IF ALREADY STORED TODAY
  1.  S (O,T)=""
  1.  S R=$$REDZONE(DFN) I $P(R,U)=APCHRELM,$P(R,U,2)=DT S O=1
  1.  S Y=$$YELZONE(DFN) I $P(Y,U)=APCHRESM,$P(Y,U,2)=DT S T=1
  1.  I O,T W !!,"These instuctions are already stored for today." G ZIS
  1.  ;get visit to attach the instructions to
  1.  K APCHIN
  1.  S APCHIN("PAT")=DFN
  1.  S APCHIN("VISIT DATE")=DT_".12"
  1.  S APCHIN("SITE")=DUZ(2)
  1.  S APCHIN("VISIT TYPE")=$S($P($G(^APCCCTRL(DUZ(2),0)),U,4)]"":$P(^APCCCTRL(DUZ(2),0),U,4),1:"O")
  1.  S APCHIN("SRV CAT")="A"
  1.  S APCHIN("USR")=DUZ
  1.  S APCHIN("SHOW VISITS")=1
  1.  S APCHIN("TIME RANGE")=-1
  1. VISIT1 ;
  1.  K APCDALVR
  1.  K APCHV
  1.  D GETVISIT^APCDAPI4(.APCHIN,.APCHV)
  1.  S APCHERR=$P(APCHV(0),U,2)
  1.  I APCHERR]"" W !!,"Error creating visit......." G SELPT
  1.  I $P(APCHV(0),U)=1 S V=$O(APCHV(0)) I APCHV(V)="ADD" S APCDVSIT=V G VAST
  1.  ;since more than one passed back display them to the user and quit
  1.  W !!,"You must now select a visit to attach these instuctions to.  Select the "
  1.  W !,"appropriate visit or create a new visit.",!
  1. SELECT ; SELECT EXISTING VISIT
  1.  W !!,"PATIENT: ",$P(^DPT(DFN,0),U)," has one or more VISITs on ",$$FMTE^XLFDT(DT),".",!,"If one of these is your visit, please select it",!
  1.  K APCHV1 S (APCHC,APCHA,APCHX)="",APCHV1=0 F  S APCHV1=$O(APCHV(APCHV1)) Q:APCHV1'=+APCHV1  S APCHX=$G(^AUPNVSIT(APCHV1,0)),APCHX11=$G(^AUPNVSIT(APCHV1,11)) D WRITE
  1.  S APCHC=APCHC+1 W !,APCHC,"  Create New Visit",!
  1.  K DIR
  1.  S DIR(0)="N^1:"_APCHC,DIR("A")="Select" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) S APCHIN("FORCE ADD")=1 G VISIT1
  1.  I APCHC=Y S APCHIN("FORCE ADD")=1 G VISIT1
  1.  S APCDVSIT=APCHX1(Y)
  1.  K APCHIN,APCDALVR
  1. VAST ;now create V Asthma entry
  1.  ;
  1.  K APCDALVR
  1.  S APCDALVR("APCDVSIT")=APCDVSIT
  1.  S APCDALVR("APCDATMP")="[APCDALVR 9000010.41 (ADD)]"
  1.  S APCDALVR("APCDTPRV")="`"_DUZ
  1.  S APCDAVLR("APCDTEPR")="`"_DUZ
  1.  S APCDALVR("APCDPAT")=DFN
  1.  S APCDALVR("APCDTRZ")=$P(APCHRELM,U,1)
  1.  S APCDALVR("APCDTYZ")=$P(APCHRESM,U,1)
  1.  D ^APCDALVR
  1.  I $D(APCDALVR("APCDAFLG")) W !!,"Error creating V Asthma entry to store instuctions." G SELPT
  1.  ;
  1. ZIS ;
  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^APCHAAP1",XBRC="",XBRX="EXIT^APCHAAP1",XBNS="APCH"
  1.  D ^XBDBQUE
  1.  D EXIT
  1.  Q
  1. WRITE ; WRITE VISITS FOR SELECT
  1.  S APCHC=APCHC+1,APCHX1(APCHC)=APCHV1
  1.  S APCHVLT=$P(+APCHX,".",2),APCHVLT=$S(APCHVLT="":"<NONE>",$L(APCHVLT)=1:APCHVLT_"0:00 ",1:$E(APCHVLT,1,2)_":"_$E(APCHVLT,3,4)_$E("00",1,2-$L($E(APCHVLT,3,4)))_" ")
  1.  S APCHVLOC=""
  1.  I $P(APCHX,U,6),$D(^AUTTLOC($P(APCHX,U,6),0)) S APCHVLOC=$P(^(0),U,7),APCHVLOC=APCHVLOC_$E("    ",1,4-$L(APCHVLOC))
  1.  S:APCHVLOC="" APCHVLOC="...."
  1.  W !,APCHC,"  TIME: ",APCHVLT,"LOC: ",APCHVLOC," TYPE: ",$P(APCHX,U,3)," CAT: ",$P(APCHX,U,7)," CLINIC: ",$S($P(APCHX,U,8)]"":$E($P(^DIC(40.7,$P(APCHX,U,8),0),U),1,8),1:"<NONE>") D
  1.  .W ?57,"DEC: ",$S($P(APCHX,U,9):$P(APCHX,U,9),1:0),$S($P(APCHX11,U,3)]"":" VCN:"_$P(APCHX11,U,3),1:"")
  1.  .I $P(APCHX,U,22) W !?3,"Hospital Location: ",$P($G(^SC($P(APCHX,U,22),0)),U)
  1.  .S APCHTIU=$$PRIMPROV^APCLV(APCHV1,"N") I APCHTIU]"" W !?3,"Provider on Visit: ",APCHTIU
  1.  .S APCHTIU=$O(^AUPNVNOT("AD",APCHV1,0)) I APCHTIU W !?3,"TIU Note: ",$$VAL^XBDIQ1(9000010.28,APCHTIU,.01),"  AUTHOR: ",$$VAL^XBDIQ1(9000010.28,APCHTIU,1202)
  1.  .S APCHTIU=$$PRIMPOV^APCLV(APCHV1,"C") W !?3,"Primary POV: ",APCHTIU,"  Narrative: ",$E($$PRIMPOV^APCLV(APCHV1,"N"),1,40)
  1.  K APCHVLT,APCHVLOC,APCHTIU
  1.  Q
  1. BROWSE ;
  1.  S XBRP="VIEWR^XBLM(""PRINT^APCHAAP1"")"
  1.  S XBRC="",XBRX="EXIT^APCHAAP1",XBIOP=0 D ^XBDBQUE
  1.  Q
  1. PRINT ;EP
  1.  D PRINT^APCHAAP2
  1.  Q
  1. REDZONE(P) ;EP - get last recorded red zone instructions
  1.  NEW R,D,I,S
  1.  S R=""  ;instructions
  1.  S D=""
  1.  S S=""
  1.  F  S D=$O(^AUPNVAST("AA",P,D)) Q:D'=+D!(R]"")  D
  1.  .S I=0 F  S I=$O(^AUPNVAST("AA",P,D,I)) Q:I'=+I  D
  1.  ..S R=$P($G(^AUPNVAST(I,13)),U,1),S=9999999-D
  1.  ..Q
  1.  .Q
  1.  Q R_U_S
  1. YELZONE(P) ;EP - get last recorded yellow zone instructions
  1.  NEW R,D,I
  1.  S R=""  ;instructions
  1.  S D="",S=""
  1.  F  S D=$O(^AUPNVAST("AA",P,D)) Q:D'=+D!(R]"")  D
  1.  .S I=0 F  S I=$O(^AUPNVAST("AA",P,D,I)) Q:I'=+I  D
  1.  ..S R=$P($G(^AUPNVAST(I,11)),U,1),S=9999999-D
  1.  ..Q
  1.  .Q
  1.  Q R_U_S
  1.  I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCHQ=1 Q
  1. HEAD1 ;
  1.  W:$D(IOF) @IOF
  1.  W !,$P(^DIC(4,DUZ(2),0),U),?53,"Today's Date: ",$$FMTE^XLFDT(DT),!
  1.  W "Patient Name: ",$P(^DPT(DFN,0),U)
  1.  W ?45,"Birth Date: ",$$DOB^AUPNPAT(DFN,"E")
  1.  W ?71,"Age: ",$$AGE^AUPNPAT(DFN),!
  1.  W $$REPEAT^XLFSTR("_",79),!!
  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. EXIT ;
  1.  D EN^XBVK("APCH")
  1.  D ^XBFMK
  1.  Q