APCDPG ; IHS/CMI/LAB - GOAL LIST UPDATE ;
;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
;; ;
START ;
W:$D(IOF) @IOF
F J=1:1:5 S X=$P($T(TEXT+J),";;",2) W !?80-$L(X)\2,X
K X,J
W !!
S APCDPGPT="" F D GETPAT Q:APCDPGPT="" S DFN=APCDPGPT D EN1,FULL^VALM1,EXIT K APCDPGPT
D EOJ
Q
GETPAT ;get patient
K ^TMP($J,"APCDPG")
K APCDPGPT,APCDLOC,APCDPAT,APCDDATE,APCDPIEN,APCDAF,APCDPGI,APCDOVRR,APCDLOOK,APCDPDFN
D KILL^AUPNPAT
S APCDPGPT=""
I '$P($G(^APCDSITE(DUZ(2),0)),U,34) S AUPNLK("INAC")=1
W !
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
Q:Y<0
S APCDPGPT=+Y
D INAC^APCDEA(APCDPGPT,.X) I 'X S APCDPGPT="" Q
D DOD(APCDPGPT,.X) I 'X S APCDPGPT="" Q
Q
GETLOC ;
S APCDLOC="",DIC="^AUTTLOC(",DIC(0)="AEMQ",DIC("B")=$P(^DIC(4,$S($G(APCDLOC):APCDLOC,1:DUZ(2)),0),U),DIC("A")="Location where GOAL List update occurred: " D ^DIC K DIC
Q:Y<0
S APCDLOC=+Y
Q
GETDATE ;
S APCDDATE=""
W !!,"Date GOAL List Updated: " R X:$S($D(DTIME):DTIME,1:300) S:'$T X=""
Q:X=""!(X="^")
S %DT="ET" D ^%DT G:Y<0 GETDATE
I Y>DT W " <Future dates not allowed>",$C(7),$C(7) K X G GETDATE
S APCDDATE=Y
Q
EOJ ;End of job cleanup
D:$D(VALMWD) CLEAR^VALM1 ;clears out all list man stuff
K ^TMP($J,"APCDPG")
K XQORNEST,VALMKEY,VALM,VALMAR,VALMBCK,VALMBG,VALMCAP,VALMCNT,VALMOFF,VALMMCON,VALMDN,VALMEVL,VALMIOXY,VALMKEY,VALMLFT,VALMLST,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMY,XQORS,XQORSPEW
K APCDPGPT,APCDLOC,APCDPAT,APCDDATE,APCDPIEN,APCDAF,APCDPGI,APCDOVRR,APCDLOOK,APCDPDFN
D KILL^AUPNPAT
Q
EN1 ;PEP - requires DFN to be set to patient
K ^TMP($J,"APCDPG")
Q:'$G(DFN)
S APCDPGPT=DFN
Q:'$G(APCDPGPT)
Q:'$D(^AUPNPAT(APCDPGPT))
Q:'$D(^DPT(APCDPGPT))
S Y=APCDPGPT D ^AUPNPAT
D GETLOC
I '$G(APCDLOC) D EXIT Q
D GETDATE
I '$G(APCDDATE) D EXIT Q
S APCDOVRR=1
D EN
K APCDPGPT
D FULL^VALM1
D EXIT
Q
EN2 ;PEP - can be called to update GOAL list, called from applications outside of PCC
D GETPAT
D EN
D FULL^VALM1
D EXIT
Q
ENDE ;EP - for data entry PL call
Q:'$G(DFN)
S APCDPGPT=DFN
Q:'$G(APCDPGPT)
Q:'$D(^AUPNPAT(APCDPGPT))
Q:'$D(^DPT(APCDPGPT))
S Y=APCDPGPT D ^AUPNPAT
S APCDLOC=APCDPLL
I '$G(APCDLOC) D EXIT Q
S APCDDATE=APCDPLD
I '$G(APCDDATE) D EXIT Q
S APCDV=$G(APCDPLV)
S APCDOVRR=1
D EN
K APCDPGPT
D FULL^VALM1
D EXIT
Q
EN ;PEP main entry point for APCD PG GOAL LIST
S VALMCC=1 ;1 means screen mode, 0 means scrolling mode
D EN^VALM("APCD PG GOAL LIST")
D CLEAR^VALM1
Q
;
HDR ;EP -- header code
S VALMHDR(1)=$TR($J(" ",80)," ","-")
S VALMHDR(2)="Patient Name: "_IORVON_$P(^DPT(APCDPGPT,0),U)_IOINORM_" DOB: "_$$FTIME^VALM1(AUPNDOB)_" Sex: "_$P(^DPT(APCDPGPT,0),U,2)_" HRN: "_$S($D(^AUPNPAT(APCDPGPT,41,DUZ(2),0)):$P(^AUPNPAT(APCDPGPT,41,DUZ(2),0),U,2),1:"????")
S VALMHDR(3)="'Active Goals are listed first followed by Goals not set."
S VALMHDR(4)="Inactive goals are not listed."
S VALMHDR(5)=$TR($J(" ",80)," ","-")
Q
;
INIT ; -- init variables and list array
D GATHER ;gather up all GOALs
S VALMCNT=APCDLINE ;this variable must be the total number of lines in list
S APCDOVRR="" ;for provider narrative lookup
Q
;
GATHER ;EP
;set up array containing list of GOALs
;**** see page 7 of List Manager Manual for info on how to
;**** set up the array that contains the list
K APCDPG
NEW APCDSX
K APCDQUIT,APCDPG S APCDRCNT=0,APCDLINE=0
I '$D(^AUPNGOAL("AC",APCDPGPT)) S APCDPG(1,0)="No GOALs currently on file",APCDPG("IDX",1,1)="" S APCDLINE=1 ;Q
S APCDLINE=APCDLINE+1,APCDPG(APCDLINE,0)=" "
S APCDRCNT=0
S APCDAF="A" D GATHER1 S APCDAF="N" D GATHER1
Q
GATHER1 ;
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="" S APCDPIEN=$O(^(APCDPGI,"")),APCDP0=^AUPNGOAL(APCDPIEN,0) D
..Q:$P(^AUPNGOAL(APCDPIEN,0),U,11)="D" ;NO DELETED
..;Q:$P(^AUPNGOAL(APCDPIEN,0),U,1)="N"
..Q:$P(^AUPNGOAL(APCDPIEN,0),U,11)="ME"
..Q:$P(^AUPNGOAL(APCDPIEN,0),U,11)="C"
..Q:$P(^AUPNGOAL(APCDPIEN,0),U,11)="S"
..I APCDAF="A" Q:$P(^AUPNGOAL(APCDPIEN,0),U,1)'="S"
..I APCDAF="N" Q:$P(^AUPNGOAL(APCDPIEN,0),U,1)'="N"
..S APCDRCNT=APCDRCNT+1,APCDLINE=APCDLINE+1,APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN,APCDX=""
..S APCDX=$$SETSTR^VALM1($J(APCDRCNT,2),APCDX,3,2),APCDX=$$SETSTR^VALM1(") GOAL ID: ",APCDX,5,11)
..S X=$S($P(^AUTTLOC(APCDF,0),U,7)]"":$J($P(^(0),U,7),4),1:"??")_$P(APCDP0,U,7),APCDX=$$SETSTR^VALM1(X,APCDX,16,10)
..S APCDX=$$SETSTR^VALM1("Status: ",APCDX,27,8),X=$$VAL^XBDIQ1(9000093,APCDPIEN,.01)_$S($P(APCDP0,U,11)]"":" - "_$$VAL^XBDIQ1(9000093,APCDPIEN,.11),1:""),APCDX=$$SETSTR^VALM1(X,APCDX,36,26)
..;S X="Created: "_$$DATE($P(APCDP0,U,3))_" By: "_$$VAL^XBDIQ1(9000093,APCDPIEN,.04)
..;S APCDX=$$SETSTR^VALM1(X,APCDX,63,20)
..S APCDPG(APCDLINE,0)=APCDX,APCDX="",APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
..S APCDLINE=APCDLINE+1
..I $P(^AUPNGOAL(APCDPIEN,0),U,1)="S" S APCDX=" Goal Start Date: "_$$DATE($P(APCDP0,U,9))_" Goal Follow up Date: "_$$DATE($P(APCDP0,U,10))
..I $P(^AUPNGOAL(APCDPIEN,0),U,1)="N" S APCDX=" Goal Created Date: "_$$DATE($P(APCDP0,U,3))
..S APCDPG(APCDLINE,0)=APCDX,APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
..;goal name, reason
..S APCDLINE=APCDLINE+1
..S APCDX=" Goal Name: "_$$VAL^XBDIQ1(9000093,APCDPIEN,1101)
..S APCDPG(APCDLINE,0)=APCDX,APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
..S APCDLINE=APCDLINE+1
..S APCDX=$S($P(^AUPNGOAL(APCDPIEN,0),U,1)="S":" Goal Reason: ",1:" Reason Goal Not Set: ")_$$VAL^XBDIQ1(9000093,APCDPIEN,1201)
..S APCDPG(APCDLINE,0)=APCDX,APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
..S APCDLINE=APCDLINE+1
..S APCDX=" Provider: "_$$VAL^XBDIQ1(9000093,APCDPIEN,.08)
..S APCDPG(APCDLINE,0)=APCDX,APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
..I $O(^AUPNGOAL(APCDPIEN,13,0)) S APCDX=" Review/Progress Notes on file, use DD to see full display." D
...S APCDLINE=APCDLINE+1,APCDPG(APCDLINE,0)=APCDX,APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
STEP ..S APCDC=0 I $O(^AUPNGOAL(APCDPIEN,21,0)) D
...S (APCDC,APCDL)=0 F S APCDL=$O(^AUPNGOAL(APCDPIEN,21,APCDL)) Q:APCDL'=+APCDL I $O(^AUPNGOAL(APCDPIEN,21,APCDL,11,0)) S APCDLR=$P(^AUTTLOC($P(^AUPNGOAL(APCDPIEN,21,APCDL,0),U),0),U,7) D
....S APCDX=0 F S APCDX=$O(^AUPNGOAL(APCDPIEN,21,APCDL,11,APCDX)) Q:APCDX'=+APCDX D
.....Q:$P(^AUPNGOAL(APCDPIEN,21,APCDL,11,APCDX,0),U,9)="D"
.....S APCDC=APCDC+1 I APCDC=1 S X=IOINORM_" "_IORVON_"Steps:"_IORVOFF S APCDLINE=APCDLINE+1,APCDPG(APCDLINE,0)=X,APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
.....S X=" "_APCDLR_" Step#"_APCDC,$E(X,25)=$P($G(^AUPNGOAL(APCDPIEN,21,APCDL,11,APCDX,11)),U,1)
.....S APCDLINE=APCDLINE+1,APCDPG(APCDLINE,0)=X,APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
.....S X="",$E(X,12)="Status: "_$E($$SS($P($G(^AUPNGOAL(APCDPIEN,21,APCDL,11,APCDX,0)),U,9)),1,15)
.....S $E(X,38)="Start Date: "_$$DATE($P(^AUPNGOAL(APCDPIEN,21,APCDL,11,APCDX,0),U,5)),$E(X,60)="F/U Date: "_$$DATE($P(^AUPNGOAL(APCDPIEN,21,APCDL,11,APCDX,0),U,6))
.....S APCDLINE=APCDLINE+1,APCDPG(APCDLINE,0)=X,APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
..Q
.Q
K APCDLR,APCDL,APCDX,APCDF
Q
TEXT ;
;;Patient Care Component (PCC)
;;
;;***********************************
;;* Update PCC Patient GOAL List *
;;***********************************
;;
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP($J,"APCDPG")
K APCDRCNT,APCDPG,APCDLINE,APCDX,APCDP0,APCDC,APCDL,APCDLR,APCDPIEN,APCDAF,APCDPGI,APCDOVRR,APCDLOOK,APCDPDFN,APCDLOC,APCDDATE
K X,Y
K VALMHDR
Q
;
EXPND ; -- expand code
Q
;
DATE(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
DOD(P,RETVAL) ;EP - called to check to see if patient is inactive
S RETVAL=1
I $P($G(^DPT(P,.35)),U,1)]"" D Q
.W !!,"***Warning*** You have selected a patient who is deceased.",!
.K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue to add data for this patient",DIR("B")="Y" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) S RETVAL=0
.S RETVAL=Y
Q
SS(%) ;EP
I %="A" Q "ACTIVE"
I %="MA" Q "MAINTAINING STEP"
I %="ME" Q "STEP MET"
I %="S" Q "STEP STOPPED"
I %="D" Q "DELETED"
Q "??"
APCDPG ; IHS/CMI/LAB - GOAL LIST UPDATE ;
+1 ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
+2 ;; ;
START ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 FOR J=1:1:5
SET X=$PIECE($TEXT(TEXT+J),";;",2)
WRITE !?80-$LENGTH(X)\2,X
+3 KILL X,J
+4 WRITE !!
+5 SET APCDPGPT=""
FOR
DO GETPAT
IF APCDPGPT=""
QUIT
SET DFN=APCDPGPT
DO EN1
DO FULL^VALM1
DO EXIT
KILL APCDPGPT
+6 DO EOJ
+7 QUIT
GETPAT ;get patient
+1 KILL ^TMP($JOB,"APCDPG")
+2 KILL APCDPGPT,APCDLOC,APCDPAT,APCDDATE,APCDPIEN,APCDAF,APCDPGI,APCDOVRR,APCDLOOK,APCDPDFN
+3 DO KILL^AUPNPAT
+4 SET APCDPGPT=""
+5 IF '$PIECE($GET(^APCDSITE(DUZ(2),0)),U,34)
SET AUPNLK("INAC")=1
+6 WRITE !
+7 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+8 IF Y<0
QUIT
+9 SET APCDPGPT=+Y
+10 DO INAC^APCDEA(APCDPGPT,.X)
IF 'X
SET APCDPGPT=""
QUIT
+11 DO DOD(APCDPGPT,.X)
IF 'X
SET APCDPGPT=""
QUIT
+12 QUIT
GETLOC ;
+1 SET APCDLOC=""
SET DIC="^AUTTLOC("
SET DIC(0)="AEMQ"
SET DIC("B")=$PIECE(^DIC(4,$SELECT($GET(APCDLOC):APCDLOC,1:DUZ(2)),0),U)
SET DIC("A")="Location where GOAL List update occurred: "
DO ^DIC
KILL DIC
+2 IF Y<0
QUIT
+3 SET APCDLOC=+Y
+4 QUIT
GETDATE ;
+1 SET APCDDATE=""
+2 WRITE !!,"Date GOAL List Updated: "
READ X:$SELECT($DATA(DTIME):DTIME,1:300)
IF '$TEST
SET X=""
+3 IF X=""!(X="^")
QUIT
+4 SET %DT="ET"
DO ^%DT
IF Y<0
GOTO GETDATE
+5 IF Y>DT
WRITE " <Future dates not allowed>",$CHAR(7),$CHAR(7)
KILL X
GOTO GETDATE
+6 SET APCDDATE=Y
+7 QUIT
EOJ ;End of job cleanup
+1 ;clears out all list man stuff
IF $DATA(VALMWD)
DO CLEAR^VALM1
+2 KILL ^TMP($JOB,"APCDPG")
+3 KILL XQORNEST,VALMKEY,VALM,VALMAR,VALMBCK,VALMBG,VALMCAP,VALMCNT,VALMOFF,VALMMCON,VALMDN,VALMEVL,VALMIOXY,VALMKEY,VALMLFT,VALMLST,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMY,XQORS,XQORSPEW
+4 KILL APCDPGPT,APCDLOC,APCDPAT,APCDDATE,APCDPIEN,APCDAF,APCDPGI,APCDOVRR,APCDLOOK,APCDPDFN
+5 DO KILL^AUPNPAT
+6 QUIT
EN1 ;PEP - requires DFN to be set to patient
+1 KILL ^TMP($JOB,"APCDPG")
+2 IF '$GET(DFN)
QUIT
+3 SET APCDPGPT=DFN
+4 IF '$GET(APCDPGPT)
QUIT
+5 IF '$DATA(^AUPNPAT(APCDPGPT))
QUIT
+6 IF '$DATA(^DPT(APCDPGPT))
QUIT
+7 SET Y=APCDPGPT
DO ^AUPNPAT
+8 DO GETLOC
+9 IF '$GET(APCDLOC)
DO EXIT
QUIT
+10 DO GETDATE
+11 IF '$GET(APCDDATE)
DO EXIT
QUIT
+12 SET APCDOVRR=1
+13 DO EN
+14 KILL APCDPGPT
+15 DO FULL^VALM1
+16 DO EXIT
+17 QUIT
EN2 ;PEP - can be called to update GOAL list, called from applications outside of PCC
+1 DO GETPAT
+2 DO EN
+3 DO FULL^VALM1
+4 DO EXIT
+5 QUIT
ENDE ;EP - for data entry PL call
+1 IF '$GET(DFN)
QUIT
+2 SET APCDPGPT=DFN
+3 IF '$GET(APCDPGPT)
QUIT
+4 IF '$DATA(^AUPNPAT(APCDPGPT))
QUIT
+5 IF '$DATA(^DPT(APCDPGPT))
QUIT
+6 SET Y=APCDPGPT
DO ^AUPNPAT
+7 SET APCDLOC=APCDPLL
+8 IF '$GET(APCDLOC)
DO EXIT
QUIT
+9 SET APCDDATE=APCDPLD
+10 IF '$GET(APCDDATE)
DO EXIT
QUIT
+11 SET APCDV=$GET(APCDPLV)
+12 SET APCDOVRR=1
+13 DO EN
+14 KILL APCDPGPT
+15 DO FULL^VALM1
+16 DO EXIT
+17 QUIT
EN ;PEP main entry point for APCD PG GOAL LIST
+1 ;1 means screen mode, 0 means scrolling mode
SET VALMCC=1
+2 DO EN^VALM("APCD PG GOAL LIST")
+3 DO CLEAR^VALM1
+4 QUIT
+5 ;
HDR ;EP -- header code
+1 SET VALMHDR(1)=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+2 SET VALMHDR(2)="Patient Name: "_IORVON_$PIECE(^DPT(APCDPGPT,0),U)_IOINORM_" DOB: "_$$FTIME^VALM1(AUPNDOB)_" Sex: "_$PIECE(^DPT(APCDPGPT,0),U,2)_" HRN: "_$SELECT(...
... $DATA(^AUPNPAT(APCDPGPT,41,DUZ(2),0)):$PIECE(^AUPNPAT(APCDPGPT,41,DUZ(2),0),U,2),1:"????")
+3 SET VALMHDR(3)="'Active Goals are listed first followed by Goals not set."
+4 SET VALMHDR(4)="Inactive goals are not listed."
+5 SET VALMHDR(5)=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+6 QUIT
+7 ;
INIT ; -- init variables and list array
+1 ;gather up all GOALs
DO GATHER
+2 ;this variable must be the total number of lines in list
SET VALMCNT=APCDLINE
+3 ;for provider narrative lookup
SET APCDOVRR=""
+4 QUIT
+5 ;
GATHER ;EP
+1 ;set up array containing list of GOALs
+2 ;**** see page 7 of List Manager Manual for info on how to
+3 ;**** set up the array that contains the list
+4 KILL APCDPG
+5 NEW APCDSX
+6 KILL APCDQUIT,APCDPG
SET APCDRCNT=0
SET APCDLINE=0
+7 ;Q
IF '$DATA(^AUPNGOAL("AC",APCDPGPT))
SET APCDPG(1,0)="No GOALs currently on file"
SET APCDPG("IDX",1,1)=""
SET APCDLINE=1
+8 SET APCDLINE=APCDLINE+1
SET APCDPG(APCDLINE,0)=" "
+9 SET APCDRCNT=0
+10 SET APCDAF="A"
DO GATHER1
SET APCDAF="N"
DO GATHER1
+11 QUIT
GATHER1 ;
+1 SET APCDF=0
FOR
SET APCDF=$ORDER(^AUPNGOAL("AA",APCDPGPT,APCDF))
IF APCDF'=+APCDF
QUIT
Begin DoDot:1
+2 SET APCDPGI=""
FOR
SET APCDPGI=$ORDER(^AUPNGOAL("AA",APCDPGPT,APCDF,APCDPGI))
IF APCDPGI=""
QUIT
SET APCDPIEN=$ORDER(^(APCDPGI,""))
SET APCDP0=^AUPNGOAL(APCDPIEN,0)
Begin DoDot:2
+3 ;NO DELETED
IF $PIECE(^AUPNGOAL(APCDPIEN,0),U,11)="D"
QUIT
+4 ;Q:$P(^AUPNGOAL(APCDPIEN,0),U,1)="N"
+5 IF $PIECE(^AUPNGOAL(APCDPIEN,0),U,11)="ME"
QUIT
+6 IF $PIECE(^AUPNGOAL(APCDPIEN,0),U,11)="C"
QUIT
+7 IF $PIECE(^AUPNGOAL(APCDPIEN,0),U,11)="S"
QUIT
+8 IF APCDAF="A"
IF $PIECE(^AUPNGOAL(APCDPIEN,0),U,1)'="S"
QUIT
+9 IF APCDAF="N"
IF $PIECE(^AUPNGOAL(APCDPIEN,0),U,1)'="N"
QUIT
+10 SET APCDRCNT=APCDRCNT+1
SET APCDLINE=APCDLINE+1
SET APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
SET APCDX=""
+11 SET APCDX=$$SETSTR^VALM1($JUSTIFY(APCDRCNT,2),APCDX,3,2)
SET APCDX=$$SETSTR^VALM1(") GOAL ID: ",APCDX,5,11)
+12 SET X=$SELECT($PIECE(^AUTTLOC(APCDF,0),U,7)]"":$JUSTIFY($PIECE(^(0),U,7),4),1:"??")_$PIECE(APCDP0,U,7)
SET APCDX=$$SETSTR^VALM1(X,APCDX,16,10)
+13 SET APCDX=$$SETSTR^VALM1("Status: ",APCDX,27,8)
SET X=$$VAL^XBDIQ1(9000093,APCDPIEN,.01)_$SELECT($PIECE(APCDP0,U,11)]"":" - "_$$VAL^XBDIQ1(9000093,APCDPIEN,.11),1:"")
SET APCDX=$$SETSTR^VALM1(X,APCDX,36,26)
+14 ;S X="Created: "_$$DATE($P(APCDP0,U,3))_" By: "_$$VAL^XBDIQ1(9000093,APCDPIEN,.04)
+15 ;S APCDX=$$SETSTR^VALM1(X,APCDX,63,20)
+16 SET APCDPG(APCDLINE,0)=APCDX
SET APCDX=""
SET APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
+17 SET APCDLINE=APCDLINE+1
+18 IF $PIECE(^AUPNGOAL(APCDPIEN,0),U,1)="S"
SET APCDX=" Goal Start Date: "_$$DATE($PIECE(APCDP0,U,9))_" Goal Follow up Date: "_$$DATE($PIECE(APCDP0,U,10))
+19 IF $PIECE(^AUPNGOAL(APCDPIEN,0),U,1)="N"
SET APCDX=" Goal Created Date: "_$$DATE($PIECE(APCDP0,U,3))
+20 SET APCDPG(APCDLINE,0)=APCDX
SET APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
+21 ;goal name, reason
+22 SET APCDLINE=APCDLINE+1
+23 SET APCDX=" Goal Name: "_$$VAL^XBDIQ1(9000093,APCDPIEN,1101)
+24 SET APCDPG(APCDLINE,0)=APCDX
SET APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
+25 SET APCDLINE=APCDLINE+1
+26 SET APCDX=$SELECT($PIECE(^AUPNGOAL(APCDPIEN,0),U,1)="S":" Goal Reason: ",1:" Reason Goal Not Set: ")_$$VAL^XBDIQ1(9000093,APCDPIEN,1201)
+27 SET APCDPG(APCDLINE,0)=APCDX
SET APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
+28 SET APCDLINE=APCDLINE+1
+29 SET APCDX=" Provider: "_$$VAL^XBDIQ1(9000093,APCDPIEN,.08)
+30 SET APCDPG(APCDLINE,0)=APCDX
SET APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
+31 IF $ORDER(^AUPNGOAL(APCDPIEN,13,0))
SET APCDX=" Review/Progress Notes on file, use DD to see full display."
Begin DoDot:3
+32 SET APCDLINE=APCDLINE+1
SET APCDPG(APCDLINE,0)=APCDX
SET APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
End DoDot:3
STEP SET APCDC=0
IF $ORDER(^AUPNGOAL(APCDPIEN,21,0))
Begin DoDot:3
+1 SET (APCDC,APCDL)=0
FOR
SET APCDL=$ORDER(^AUPNGOAL(APCDPIEN,21,APCDL))
IF APCDL'=+APCDL
QUIT
IF $ORDER(^AUPNGOAL(APCDPIEN,21,APCDL,11,0))
SET APCDLR=$PIECE(^AUTTLOC($PIECE(^AUPNGOAL(APCDPIEN,21,APCDL,0),U),0),U,7)
Begin DoDot:4
+2 SET APCDX=0
FOR
SET APCDX=$ORDER(^AUPNGOAL(APCDPIEN,21,APCDL,11,APCDX))
IF APCDX'=+APCDX
QUIT
Begin DoDot:5
+3 IF $PIECE(^AUPNGOAL(APCDPIEN,21,APCDL,11,APCDX,0),U,9)="D"
QUIT
+4 SET APCDC=APCDC+1
IF APCDC=1
SET X=IOINORM_" "_IORVON_"Steps:"_IORVOFF
SET APCDLINE=APCDLINE+1
SET APCDPG(APCDLINE,0)=X
SET APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
+5 SET X=" "_APCDLR_" Step#"_APCDC
SET $EXTRACT(X,25)=$PIECE($GET(^AUPNGOAL(APCDPIEN,21,APCDL,11,APCDX,11)),U,1)
+6 SET APCDLINE=APCDLINE+1
SET APCDPG(APCDLINE,0)=X
SET APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
+7 SET X=""
SET $EXTRACT(X,12)="Status: "_$EXTRACT($$SS($PIECE($GET(^AUPNGOAL(APCDPIEN,21,APCDL,11,APCDX,0)),U,9)),1,15)
+8 SET $EXTRACT(X,38)="Start Date: "_$$DATE($PIECE(^AUPNGOAL(APCDPIEN,21,APCDL,11,APCDX,0),U,5))
SET $EXTRACT(X,60)="F/U Date: "_$$DATE($PIECE(^AUPNGOAL(APCDPIEN,21,APCDL,11,APCDX,0),U,6))
+9 SET APCDLINE=APCDLINE+1
SET APCDPG(APCDLINE,0)=X
SET APCDPG("IDX",APCDLINE,APCDRCNT)=APCDPIEN
End DoDot:5
End DoDot:4
End DoDot:3
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 KILL APCDLR,APCDL,APCDX,APCDF
+13 QUIT
TEXT ;
+1 ;;Patient Care Component (PCC)
+2 ;;
+3 ;;***********************************
+4 ;;* Update PCC Patient GOAL List *
+5 ;;***********************************
+6 ;;
+7 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP($JOB,"APCDPG")
+2 KILL APCDRCNT,APCDPG,APCDLINE,APCDX,APCDP0,APCDC,APCDL,APCDLR,APCDPIEN,APCDAF,APCDPGI,APCDOVRR,APCDLOOK,APCDPDFN,APCDLOC,APCDDATE
+3 KILL X,Y
+4 KILL VALMHDR
+5 QUIT
+6 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
DATE(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
DOD(P,RETVAL) ;EP - called to check to see if patient is inactive
+1 SET RETVAL=1
+2 IF $PIECE($GET(^DPT(P,.35)),U,1)]""
Begin DoDot:1
+3 WRITE !!,"***Warning*** You have selected a patient who is deceased.",!
+4 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue to add data for this patient"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
SET RETVAL=0
+6 SET RETVAL=Y
End DoDot:1
QUIT
+7 QUIT
SS(%) ;EP
+1 IF %="A"
QUIT "ACTIVE"
+2 IF %="MA"
QUIT "MAINTAINING STEP"
+3 IF %="ME"
QUIT "STEP MET"
+4 IF %="S"
QUIT "STEP STOPPED"
+5 IF %="D"
QUIT "DELETED"
+6 QUIT "??"
