AMHPL1 ; IHS/CMI/LAB - problem list update from list manager ;
;;4.0;IHS BEHAVIORAL HEALTH;**2,4**;JUN 18, 2010;Build 28
;
;
DIE ;
S DA=AMHPIEN,DIE="^AUPNPROB(",DR=AMHTEMP D ^DIE
KDIE ;kill all vars used by DIE
K DIE,DR,DA,DIU,DIV,DQ,D0,DO,DI,DIW,DIY,%,DQ,DLAYGO
Q
GETPROB ;get record
S AMHPIEN=0
I 'AMHRCNT W !,"No problems to select." Q
S DIR(0)="N^1:"_AMHRCNT_":0",DIR("A")="Select Problem" KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"No Problem Selected" D PAUSE,EXIT Q
S AMHP=Y
S (X,Y)=0 F S X=$O(^TMP($J,"AMHPL","IDX",X)) Q:X'=+X!(AMHPIEN) I $O(^TMP($J,"AMHPL","IDX",X,0))=AMHP S Y=$O(^TMP($J,"AMHPL","IDX",X,0)),AMHPIEN=^TMP($J,"AMHPL","IDX",X,Y)
I '$D(^AUPNPROB(AMHPIEN,0)) W !,"Not a valid PCC PROBLEM." K AMHP S AMHPIEN=0 Q
D FULL^VALM1 ;give me full control of screen
Q
ADD ;EP - called from protocol to add a problem to problem list
D FULL^VALM1 ; this gives me back all screen control
Q:'$G(AMHPLPT) ; just want to be sure I have a patient
S AMHPAT=AMHPLPT
S:'$G(AMHLOC) AMHLOC=DUZ(2)
S:$G(AMHDATE)="" AMHDATE=DT ; set up vars needed by pcc data entry template
W:$D(IOF) @IOF W !,"Adding a new problem for ",$P(^DPT(AMHPLPT,0),U),".",!!
S DIC("A")="Enter Diagnosis Code: ",DIC="^AMHPROB(",DIC(0)="AEMQ" D ^DIC
I Y=-1 W !!,"No diagnosis code selected." D PAUSE,EXIT Q
NEW AMHPPTR,APCDLOOK,AMHPIEN
S AMHPPTR=+Y,APCDLOOK=$S($$IMP^AMHUTIL2(AMHDATE)=1:$P(^AMHPROB(AMHPPTR,0),U,5),1:$P(^AMHPROB(AMHPPTR,0),U,17))
I $T(ICDDX^ICDEX)="" S APCDLOOK=+$$CODEN^ICDCODE(APCDLOOK,80)
I $T(ICDDX^ICDEX)]"" S APCDLOOK=+$$CODEN^ICDEX(APCDLOOK,80)
I APCDLOOK=""!(APCDLOOK=-1) W !!,"no icd code mapped to that code." D PAUSE,EXIT Q
S APCDLOOK="`"_APCDLOOK
S APCDOVRR=1
;S DLAYGO=9000011
D KDIE S DLAYGO=9000011,DIE("NO^")=1,DIE="^AUPNPAT(",DR="[AMH ADD PCC PROBLEM]",DA=AMHPLPT D ^DIE D KDIE
W !
D PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
K DLAYGO D EXIT
Q
EDIT ;EP - called from protocol to modify a problem on problem list
NEW AMHPIEN
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
S APCDPIEN=AMHPIEN
S AMHTEMP="[APCD MODIFY PROBLEM]"
W:$D(IOF) @IOF W !,"Editing Problem ... "
D DIE K APCDPIEN
W !
D PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
D EXIT
Q
DEL ;EP - called from protocol to delete a problem on problem list
D FULL^VALM1
NEW AMHPIEN
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
S APCDPIEN=AMHPIEN
;
W !!,"Please Note: You are NOT permitted to delete a PCC 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=AMHPIEN,DR="[APCD DELETE PROBLEM]",DIE="^AUPNPROB(" D ^DIE K DA,DIE,DR
W !
D PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
D PAUSE,EXIT,^XBFMK
Q
AN ;EP - add a note, called from protocol
NEW AMHPIEN
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
D NO1^AMHPL2
D EXIT
Q
MN ;EP - called from protocol to modify a note
NEW AMHPIEN
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
D MN1^AMHPL2
D PAUSE,EXIT
Q
RNO ;EP - called from protocol to remove a note
NEW AMHPIEN
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
D RNO1^AMHPL2
D PAUSE,EXIT
Q
ACT ;EP - called from protocol to activate an inactive problem
NEW AMHPIEN,AMHNDT
S AMHNDT=$P(AMHDATE,".")
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
I $P(^AUPNPROB(AMHPIEN,0),U,12)="A" W !!,"That problem is already ACTIVE!!" D PAUSE,EXIT Q
S AMHTEMP=".12///A;.03////^S X=DT;.14////^S X=DUZ"
W:$D(IOF) @IOF W !,"Activating Problem ... "
D DIE
D PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
D EXIT
Q
INACT ;EP - called from protocol to inactivate an active problem
NEW AMHPIEN,AMHNDT
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
I $P(^AUPNPROB(AMHPIEN,0),U,12)="I" W !!,"That problem is already INACTIVE!!",! D PAUSE,EXIT Q
S AMHTEMP=".12///I;.03////^S X=DT;.14////^S X=DUZ"
W:$D(IOF) @IOF W !,"Inactivating Problem ... "
D DIE
D PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
D EXIT
Q
HS ;EP - called from protocol to display 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=AMHPLPT
S AMHHDR="PCC Health Summary for "_$P(^DPT(AMHPLPT,0),U)
D VIEWR^XBLM("EN^APCHS",AMHHDR)
S (DFN,Y)=AMHPLPT D ^AUPNPAT
K APCHSPAT,APCHSTYP,APCHSTAT,APCHSMTY,AMCHDAYS,AMCHDOB,AMHHDR
D EXIT
Q
DD ;EP - called from protocol to display (DIQ) a problem in detail
NEW AMHPIEN
D GETPROB
I 'AMHPIEN D PAUSE,EXIT Q
D DIQ^XBLM(9000011,AMHPIEN)
D EXIT
Q
FS ;EP -called from protcol to display face sheet
D FULL^VALM1
S AMHHDR="Demographic Face Sheet For "_$P(^DPT(AMHPLPT,0),U)
D VIEWR^XBLM("START^AGFACE",AMHHDR)
K AGOPT,AGDENT,AGMVDF,AMHHDR
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 given ien of problem entry
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 ;
K APCDOVRR
K DLAYGO
K APCDPIEN
D TERM^VALM0
S VALMBCK="R"
;D INIT^AMHPL
;S VALMCNT=AMHLINE
;D HDR^AMHPL
K AMHTEMP,AMHPRMT,AMHP,AMHPIEN,AMHAF,AMHF,AMHP0,AMHPRB,APCDLOOK,AMHPPTR
D KDIE
Q
NAP ;EP - called from protocol to DOCUMENT NO ACTIVE PROBLEMS IN PCC
D FULL^VALM1
NEW AMHDD,AMHNOGO
I $$ANYACTP(AMHPAT,DT) D Q
.W !!,"There are active problems on this patient's PCC problem list. You"
.W !,"cannot use this action item."
.D PAUSE,EXIT Q
I $$ANYACTBP(AMHPAT,DT) D I $G(AMHNOGO) D PAUSE,EXIT Q
.W !!,"There are active problems on this patient's Behavioral health problem list.",!
.S AMHNOGO=""
.K DIR
.S DIR(0)="Y",DIR("A")="Do you still want to document 'No Active Problems' in PCC",DIR("B")="N" KILL DA D ^DIR KILL DIR
.I $D(DIRUT) S AMHNOGO=1 Q
.I 'Y S AMHNOGO=1 Q
;
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(AMHDATE):$$FMTE^XLFDT($P(AMHDATE,".")),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 AMHDD=Y
NAPDE1P ;GET PROVIDER
S DIR(0)="9000010.54,1204",DIR("A")="Enter the PROVIDER who documented 'No Active Problems'"
S DIR("B")=$$PRIMPROV^AMHUTIL(AMHR,"N") KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." G NAPDE1P
S AMHPRV=+Y
D NAPPCC^AMHAPRB(AMHR,AMHDD,AMHPRV)
;D PLRPCC^AMHAPRB(AMHR,AMHPIEN,AMHPRV)
;I $P(AMHRET,U,1)=0 W !!,"error: ",$P(AMHRET,U,2)
D PAUSE,EXIT
Q
ANYACTP(P,EDATE) ;EP - does this patient have any active problems IN PCC?
I '$G(P) Q 0
S EDATE=$G(EDATE)
NEW X,Y,Z
S Z=0
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(Z) D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)'="A"
.I EDATE,$P(^AUPNPROB(X,0),U,8)>EDATE Q
.S Z=1
.Q
Q Z
;
ANYACTBP(P,EDATE) ;EP - does this patient have any active problems IN BH?
I '$G(P) Q 0
S EDATE=$G(EDATE)
NEW X,Y,Z
S Z=0
S X=0 F S X=$O(^AMHPPROB("AC",P,X)) Q:X'=+X!(Z) D
.Q:'$D(^AMHPPROB(X,0))
.Q:$P(^AMHPPROB(X,0),U,12)'="A"
.I EDATE,$P(^AMHPPROB(X,0),U,8)>EDATE Q
.S Z=1
.Q
Q Z
PLR ;EP - called from protocol to DOCUMENT NO ACTIVE PROBLEMS IN PCC
D FULL^VALM1
NEW AMHDD,AMHNOGO
;
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(AMHDATE):$$FMTE^XLFDT($P(AMHDATE,".")),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 AMHDD=Y
PLRDE1P ;GET PROVIDER
S DIR(0)="9000010.54,1204",DIR("A")="Enter the PROVIDER who reviewed the problem list"
S DIR("B")=$$PRIMPROV^AMHUTIL(AMHR,"N") KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"This is required." G NAPDE1P
S AMHPRV=+Y
D PLRPCC^AMHAPRB(AMHR,AMHDD,AMHPRV)
;D PLRPCC^AMHAPRB(AMHR,AMHPIEN,AMHPRV)
;I $P(AMHRET,U,1)=0 W !!,"error: ",$P(AMHRET,U,2)
D PAUSE,EXIT
Q
AMHPL1 ; IHS/CMI/LAB - problem list update from list manager ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**2,4**;JUN 18, 2010;Build 28
+2 ;
+3 ;
DIE ;
+1 SET DA=AMHPIEN
SET DIE="^AUPNPROB("
SET DR=AMHTEMP
DO ^DIE
KDIE ;kill all vars used by DIE
+1 KILL DIE,DR,DA,DIU,DIV,DQ,D0,DO,DI,DIW,DIY,%,DQ,DLAYGO
+2 QUIT
GETPROB ;get record
+1 SET AMHPIEN=0
+2 IF 'AMHRCNT
WRITE !,"No problems to select."
QUIT
+3 SET DIR(0)="N^1:"_AMHRCNT_":0"
SET DIR("A")="Select Problem"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
WRITE !!,"No Problem Selected"
DO PAUSE
DO EXIT
QUIT
+5 SET AMHP=Y
+6 SET (X,Y)=0
FOR
SET X=$ORDER(^TMP($JOB,"AMHPL","IDX",X))
IF X'=+X!(AMHPIEN)
QUIT
IF $ORDER(^TMP($JOB,"AMHPL","IDX",X,0))=AMHP
SET Y=$ORDER(^TMP($JOB,"AMHPL","IDX",X,0))
SET AMHPIEN=^TMP($JOB,"AMHPL","IDX",X,Y)
+7 IF '$DATA(^AUPNPROB(AMHPIEN,0))
WRITE !,"Not a valid PCC PROBLEM."
KILL AMHP
SET AMHPIEN=0
QUIT
+8 ;give me full control of screen
DO FULL^VALM1
+9 QUIT
ADD ;EP - called from protocol to add a problem to problem list
+1 ; this gives me back all screen control
DO FULL^VALM1
+2 ; just want to be sure I have a patient
IF '$GET(AMHPLPT)
QUIT
+3 SET AMHPAT=AMHPLPT
+4 IF '$GET(AMHLOC)
SET AMHLOC=DUZ(2)
+5 ; set up vars needed by pcc data entry template
IF $GET(AMHDATE)=""
SET AMHDATE=DT
+6 IF $DATA(IOF)
WRITE @IOF
WRITE !,"Adding a new problem for ",$PIECE(^DPT(AMHPLPT,0),U),".",!!
+7 SET DIC("A")="Enter Diagnosis Code: "
SET DIC="^AMHPROB("
SET DIC(0)="AEMQ"
DO ^DIC
+8 IF Y=-1
WRITE !!,"No diagnosis code selected."
DO PAUSE
DO EXIT
QUIT
+9 NEW AMHPPTR,APCDLOOK,AMHPIEN
+10 SET AMHPPTR=+Y
SET APCDLOOK=$SELECT($$IMP^AMHUTIL2(AMHDATE)=1:$PIECE(^AMHPROB(AMHPPTR,0),U,5),1:$PIECE(^AMHPROB(AMHPPTR,0),U,17))
+11 IF $TEXT(ICDDX^ICDEX)=""
SET APCDLOOK=+$$CODEN^ICDCODE(APCDLOOK,80)
+12 IF $TEXT(ICDDX^ICDEX)]""
SET APCDLOOK=+$$CODEN^ICDEX(APCDLOOK,80)
+13 IF APCDLOOK=""!(APCDLOOK=-1)
WRITE !!,"no icd code mapped to that code."
DO PAUSE
DO EXIT
QUIT
+14 SET APCDLOOK="`"_APCDLOOK
+15 SET APCDOVRR=1
+16 ;S DLAYGO=9000011
+17 DO KDIE
SET DLAYGO=9000011
SET DIE("NO^")=1
SET DIE="^AUPNPAT("
SET DR="[AMH ADD PCC PROBLEM]"
SET DA=AMHPLPT
DO ^DIE
DO KDIE
+18 WRITE !
+19 DO PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
+20 KILL DLAYGO
DO EXIT
+21 QUIT
EDIT ;EP - called from protocol to modify a problem on problem list
+1 NEW AMHPIEN
+2 DO GETPROB
+3 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+4 SET APCDPIEN=AMHPIEN
+5 SET AMHTEMP="[APCD MODIFY PROBLEM]"
+6 IF $DATA(IOF)
WRITE @IOF
WRITE !,"Editing Problem ... "
+7 DO DIE
KILL APCDPIEN
+8 WRITE !
+9 DO PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
+10 DO EXIT
+11 QUIT
DEL ;EP - called from protocol to delete a problem on problem list
+1 DO FULL^VALM1
+2 NEW AMHPIEN
+3 DO GETPROB
+4 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+5 SET APCDPIEN=AMHPIEN
+6 ;
+7 WRITE !!,"Please Note: You are NOT permitted to delete a PCC problem without",!,"entering a reason for the deletion."
+8 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
+9 IF $DATA(DIRUT)
WRITE !,"okay, not deleted."
DO PAUSE
DO EXIT
QUIT
+10 IF 'Y
WRITE !,"Okay, not deleted."
DO PAUSE
DO EXIT
QUIT
+11 SET DA=AMHPIEN
SET DR="[APCD DELETE PROBLEM]"
SET DIE="^AUPNPROB("
DO ^DIE
KILL DA,DIE,DR
+12 WRITE !
+13 DO PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
+14 DO PAUSE
DO EXIT
DO ^XBFMK
+15 QUIT
AN ;EP - add a note, called from protocol
+1 NEW AMHPIEN
+2 DO GETPROB
+3 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+4 DO NO1^AMHPL2
+5 DO EXIT
+6 QUIT
MN ;EP - called from protocol to modify a note
+1 NEW AMHPIEN
+2 DO GETPROB
+3 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+4 DO MN1^AMHPL2
+5 DO PAUSE
DO EXIT
+6 QUIT
RNO ;EP - called from protocol to remove a note
+1 NEW AMHPIEN
+2 DO GETPROB
+3 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+4 DO RNO1^AMHPL2
+5 DO PAUSE
DO EXIT
+6 QUIT
ACT ;EP - called from protocol to activate an inactive problem
+1 NEW AMHPIEN,AMHNDT
+2 SET AMHNDT=$PIECE(AMHDATE,".")
+3 DO GETPROB
+4 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+5 IF $PIECE(^AUPNPROB(AMHPIEN,0),U,12)="A"
WRITE !!,"That problem is already ACTIVE!!"
DO PAUSE
DO EXIT
QUIT
+6 SET AMHTEMP=".12///A;.03////^S X=DT;.14////^S X=DUZ"
+7 IF $DATA(IOF)
WRITE @IOF
WRITE !,"Activating Problem ... "
+8 DO DIE
+9 DO PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
+10 DO EXIT
+11 QUIT
INACT ;EP - called from protocol to inactivate an active problem
+1 NEW AMHPIEN,AMHNDT
+2 DO GETPROB
+3 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+4 IF $PIECE(^AUPNPROB(AMHPIEN,0),U,12)="I"
WRITE !!,"That problem is already INACTIVE!!",!
DO PAUSE
DO EXIT
QUIT
+5 SET AMHTEMP=".12///I;.03////^S X=DT;.14////^S X=DUZ"
+6 IF $DATA(IOF)
WRITE @IOF
WRITE !,"Inactivating Problem ... "
+7 DO DIE
+8 DO PLUPCC^AMHAPRB(AMHR,AMHPIEN,$$PRIMPROV^AMHUTIL(AMHR,"I"))
+9 DO EXIT
+10 QUIT
HS ;EP - called from protocol to display 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=AMHPLPT
+8 SET AMHHDR="PCC Health Summary for "_$PIECE(^DPT(AMHPLPT,0),U)
+9 DO VIEWR^XBLM("EN^APCHS",AMHHDR)
+10 SET (DFN,Y)=AMHPLPT
DO ^AUPNPAT
+11 KILL APCHSPAT,APCHSTYP,APCHSTAT,APCHSMTY,AMCHDAYS,AMCHDOB,AMHHDR
+12 DO EXIT
+13 QUIT
DD ;EP - called from protocol to display (DIQ) a problem in detail
+1 NEW AMHPIEN
+2 DO GETPROB
+3 IF 'AMHPIEN
DO PAUSE
DO EXIT
QUIT
+4 DO DIQ^XBLM(9000011,AMHPIEN)
+5 DO EXIT
+6 QUIT
FS ;EP -called from protcol to display face sheet
+1 DO FULL^VALM1
+2 SET AMHHDR="Demographic Face Sheet For "_$PIECE(^DPT(AMHPLPT,0),U)
+3 DO VIEWR^XBLM("START^AGFACE",AMHHDR)
+4 KILL AGOPT,AGDENT,AGMVDF,AMHHDR
+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 given ien of problem entry
+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 KILL APCDOVRR
+2 KILL DLAYGO
+3 KILL APCDPIEN
+4 DO TERM^VALM0
+5 SET VALMBCK="R"
+6 ;D INIT^AMHPL
+7 ;S VALMCNT=AMHLINE
+8 ;D HDR^AMHPL
+9 KILL AMHTEMP,AMHPRMT,AMHP,AMHPIEN,AMHAF,AMHF,AMHP0,AMHPRB,APCDLOOK,AMHPPTR
+10 DO KDIE
+11 QUIT
NAP ;EP - called from protocol to DOCUMENT NO ACTIVE PROBLEMS IN PCC
+1 DO FULL^VALM1
+2 NEW AMHDD,AMHNOGO
+3 IF $$ANYACTP(AMHPAT,DT)
Begin DoDot:1
+4 WRITE !!,"There are active problems on this patient's PCC problem list. You"
+5 WRITE !,"cannot use this action item."
+6 DO PAUSE
DO EXIT
QUIT
End DoDot:1
QUIT
+7 IF $$ANYACTBP(AMHPAT,DT)
Begin DoDot:1
+8 WRITE !!,"There are active problems on this patient's Behavioral health problem list.",!
+9 SET AMHNOGO=""
+10 KILL DIR
+11 SET DIR(0)="Y"
SET DIR("A")="Do you still want to document 'No Active Problems' in PCC"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+12 IF $DATA(DIRUT)
SET AMHNOGO=1
QUIT
+13 IF 'Y
SET AMHNOGO=1
QUIT
End DoDot:1
IF $GET(AMHNOGO)
DO PAUSE
DO EXIT
QUIT
+14 ;
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(AMHDATE):$$FMTE^XLFDT($PIECE(AMHDATE,".")),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 AMHDD=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")=$$PRIMPROV^AMHUTIL(AMHR,"N")
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
WRITE !!,"This is required."
GOTO NAPDE1P
+4 SET AMHPRV=+Y
+5 DO NAPPCC^AMHAPRB(AMHR,AMHDD,AMHPRV)
+6 ;D PLRPCC^AMHAPRB(AMHR,AMHPIEN,AMHPRV)
+7 ;I $P(AMHRET,U,1)=0 W !!,"error: ",$P(AMHRET,U,2)
+8 DO PAUSE
DO EXIT
+9 QUIT
ANYACTP(P,EDATE) ;EP - does this patient have any active problems IN PCC?
+1 IF '$GET(P)
QUIT 0
+2 SET EDATE=$GET(EDATE)
+3 NEW X,Y,Z
+4 SET Z=0
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(Z)
QUIT
Begin DoDot:1
+6 IF '$DATA(^AUPNPROB(X,0))
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+8 IF EDATE
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+9 SET Z=1
+10 QUIT
End DoDot:1
+11 QUIT Z
+12 ;
ANYACTBP(P,EDATE) ;EP - does this patient have any active problems IN BH?
+1 IF '$GET(P)
QUIT 0
+2 SET EDATE=$GET(EDATE)
+3 NEW X,Y,Z
+4 SET Z=0
+5 SET X=0
FOR
SET X=$ORDER(^AMHPPROB("AC",P,X))
IF X'=+X!(Z)
QUIT
Begin DoDot:1
+6 IF '$DATA(^AMHPPROB(X,0))
QUIT
+7 IF $PIECE(^AMHPPROB(X,0),U,12)'="A"
QUIT
+8 IF EDATE
IF $PIECE(^AMHPPROB(X,0),U,8)>EDATE
QUIT
+9 SET Z=1
+10 QUIT
End DoDot:1
+11 QUIT Z
PLR ;EP - called from protocol to DOCUMENT NO ACTIVE PROBLEMS IN PCC
+1 DO FULL^VALM1
+2 NEW AMHDD,AMHNOGO
+3 ;
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(AMHDATE):$$FMTE^XLFDT($PIECE(AMHDATE,".")),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 AMHDD=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")=$$PRIMPROV^AMHUTIL(AMHR,"N")
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
WRITE !!,"This is required."
GOTO NAPDE1P
+4 SET AMHPRV=+Y
+5 DO PLRPCC^AMHAPRB(AMHR,AMHDD,AMHPRV)
+6 ;D PLRPCC^AMHAPRB(AMHR,AMHPIEN,AMHPRV)
+7 ;I $P(AMHRET,U,1)=0 W !!,"error: ",$P(AMHRET,U,2)
+8 DO PAUSE
DO EXIT
+9 QUIT
