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

APCDPG1.m

Go to the documentation of this file. 
  1. APCDPG1 ; IHS/CMI/LAB - GOAL list update from list manager ;
  1.  ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
  1.  ;
  1.  ;
  1. DIE ;
  1.  S DA=APCDPIEN,DIE="^AUPNGOAL(",DR=APCDTEMP D ^DIE
  1. KDIE ;kill all vars used by DIE
  1.  K DIE,DR,DA,DIU,DIV,DQ,D0,DO,DI,DIW,DIY,%,DQ,DLAYGO,DIADD
  1.  Q
  1. GETGOAL ;get record
  1.  S APCDPIEN=0
  1.  S DIR(0)="N^1:"_APCDRCNT_":0",DIR("A")="Select GOAL" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) W !!,"No GOAL Seleted" Q
  1.  S APCDP=Y
  1.  S (X,Y)=0 F  S X=$O(APCDPG("IDX",X)) Q:X'=+X!(APCDPIEN)  I $O(APCDPG("IDX",X,0))=APCDP S Y=$O(APCDPG("IDX",X,0)),APCDPIEN=APCDPG("IDX",X,Y)
  1.  I '$D(^AUPNGOAL(APCDPIEN,0)) W !,"Not a valid GOAL." K APCDP S APCDPIEN=0 Q
  1.  D FULL^VALM1 ;give me full control of screen
  1.  Q
  1. ADD ;EP - called from protocol to add a GOAL to GOAL list
  1.  D FULL^VALM1 ; this gives me back all screen control
  1.  Q:'$G(APCDPGPT)  ; just want to be sure I have a patient
  1.  S APCDPAT=APCDPGPT
  1.  S:'$G(APCDLOC) APCDLOC=DUZ(2)
  1.  S:$G(APCDDATE)="" APCDDATE=APCDNDT
  1.  W:$D(IOF) @IOF W !,"Adding a new GOAL for ",$P(^DPT(APCDPGPT,0),U),".",!!
  1.  S APCDIGS=""
  1.  S DIR(0)="9000093,.01",DIR("A")="Enter INITIAL GOAL Setting" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D EXIT Q
  1.  S APCDIGS=Y
  1.  ;create goal entry and populate date created/last updated/creator/user last update
  1.  K DIC S DIC(0)="EL",DIC="^AUPNGOAL(",DLAYGO=9000093,DIADD=1,X=APCDIGS  ;,DIC("DR")=$S(APCDIGS="S":"[APCD PG (ADD)]",1:"[APCD PG NOT SET (ADD)]")
  1.  K DD,DO,D0 D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
  1.  I Y=-1 W !!,$C(7),$C(7),"Goal record not created.",! D PAUSE,EXIT Q
  1.  ;update multiple of user last update/date edited
  1.  S APCDPIEN=+Y
  1.  D KDIE S DA=APCDPIEN,DIE("NO^")=1,DIE="^AUPNGOAL(",DR=$S(APCDIGS="S":"[APCD PG (ADD)]",1:"[APCD PG NOT SET (ADD)]") D ^DIE
  1.  I $D(Y) W !!,"error creating goal.." D KDIE Q
  1.  D KDIE
  1.  I $P(^AUPNGOAL(APCDPIEN,0),U,1)="S" S APCDGOAL=APCDPIEN D STP^APCDAGOL
  1.  K DLAYGO D EXIT
  1.  Q
  1. EDIT ;EP - called from protocol to modify a GOAL on GOAL list
  1.  NEW APCDPIEN,APCDPAT
  1.  D GETGOAL
  1.  I 'APCDPIEN D PAUSE,EXIT Q
  1.  S APCDPAT=APCDPGPT
  1.  S:'$G(APCDLOC) APCDLOC=DUZ(2)
  1.  S:$G(APCDDATE)="" APCDDATE=APCDNDT
  1.  S X=$P(^AUPNGOAL(APCDPIEN,0),U,1)
  1.  S APCDTEMP=$S(X="S":"[APCD PG (MOD)]",1:"[APCD PG NOT SET (MOD)]")
  1.  W:$D(IOF) @IOF W !,"Editing GOAL ... "
  1.  D DIE
  1.  S DA=APCDPIEN,DIE="^AUPNGOAL(",DR=".05////^S X=$$NOW^XLFDT;.12////^S X=DUZ" D ^DIE
  1.  D REV
  1.  D EXIT
  1.  Q
  1. DEL ;EP - called from protocol to delete a GOAL on GOAL list
  1.  D FULL^VALM1
  1.  W !!,"PLEASE NOTE:  Goals should only be deleted if they were entered in error."
  1.  W !,"If you want to mark the goal as completed or if you want to change this goal,"
  1.  W !,"use the RV action to mark the goal as Met if it is complete or Stopped if"
  1.  W !,"this goal is being replaced with another goal.",!!
  1.  S DIR(0)="Y",DIR("A")="Do you wish to continue to delete a Goal",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D EXIT Q
  1.  I 'Y D EXIT Q
  1.  NEW APCDPIEN,APCDPAT
  1.  D GETGOAL
  1.  I 'APCDPIEN D PAUSE,EXIT Q
  1.  W:$D(IOF) @IOF
  1.  W !!,"Deleting the following GOAL from ",$P($P(^DPT(APCDPGPT,0),U),",",2)," ",$P($P(^(0),U),","),"'s GOAL List.",!
  1.  S DA=APCDPIEN,DIC="^AUPNGOAL(" D EN^DIQ
  1.  ;
  1.  W ! S DIR(0)="Y",DIR("A")="Are you sure you want to delete this GOAL",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I $D(DIRUT) W !,"okay, not deleted." D PAUSE,EXIT Q
  1.  I 'Y W !,"Okay, not deleted." D PAUSE,EXIT Q
  1.  ;S DA=APCDPIEN,DIK="^AUPNGOAL(" D ^DIK K DA,DIE,DR
  1.  S DA=APCDPIEN,DIE="^AUPNGOAL(",DR="[APCDPG DELETE GOAL]",DIE("NO^")=1 D ^DIE K DIE,DA,DR
  1.  D PAUSE,EXIT,^XBFMK
  1.  Q
  1. AN ;EP - add a step, called from protocol
  1.  NEW APCDPIEN
  1.  D GETGOAL
  1.  I 'APCDPIEN D PAUSE,EXIT Q
  1.  D NO1^APCDPG2
  1.  D EXIT
  1.  Q
  1. MN ;EP - called from protocol to modify a step
  1.  NEW APCDPIEN
  1.  D GETGOAL
  1.  I 'APCDPIEN D PAUSE,EXIT Q
  1.  D MN1^APCDPG2
  1.  D PAUSE,EXIT
  1.  Q
  1. RNO ;EP - called from protocol to remove a step
  1.  D FULL^VALM1
  1.  W !!,"PLEASE NOTE:  Steps should only be deleted if they were entered in error."
  1.  W !,"If you want to mark the step as completed or if you want to change this step,"
  1.  W !,"use the ES (Edit Step) action to mark the step as Met if it is complete or "
  1.  W !,"Stopped if this step is being replaced with another step.",!!
  1.  S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D EXIT Q
  1.  I 'Y D EXIT Q
  1.  NEW APCDPIEN
  1.  D GETGOAL
  1.  I 'APCDPIEN D PAUSE,EXIT Q
  1.  D RNO1^APCDPG2
  1.  D PAUSE,EXIT
  1.  Q
  1. HS ;EP - called from protocol to display health summary
  1.  D FULL^VALM1
  1.  S X="" I DUZ(2),$D(^APCCCTRL(DUZ(2),0))#2 S X=$P(^(0),U,3) I X,$D(^APCHSCTL(X,0)) S X=$P(^APCHSCTL(X,0),U)
  1.  I $D(^DISV(DUZ,"^APCHSCTL(")) S Y=^("^APCHSCTL(") I $D(^APCHSCTL(Y,0)) S X=$P(^(0),U,1)
  1.  S:X="" X="ADULT REGULAR"
  1.  K DIC,DR,DD S DIC("B")=X,DIC="^APCHSCTL(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DD,D0,D1,DQ
  1.  I Y=-1 D PAUSE,EXIT Q
  1.  S APCHSTYP=+Y,APCHSPAT=APCDPGPT
  1.  S APCDHDR="PCC Health Summary for "_$P(^DPT(APCDPGPT,0),U)
  1.  D VIEWR^XBLM("EN^APCHS",APCDHDR)
  1.  S (DFN,Y)=APCDPGPT D ^AUPNPAT
  1.  K APCHSPAT,APCHSTYP,APCHSTAT,APCHSMTY,AMCHDAYS,AMCHDOB,APCDHDR
  1.  D EXIT
  1.  Q
  1. DD ;EP - called from protocol to display (DIQ) a GOAL in detail
  1.  NEW APCDPIEN
  1.  D GETGOAL
  1.  I 'APCDPIEN D PAUSE,EXIT Q
  1.  D DIQ^XBLM(9000093,APCDPIEN)
  1.  D EXIT
  1.  Q
  1. FS ;EP -called from protcol to display face sheet
  1.  D FULL^VALM1
  1.  S APCDHDR="Demographic Face Sheet For "_$P(^DPT(APCDPGPT,0),U)
  1.  D VIEWR^XBLM("START^AGFACE",APCDHDR)
  1.  K AGOPT,AGDENT,AGMVDF,APCDHDR
  1.  D EXIT
  1.  Q
  1. PAUSE ;EP
  1.  S DIR(0)="EO",DIR("A")="Press return to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  Q
  1. GETNUM(P) ;EP - get GOAL number given ien of GOAL entry
  1.  NEW N,F
  1.  S N=""
  1.  I 'P Q N
  1.  I '$D(^AUPNGOAL(P,0)) Q N
  1.  S F=$P(^AUPNGOAL(P,0),U,6)
  1.  S N=$S($P(^AUTTLOC(F,0),U,7)]"":$J($P(^(0),U,7),4),1:"??")_$P(^AUPNGOAL(P,0),U,7)
  1.  Q N
  1. EXIT ;
  1.  D TERM^VALM0
  1.  S VALMBCK="R"
  1.  D GATHER^APCDPG
  1.  S VALMCNT=APCDLINE
  1.  D HDR^APCDPG
  1.  K APCDTEMP,APCDPRMT,APCDP,APCDPIEN,APCDAF,APCDF,APCDP0,APCDPRB
  1.  D KDIE
  1.  Q
  1. REVE ;
  1.  NEW APCDPIEN,APCDPAT
  1.  D GETGOAL
  1.  I 'APCDPIEN D PAUSE,EXIT Q
  1.  S APCDPAT=APCDPGPT
  1.  S:'$G(APCDLOC) APCDLOC=DUZ(2)
  1.  S:$G(APCDDATE)="" APCDDATE=APCDNDT
  1.  S DA=APCDPIEN,DIE="^AUPNGOAL(",DR=".05////^S X=$$NOW^XLFDT;.12////^S X=DUZ" D ^DIE
  1.  S APCDSS=$P(^AUPNGOAL(APCDPIEN,0),U,11)
  1.  I $P(^AUPNGOAL(APCDPIEN,0),U,1)="N" G REVE1
  1.  S DIR(0)="S^ME:GOAL MET;MA:MAINTAINING GOAL;S:GOAL STOPPED;N:NO CHANGE",DIR("A")="GOAL STATUS",DIR("B")=APCDSS KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D EXIT Q
  1.  S APCDSS=Y
  1.  I APCDSS="N" G REVE1
  1.  S DR=".11////"_APCDSS_$S(APCDSS="MA":";.1",1:"")
  1.  S DA=APCDPIEN,DIE="^AUPNGOAL("
  1.  D ^DIE
  1.  K DIE,DR,DA
  1. REVE1 D REV
  1.  D EXIT
  1.  Q
  1. REV ;
  1.  W !!?3,"Review/Progress Notes currently on file for this goal:"
  1.  S APCDC=0 K APCDCM
  1.  I '$O(^AUPNGOAL(APCDPIEN,13,0)) W "  None recorded" G FM12
  1.  D EN^DDIOL($$REPEAT^XLFSTR("-",75),"","!?3")
  1.  S X=0 F  S X=$O(^AUPNGOAL(APCDPIEN,13,X)) Q:X'=+X  D
  1.  .S APCDC=APCDC+1,APCDCM(APCDC)=X
  1.  .W !?2,APCDC,")  ",$$DATE^APCDPG($P(^AUPNGOAL(APCDPIEN,13,X,0),U,1)),"  ",$P(^AUPNGOAL(APCDPIEN,13,X,0),U,2)
  1. FM12 ;
  1.  D EN^DDIOL("","","!!")
  1.  K DIR
  1.  S DIR(0)="S^A:Add a Review/Progress Note"_$S(APCDC:";E:Edit an Existing Review/Progress Note;D:Delete an Existing Review/Progress Note",1:"")_";N:No Change"
  1.  S DIR("A")="Which action",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G FM13
  1.  I Y="N" S APCDDONE=1 G FM13
  1.  S Y="FM"_Y
  1.  D @Y
  1.  G REV
  1. FM13 ; 
  1.  K Y,APCDC,APCDCM
  1.  Q
  1.  ;
  1. FME ;
  1.  D EN^DDIOL("","","!")
  1.  K DIR
  1.  S DIR(0)="N^1:"_APCDC_":0",DIR("A")="Edit Which One" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) Q
  1.  K DIC,DA,DR
  1.  S DA(1)=APCDPIEN,DA=APCDCM(Y)
  1.  S DIE="^AUPNGOAL("_APCDPIEN_",13,",DIC("P")=$P(^DD(9000093,1300,0),U,2)
  1.  S DR=".02"
  1.  D ^DIE
  1.  D KDIE
  1.  Q
  1. FMD ;
  1.  D EN^DDIOL("","","!")
  1.  K DIR
  1.  S DIR(0)="N^1:"_APCDC_":0",DIR("A")="Delete Which One" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) Q
  1.  K DIC,DA,DR
  1.  S DA(1)=APCDPIEN,DA=APCDCM(Y)
  1.  S DIE="^AUPNGOAL("_APCDPIEN_",13,",DIC("P")=$P(^DD(9000093,1300,0),U,2)
  1.  S DR=".01///@"
  1.  D ^DIE
  1.  D KDIE
  1.  Q
  1. FMA ;
  1.  ;GET DATE/TEXT
  1.  ;call FILE^DICN to file this POV
  1.  ;
  1.  S APCDREVD=""
  1.  S DIR(0)="D^:DT:EP",DIR("A")="Enter date of Review",DIR("B")=$$FMTE^XLFDT(DT) KILL DA D ^DIR KILL DIR
  1.  Q:$D(DIRUT)
  1.  S APCDREVD=Y
  1.  S APCDREVT=""
  1.  S DIR(0)="F^2:120",DIR("A")="Enter Review/Progress Note" KILL DA D ^DIR KILL DIR
  1.  Q:$D(DIRUT)
  1.  Q:Y=""
  1.  S APCDREVT=Y
  1.  ;now file
  1.  S DA=APCDPIEN,DIE="^AUPNGOAL(",DR="1300///"_$$FMTE^XLFDT(APCDREVD),DR(2,9000093.13)=".02////^S X=APCDREVT" D ^DIE K DIE,DA,DR
  1.  K DIC,DA,DR,Y,X
  1.  Q
  1. IG ;EP - called from protocol to display health summary
  1.  D FULL^VALM1
  1.  ;
  1.  S APCDHDR="Inactive (Met and Stopped Goals) for "_$P(^DPT(APCDPGPT,0),U)
  1.  D VIEWR^XBLM("IG1^APCDPG1",APCDHDR)
  1.  D CLEAR^VALM1
  1.  D EXIT
  1.  Q
  1. IG1 ;
  1.  ;LOOP THROUGH AND DISPLAY ALL INACTIVE GOALS USING DIQ
  1.  NEW APCDX,APCDY,APCDF
  1.  S APCDF=0 F  S APCDF=$O(^AUPNGOAL("AA",APCDPGPT,APCDF)) Q:APCDF'=+APCDF  D
  1.  .S APCDPGI="" F  S APCDPGI=$O(^AUPNGOAL("AA",APCDPGPT,APCDF,APCDPGI)) Q:APCDPGI=""  D
  1.  ..S APCDPIEN=$O(^AUPNGOAL("AA",APCDPGPT,APCDF,APCDPGI,"")),APCDP0=^AUPNGOAL(APCDPIEN,0)
  1.  ..Q:$P(APCDP0,U,1)="N"
  1.  ..Q:$P(APCDP0,U,11)="A"
  1.  ..Q:$P(APCDP0,U,11)="D"
  1.  ..Q:$P(APCDP0,U,11)="MA"
  1.  ..S APCDSTR="" D SET
  1.  ..D BUILD
  1.  Q
  1. SET ;set array
  1.  W APCDSTR,!
  1.  Q
  1. BUILD ; build array
  1.  NEW APCDSTR,APCDI,APCDII,APCDSTR,APCDAR,APCDF,APCDVREC,APCDV,APCDH,APCDSTR,APCDVFLE,APCDVNM,APCDVI,APCDNARR,APCDVDG,APCDVIGR,APCDJ,APCDF1,APCDVFC,APCDCTR
  1.  NEW F,F1,X,H
  1.  K APCDAR
  1.  S APCDSTR="",APCDCTR=0
  1.  S APCDH="Patient Name",APCDV=$E($P(^DPT($P(APCDP0,U,2),0),U),1,20) D BUILD1
  1.  S APCDSTR="" D SET
  1. GOAL ;
  1.  D GETS^DIQ(9000093,APCDPIEN_",","**","","APCDAR")
  1.  S APCDI=APCDPIEN_","
  1.  S F=9000093 F APCDF=.01,.03,.04,.06,.07,.08 I $G(APCDAR(F,APCDI,APCDF))]"" D
  1.  .Q:APCDF=".02"
  1.  .S APCDH=$P(^DD(F,APCDF,0),U)
  1.  .S APCDV=APCDAR(F,APCDI,APCDF)
  1.  .D BUILD1
  1.  .Q
  1.  ;GOAL TYPE
  1.  S F=9000093.01,APCDII=0
  1.  S APCDF="" F  S APCDII=$O(APCDAR(F,APCDII)) Q:APCDII=""  D
  1.  .S APCDF=0 F  S APCDF=$O(APCDAR(F,APCDII,APCDF)) Q:APCDF=""  D
  1.  ..S APCDH=$P(^DD(9000093.01,APCDF,0),U,1)
  1.  ..S APCDV=APCDAR(F,APCDII,APCDF)
  1.  ..D BUILD1
  1.  S F=9000093 F APCDF=1101,1201,.09,.1,.11,.05,.12 I $G(APCDAR(F,APCDI,APCDF))]"" D
  1.  .S APCDH=$P(^DD(F,APCDF,0),U)
  1.  .S APCDV=APCDAR(F,APCDI,APCDF)
  1.  .D BUILD1
  1.  .Q
  1.  ;STEPS
  1.  I $O(^AUPNGOAL(APCDPIEN,21,0)) S APCDSTR="" D SET S APCDSTR="Steps: " D SET
  1.  S F=9000093.211101,APCDII=0
  1.  S APCDF="" F  S APCDII=$O(APCDAR(F,APCDII)) Q:APCDII=""  D
  1.  .S APCDSTR="" D SET
  1.  .S APCDF=0 F  S APCDF=$O(APCDAR(F,APCDII,APCDF)) Q:APCDF=""  D
  1.  ..S APCDH=$P(^DD(F,APCDF,0),U,1)
  1.  ..S APCDV=APCDAR(F,APCDII,APCDF)
  1.  ..D BUILD1
  1.  ;STEPS
  1.  I $O(^AUPNGOAL(APCDPIEN,13,0)) S APCDSTR="" D SET S APCDSTR="Followup/Reviews: " D SET
  1.  S F=9000093.13,APCDII=0
  1.  S APCDF="" F  S APCDII=$O(APCDAR(F,APCDII)) Q:APCDII=""  D
  1.  .S APCDSTR="" D SET
  1.  .S APCDF=0 F  S APCDF=$O(APCDAR(F,APCDII,APCDF)) Q:APCDF=""  D
  1.  ..S APCDH=$P(^DD(F,APCDF,0),U,1)
  1.  ..S APCDV=APCDAR(F,APCDII,APCDF)
  1.  ..D BUILD1
  1.  S APCDSTR="" D SET
  1.  Q  ;
  1. BUILD1 ;
  1.  S APCDSTR=$E(APCDH,1,21)_":",APCDSTR=$$SETSTR^VALM1(APCDV,APCDSTR,24,$L(APCDV))
  1.  D SET
  1.  Q