- 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 ;
