APCDPL1 ; IHS/CMI/LAB - problem list update ;
;;2.0;IHS PCC SUITE;**5,6,7,10,15**;MAY 14, 2009;Build 11
;
;
DIE ;
S DA=APCDPIEN,DIE="^AUPNPROB(",DR=APCDTEMP D ^DIE
KDIE ;
K DIE,DR,DA,DIU,DIV,DQ,D0,DO,DI,DIW,DIY,%,DQ,DLAYGO
Q
GETPROB ;get record
S APCDPIEN=0
S DIR(0)="N^1:"_APCDRCNT_":0",DIR("A")="Select Problem" KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"No Problem Seleted" Q
S APCDP=Y
S (X,Y)=0 F S X=$O(^TMP($J,"APCDPL","IDX",X)) Q:X'=+X!(APCDPIEN) I $O(^TMP($J,"APCDPL","IDX",X,0))=APCDP S Y=$O(^TMP($J,"APCDPL","IDX",X,0)),APCDPIEN=^TMP($J,"APCDPL","IDX",X,Y)
I '$D(^AUPNPROB(APCDPIEN,0)) W !,"Not a valid PCC PROBLEM." K APCDP S APCDPIEN=0 Q
D FULL^VALM1
Q
ADD ;EP - add prob
D FULL^VALM1
Q:'$G(APCDPLPT)
S APCDPAT=APCDPLPT
S:'$G(APCDLOC) APCDLOC=DUZ(2)
S:$G(APCDDATE)="" APCDDATE=APCDNDT
W:$D(IOF) @IOF W !,"Adding a new problem for ",$P(^DPT(APCDPLPT,0),U),".",!!
D KDIE S DIE("NO^")=1,DLAYGO=9000011,DIE="^AUPNPAT(",DR="[APCD PO (ADD)]",DA=APCDPLPT D ^DIE D KDIE
K DLAYGO D EXIT
Q
EDIT ;EP - edit prob
NEW APCDPIEN,APCDPAT,APCDIAIEP
D GETPROB
I 'APCDPIEN D PAUSE,EXIT Q
S APCDPAT=APCDPLPT
S:'$G(APCDLOC) APCDLOC=DUZ(2)
S:$G(APCDDATE)="" APCDDATE=APCDNDT
S APCDTEMP="[APCD MODIFY PROBLEM]"
W:$D(IOF) @IOF W !!,"Editing Problem Number: ",$$GETNUM^APCDPL1(APCDPIEN),!
I $P($G(^AUPNPROB(APCDPIEN,800)),U,1)]"" D G ACT1
.W !!,"This problem has been SNOMED coded, you can only edit the Status and",!,"Date of Onset fields."
.S APCDIAEP=1
K DIR
S DIR(0)="9000011,.01",DIR("A")="Diagnosis",DIR("B")=$$GET1^DIQ(9000011,APCDPIEN,.01) KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EXIT Q
I +Y'=$$GET1^DIQ(9000011,APCDPIEN,.01) D
.S DIE="^AUPNPROB(",DR=".01////"_+Y,DA=APCDPIEN D ^DIE K DA,DR,DIE
D DIE
S DA=APCDPIEN
S APCDVSIT=$G(APCDPLV)
D PLUDE^APCDAPRB
D EXIT
Q
GETDX ;
NEW DA,DIR,DIRUT,Y,X
S APCDTNDX=$$GET1^DIQ(9000011,APCDTDA,.01,"I")
S DIR(0)="9000011,.01",DIR("A")="Diagnosis",DIR("B")=$$GET1^DIQ(9000011,APCDTDA,.01) KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
S APCDTNDX=+Y
Q
DEL ;EP - delete prob
NEW APCDPIEN,APCDPAT
D GETPROB
I 'APCDPIEN D PAUSE,EXIT Q
W:$D(IOF) @IOF
W !!,"Deleting the following Problem from ",$P($P(^DPT(APCDPLPT,0),U),",",2)," ",$P($P(^(0),U),","),"'s Problem List.",!
S DA=APCDPIEN,DIC="^AUPNPROB(" D EN^DIQ
;
W !!,"Please Note: You are NOT permitted to delete a problem without",!,"entering a reason for the deletion."
W ! S DIR(0)="Y",DIR("A")="Are you sure you want to delete this PROBLEM",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,DR="[APCD DELETE PROBLEM]",DIE="^AUPNPROB(" D ^DIE K DA,DIE,DR
S APCDPAT=APCDPLPT
S:$G(APCDDATE)="" APCDDATE=APCDNDT
W !
S APCDVSIT=$G(APCDPLV)
S DA=APCDPIEN
D PLUDE^APCDAPRB
D PAUSE,EXIT,^XBFMK
Q
AN ;EP - add a note
NEW APCDPIEN
D GETPROB
I 'APCDPIEN D PAUSE,EXIT Q
D NO1^APCDPL2
D EXIT
Q
MN ;EP - modify a note
NEW APCDPIEN
D GETPROB
I 'APCDPIEN D PAUSE,EXIT Q
D MN1^APCDPL2
D PAUSE,EXIT
Q
RNO ;EP - remove a note
NEW APCDPIEN
D GETPROB
I 'APCDPIEN D PAUSE,EXIT Q
D RNO1^APCDPL2
D PAUSE,EXIT
Q
ACT ;EP - called from protocol
NEW APCDPIEN,APCDNDT,APCDPAT
S APCDNDT=$P(APCDDATE,".")
D GETPROB
I 'APCDPIEN D PAUSE,EXIT Q
;
ACT1 ;D DIE
S DA=APCDPIEN,APCDTOLD=$P(^AUPNPROB(APCDPIEN,0),U,12)
D CPS^APCDAPRB
;I $P(^AUPNPROB(APCDPIEN,0),U,12)=APCDTOLD G ACTE
I $G(APCDIAEP) NEW DIE S DIE="^AUPNPROB(",DA=APCDPIEN,DR=".13" D ^DIE K DIE,DA,DR
I '$G(APCDIAEP),$P(^AUPNPROB(APCDPIEN,0),U,12)=APCDTOLD G ACTE
S APCDPAT=APCDPLPT
S:'$G(APCDLOC) APCDLOC=DUZ(2)
S:$G(APCDDATE)="" APCDDATE=APCDNDT
S APCDVSIT=$G(APCDPLV)
S DA=APCDPIEN
D PLUDE^APCDAPRB
ACTE ;
;I $G(APCDIAEP) NEW DIE S DIE="^AUPNPROB(",DA=APCDPIEN,DR=".13" D ^DIE K DIE,DA,DR,APCDIAEP
K APCDTOLD,APCDIAEP
D EXIT
Q
INACT ;EP - called from protocol to inactivate an active problem
NEW APCDPIEN,APCDNDT,APCDPAT
S APCDNDT=$P(APCDDATE,".")
D GETPROB
I 'APCDPIEN D PAUSE,EXIT Q
I $P(^AUPNPROB(APCDPIEN,0),U,12)="I" W !!,"That problem is already INACTIVE!!",! D PAUSE,EXIT Q
S APCDTEMP=".12///I;.03////^S X=APCDNDT;.14////^S X=DUZ"
W:$D(IOF) @IOF W !,"Inactivating Problem ... "
D DIE
S APCDPAT=APCDPLPT
;S:'$G(APCDLOC) APCDLOC=DUZ(2)
S:$G(APCDDATE)="" APCDDATE=APCDNDT
S APCDPLV=$G(APCDVSIT)
S DA=APCDPIEN
D PLUDE^APCDAPRB
D EXIT
Q
HS ;EP - 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=APCDPLPT
S APCDHDR="PCC Health Summary for "_$P(^DPT(APCDPLPT,0),U)
D VIEWR^XBLM("EN^APCHS",APCDHDR)
S (DFN,Y)=APCDPLPT D ^AUPNPAT
K APCHSPAT,APCHSTYP,APCHSTAT,APCHSMTY,AMCHDAYS,AMCHDOB,APCDHDR
D EXIT
Q
DD ;EP - called from protocol detail
NEW APCDPIEN
D GETPROB
I 'APCDPIEN D PAUSE,EXIT Q
D DIQ^XBLM(9000011,APCDPIEN)
D EXIT
Q
FS ;EP -FACE SHEET
D FULL^VALM1
S APCDHDR="Demographic Face Sheet For "_$P(^DPT(APCDPLPT,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 problem number
NEW N,F
S N=""
I 'P Q N
I '$D(^AUPNPROB(P,0)) Q N
S F=$P(^AUPNPROB(P,0),U,6)
S N=$S($P(^AUTTLOC(F,0),U,7)]"":$J($P(^(0),U,7),4),1:"??")_$P(^AUPNPROB(P,0),U,7)
Q N
EXIT ;
D TERM^VALM0
S VALMBCK="R"
D GATHER^APCDPL
S VALMCNT=APCDLINE
D HDR^APCDPL
K APCDTEMP,APCDPRMT,APCDP,APCDPIEN,APCDAF,APCDF,APCDP0,APCDPRB
D KDIE
Q
NAP ;EP - called from protocol
D FULL^VALM1
Q:'$G(APCDPLPT)
I $$ANYACTP^APCDAPRB(APCDPLPT) D Q
.W !!,"There are active problems on this patient's problem list. You"
.W !,"cannot use this action item."
.D PAUSE,EXIT Q
S APCDPAT=APCDPLPT
S:'$G(APCDLOC) APCDLOC=DUZ(2)
S:$G(APCDDATE)="" APCDDATE=APCDNDT
NAPDE1 ;EP - called from xbnew
S DIR(0)="Y",DIR("A")="Did the Provider indicate that the patient has No Active Problems",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !,"No action taken." D PAUSE,EXIT Q
I 'Y W !,"No action taken." D PAUSE,EXIT Q
S DIR(0)="D^::EPTSX",DIR("A")="Enter the Date the Provider documented 'No Active Problems'"
S DIR("B")=$S($G(APCDDATE):$$FMTE^XLFDT($P(APCDDATE,".")),$G(APCDPLV):$$FMTE^XLFDT($$VD^APCLV(APCDPLV)),1:$$FMTE^XLFDT(DT)),DIR("?")="This is the visit date or the date the provider provided the information."
KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." G NAPDE1
I $P(Y,".")>DT W !!,"Future Dates not allowed.",! G NAPDE1
S APCDD=Y
NAPDE1P ;GET PROVIDER
S DIR(0)="9000010.54,1204",DIR("A")="Enter the PROVIDER who documented 'No Active Problems'"
S DIR("B")=$S($G(APCDPLV):$$PRIMPROV^APCLV(APCDPLV,"N"),1:"") KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." G NAPDE1P
S APCDPRV=+Y
D NAPADD($G(APCDPLV),APCDPAT,APCDD,APCDPRV,.APCDRET)
I $P(APCDRET,U,1)=0 W !!,"error: ",$P(APCDRET,U,2)
D PAUSE,EXIT
Q
NAPADD(APCDV,APCDP,APCDD,APCDPRV,RETVAL) ;PEP - called to update Problem list update fields
;this API can be called to have a V UPDATED/REVIEWED entry and populate the
;.11, .12, and .13 fields
;input:
; APCDV - ien of visit, if in the context of a visit
; APCDP - DFN
; APCDD - Date and optionally time of problem list update (fileman format)
; APCDPRV = ien of provider updating the problem list
;this API will create a new V UPDATED/REVIEWED entry if there isn't currently one
;for Provider APCDP on date APCDD
;if not in the context of a visit (APCDV = null) then an event visit will be created
;with a V UPDATED/REVIEWED v file entry
;
;RETURN VALUE:
; ien of V UPDATED/REVIEWED entry that was created
; or 0^error message
S APCDPIEN=$G(APCDPIEN)
S APCDV=$G(APCDV)
S APCDP=$G(APCDP)
I 'APCDP S RETVAL="0^not a valid patient DFN" Q
I '$D(^AUPNPAT(APCDP,0)) S RETVAL="0^not a valid patient DFN" Q
S APCDD=$G(APCDD)
I 'APCDD S RETVAL="0^no valid date passed" Q
S APCDPRV=$G(APCDPRV)
I 'APCDPRV S RETVAL="0^no valid provider ien passed" Q
S RETVAL=""
;
I APCDV D NAPV Q
;NO VISIT SO CREATE EVENT VISIT AND CALL NAPV
D EVSIT,NAPV
Q
NAPV ;have a visit so create a v updated/reviewed for provider APCDPRV if one does
;not exist on this visit already.
NEW APCDX,APCDVD,APCDVRI,APCDVAL
S APCDVAL=$O(^AUTTCRA("C","NAP",0))
I APCDVAL="" S RETVAL="0^action item missing" Q
S APCDVRI=""
S APCDX=0 F S APCDX=$O(^AUPNVRUP("AD",APCDV,APCDX)) Q:APCDX=""!(APCDVRI) D
.;is this entry a problem list review entry?
.Q:$P(^AUPNVRUP(APCDX,0),U,1)'=APCDVAL ;this one isn't a NAP entry
.Q:$P($G(^AUPNVRUP(APCDX,2)),U,1)
.Q:$P($G(^AUPNVRUP(APCDX,12)),U,4)'=APCDPRV ;not this provider
.S APCDVRI=APCDX ;found one so don't create one
.Q
I APCDVRI S RETVAL=APCDVRI Q
;create V UPDATED/REVIEWED entry
NEW APCDALVR
S APCDALVR("APCDPAT")=APCDP
S APCDALVR("APCDVSIT")=APCDV
S APCDALVR("APCDATMP")="[APCDALVR 9000010.54 (ADD)]"
S APCDALVR("APCDTCLA")="`"_APCDVAL
S APCDALVR("APCDTCDT")=APCDD
S APCDALVR("APCDTEPR")="`"_APCDPRV
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) S RETVAL=0_"^Error creating V UPDATED/REVIEWED entry. PCC not updated."
K APCDALVR
D PLRV
Q
BSD ;
NEW APCDBSDV,APCDIN,Y
K APCDIN
S APCDIN("PAT")=APCDP
S APCDIN("VISIT DATE")=APCDD_".12"
S APCDIN("SITE")=DUZ(2)
S APCDIN("VISIT TYPE")=$S($P($G(^APCCCTRL(DUZ(2),0)),U,4)]"":$P(^APCCCTRL(DUZ(2),0),U,4),1:"O")
S APCDIN("SRV CAT")="E"
S APCDIN("TIME RANGE")=0
S APCDIN("USR")=DUZ
K APCDALVR
K APCDBSDV
NEW APCDDATE,AUPNPAT,AUPNDOB,AUPNSEX,AUPNDOD,AUPNDAYS,APCDPAT
D GETVISIT^APCDAPI4(.APCDIN,.APCDBSDV)
;S Y=APCDP D ^AUPNPAT
S T=$P(APCDBSDV(0),U,2)
I T]"" S RETVAL="0^could not create event visit" Q
S V=$O(APCDBSDV(0)) S APCDV=V
I $G(APCDBSDV(V))="ADD" D DEDT^APCDEA2(APCDV)
Q
EVSIT ;EP - get/create event visit
I $L($T(^BSDAPI4)) D Q
.D BSD
K APCDVSIT
K APCDALVR
S APCDALVR("APCDAUTO")=""
S APCDALVR("APCDPAT")=APCDP
S APCDALVR("APCDCAT")="E"
S APCDALVR("APCDLOC")=DUZ(2)
S APCDALVR("APCDTYPE")=$S($P($G(^APCCCTRL(DUZ(2),0)),U,4)]"":$P(^APCCCTRL(DUZ(2),0),U,4),1:"O")
S APCDALVR("APCDDATE")=APCDD_".12"
D ^APCDALV
S APCDV=$G(APCDALVR("APCDVSIT"))
I $G(APCDALVR("APCDVSIT","NEW")) D DEDT^APCDEA2(APCDVSIT)
K APCDALVR
Q
PLR ;EP - called from protocol
NEW APCDPIEN,APCDNDT,APCDPAT
S APCDNDT=$P(APCDDATE,".")
D FULL^VALM1
Q:'$G(APCDPLPT)
S APCDPAT=APCDPLPT
S:'$G(APCDLOC) APCDLOC=DUZ(2)
S:$G(APCDDATE)="" APCDDATE=APCDNDT
PLRDE1 ;EP - called from xbnew
S DIR(0)="Y",DIR("A")="Did the Provider indicate that he/she reviewed the Problem List",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !,"No action taken." D PAUSE,EXIT Q
I 'Y W !,"No action taken." D PAUSE,EXIT Q
S DIR(0)="D^::EPTSX",DIR("A")="Enter the Date the Provider Reviewed the Problem List"
S DIR("B")=$S($G(APCDDATE):$$FMTE^XLFDT($P(APCDDATE,".")),$G(APCDPLV):$$FMTE^XLFDT($$VD^APCLV(APCDPLV)),1:$$FMTE^XLFDT(DT)),DIR("?")="This is the visit date or the date the provider provided the information."
KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." G PLRDE1
I $P(Y,".")>DT W !!,"Future Dates not allowed.",! G PLRDE1
S APCDD=Y
PLRDE1P ;GET PROVIDER
S DIR(0)="9000010.54,1204",DIR("A")="Enter the PROVIDER who Reviewed the Problem List"
S DIR("B")=$S($G(APCDPLV):$$PRIMPROV^APCLV(APCDPLV,"N"),1:"") KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." G PLRDE1P
S APCDPRV=+Y
D PLRADD($G(APCDPLV),APCDPAT,APCDD,APCDPRV,.APCDRET)
I $P(APCDRET,U,1)=0 W !!,"error: ",$P(APCDRET,U,2)
D PAUSE,EXIT
Q
PLRADD(APCDV,APCDP,APCDD,APCDPRV,RETVAL) ;PEP - called to update Problem list update fields
;this API can be called to have a V UPDATED/REVIEWED entry and populate the
;.11, .12, and .13 fields
;input:
; APCDV - ien of visit, if in the context of a visit
; APCDP - DFN
; APCDD - Date and optionally time of problem list update (fileman format)
; APCDPRV = ien of provider updating the problem list
;this API will create a new V UPDATED/REVIEWED entry if there isn't currently one
;for Provider APCDP on date APCDD
;if not in the context of a visit (APCDV = null) then an event visit will be created
;with a V UPDATED/REVIEWED v file entry
;
;RETURN VALUE:
; ien of V UPDATED/REVIEWED entry that was created
; or 0^error message
S APCDPIEN=$G(APCDPIEN)
S APCDV=$G(APCDV)
S APCDP=$G(APCDP)
I 'APCDP S RETVAL="0^not a valid patient DFN" Q
I '$D(^AUPNPAT(APCDP,0)) S RETVAL="0^not a valid patient DFN" Q
S APCDD=$G(APCDD)
I 'APCDD S RETVAL="0^no valid date passed" Q
S APCDPRV=$G(APCDPRV)
I 'APCDPRV S RETVAL="0^no valid provider ien passed" Q
S RETVAL=""
;
I APCDV D PLRV Q
;NO VISIT SO CREATE EVENT VISIT AND CALL PLRV
D EVSIT,PLRV
Q
PLRV ;have a visit so create a v updated/reviewed for provider APCDPRV if one does
;not exist on this visit already.
NEW APCDX,APCDVD,APCDVRI,APCDVAL
S APCDVAL=$O(^AUTTCRA("C","PLR",0))
I APCDVAL="" S RETVAL="0^action item missing" Q
S APCDVRI=""
S APCDX=0 F S APCDX=$O(^AUPNVRUP("AD",APCDV,APCDX)) Q:APCDX=""!(APCDVRI) D
.;is this entry a problem list review entry?
.Q:$P(^AUPNVRUP(APCDX,0),U,1)'=APCDVAL ;this one isn't a PLR entry
.Q:$P($G(^AUPNVRUP(APCDX,2)),U,1)
.Q:$P($G(^AUPNVRUP(APCDX,12)),U,4)'=APCDPRV ;not this provider
.S APCDVRI=APCDX ;found one so don't create one
.Q
I APCDVRI S RETVAL=APCDVRI Q
NEW APCDALVR
S APCDALVR("APCDPAT")=APCDP
S APCDALVR("APCDVSIT")=APCDV
S APCDALVR("APCDATMP")="[APCDALVR 9000010.54 (ADD)]"
S APCDALVR("APCDTCLA")="`"_APCDVAL
S APCDALVR("APCDTCDT")=APCDD
S APCDALVR("APCDTEPR")="`"_APCDPRV
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) S RETVAL=0_"^Error creating V UPDATED/REVIEWED entry. PCC not updated."
K APCDALVR
Q
RESOLVE ;EP - called from protocol
NEW APCDPIEN,APCDNDT,APCDPAT
S APCDNDT=$P(APCDDATE,".")
D GETPROB
I 'APCDPIEN D PAUSE,EXIT Q
I $P(^AUPNPROB(APCDPIEN,0),U,12)="R" W !!,"That problem is already RESOLVED!!",! D PAUSE,EXIT Q
S APCDTEMP=".12///R;.03////^S X=APCDNDT;.14////^S X=DUZ"
W:$D(IOF) @IOF W !,"Resolving Problem ... "
D DIE
S APCDPAT=APCDPLPT
S:$G(APCDDATE)="" APCDDATE=APCDNDT
S APCDPLV=$G(APCDVSIT)
S DA=APCDPIEN
D PLUDE^APCDAPRB
D EXIT
Q
APCDPL1 ; IHS/CMI/LAB - problem list update ;
+1 ;;2.0;IHS PCC SUITE;**5,6,7,10,15**;MAY 14, 2009;Build 11
+2 ;
+3 ;
DIE ;
+1 SET DA=APCDPIEN
SET DIE="^AUPNPROB("
SET DR=APCDTEMP
DO ^DIE
KDIE ;
+1 KILL DIE,DR,DA,DIU,DIV,DQ,D0,DO,DI,DIW,DIY,%,DQ,DLAYGO
+2 QUIT
GETPROB ;get record
+1 SET APCDPIEN=0
+2 SET DIR(0)="N^1:"_APCDRCNT_":0"
SET DIR("A")="Select Problem"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
WRITE !!,"No Problem Seleted"
QUIT
+4 SET APCDP=Y
+5 SET (X,Y)=0
FOR
SET X=$ORDER(^TMP($JOB,"APCDPL","IDX",X))
IF X'=+X!(APCDPIEN)
QUIT
IF $ORDER(^TMP($JOB,"APCDPL","IDX",X,0))=APCDP
SET Y=$ORDER(^TMP($JOB,"APCDPL","IDX",X,0))
SET APCDPIEN=^TMP($JOB,"APCDPL","IDX",X,Y)
+6 IF '$DATA(^AUPNPROB(APCDPIEN,0))
WRITE !,"Not a valid PCC PROBLEM."
KILL APCDP
SET APCDPIEN=0
QUIT
+7 DO FULL^VALM1
+8 QUIT
ADD ;EP - add prob
+1 DO FULL^VALM1
+2 IF '$GET(APCDPLPT)
QUIT
+3 SET APCDPAT=APCDPLPT
+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 problem for ",$PIECE(^DPT(APCDPLPT,0),U),".",!!
+7 DO KDIE
SET DIE("NO^")=1
SET DLAYGO=9000011
SET DIE="^AUPNPAT("
SET DR="[APCD PO (ADD)]"
SET DA=APCDPLPT
DO ^DIE
DO KDIE
+8 KILL DLAYGO
DO EXIT
+9 QUIT
EDIT ;EP - edit prob
+1 NEW APCDPIEN,APCDPAT,APCDIAIEP
+2 DO GETPROB
+3 IF 'APCDPIEN
DO PAUSE
DO EXIT
QUIT
+4 SET APCDPAT=APCDPLPT
+5 IF '$GET(APCDLOC)
SET APCDLOC=DUZ(2)
+6 IF $GET(APCDDATE)=""
SET APCDDATE=APCDNDT
+7 SET APCDTEMP="[APCD MODIFY PROBLEM]"
+8 IF $DATA(IOF)
WRITE @IOF
WRITE !!,"Editing Problem Number: ",$$GETNUM^APCDPL1(APCDPIEN),!
+9 IF $PIECE($GET(^AUPNPROB(APCDPIEN,800)),U,1)]""
Begin DoDot:1
+10 WRITE !!,"This problem has been SNOMED coded, you can only edit the Status and",!,"Date of Onset fields."
+11 SET APCDIAEP=1
End DoDot:1
GOTO ACT1
+12 KILL DIR
+13 SET DIR(0)="9000011,.01"
SET DIR("A")="Diagnosis"
SET DIR("B")=$$GET1^DIQ(9000011,APCDPIEN,.01)
KILL DA
DO ^DIR
KILL DIR
+14 IF $DATA(DIRUT)
DO EXIT
QUIT
+15 IF +Y'=$$GET1^DIQ(9000011,APCDPIEN,.01)
Begin DoDot:1
+16 SET DIE="^AUPNPROB("
SET DR=".01////"_+Y
SET DA=APCDPIEN
DO ^DIE
KILL DA,DR,DIE
End DoDot:1
+17 DO DIE
+18 SET DA=APCDPIEN
+19 SET APCDVSIT=$GET(APCDPLV)
+20 DO PLUDE^APCDAPRB
+21 DO EXIT
+22 QUIT
GETDX ;
+1 NEW DA,DIR,DIRUT,Y,X
+2 SET APCDTNDX=$$GET1^DIQ(9000011,APCDTDA,.01,"I")
+3 SET DIR(0)="9000011,.01"
SET DIR("A")="Diagnosis"
SET DIR("B")=$$GET1^DIQ(9000011,APCDTDA,.01)
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
QUIT
+5 SET APCDTNDX=+Y
+6 QUIT
DEL ;EP - delete prob
+1 NEW APCDPIEN,APCDPAT
+2 DO GETPROB
+3 IF 'APCDPIEN
DO PAUSE
DO EXIT
QUIT
+4 IF $DATA(IOF)
WRITE @IOF
+5 WRITE !!,"Deleting the following Problem from ",$PIECE($PIECE(^DPT(APCDPLPT,0),U),",",2)," ",$PIECE($PIECE(^(0),U),","),"'s Problem List.",!
+6 SET DA=APCDPIEN
SET DIC="^AUPNPROB("
DO EN^DIQ
+7 ;
+8 WRITE !!,"Please Note: You are NOT permitted to delete a problem without",!,"entering a reason for the deletion."
+9 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this PROBLEM"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+10 IF $DATA(DIRUT)
WRITE !,"okay, not deleted."
DO PAUSE
DO EXIT
QUIT
+11 IF 'Y
WRITE !,"Okay, not deleted."
DO PAUSE
DO EXIT
QUIT
+12 SET DA=APCDPIEN
SET DR="[APCD DELETE PROBLEM]"
SET DIE="^AUPNPROB("
DO ^DIE
KILL DA,DIE,DR
+13 SET APCDPAT=APCDPLPT
+14 IF $GET(APCDDATE)=""
SET APCDDATE=APCDNDT
+15 WRITE !
+16 SET APCDVSIT=$GET(APCDPLV)
+17 SET DA=APCDPIEN
+18 DO PLUDE^APCDAPRB
+19 DO PAUSE
DO EXIT
DO ^XBFMK
+20 QUIT
AN ;EP - add a note
+1 NEW APCDPIEN
+2 DO GETPROB
+3 IF 'APCDPIEN
DO PAUSE
DO EXIT
QUIT
+4 DO NO1^APCDPL2
+5 DO EXIT
+6 QUIT
MN ;EP - modify a note
+1 NEW APCDPIEN
+2 DO GETPROB
+3 IF 'APCDPIEN
DO PAUSE
DO EXIT
QUIT
+4 DO MN1^APCDPL2
+5 DO PAUSE
DO EXIT
+6 QUIT
RNO ;EP - remove a note
+1 NEW APCDPIEN
+2 DO GETPROB
+3 IF 'APCDPIEN
DO PAUSE
DO EXIT
QUIT
+4 DO RNO1^APCDPL2
+5 DO PAUSE
DO EXIT
+6 QUIT
ACT ;EP - called from protocol
+1 NEW APCDPIEN,APCDNDT,APCDPAT
+2 SET APCDNDT=$PIECE(APCDDATE,".")
+3 DO GETPROB
+4 IF 'APCDPIEN
DO PAUSE
DO EXIT
QUIT
+5 ;
ACT1 ;D DIE
+1 SET DA=APCDPIEN
SET APCDTOLD=$PIECE(^AUPNPROB(APCDPIEN,0),U,12)
+2 DO CPS^APCDAPRB
+3 ;I $P(^AUPNPROB(APCDPIEN,0),U,12)=APCDTOLD G ACTE
+4 IF $GET(APCDIAEP)
NEW DIE
SET DIE="^AUPNPROB("
SET DA=APCDPIEN
SET DR=".13"
DO ^DIE
KILL DIE,DA,DR
+5 IF '$GET(APCDIAEP)
IF $PIECE(^AUPNPROB(APCDPIEN,0),U,12)=APCDTOLD
GOTO ACTE
+6 SET APCDPAT=APCDPLPT
+7 IF '$GET(APCDLOC)
SET APCDLOC=DUZ(2)
+8 IF $GET(APCDDATE)=""
SET APCDDATE=APCDNDT
+9 SET APCDVSIT=$GET(APCDPLV)
+10 SET DA=APCDPIEN
+11 DO PLUDE^APCDAPRB
ACTE ;
+1 ;I $G(APCDIAEP) NEW DIE S DIE="^AUPNPROB(",DA=APCDPIEN,DR=".13" D ^DIE K DIE,DA,DR,APCDIAEP
+2 KILL APCDTOLD,APCDIAEP
+3 DO EXIT
+4 QUIT
INACT ;EP - called from protocol to inactivate an active problem
+1 NEW APCDPIEN,APCDNDT,APCDPAT
+2 SET APCDNDT=$PIECE(APCDDATE,".")
+3 DO GETPROB
+4 IF 'APCDPIEN
DO PAUSE
DO EXIT
QUIT
+5 IF $PIECE(^AUPNPROB(APCDPIEN,0),U,12)="I"
WRITE !!,"That problem is already INACTIVE!!",!
DO PAUSE
DO EXIT
QUIT
+6 SET APCDTEMP=".12///I;.03////^S X=APCDNDT;.14////^S X=DUZ"
+7 IF $DATA(IOF)
WRITE @IOF
WRITE !,"Inactivating Problem ... "
+8 DO DIE
+9 SET APCDPAT=APCDPLPT
+10 ;S:'$G(APCDLOC) APCDLOC=DUZ(2)
+11 IF $GET(APCDDATE)=""
SET APCDDATE=APCDNDT
+12 SET APCDPLV=$GET(APCDVSIT)
+13 SET DA=APCDPIEN
+14 DO PLUDE^APCDAPRB
+15 DO EXIT
+16 QUIT
HS ;EP - 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=APCDPLPT
+8 SET APCDHDR="PCC Health Summary for "_$PIECE(^DPT(APCDPLPT,0),U)
+9 DO VIEWR^XBLM("EN^APCHS",APCDHDR)
+10 SET (DFN,Y)=APCDPLPT
DO ^AUPNPAT
+11 KILL APCHSPAT,APCHSTYP,APCHSTAT,APCHSMTY,AMCHDAYS,AMCHDOB,APCDHDR
+12 DO EXIT
+13 QUIT
DD ;EP - called from protocol detail
+1 NEW APCDPIEN
+2 DO GETPROB
+3 IF 'APCDPIEN
DO PAUSE
DO EXIT
QUIT
+4 DO DIQ^XBLM(9000011,APCDPIEN)
+5 DO EXIT
+6 QUIT
FS ;EP -FACE SHEET
+1 DO FULL^VALM1
+2 SET APCDHDR="Demographic Face Sheet For "_$PIECE(^DPT(APCDPLPT,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 problem number
+1 NEW N,F
+2 SET N=""
+3 IF 'P
QUIT N
+4 IF '$DATA(^AUPNPROB(P,0))
QUIT N
+5 SET F=$PIECE(^AUPNPROB(P,0),U,6)
+6 SET N=$SELECT($PIECE(^AUTTLOC(F,0),U,7)]"":$JUSTIFY($PIECE(^(0),U,7),4),1:"??")_$PIECE(^AUPNPROB(P,0),U,7)
+7 QUIT N
EXIT ;
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO GATHER^APCDPL
+4 SET VALMCNT=APCDLINE
+5 DO HDR^APCDPL
+6 KILL APCDTEMP,APCDPRMT,APCDP,APCDPIEN,APCDAF,APCDF,APCDP0,APCDPRB
+7 DO KDIE
+8 QUIT
NAP ;EP - called from protocol
+1 DO FULL^VALM1
+2 IF '$GET(APCDPLPT)
QUIT
+3 IF $$ANYACTP^APCDAPRB(APCDPLPT)
Begin DoDot:1
+4 WRITE !!,"There are active problems on this patient's problem list. You"
+5 WRITE !,"cannot use this action item."
+6 DO PAUSE
DO EXIT
QUIT
End DoDot:1
QUIT
+7 SET APCDPAT=APCDPLPT
+8 IF '$GET(APCDLOC)
SET APCDLOC=DUZ(2)
+9 IF $GET(APCDDATE)=""
SET APCDDATE=APCDNDT
NAPDE1 ;EP - called from xbnew
+1 SET DIR(0)="Y"
SET DIR("A")="Did the Provider indicate that the patient has No Active Problems"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
WRITE !,"No action taken."
DO PAUSE
DO EXIT
QUIT
+3 IF 'Y
WRITE !,"No action taken."
DO PAUSE
DO EXIT
QUIT
+4 SET DIR(0)="D^::EPTSX"
SET DIR("A")="Enter the Date the Provider documented 'No Active Problems'"
+5 SET DIR("B")=$SELECT($GET(APCDDATE):$$FMTE^XLFDT($PIECE(APCDDATE,".")),$GET(APCDPLV):$$FMTE^XLFDT($$VD^APCLV(APCDPLV)),1:$$FMTE^XLFDT(DT))
SET DIR("?")="This is the visit date or the date the provider provided the information."
+6 KILL DA
DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
WRITE !!,"This is required."
GOTO NAPDE1
+8 IF $PIECE(Y,".")>DT
WRITE !!,"Future Dates not allowed.",!
GOTO NAPDE1
+9 SET APCDD=Y
NAPDE1P ;GET PROVIDER
+1 SET DIR(0)="9000010.54,1204"
SET DIR("A")="Enter the PROVIDER who documented 'No Active Problems'"
+2 SET DIR("B")=$SELECT($GET(APCDPLV):$$PRIMPROV^APCLV(APCDPLV,"N"),1:"")
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
WRITE !!,"This is required."
GOTO NAPDE1P
+4 SET APCDPRV=+Y
+5 DO NAPADD($GET(APCDPLV),APCDPAT,APCDD,APCDPRV,.APCDRET)
+6 IF $PIECE(APCDRET,U,1)=0
WRITE !!,"error: ",$PIECE(APCDRET,U,2)
+7 DO PAUSE
DO EXIT
+8 QUIT
NAPADD(APCDV,APCDP,APCDD,APCDPRV,RETVAL) ;PEP - called to update Problem list update fields
+1 ;this API can be called to have a V UPDATED/REVIEWED entry and populate the
+2 ;.11, .12, and .13 fields
+3 ;input:
+4 ; APCDV - ien of visit, if in the context of a visit
+5 ; APCDP - DFN
+6 ; APCDD - Date and optionally time of problem list update (fileman format)
+7 ; APCDPRV = ien of provider updating the problem list
+8 ;this API will create a new V UPDATED/REVIEWED entry if there isn't currently one
+9 ;for Provider APCDP on date APCDD
+10 ;if not in the context of a visit (APCDV = null) then an event visit will be created
+11 ;with a V UPDATED/REVIEWED v file entry
+12 ;
+13 ;RETURN VALUE:
+14 ; ien of V UPDATED/REVIEWED entry that was created
+15 ; or 0^error message
+16 SET APCDPIEN=$GET(APCDPIEN)
+17 SET APCDV=$GET(APCDV)
+18 SET APCDP=$GET(APCDP)
+19 IF 'APCDP
SET RETVAL="0^not a valid patient DFN"
QUIT
+20 IF '$DATA(^AUPNPAT(APCDP,0))
SET RETVAL="0^not a valid patient DFN"
QUIT
+21 SET APCDD=$GET(APCDD)
+22 IF 'APCDD
SET RETVAL="0^no valid date passed"
QUIT
+23 SET APCDPRV=$GET(APCDPRV)
+24 IF 'APCDPRV
SET RETVAL="0^no valid provider ien passed"
QUIT
+25 SET RETVAL=""
+26 ;
+27 IF APCDV
DO NAPV
QUIT
+28 ;NO VISIT SO CREATE EVENT VISIT AND CALL NAPV
+29 DO EVSIT
DO NAPV
+30 QUIT
NAPV ;have a visit so create a v updated/reviewed for provider APCDPRV if one does
+1 ;not exist on this visit already.
+2 NEW APCDX,APCDVD,APCDVRI,APCDVAL
+3 SET APCDVAL=$ORDER(^AUTTCRA("C","NAP",0))
+4 IF APCDVAL=""
SET RETVAL="0^action item missing"
QUIT
+5 SET APCDVRI=""
+6 SET APCDX=0
FOR
SET APCDX=$ORDER(^AUPNVRUP("AD",APCDV,APCDX))
IF APCDX=""!(APCDVRI)
QUIT
Begin DoDot:1
+7 ;is this entry a problem list review entry?
+8 ;this one isn't a NAP entry
IF $PIECE(^AUPNVRUP(APCDX,0),U,1)'=APCDVAL
QUIT
+9 IF $PIECE($GET(^AUPNVRUP(APCDX,2)),U,1)
QUIT
+10 ;not this provider
IF $PIECE($GET(^AUPNVRUP(APCDX,12)),U,4)'=APCDPRV
QUIT
+11 ;found one so don't create one
SET APCDVRI=APCDX
+12 QUIT
End DoDot:1
+13 IF APCDVRI
SET RETVAL=APCDVRI
QUIT
+14 ;create V UPDATED/REVIEWED entry
+15 NEW APCDALVR
+16 SET APCDALVR("APCDPAT")=APCDP
+17 SET APCDALVR("APCDVSIT")=APCDV
+18 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.54 (ADD)]"
+19 SET APCDALVR("APCDTCLA")="`"_APCDVAL
+20 SET APCDALVR("APCDTCDT")=APCDD
+21 SET APCDALVR("APCDTEPR")="`"_APCDPRV
+22 DO ^APCDALVR
+23 IF $DATA(APCDALVR("APCDAFLG"))
SET RETVAL=0_"^Error creating V UPDATED/REVIEWED entry. PCC not updated."
+24 KILL APCDALVR
+25 DO PLRV
+26 QUIT
BSD ;
+1 NEW APCDBSDV,APCDIN,Y
+2 KILL APCDIN
+3 SET APCDIN("PAT")=APCDP
+4 SET APCDIN("VISIT DATE")=APCDD_".12"
+5 SET APCDIN("SITE")=DUZ(2)
+6 SET APCDIN("VISIT TYPE")=$SELECT($PIECE($GET(^APCCCTRL(DUZ(2),0)),U,4)]"":$PIECE(^APCCCTRL(DUZ(2),0),U,4),1:"O")
+7 SET APCDIN("SRV CAT")="E"
+8 SET APCDIN("TIME RANGE")=0
+9 SET APCDIN("USR")=DUZ
+10 KILL APCDALVR
+11 KILL APCDBSDV
+12 NEW APCDDATE,AUPNPAT,AUPNDOB,AUPNSEX,AUPNDOD,AUPNDAYS,APCDPAT
+13 DO GETVISIT^APCDAPI4(.APCDIN,.APCDBSDV)
+14 ;S Y=APCDP D ^AUPNPAT
+15 SET T=$PIECE(APCDBSDV(0),U,2)
+16 IF T]""
SET RETVAL="0^could not create event visit"
QUIT
+17 SET V=$ORDER(APCDBSDV(0))
SET APCDV=V
+18 IF $GET(APCDBSDV(V))="ADD"
DO DEDT^APCDEA2(APCDV)
+19 QUIT
EVSIT ;EP - get/create event visit
+1 IF $LENGTH($TEXT(^BSDAPI4))
Begin DoDot:1
+2 DO BSD
End DoDot:1
QUIT
+3 KILL APCDVSIT
+4 KILL APCDALVR
+5 SET APCDALVR("APCDAUTO")=""
+6 SET APCDALVR("APCDPAT")=APCDP
+7 SET APCDALVR("APCDCAT")="E"
+8 SET APCDALVR("APCDLOC")=DUZ(2)
+9 SET APCDALVR("APCDTYPE")=$SELECT($PIECE($GET(^APCCCTRL(DUZ(2),0)),U,4)]"":$PIECE(^APCCCTRL(DUZ(2),0),U,4),1:"O")
+10 SET APCDALVR("APCDDATE")=APCDD_".12"
+11 DO ^APCDALV
+12 SET APCDV=$GET(APCDALVR("APCDVSIT"))
+13 IF $GET(APCDALVR("APCDVSIT","NEW"))
DO DEDT^APCDEA2(APCDVSIT)
+14 KILL APCDALVR
+15 QUIT
PLR ;EP - called from protocol
+1 NEW APCDPIEN,APCDNDT,APCDPAT
+2 SET APCDNDT=$PIECE(APCDDATE,".")
+3 DO FULL^VALM1
+4 IF '$GET(APCDPLPT)
QUIT
+5 SET APCDPAT=APCDPLPT
+6 IF '$GET(APCDLOC)
SET APCDLOC=DUZ(2)
+7 IF $GET(APCDDATE)=""
SET APCDDATE=APCDNDT
PLRDE1 ;EP - called from xbnew
+1 SET DIR(0)="Y"
SET DIR("A")="Did the Provider indicate that he/she reviewed the Problem List"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
WRITE !,"No action taken."
DO PAUSE
DO EXIT
QUIT
+3 IF 'Y
WRITE !,"No action taken."
DO PAUSE
DO EXIT
QUIT
+4 SET DIR(0)="D^::EPTSX"
SET DIR("A")="Enter the Date the Provider Reviewed the Problem List"
+5 SET DIR("B")=$SELECT($GET(APCDDATE):$$FMTE^XLFDT($PIECE(APCDDATE,".")),$GET(APCDPLV):$$FMTE^XLFDT($$VD^APCLV(APCDPLV)),1:$$FMTE^XLFDT(DT))
SET DIR("?")="This is the visit date or the date the provider provided the information."
+6 KILL DA
DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
WRITE !!,"This is required."
GOTO PLRDE1
+8 IF $PIECE(Y,".")>DT
WRITE !!,"Future Dates not allowed.",!
GOTO PLRDE1
+9 SET APCDD=Y
PLRDE1P ;GET PROVIDER
+1 SET DIR(0)="9000010.54,1204"
SET DIR("A")="Enter the PROVIDER who Reviewed the Problem List"
+2 SET DIR("B")=$SELECT($GET(APCDPLV):$$PRIMPROV^APCLV(APCDPLV,"N"),1:"")
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
WRITE !!,"This is required."
GOTO PLRDE1P
+4 SET APCDPRV=+Y
+5 DO PLRADD($GET(APCDPLV),APCDPAT,APCDD,APCDPRV,.APCDRET)
+6 IF $PIECE(APCDRET,U,1)=0
WRITE !!,"error: ",$PIECE(APCDRET,U,2)
+7 DO PAUSE
DO EXIT
+8 QUIT
PLRADD(APCDV,APCDP,APCDD,APCDPRV,RETVAL) ;PEP - called to update Problem list update fields
+1 ;this API can be called to have a V UPDATED/REVIEWED entry and populate the
+2 ;.11, .12, and .13 fields
+3 ;input:
+4 ; APCDV - ien of visit, if in the context of a visit
+5 ; APCDP - DFN
+6 ; APCDD - Date and optionally time of problem list update (fileman format)
+7 ; APCDPRV = ien of provider updating the problem list
+8 ;this API will create a new V UPDATED/REVIEWED entry if there isn't currently one
+9 ;for Provider APCDP on date APCDD
+10 ;if not in the context of a visit (APCDV = null) then an event visit will be created
+11 ;with a V UPDATED/REVIEWED v file entry
+12 ;
+13 ;RETURN VALUE:
+14 ; ien of V UPDATED/REVIEWED entry that was created
+15 ; or 0^error message
+16 SET APCDPIEN=$GET(APCDPIEN)
+17 SET APCDV=$GET(APCDV)
+18 SET APCDP=$GET(APCDP)
+19 IF 'APCDP
SET RETVAL="0^not a valid patient DFN"
QUIT
+20 IF '$DATA(^AUPNPAT(APCDP,0))
SET RETVAL="0^not a valid patient DFN"
QUIT
+21 SET APCDD=$GET(APCDD)
+22 IF 'APCDD
SET RETVAL="0^no valid date passed"
QUIT
+23 SET APCDPRV=$GET(APCDPRV)
+24 IF 'APCDPRV
SET RETVAL="0^no valid provider ien passed"
QUIT
+25 SET RETVAL=""
+26 ;
+27 IF APCDV
DO PLRV
QUIT
+28 ;NO VISIT SO CREATE EVENT VISIT AND CALL PLRV
+29 DO EVSIT
DO PLRV
+30 QUIT
PLRV ;have a visit so create a v updated/reviewed for provider APCDPRV if one does
+1 ;not exist on this visit already.
+2 NEW APCDX,APCDVD,APCDVRI,APCDVAL
+3 SET APCDVAL=$ORDER(^AUTTCRA("C","PLR",0))
+4 IF APCDVAL=""
SET RETVAL="0^action item missing"
QUIT
+5 SET APCDVRI=""
+6 SET APCDX=0
FOR
SET APCDX=$ORDER(^AUPNVRUP("AD",APCDV,APCDX))
IF APCDX=""!(APCDVRI)
QUIT
Begin DoDot:1
+7 ;is this entry a problem list review entry?
+8 ;this one isn't a PLR entry
IF $PIECE(^AUPNVRUP(APCDX,0),U,1)'=APCDVAL
QUIT
+9 IF $PIECE($GET(^AUPNVRUP(APCDX,2)),U,1)
QUIT
+10 ;not this provider
IF $PIECE($GET(^AUPNVRUP(APCDX,12)),U,4)'=APCDPRV
QUIT
+11 ;found one so don't create one
SET APCDVRI=APCDX
+12 QUIT
End DoDot:1
+13 IF APCDVRI
SET RETVAL=APCDVRI
QUIT
+14 NEW APCDALVR
+15 SET APCDALVR("APCDPAT")=APCDP
+16 SET APCDALVR("APCDVSIT")=APCDV
+17 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.54 (ADD)]"
+18 SET APCDALVR("APCDTCLA")="`"_APCDVAL
+19 SET APCDALVR("APCDTCDT")=APCDD
+20 SET APCDALVR("APCDTEPR")="`"_APCDPRV
+21 DO ^APCDALVR
+22 IF $DATA(APCDALVR("APCDAFLG"))
SET RETVAL=0_"^Error creating V UPDATED/REVIEWED entry. PCC not updated."
+23 KILL APCDALVR
+24 QUIT
RESOLVE ;EP - called from protocol
+1 NEW APCDPIEN,APCDNDT,APCDPAT
+2 SET APCDNDT=$PIECE(APCDDATE,".")
+3 DO GETPROB
+4 IF 'APCDPIEN
DO PAUSE
DO EXIT
QUIT
+5 IF $PIECE(^AUPNPROB(APCDPIEN,0),U,12)="R"
WRITE !!,"That problem is already RESOLVED!!",!
DO PAUSE
DO EXIT
QUIT
+6 SET APCDTEMP=".12///R;.03////^S X=APCDNDT;.14////^S X=DUZ"
+7 IF $DATA(IOF)
WRITE @IOF
WRITE !,"Resolving Problem ... "
+8 DO DIE
+9 SET APCDPAT=APCDPLPT
+10 IF $GET(APCDDATE)=""
SET APCDDATE=APCDNDT
+11 SET APCDPLV=$GET(APCDVSIT)
+12 SET DA=APCDPIEN
+13 DO PLUDE^APCDAPRB
+14 DO EXIT
+15 QUIT
