APCDPL ; IHS/CMI/LAB - PROBLEM LIST UPDATE ;
;;2.0;IHS PCC SUITE;**2,5,6,10**;MAY 14, 2009;Build 88
;; ;
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 APCDPLPT="" F D GETPAT Q:APCDPLPT="" S DFN=APCDPLPT D EN1,FULL^VALM1,EXIT K APCDPLPT
D EOJ
Q
GETPAT ;get patient
K ^TMP($J,"APCDPL")
K APCDPLPT,APCDLOC,APCDPAT,APCDDATE,APCDPIEN,APCDAF,APCDPRB,APCDOVRR,APCDLOOK,APCDPDFN
D KILL^AUPNPAT
S APCDPLPT=""
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 APCDPLPT=+Y
D INAC^APCDEA(APCDPLPT,.X) I 'X S APCDPLPT="" 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 Problem List update occurred: " D ^DIC K DIC
Q:Y<0
S APCDLOC=+Y
Q
GETDATE ;
S APCDDATE=""
W !!,"Date Problem 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,"APCDPL")
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 APCDPLPT,APCDLOC,APCDPAT,APCDDATE,APCDPIEN,APCDAF,APCDPRB,APCDOVRR,APCDLOOK,APCDPDFN
D KILL^AUPNPAT
Q
EN1 ;PEP - requires DFN to be set to patient
K ^TMP($J,"APCDPL")
Q:'$G(DFN)
S APCDPLPT=DFN
Q:'$G(APCDPLPT)
Q:'$D(^AUPNPAT(APCDPLPT))
Q:'$D(^DPT(APCDPLPT))
S Y=APCDPLPT D ^AUPNPAT
D GETLOC
I '$G(APCDLOC) D EXIT Q
D GETDATE
I '$G(APCDDATE) D EXIT Q
S APCDOVRR=1
D EN
K APCDPLPT
D FULL^VALM1
D EXIT
Q
EN2 ;PEP - can be called to update problem 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 APCDPLPT=DFN
Q:'$G(APCDPLPT)
Q:'$D(^AUPNPAT(APCDPLPT))
Q:'$D(^DPT(APCDPLPT))
S Y=APCDPLPT D ^AUPNPAT
S APCDLOC=APCDPLL
I '$G(APCDLOC) D EXIT Q
S APCDDATE=APCDPLD
I '$G(APCDDATE) D EXIT Q
S APCDV=$G(APCDPLV)
I APCDV<0 S APCDV=""
S APCDOVRR=1
D EN
K APCDPLPT
D FULL^VALM1
D EXIT
Q
EN ;PEP main entry point for APCD PL PROBLEM LIST
S VALMCC=1 ;1 means screen mode, 0 means scrolling mode
D EN^VALM("APCD PL PROBLEM LIST")
D CLEAR^VALM1
Q
;
HDR ;EP -- header code
S VALMHDR(1)=$TR($J(" ",80)," ","-")
S VALMHDR(2)="Patient Name: "_IORVON_$P(^DPT(APCDPLPT,0),U)_IORVOFF_" DOB: "_$$FTIME^VALM1(AUPNDOB)_" Sex: "_$P(^DPT(APCDPLPT,0),U,2)_" HRN: "_$S($D(^AUPNPAT(APCDPLPT,41,DUZ(2),0)):$P(^AUPNPAT(APCDPLPT,41,DUZ(2),0),U,2),1:"????")
S VALMHDR(3)=$TR($J(" ",80)," ","-")
Q
;
INIT ; -- init variables and list array
D GATHER ;gather up all problems
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 problems
;**** see page 7 of List Manager Manual for info on how to
;**** set up the array that contains the list
K ^TMP($J,"APCDPL")
NEW APCDSX
K APCDQUIT,APCDPL S APCDRCNT=0,APCDLINE=0
I '$D(^AUPNPROB("AC",APCDPLPT)) S ^TMP($J,"APCDPL",1,0)="No Problems currently on file",^TMP($J,"APCDPL","IDX",1,1)="" S APCDLINE=1 ;Q
S APCDSX=$$LASTPLR^APCLAPI6(APCDPLPT,,DT,"A")
I APCDSX S APCDLINE=APCDLINE+1,^TMP($J,"APCDPL",APCDLINE,0)="Problem List Reviewed On: "_$$FMTE^XLFDT($P(APCDSX,U,1))_" By: "_$E($P($G(^VA(200,+$P(APCDSX,U,3),0)),U),1,25)
S APCDSX=$$LASTPLU^APCLAPI6(APCDPLPT,,DT,"A")
I APCDSX S APCDLINE=APCDLINE+1,^TMP($J,"APCDPL",APCDLINE,0)="Problem List Updated On: "_$$FMTE^XLFDT($P(APCDSX,U,1))_" By: "_$E($P($G(^VA(200,+$P(APCDSX,U,3),0)),U),1,25)
S APCDSX=$$LASTNAP^APCLAPI6(APCDPLPT,,DT,"A")
;I '$$ANYACTP^APCDAPRB(APCDPLPT),APCDSX S APCDLINE=APCDLINE+1,^TMP($J,"APCDPL",APCDLINE,0)="No Active Problems: "_$$FMTE^XLFDT($P(APCDSX,U,1))_" Documented By: "_$E($P($G(^VA(200,+$P(APCDSX,U,3),0)),U),1,25)
I APCDSX S APCDLINE=APCDLINE+1,^TMP($J,"APCDPL",APCDLINE,0)="No Active Problems Documented On: "_$$FMTE^XLFDT($P(APCDSX,U,1))_" By: "_$E($P($G(^VA(200,+$P(APCDSX,U,3),0)),U),1,25)
S APCDLINE=APCDLINE+1,^TMP($J,"APCDPL",APCDLINE,0)=" "
S APCDRCNT=0
S APCDAF="ASOE" D GATHER1 S APCDAF="IR" D GATHER1
Q
GATHER1 ;
S APCDF=0 F S APCDF=$O(^AUPNPROB("AA",APCDPLPT,APCDF)) Q:APCDF'=+APCDF D
.S APCDPRB="" F S APCDPRB=$O(^AUPNPROB("AA",APCDPLPT,APCDF,APCDPRB)) Q:APCDPRB="" S APCDPIEN=$O(^(APCDPRB,"")),APCDP0=^AUPNPROB(APCDPIEN,0) I APCDAF[$P(^AUPNPROB(APCDPIEN,0),U,12) D
..S APCDRCNT=APCDRCNT+1,APCDLINE=APCDLINE+1,^TMP($J,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN,APCDX=""
..S APCDX=$$SETSTR^VALM1($J(APCDRCNT,2),APCDX,3,2),APCDX=$$SETSTR^VALM1(") Problem ID:",APCDX,5,14),X=$S($P(^AUTTLOC(APCDF,0),U,7)]"":$J($P(^(0),U,7),4),1:"??")_$P(APCDP0,U,7),APCDX=$$SETSTR^VALM1(X,APCDX,19,8)
..S APCDX=$$SETSTR^VALM1("DX:",APCDX,28,3),APCDX=$$SETSTR^VALM1($$VAL^XBDIQ1(9000011,APCDPIEN,.01),APCDX,32,8),X="Status: "_$E($$EXTSET^XBFUNC(9000011,.12,$P(APCDP0,U,12)),1,9),APCDX=$$SETSTR^VALM1(X,APCDX,41,25)
..S APCDX=$$SETSTR^VALM1("Onset:",APCDX,66,6) I $P(APCDP0,U,13)]"" S APCDX=$$SETSTR^VALM1($$FMTE^XLFDT($P(APCDP0,U,13),"2D"),APCDX,73,17)
..S ^TMP($J,"APCDPL",APCDLINE,0)=APCDX,APCDX="",^TMP($J,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
..S APCDLINE=APCDLINE+1,APCDX=$$GET1^DIQ(9000011,APCDPIEN,.05),^TMP($J,"APCDPL",APCDLINE,0)=" Provider Narrative: "_IOINHI_APCDX_IOINORM,^TMP($J,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
..I $$ASKCL^AUPNVPLC($P(APCDP0,U)) S APCDLINE=APCDLINE+1,APCDX=$$VAL^XBDIQ1(9000011,APCDPIEN,.15),^TMP($J,"APCDPL",APCDLINE,0)=" Classification: "_IOINHI_APCDX_IOINORM,^TMP($J,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
..I $P(APCDP0,U,16)!($P(APCDP0,U,17))!($P(APCDP0,U,18)) D
...S APCDLINE=APCDLINE+1,APCDX=" E Code: "_$$VAL^XBDIQ1(9000011,APCDPIEN,.16)
...I $P(APCDP0,U,17) S APCDX=APCDX_" E Code 2: "_$$VAL^XBDIQ1(9000011,APCDPIEN,.17)
...I $P(APCDP0,U,18) S APCDX=APCDX_" E Code 3: "_$$VAL^XBDIQ1(9000011,APCDPIEN,.18)
...S ^TMP($J,"APCDPL",APCDLINE,0)=APCDX,APCDX="",^TMP($J,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
..S X=$$GET1^DIQ(9000011,APCDPIEN_",",80001) I X]"" S APCDLINE=APCDLINE+1,APCDX=" SNOMED CONCEPT ID: "_X,^TMP($J,"APCDPL",APCDLINE,0)=APCDX,^TMP($J,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
..I $O(^AUPNPROB(APCDPIEN,13,0)) S APCDX=" Severity:" D
...S X=0 F S X=$O(^AUPNPROB(APCDPIEN,13,X)) Q:X'=+X S APCDX=APCDX_" "_$$GET1^DIQ(9000011.13,X_","_APCDPIEN,.01)
...S APCDLINE=APCDLINE+1,^TMP($J,"APCDPL",APCDLINE,0)=APCDX,APCDX="",^TMP($J,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
NOTE ..S APCDC=0 I $O(^AUPNPROB(APCDPIEN,11,0)) D
...S (APCDC,APCDL)=0 F S APCDL=$O(^AUPNPROB(APCDPIEN,11,APCDL)) Q:APCDL'=+APCDL I $O(^AUPNPROB(APCDPIEN,11,APCDL,11,0)) S APCDLR=$P(^AUTTLOC($P(^AUPNPROB(APCDPIEN,11,APCDL,0),U),0),U,7) D
....S APCDX=0 F S APCDX=$O(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX)) Q:APCDX'=+APCDX D
.....S APCDC=APCDC+1 I APCDC=1 S X=IOINORM_" "_IORVON_"Comments:"_IORVOFF S APCDLINE=APCDLINE+1,^TMP($J,"APCDPL",APCDLINE,0)=X,^TMP($J,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
.....S X=" "_APCDLR_" Comment#"_$P(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX,0),U)_" "_$S($P(^(0),U,5)]"":$$FMTE^XLFDT($P(^(0),U,5),5),1:" ")_" "_$P(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX,0),U,3)
.....S APCDLINE=APCDLINE+1,^TMP($J,"APCDPL",APCDLINE,0)=X,^TMP($J,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
..S APCDLINE=APCDLINE+1,^TMP($J,"APCDPL",APCDLINE,0)=IOINORM_" ",^TMP($J,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
..Q
.Q
K APCDLR,APCDL,APCDX,APCDF
Q
TEXT ;
;;Patient Care Component (PCC)
;;
;;***********************************
;;* Update PCC Patient Problem List *
;;***********************************
;;
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP($J,"APCDPL")
K APCDRCNT,APCDPL,APCDLINE,APCDX,APCDP0,APCDC,APCDL,APCDLR,APCDPIEN,APCDAF,APCDPRB,APCDOVRR,APCDLOOK,APCDPDFN,APCDLOC,APCDDATE
K X,Y
K VALMHDR
Q
;
EXPND ; -- expand code
Q
;
APCDPL ; IHS/CMI/LAB - PROBLEM LIST UPDATE ;
+1 ;;2.0;IHS PCC SUITE;**2,5,6,10**;MAY 14, 2009;Build 88
+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 APCDPLPT=""
FOR
DO GETPAT
IF APCDPLPT=""
QUIT
SET DFN=APCDPLPT
DO EN1
DO FULL^VALM1
DO EXIT
KILL APCDPLPT
+6 DO EOJ
+7 QUIT
GETPAT ;get patient
+1 KILL ^TMP($JOB,"APCDPL")
+2 KILL APCDPLPT,APCDLOC,APCDPAT,APCDDATE,APCDPIEN,APCDAF,APCDPRB,APCDOVRR,APCDLOOK,APCDPDFN
+3 DO KILL^AUPNPAT
+4 SET APCDPLPT=""
+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 APCDPLPT=+Y
+10 DO INAC^APCDEA(APCDPLPT,.X)
IF 'X
SET APCDPLPT=""
QUIT
+11 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 Problem 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 Problem 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,"APCDPL")
+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 APCDPLPT,APCDLOC,APCDPAT,APCDDATE,APCDPIEN,APCDAF,APCDPRB,APCDOVRR,APCDLOOK,APCDPDFN
+5 DO KILL^AUPNPAT
+6 QUIT
EN1 ;PEP - requires DFN to be set to patient
+1 KILL ^TMP($JOB,"APCDPL")
+2 IF '$GET(DFN)
QUIT
+3 SET APCDPLPT=DFN
+4 IF '$GET(APCDPLPT)
QUIT
+5 IF '$DATA(^AUPNPAT(APCDPLPT))
QUIT
+6 IF '$DATA(^DPT(APCDPLPT))
QUIT
+7 SET Y=APCDPLPT
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 APCDPLPT
+15 DO FULL^VALM1
+16 DO EXIT
+17 QUIT
EN2 ;PEP - can be called to update problem 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 APCDPLPT=DFN
+3 IF '$GET(APCDPLPT)
QUIT
+4 IF '$DATA(^AUPNPAT(APCDPLPT))
QUIT
+5 IF '$DATA(^DPT(APCDPLPT))
QUIT
+6 SET Y=APCDPLPT
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 IF APCDV<0
SET APCDV=""
+13 SET APCDOVRR=1
+14 DO EN
+15 KILL APCDPLPT
+16 DO FULL^VALM1
+17 DO EXIT
+18 QUIT
EN ;PEP main entry point for APCD PL PROBLEM LIST
+1 ;1 means screen mode, 0 means scrolling mode
SET VALMCC=1
+2 DO EN^VALM("APCD PL PROBLEM 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(APCDPLPT,0),U)_IORVOFF_" DOB: "_$$FTIME^VALM1(AUPNDOB)_" Sex: "_$PIECE(^DPT(APCDPLPT,0),U,2)_" HRN: "_$SELECT(...
... $DATA(^AUPNPAT(APCDPLPT,41,DUZ(2),0)):$PIECE(^AUPNPAT(APCDPLPT,41,DUZ(2),0),U,2),1:"????")
+3 SET VALMHDR(3)=$TRANSLATE($JUSTIFY(" ",80)," ","-")
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 ;gather up all problems
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 problems
+2 ;**** see page 7 of List Manager Manual for info on how to
+3 ;**** set up the array that contains the list
+4 KILL ^TMP($JOB,"APCDPL")
+5 NEW APCDSX
+6 KILL APCDQUIT,APCDPL
SET APCDRCNT=0
SET APCDLINE=0
+7 ;Q
IF '$DATA(^AUPNPROB("AC",APCDPLPT))
SET ^TMP($JOB,"APCDPL",1,0)="No Problems currently on file"
SET ^TMP($JOB,"APCDPL","IDX",1,1)=""
SET APCDLINE=1
+8 SET APCDSX=$$LASTPLR^APCLAPI6(APCDPLPT,,DT,"A")
+9 IF APCDSX
SET APCDLINE=APCDLINE+1
SET ^TMP($JOB,"APCDPL",APCDLINE,0)="Problem List Reviewed On: "_$$FMTE^XLFDT($PIECE(APCDSX,U,1))_" By: "_$EXTRACT($PIECE($GET(^VA(200,+$PIECE(APCDSX,U,3),0)),U),1,25)
+10 SET APCDSX=$$LASTPLU^APCLAPI6(APCDPLPT,,DT,"A")
+11 IF APCDSX
SET APCDLINE=APCDLINE+1
SET ^TMP($JOB,"APCDPL",APCDLINE,0)="Problem List Updated On: "_$$FMTE^XLFDT($PIECE(APCDSX,U,1))_" By: "_$EXTRACT($PIECE($GET(^VA(200,+$PIECE(APCDSX,U,3),0)),U),1,25)
+12 SET APCDSX=$$LASTNAP^APCLAPI6(APCDPLPT,,DT,"A")
+13 ;I '$$ANYACTP^APCDAPRB(APCDPLPT),APCDSX S APCDLINE=APCDLINE+1,^TMP($J,"APCDPL",APCDLINE,0)="No Active Problems: "_$$FMTE^XLFDT($P(APCDSX,U,1))_" Documented By: "_$E($P($G(^VA(200,+$P(APCDSX,U,3),0)),U),1,25)
+14 IF APCDSX
SET APCDLINE=APCDLINE+1
SET ^TMP($JOB,"APCDPL",APCDLINE,0)="No Active Problems Documented On: "_$$FMTE^XLFDT($PIECE(APCDSX,U,1))_" By: "_$EXTRACT($PIECE($GET(^VA(200,+$PIECE(APCDSX,U,3),0)),U),1,25)
+15 SET APCDLINE=APCDLINE+1
SET ^TMP($JOB,"APCDPL",APCDLINE,0)=" "
+16 SET APCDRCNT=0
+17 SET APCDAF="ASOE"
DO GATHER1
SET APCDAF="IR"
DO GATHER1
+18 QUIT
GATHER1 ;
+1 SET APCDF=0
FOR
SET APCDF=$ORDER(^AUPNPROB("AA",APCDPLPT,APCDF))
IF APCDF'=+APCDF
QUIT
Begin DoDot:1
+2 SET APCDPRB=""
FOR
SET APCDPRB=$ORDER(^AUPNPROB("AA",APCDPLPT,APCDF,APCDPRB))
IF APCDPRB=""
QUIT
SET APCDPIEN=$ORDER(^(APCDPRB,""))
SET APCDP0=^AUPNPROB(APCDPIEN,0)
IF APCDAF[$PIECE(^AUPNPROB(APCDPIEN,0),U,12)
Begin DoDot:2
+3 SET APCDRCNT=APCDRCNT+1
SET APCDLINE=APCDLINE+1
SET ^TMP($JOB,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
SET APCDX=""
+4 SET APCDX=$$SETSTR^VALM1($JUSTIFY(APCDRCNT,2),APCDX,3,2)
SET APCDX=$$SETSTR^VALM1(") Problem ID:",APCDX,5,14)
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,19,8)
+5 SET APCDX=$$SETSTR^VALM1("DX:",APCDX,28,3)
SET APCDX=$$SETSTR^VALM1($$VAL^XBDIQ1(9000011,APCDPIEN,.01),APCDX,32,8)
SET X="Status: "_$EXTRACT($$EXTSET^XBFUNC(9000011,.12,$PIECE(APCDP0,U,12)),1,9)
SET APCDX=$$SETSTR^VALM1(X,APCDX,41,25)
+6 SET APCDX=$$SETSTR^VALM1("Onset:",APCDX,66,6)
IF $PIECE(APCDP0,U,13)]""
SET APCDX=$$SETSTR^VALM1($$FMTE^XLFDT($PIECE(APCDP0,U,13),"2D"),APCDX,73,17)
+7 SET ^TMP($JOB,"APCDPL",APCDLINE,0)=APCDX
SET APCDX=""
SET ^TMP($JOB,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
+8 SET APCDLINE=APCDLINE+1
SET APCDX=$$GET1^DIQ(9000011,APCDPIEN,.05)
SET ^TMP($JOB,"APCDPL",APCDLINE,0)=" Provider Narrative: "_IOINHI_APCDX_IOINORM
SET ^TMP($JOB,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
+9 IF $$ASKCL^AUPNVPLC($PIECE(APCDP0,U))
SET APCDLINE=APCDLINE+1
SET APCDX=$$VAL^XBDIQ1(9000011,APCDPIEN,.15)
SET ^TMP($JOB,"APCDPL",APCDLINE,0)=" Classification: "_IOINHI_APCDX_IOINORM
SET ^TMP($JOB,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
+10 IF $PIECE(APCDP0,U,16)!($PIECE(APCDP0,U,17))!($PIECE(APCDP0,U,18))
Begin DoDot:3
+11 SET APCDLINE=APCDLINE+1
SET APCDX=" E Code: "_$$VAL^XBDIQ1(9000011,APCDPIEN,.16)
+12 IF $PIECE(APCDP0,U,17)
SET APCDX=APCDX_" E Code 2: "_$$VAL^XBDIQ1(9000011,APCDPIEN,.17)
+13 IF $PIECE(APCDP0,U,18)
SET APCDX=APCDX_" E Code 3: "_$$VAL^XBDIQ1(9000011,APCDPIEN,.18)
+14 SET ^TMP($JOB,"APCDPL",APCDLINE,0)=APCDX
SET APCDX=""
SET ^TMP($JOB,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
End DoDot:3
+15 SET X=$$GET1^DIQ(9000011,APCDPIEN_",",80001)
IF X]""
SET APCDLINE=APCDLINE+1
SET APCDX=" SNOMED CONCEPT ID: "_X
SET ^TMP($JOB,"APCDPL",APCDLINE,0)=APCDX
SET ^TMP($JOB,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
+16 IF $ORDER(^AUPNPROB(APCDPIEN,13,0))
SET APCDX=" Severity:"
Begin DoDot:3
+17 SET X=0
FOR
SET X=$ORDER(^AUPNPROB(APCDPIEN,13,X))
IF X'=+X
QUIT
SET APCDX=APCDX_" "_$$GET1^DIQ(9000011.13,X_","_APCDPIEN,.01)
+18 SET APCDLINE=APCDLINE+1
SET ^TMP($JOB,"APCDPL",APCDLINE,0)=APCDX
SET APCDX=""
SET ^TMP($JOB,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
End DoDot:3
NOTE SET APCDC=0
IF $ORDER(^AUPNPROB(APCDPIEN,11,0))
Begin DoDot:3
+1 SET (APCDC,APCDL)=0
FOR
SET APCDL=$ORDER(^AUPNPROB(APCDPIEN,11,APCDL))
IF APCDL'=+APCDL
QUIT
IF $ORDER(^AUPNPROB(APCDPIEN,11,APCDL,11,0))
SET APCDLR=$PIECE(^AUTTLOC($PIECE(^AUPNPROB(APCDPIEN,11,APCDL,0),U),0),U,7)
Begin DoDot:4
+2 SET APCDX=0
FOR
SET APCDX=$ORDER(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX))
IF APCDX'=+APCDX
QUIT
Begin DoDot:5
+3 SET APCDC=APCDC+1
IF APCDC=1
SET X=IOINORM_" "_IORVON_"Comments:"_IORVOFF
SET APCDLINE=APCDLINE+1
SET ^TMP($JOB,"APCDPL",APCDLINE,0)=X
SET ^TMP($JOB,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
+4 SET X=" "_APCDLR_" Comment#"_$PIECE(^AUPNPROB(APCDPIEN,11,APCDL,11,APCDX,0),U)_" "_$SELECT($PIECE(^(0),U,5)]"":$$FMTE^XLFDT($PIECE(^(0),U,5),5),1:" ")_" "_$PIECE(^AUPNPROB(APCDPI
EN,11,APCDL,11,APCDX,0),U,3)
+5 SET APCDLINE=APCDLINE+1
SET ^TMP($JOB,"APCDPL",APCDLINE,0)=X
SET ^TMP($JOB,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
End DoDot:5
End DoDot:4
End DoDot:3
+6 SET APCDLINE=APCDLINE+1
SET ^TMP($JOB,"APCDPL",APCDLINE,0)=IOINORM_" "
SET ^TMP($JOB,"APCDPL","IDX",APCDLINE,APCDRCNT)=APCDPIEN
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 KILL APCDLR,APCDL,APCDX,APCDF
+10 QUIT
TEXT ;
+1 ;;Patient Care Component (PCC)
+2 ;;
+3 ;;***********************************
+4 ;;* Update PCC Patient Problem 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,"APCDPL")
+2 KILL APCDRCNT,APCDPL,APCDLINE,APCDX,APCDP0,APCDC,APCDL,APCDLR,APCDPIEN,APCDAF,APCDPRB,APCDOVRR,APCDLOOK,APCDPDFN,APCDLOC,APCDDATE
+3 KILL X,Y
+4 KILL VALMHDR
+5 QUIT
+6 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
