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