- 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 "??"
