APCDPL1.m

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