AMHBPL2 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ; 08 Sep 2011 12:17 PM
;;4.0;IHS BEHAVIORAL HEALTH;**2,4**;JUN 18, 2010;Build 28
;
NO1 ;EP
NEW AMHNOTES,AMHTNDF,AMHTQ,AMHNNUM,X,Y,AMHTN,AMHTDOI,AMHTTPT,AMHAUTH,AMHUPV
S AMHUPV=0
NO12 W:$D(IOF) @IOF
W !!,"Adding a Note to the following problem on ",$P($P(^DPT(DFN,0),U),",",2)," ",$P($P(^(0),U),","),"'s BH Problem List.",!
;S (X,D)=0 F S X=$O(AMHBHPL("IDX",X)) Q:X'=+X!D S Y=$O(AMHBHPL("IDX",X,0)) S:Y>AMHPIEN D=1 I AMHBHPL("IDX",X,Y)=AMHPIEN W !,AMHBHPL(X,0)
S DA=AMHPIEN,DIC="^AMHPPROB(" D EN^DIQ
D DDN^AMHBPL1
;S AMHTNDF=0 F AMHTQ=0:0 S AMHTNDF=$O(^AMHPTP("AE",AMHPIEN,AMHTNDF)) Q:'AMHTNDF D DSPN
W ! S DIR(0)="Y",DIR("A")="Add a new Problem Note for this Problem",DIR("B")="Y" K DA D ^DIR K DIR
G:$D(DIRUT) NOX
G:Y=0 NOX
NUM ;
S AMHNNUM=$$GETNUM^AMHLETN(AMHPIEN)
W !
S DIC="^AMHPTP(",X=AMHNNUM,DIC("DR")=".02////"_AMHPAT_";.03////"_AMHPIEN_";.05////"_DT,DIADD=1,DLAYGO=9002011.53,DIC(0)="EL"
D FILE^DICN
K DLAYGO,DIADD,DIC,DA
I Y=-1 W !,"error creating note entry" D PAUSE^AMHBPL1 G NOX ; Q
W !
S AMHNIEN=+Y
S DIE="^AMHPTP(",DA=AMHNIEN,DR=".04;.06//^S X=$P(^VA(200,DUZ,0),U);.07" D ^DIE K DIE,DR,DA
S AMHUPV=1
G NO12 ; D EXIT
NOX ;
I AMHUPV D PLUDE^AMHAPRB(AMHPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I")) S DA=AMHPIEN,DIE="^AMHPPROB(",DR=".03////"_$$NOW^XLFDT_".15////"_DUZ D ^DIE K DA,DIE,DR
K Y,X,L,AMHNNUM,AMHL,DIC,DA,DD,AMHC,AMHN,AMHNIEN,DR,DIADD
Q
RNO1 ;EP - called from AMHBPL1 - remove a note
NEW AMHNOTES,AMHTNDF,AMHTQ,AMHNNUM,X,Y,AMHTN,AMHTDOI,AMHTTPT,AMHAUTH,AMHRN
W:$D(IOF) @IOF
K AMHN,AMHL,AMHX,AMHC
W !!,"Editing a Note on the following problem on ",$P($P(^DPT(DFN,0),U),",",2)," ",$P($P(^(0),U),","),"'s BH Problem List.",!
S DA=AMHPIEN,DIC="^AMHPPROB(" D EN^DIQ
D DDN^AMHBPL1
;S AMHTNDF=0 F AMHTQ=0:0 S AMHTNDF=$O(^AMHPTP("AE",AMHPIEN,AMHTNDF)) Q:'AMHTNDF D DSPN
I '$D(AMHNOTES) W !?8,"No notes on file for this problem" G RNO1X
W ! K DIR S DIR(0)="N^1:"_AMHC_":",DIR("A")="Remove which one" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) W !,"Okay, bye." G RNO1X
I 'Y W !,"No Note selected" G RNO1X
S AMHRN=AMHNOTES(+Y)
RSURE ;
W !! S DIR(0)="Y",DIR("A")="Are you sure you want to delete this NOTE",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) W !,"okay, not deleted." G RNO1X
I 'Y W !,"Okay, not deleted." G RNO1X
S DA=AMHRN,DIE="^AMHPTP(",DR=".01///@" D ^DIE K DIE,DR,DA,Y W !
D PLUDE^AMHAPRB(AMHPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I")) S DA=AMHPIEN,DIE="^AMHPPROB(",DR=".03////"_$$NOW^XLFDT_".15////"_DUZ D ^DIE K DA,DIE,DR
RNO1X ;xit
K AMHPIEN,AMHL,AMHX,AMHN,AMHY
Q
MN1 ;EP - called to modify a note
NEW AMHNOTES,AMHTNDF,AMHTQ,AMHNNUM,X,Y,AMHTN,AMHTDOI,AMHTTPT,AMHAUTH
W:$D(IOF) @IOF
K AMHN,AMHL,AMHX,AMHC
W !!,"Editing a Note on the following problem on ",$P($P(^DPT(DFN,0),U),",",2)," ",$P($P(^(0),U),","),"'s BH Problem List.",!
S DA=AMHPIEN,DIC="^AMHPPROB(" D EN^DIQ
D DDN^AMHBPL1
;S AMHTNDF=0 F AMHTQ=0:0 S AMHTNDF=$O(^AMHPTP("AE",AMHPIEN,AMHTNDF)) Q:'AMHTNDF D DSPN
I '$D(AMHNOTES) W !?8,"No notes on file for this problem" G RNO1X
W ! K DIR S DIR(0)="N^1:"_AMHC_":",DIR("A")="Edit which one" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) W !,"Okay, bye." G RNO1X
I 'Y W !,"No Note selected" G RNO1X
S AMHY=+Y
MSURE ;
S DA=AMHNOTES(+Y),DIE="^AMHPTP(",DR=".04;.07" D ^DIE K DIE,DR,DA,Y W !
D PLUDE^AMHAPRB(AMHPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I")) S DA=AMHPIEN,DIE="^AMHPPROB(",DR=".03////"_$$NOW^XLFDT_".15////"_DUZ D ^DIE K DA,DIE,DR
MNO1X ;
K AMHPIEN,AMHL,AMHX,AMHN,AMHY,AMHNOTES
Q
BHP ;EP - called from protocol
D FULL^VALM1
;I '$D(^XUSEC("AMHZ PCC PROBLEM LIST",DUZ)) W !!,"You do not have security access to the PCC Problem List. Please see your",!,"supervisor or program manager. The security Key is AMHZ PCC PROBLEM LIST.",! D PAUSE^AMHBPL1,EXIT^AMHBPL1 Q
W !!,"Please select the problem entry to add to the PCC Problem List."
NEW AMHPIEN,AMHTEMP,AMHDSME,AMHDSMI,AMHDSM9,AMHN,AMHPLI
D GETPROB^AMHBPL1
I 'AMHPIEN D PAUSE^AMHBPL1 G BHPX ; Q
S AMHDSMI=$P(^AMHPPROB(AMHPIEN,0),U,1)
S AMHDSME=$P(^AMHPROB(AMHDSMI,0),U,1)
S AMHDSM9=$P(^AMHPROB(AMHDSMI,0),U,5) ;icd9 code
S AMHDSM0=$P(^AMHPROB(AMHDSMI,0),U,17)
I AMHDSM9="",AMHDSM0="" W !!,"This code is administrative in nature and cannot be added to the PCC ",!,"Problem List.",! D PAUSE^AMHBPL1 G BHPX
D ^AMHPROB
S AMHDSMI=$P(^AMHPPROB(AMHPIEN,0),U,1)
S AMHDSME=$P(^AMHPROB(AMHDSMI,0),U,1)
S AMHDSM9=$P(^AMHPROB(AMHDSMI,0),U,5) ;icd9 code
S AMHN=$P(^AMHPPROB(AMHPIEN,0),U,5) I AMHN S AMHN="`"_AMHN
I $$HASPROB(AMHPAT,AMHDSM9) W !!,AMHDSM9," is already on this patient's PCC Problem List."
W ! S DIR(0)="Y",DIR("A")="Are you sure you want to add diagnosis "_AMHDSME_" to PCC",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) W !,"okay, not added." G BHPX
I 'Y W !,"Okay, not added." G BHPX
S X=$$ADDPROB(AMHDSM9,AMHPAT,,,AMHN,,,$P(^AMHPPROB(AMHPIEN,0),U,12),$P(^AMHPPROB(AMHPIEN,0),U,13))
I X W !,"Error updating PCC Problem List...Notify Help Desk." D BHPX
S AMHPLI=$P(X,U,2)
W !,"This is the only narrative the rest of the medical community will see",!,"on the Health Summary for this problem. You may change it now if desired.",!
S DA=AMHPLI,DIE="^AUPNPROB(",DR=".05//" D ^DIE K DA,DR,DIE
BHPX ;
D EXIT^AMHBPL1
Q
HASPROB(P,D) ;EP
NEW X,G
S G=0
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.I $$VAL^XBDIQ1(9000011,X,.01)=D S G=1
Q G
ADDPROB(AMHDX,AMHP,AMHDLM,AMHCLS,AMHN,AMHFAC,AMHDTE,AMHSTAT,AMHDOO,AMHCLAS,AMHEBU,AMHEC1,AMHEC2,AMHEC3) ;PEP called to non-interactively add a problem to the pcc problem list
;AMHDX is the dx - pass in "`"_ien format or pass code (required)
;AMHP is the patient dfn (required)
;AMHDLM is the date last modified, if null I will stuff DT, PASS IN EXTERNAL FORMAT PLEASE
;AMHCLS is the class (not required)
;AMHN - provider narrative pass either "`"_ien of prov narr or pass narrative text
;AMHFAC - facility ien, if null will use DUZ(2)
;AMHDTE - date entered, if null will use DT , PASS IN EXTERNAL FORMAT PLEASE
;AMHSTAT - status I or A WILL DEFAULT TO A IF NONE PASSED
;AMHDOO - date of onset (pass in EXTERNAL format please) (not required)
;AMHCLAS= .15 field
;AMHEBU = ENTERED BY (field 1.03) if blank is stuffed with DUZ
;AMHEC1, AMHEC2, AMHEC3 - E CODES pass in "`"_ien format or pass code (required)
;
;error codes will be past back
; 1 = invalid dx, either not a valid ien, inactive code, E code
; 2 = invalid patient dfn, either not a valid dfn or patient merged
; 3 = invalid class code
; 4 = error creating entry with FILE^DICN
; 5 = invalid date last modified
; 6 = invalid provider narrative
; 7 = invalid date entered
; 8 = invalid facility
; 9 = invalid status
; 10 = invalid date of onset
; 11 = invalid ecode 1
; 12 = invalid ecode 2
; 13 = invalid ecode 3
;
NEW AMHERR
S AMHERR=0
D EN^XBNEW("AP^AMHBPL2","AMHDX;AMHP;AMHDLM;AMHCLS;AMHN;AMHFAC;AMHDTE;AMHSTAT;AMHDOO;AMHCLAS;AMHEBU;AMHERR;AMHEC1;AMHEC2;AMHEC3;AMHPLI")
Q AMHERR_U_$G(AMHPLI)
;
AP ;EP
NEW IEN,%,F,%FDA
P I '$G(AMHP) S AMHERR=2 Q
I '$D(^DPT(AMHP)) S AMHERR=2 Q
I $P(^DPT(AMHP,0),U,19) S AMHERR=2 Q
I '$D(^AUPNPAT(AMHP)) S AMHERR=2 Q
S Y=AMHP D ^AUPNPAT
DX ;DX CHK
I $G(AMHDX)="" S AMHERR=1 Q
D CHK^DIE(9000011,.01,"",AMHDX,.%) I %="^" S AMHERR=1 Q
S AMHDX=%
DLM ;
I $G(AMHDLM)="" S AMHDLM=$$FMTE^XLFDT(DT,"1D")
D CHK^DIE(9000011,.03,"",AMHDLM,.%) I %="^" S AMHERR=5 Q
CLS ;
I $G(AMHCLS)="" S AMHCLS=""
I AMHCLS]"" D Q:AMHERR
.D CHK^DIE(9000011,.04,"",AMHCLS,.%) I %="^" S AMHERR=3 Q
NARR ;
I $G(AMHN)="" S AMHERR=6 Q
I $$CHKNARR(AMHN) S AMHERR=6 Q
FAC ;
I '$G(AMHFAC) S AMHFAC=DUZ(2)
I '$D(^AUTTLOC(AMHFAC)) S AMHERR=8 Q
DTE ;
I $G(AMHDTE)="" S AMHDTE=$$FMTE^XLFDT(DT,"1D")
D CHK^DIE(9000011,.08,"",AMHDTE,.%) I %="^" S AMHERR=7 Q
STATUS ;
I $G(AMHSTAT)="" S AMHSTAT="A" G DOO
D CHK^DIE(9000011,.12,"",AMHSTAT,.%) I %="^" S AMHERR=9 Q
DOO ;
S:$G(AMHDOO)="" AMHDOO="" G CLASS
D CHK^DIE(9000011,.13,"",AMHDOO,.%) I %="^" S AMHERR=10 Q
CLASS ;
S AMHCLAS=$G(AMHCLAS)
S AMHEC1=$G(AMHEC1)
I AMHEC1]"" D CHK^DIE(9000011,.16,"",AMHEC1,.%) I %="^" S AMHERR=11 Q
S AMHEC2=$G(AMHEC2)
I AMHEC2]"" D CHK^DIE(9000011,.17,"",AMHEC2,.%) I %="^" S AMHERR=12 Q
S AMHEC3=$G(AMHEC3)
I AMHEC3]"" D CHK^DIE(9000011,.18,"",AMHEC3,.%) I %="^" S AMHERR=13 Q
NMBR ;calculate new number
NEW X,Y S X=0,Y="" F S Y=$O(^AUPNPROB("AA",AMHP,AMHFAC,Y)) S:Y'="" X=$E(Y,2,4) I Y="" S X=X+1 K Y Q
S AMHNMBR=X
FILE ;
S AMHOVRR=1,AMHALVR=""
S X=AMHDX,DIC(0)="L",DIC="^AUPNPROB(",DLAYGO=9000011,DIADD=1
S DIC("DR")=".02////"_AMHP_";.03///"_AMHDLM_";.04///"_AMHCLS_";.05///"_AMHN_";.06////"_AMHFAC_";.08///"_AMHDTE_";.07///"_AMHNMBR_";.12///"_AMHSTAT_";.13///"_AMHDOO_";1.03////"_$S($G(AMHEBU):AMHEBU,1:DUZ)_";.15///"_AMHCLAS
S DIC("DR")=DIC("DR")_";.16///"_AMHEC1_";.17///"_AMHEC2_";.18///"_AMHEC3
K DD,DO D FILE^DICN K DD,DO,DR,DLAYGO,DIADD,DIC
I Y=-1 S AMHERR=4 Q
S AMHPLI=+Y
Q
CHKNARR(D) ;
NEW %,F
S F=0
I $E(D)="`" S D=$P(D,"`",2) D Q F
.I '$D(^AUTNPOV(D)) S F=1
.;S AMHN=D
.Q
S X=D X $P(^DD(9999999.27,.01,0),U,5,99)
I '$D(X) S F=1
Q F
DELPROB(P,REASON,OTHER) ;PEP called to delete a problem from the PCC Problem list
;non interactive -1 will be returned if a valid problem ien was not passed
;sets .12 field to D, sets 2.01 to DUZ, set 2.02 to $$NOW
;if passed sets 2.03 to REASON
;if passed, sets 2.04 to OTHER
NEW DA,DIE,DR
I '$G(P) Q -1
I '$D(^AUPNPROB(P)) Q -1
S REASON=$G(REASON)
S OTHER=$G(OTHER)
S DA=P ;,DIK="^AUPNPROB(" D ^DIK
S DIE="^AUPNPROB("
S DR=".12////D;2.01////"_DUZ_";2.02///^S X=$$NOW^XLFDT;2.03///"_REASON_";2.04///"_OTHER
D ^DIE K DA,DR,DIE
I $D(Y) Q "-1^INVALID DATA"
Q ""
PCC ;EP
D FULL^VALM1
;I '$D(^XUSEC("AMHZ PCC PROBLEM LIST",DUZ)) W !!,"You do not have the security access to the PCC Problem List. Please see your",!,"supervisor or program manager. The security Key is AMHZ PCC PROBLEM LIST.",! D PAUSE^AMHBPL1,EXIT^AMHBPL1 Q
W !!,"You are now leaving the Behavioral Health Problem List and will be taken"
W !,"into the PCC Problem List for viewing.",!!
S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EXIT^AMHBPL1 Q
I 'Y D EXIT^AMHBPL1 Q
;
S DFN=AMHPAT
D EN^AMHPL
D EXIT^AMHBPL1
Q
AMHBPL2 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ; 08 Sep 2011 12:17 PM
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**2,4**;JUN 18, 2010;Build 28
+2 ;
NO1 ;EP
+1 NEW AMHNOTES,AMHTNDF,AMHTQ,AMHNNUM,X,Y,AMHTN,AMHTDOI,AMHTTPT,AMHAUTH,AMHUPV
+2 SET AMHUPV=0
NO12 IF $DATA(IOF)
WRITE @IOF
+1 WRITE !!,"Adding a Note to the following problem on ",$PIECE($PIECE(^DPT(DFN,0),U),",",2)," ",$PIECE($PIECE(^(0),U),","),"'s BH Problem List.",!
+2 ;S (X,D)=0 F S X=$O(AMHBHPL("IDX",X)) Q:X'=+X!D S Y=$O(AMHBHPL("IDX",X,0)) S:Y>AMHPIEN D=1 I AMHBHPL("IDX",X,Y)=AMHPIEN W !,AMHBHPL(X,0)
+3 SET DA=AMHPIEN
SET DIC="^AMHPPROB("
DO EN^DIQ
+4 DO DDN^AMHBPL1
+5 ;S AMHTNDF=0 F AMHTQ=0:0 S AMHTNDF=$O(^AMHPTP("AE",AMHPIEN,AMHTNDF)) Q:'AMHTNDF D DSPN
+6 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Add a new Problem Note for this Problem"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
GOTO NOX
+8 IF Y=0
GOTO NOX
NUM ;
+1 SET AMHNNUM=$$GETNUM^AMHLETN(AMHPIEN)
+2 WRITE !
+3 SET DIC="^AMHPTP("
SET X=AMHNNUM
SET DIC("DR")=".02////"_AMHPAT_";.03////"_AMHPIEN_";.05////"_DT
SET DIADD=1
SET DLAYGO=9002011.53
SET DIC(0)="EL"
+4 DO FILE^DICN
+5 KILL DLAYGO,DIADD,DIC,DA
+6 ; Q
IF Y=-1
WRITE !,"error creating note entry"
DO PAUSE^AMHBPL1
GOTO NOX
+7 WRITE !
+8 SET AMHNIEN=+Y
+9 SET DIE="^AMHPTP("
SET DA=AMHNIEN
SET DR=".04;.06//^S X=$P(^VA(200,DUZ,0),U);.07"
DO ^DIE
KILL DIE,DR,DA
+10 SET AMHUPV=1
+11 ; D EXIT
GOTO NO12
NOX ;
+1 IF AMHUPV
DO PLUDE^AMHAPRB(AMHPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I"))
SET DA=AMHPIEN
SET DIE="^AMHPPROB("
SET DR=".03////"_$$NOW^XLFDT_".15////"_DUZ
DO ^DIE
KILL DA,DIE,DR
+2 KILL Y,X,L,AMHNNUM,AMHL,DIC,DA,DD,AMHC,AMHN,AMHNIEN,DR,DIADD
+3 QUIT
RNO1 ;EP - called from AMHBPL1 - remove a note
+1 NEW AMHNOTES,AMHTNDF,AMHTQ,AMHNNUM,X,Y,AMHTN,AMHTDOI,AMHTTPT,AMHAUTH,AMHRN
+2 IF $DATA(IOF)
WRITE @IOF
+3 KILL AMHN,AMHL,AMHX,AMHC
+4 WRITE !!,"Editing a Note on the following problem on ",$PIECE($PIECE(^DPT(DFN,0),U),",",2)," ",$PIECE($PIECE(^(0),U),","),"'s BH Problem List.",!
+5 SET DA=AMHPIEN
SET DIC="^AMHPPROB("
DO EN^DIQ
+6 DO DDN^AMHBPL1
+7 ;S AMHTNDF=0 F AMHTQ=0:0 S AMHTNDF=$O(^AMHPTP("AE",AMHPIEN,AMHTNDF)) Q:'AMHTNDF D DSPN
+8 IF '$DATA(AMHNOTES)
WRITE !?8,"No notes on file for this problem"
GOTO RNO1X
+9 WRITE !
KILL DIR
SET DIR(0)="N^1:"_AMHC_":"
SET DIR("A")="Remove which one"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+10 IF $DATA(DIRUT)
WRITE !,"Okay, bye."
GOTO RNO1X
+11 IF 'Y
WRITE !,"No Note selected"
GOTO RNO1X
+12 SET AMHRN=AMHNOTES(+Y)
RSURE ;
+1 WRITE !!
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this NOTE"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
WRITE !,"okay, not deleted."
GOTO RNO1X
+3 IF 'Y
WRITE !,"Okay, not deleted."
GOTO RNO1X
+4 SET DA=AMHRN
SET DIE="^AMHPTP("
SET DR=".01///@"
DO ^DIE
KILL DIE,DR,DA,Y
WRITE !
+5 DO PLUDE^AMHAPRB(AMHPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I"))
SET DA=AMHPIEN
SET DIE="^AMHPPROB("
SET DR=".03////"_$$NOW^XLFDT_".15////"_DUZ
DO ^DIE
KILL DA,DIE,DR
RNO1X ;xit
+1 KILL AMHPIEN,AMHL,AMHX,AMHN,AMHY
+2 QUIT
MN1 ;EP - called to modify a note
+1 NEW AMHNOTES,AMHTNDF,AMHTQ,AMHNNUM,X,Y,AMHTN,AMHTDOI,AMHTTPT,AMHAUTH
+2 IF $DATA(IOF)
WRITE @IOF
+3 KILL AMHN,AMHL,AMHX,AMHC
+4 WRITE !!,"Editing a Note on the following problem on ",$PIECE($PIECE(^DPT(DFN,0),U),",",2)," ",$PIECE($PIECE(^(0),U),","),"'s BH Problem List.",!
+5 SET DA=AMHPIEN
SET DIC="^AMHPPROB("
DO EN^DIQ
+6 DO DDN^AMHBPL1
+7 ;S AMHTNDF=0 F AMHTQ=0:0 S AMHTNDF=$O(^AMHPTP("AE",AMHPIEN,AMHTNDF)) Q:'AMHTNDF D DSPN
+8 IF '$DATA(AMHNOTES)
WRITE !?8,"No notes on file for this problem"
GOTO RNO1X
+9 WRITE !
KILL DIR
SET DIR(0)="N^1:"_AMHC_":"
SET DIR("A")="Edit which one"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+10 IF $DATA(DIRUT)
WRITE !,"Okay, bye."
GOTO RNO1X
+11 IF 'Y
WRITE !,"No Note selected"
GOTO RNO1X
+12 SET AMHY=+Y
MSURE ;
+1 SET DA=AMHNOTES(+Y)
SET DIE="^AMHPTP("
SET DR=".04;.07"
DO ^DIE
KILL DIE,DR,DA,Y
WRITE !
+2 DO PLUDE^AMHAPRB(AMHPIEN,AMHPAT,AMHR,,$$PRIMPROV^AMHUTIL(AMHR,"I"))
SET DA=AMHPIEN
SET DIE="^AMHPPROB("
SET DR=".03////"_$$NOW^XLFDT_".15////"_DUZ
DO ^DIE
KILL DA,DIE,DR
MNO1X ;
+1 KILL AMHPIEN,AMHL,AMHX,AMHN,AMHY,AMHNOTES
+2 QUIT
BHP ;EP - called from protocol
+1 DO FULL^VALM1
+2 ;I '$D(^XUSEC("AMHZ PCC PROBLEM LIST",DUZ)) W !!,"You do not have security access to the PCC Problem List. Please see your",!,"supervisor or program manager. The security Key is AMHZ PCC PROBLEM LIST.",! D PAUSE^AMHBPL1,EXIT^AMHBPL1 Q
+3 WRITE !!,"Please select the problem entry to add to the PCC Problem List."
+4 NEW AMHPIEN,AMHTEMP,AMHDSME,AMHDSMI,AMHDSM9,AMHN,AMHPLI
+5 DO GETPROB^AMHBPL1
+6 ; Q
IF 'AMHPIEN
DO PAUSE^AMHBPL1
GOTO BHPX
+7 SET AMHDSMI=$PIECE(^AMHPPROB(AMHPIEN,0),U,1)
+8 SET AMHDSME=$PIECE(^AMHPROB(AMHDSMI,0),U,1)
+9 ;icd9 code
SET AMHDSM9=$PIECE(^AMHPROB(AMHDSMI,0),U,5)
+10 SET AMHDSM0=$PIECE(^AMHPROB(AMHDSMI,0),U,17)
+11 IF AMHDSM9=""
IF AMHDSM0=""
WRITE !!,"This code is administrative in nature and cannot be added to the PCC ",!,"Problem List.",!
DO PAUSE^AMHBPL1
GOTO BHPX
+12 DO ^AMHPROB
+13 SET AMHDSMI=$PIECE(^AMHPPROB(AMHPIEN,0),U,1)
+14 SET AMHDSME=$PIECE(^AMHPROB(AMHDSMI,0),U,1)
+15 ;icd9 code
SET AMHDSM9=$PIECE(^AMHPROB(AMHDSMI,0),U,5)
+16 SET AMHN=$PIECE(^AMHPPROB(AMHPIEN,0),U,5)
IF AMHN
SET AMHN="`"_AMHN
+17 IF $$HASPROB(AMHPAT,AMHDSM9)
WRITE !!,AMHDSM9," is already on this patient's PCC Problem List."
+18 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to add diagnosis "_AMHDSME_" to PCC"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+19 IF $DATA(DIRUT)
WRITE !,"okay, not added."
GOTO BHPX
+20 IF 'Y
WRITE !,"Okay, not added."
GOTO BHPX
+21 SET X=$$ADDPROB(AMHDSM9,AMHPAT,,,AMHN,,,$PIECE(^AMHPPROB(AMHPIEN,0),U,12),$PIECE(^AMHPPROB(AMHPIEN,0),U,13))
+22 IF X
WRITE !,"Error updating PCC Problem List...Notify Help Desk."
DO BHPX
+23 SET AMHPLI=$PIECE(X,U,2)
+24 WRITE !,"This is the only narrative the rest of the medical community will see",!,"on the Health Summary for this problem. You may change it now if desired.",!
+25 SET DA=AMHPLI
SET DIE="^AUPNPROB("
SET DR=".05//"
DO ^DIE
KILL DA,DR,DIE
BHPX ;
+1 DO EXIT^AMHBPL1
+2 QUIT
HASPROB(P,D) ;EP
+1 NEW X,G
+2 SET G=0
+3 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+5 IF $$VAL^XBDIQ1(9000011,X,.01)=D
SET G=1
End DoDot:1
+6 QUIT G
ADDPROB(AMHDX,AMHP,AMHDLM,AMHCLS,AMHN,AMHFAC,AMHDTE,AMHSTAT,AMHDOO,AMHCLAS,AMHEBU,AMHEC1,AMHEC2,AMHEC3) ;PEP called to non-interactively add a problem to the pcc problem list
+1 ;AMHDX is the dx - pass in "`"_ien format or pass code (required)
+2 ;AMHP is the patient dfn (required)
+3 ;AMHDLM is the date last modified, if null I will stuff DT, PASS IN EXTERNAL FORMAT PLEASE
+4 ;AMHCLS is the class (not required)
+5 ;AMHN - provider narrative pass either "`"_ien of prov narr or pass narrative text
+6 ;AMHFAC - facility ien, if null will use DUZ(2)
+7 ;AMHDTE - date entered, if null will use DT , PASS IN EXTERNAL FORMAT PLEASE
+8 ;AMHSTAT - status I or A WILL DEFAULT TO A IF NONE PASSED
+9 ;AMHDOO - date of onset (pass in EXTERNAL format please) (not required)
+10 ;AMHCLAS= .15 field
+11 ;AMHEBU = ENTERED BY (field 1.03) if blank is stuffed with DUZ
+12 ;AMHEC1, AMHEC2, AMHEC3 - E CODES pass in "`"_ien format or pass code (required)
+13 ;
+14 ;error codes will be past back
+15 ; 1 = invalid dx, either not a valid ien, inactive code, E code
+16 ; 2 = invalid patient dfn, either not a valid dfn or patient merged
+17 ; 3 = invalid class code
+18 ; 4 = error creating entry with FILE^DICN
+19 ; 5 = invalid date last modified
+20 ; 6 = invalid provider narrative
+21 ; 7 = invalid date entered
+22 ; 8 = invalid facility
+23 ; 9 = invalid status
+24 ; 10 = invalid date of onset
+25 ; 11 = invalid ecode 1
+26 ; 12 = invalid ecode 2
+27 ; 13 = invalid ecode 3
+28 ;
+29 NEW AMHERR
+30 SET AMHERR=0
+31 DO EN^XBNEW("AP^AMHBPL2","AMHDX;AMHP;AMHDLM;AMHCLS;AMHN;AMHFAC;AMHDTE;AMHSTAT;AMHDOO;AMHCLAS;AMHEBU;AMHERR;AMHEC1;AMHEC2;AMHEC3;AMHPLI")
+32 QUIT AMHERR_U_$GET(AMHPLI)
+33 ;
AP ;EP
+1 NEW IEN,%,F,%FDA
P IF '$GET(AMHP)
SET AMHERR=2
QUIT
+1 IF '$DATA(^DPT(AMHP))
SET AMHERR=2
QUIT
+2 IF $PIECE(^DPT(AMHP,0),U,19)
SET AMHERR=2
QUIT
+3 IF '$DATA(^AUPNPAT(AMHP))
SET AMHERR=2
QUIT
+4 SET Y=AMHP
DO ^AUPNPAT
DX ;DX CHK
+1 IF $GET(AMHDX)=""
SET AMHERR=1
QUIT
+2 DO CHK^DIE(9000011,.01,"",AMHDX,.%)
IF %="^"
SET AMHERR=1
QUIT
+3 SET AMHDX=%
DLM ;
+1 IF $GET(AMHDLM)=""
SET AMHDLM=$$FMTE^XLFDT(DT,"1D")
+2 DO CHK^DIE(9000011,.03,"",AMHDLM,.%)
IF %="^"
SET AMHERR=5
QUIT
CLS ;
+1 IF $GET(AMHCLS)=""
SET AMHCLS=""
+2 IF AMHCLS]""
Begin DoDot:1
+3 DO CHK^DIE(9000011,.04,"",AMHCLS,.%)
IF %="^"
SET AMHERR=3
QUIT
End DoDot:1
IF AMHERR
QUIT
NARR ;
+1 IF $GET(AMHN)=""
SET AMHERR=6
QUIT
+2 IF $$CHKNARR(AMHN)
SET AMHERR=6
QUIT
FAC ;
+1 IF '$GET(AMHFAC)
SET AMHFAC=DUZ(2)
+2 IF '$DATA(^AUTTLOC(AMHFAC))
SET AMHERR=8
QUIT
DTE ;
+1 IF $GET(AMHDTE)=""
SET AMHDTE=$$FMTE^XLFDT(DT,"1D")
+2 DO CHK^DIE(9000011,.08,"",AMHDTE,.%)
IF %="^"
SET AMHERR=7
QUIT
STATUS ;
+1 IF $GET(AMHSTAT)=""
SET AMHSTAT="A"
GOTO DOO
+2 DO CHK^DIE(9000011,.12,"",AMHSTAT,.%)
IF %="^"
SET AMHERR=9
QUIT
DOO ;
+1 IF $GET(AMHDOO)=""
SET AMHDOO=""
GOTO CLASS
+2 DO CHK^DIE(9000011,.13,"",AMHDOO,.%)
IF %="^"
SET AMHERR=10
QUIT
CLASS ;
+1 SET AMHCLAS=$GET(AMHCLAS)
+2 SET AMHEC1=$GET(AMHEC1)
+3 IF AMHEC1]""
DO CHK^DIE(9000011,.16,"",AMHEC1,.%)
IF %="^"
SET AMHERR=11
QUIT
+4 SET AMHEC2=$GET(AMHEC2)
+5 IF AMHEC2]""
DO CHK^DIE(9000011,.17,"",AMHEC2,.%)
IF %="^"
SET AMHERR=12
QUIT
+6 SET AMHEC3=$GET(AMHEC3)
+7 IF AMHEC3]""
DO CHK^DIE(9000011,.18,"",AMHEC3,.%)
IF %="^"
SET AMHERR=13
QUIT
NMBR ;calculate new number
+1 NEW X,Y
SET X=0
SET Y=""
FOR
SET Y=$ORDER(^AUPNPROB("AA",AMHP,AMHFAC,Y))
IF Y'=""
SET X=$EXTRACT(Y,2,4)
IF Y=""
SET X=X+1
KILL Y
QUIT
+2 SET AMHNMBR=X
FILE ;
+1 SET AMHOVRR=1
SET AMHALVR=""
+2 SET X=AMHDX
SET DIC(0)="L"
SET DIC="^AUPNPROB("
SET DLAYGO=9000011
SET DIADD=1
+3 SET DIC("DR")=".02////"_AMHP_";.03///"_AMHDLM_";.04///"_AMHCLS_";.05///"_AMHN_";.06////"_AMHFAC_";.08///"_AMHDTE_";.07///"_AMHNMBR_";.12///"_AMHSTAT_";.13///"_AMHDOO_";1.03////"_$SELECT($GET(AMHEBU):AMHEBU,1:DUZ)_";.15///"_AMHCLAS
+4 SET DIC("DR")=DIC("DR")_";.16///"_AMHEC1_";.17///"_AMHEC2_";.18///"_AMHEC3
+5 KILL DD,DO
DO FILE^DICN
KILL DD,DO,DR,DLAYGO,DIADD,DIC
+6 IF Y=-1
SET AMHERR=4
QUIT
+7 SET AMHPLI=+Y
+8 QUIT
CHKNARR(D) ;
+1 NEW %,F
+2 SET F=0
+3 IF $EXTRACT(D)="`"
SET D=$PIECE(D,"`",2)
Begin DoDot:1
+4 IF '$DATA(^AUTNPOV(D))
SET F=1
+5 ;S AMHN=D
+6 QUIT
End DoDot:1
QUIT F
+7 SET X=D
XECUTE $PIECE(^DD(9999999.27,.01,0),U,5,99)
+8 IF '$DATA(X)
SET F=1
+9 QUIT F
DELPROB(P,REASON,OTHER) ;PEP called to delete a problem from the PCC Problem list
+1 ;non interactive -1 will be returned if a valid problem ien was not passed
+2 ;sets .12 field to D, sets 2.01 to DUZ, set 2.02 to $$NOW
+3 ;if passed sets 2.03 to REASON
+4 ;if passed, sets 2.04 to OTHER
+5 NEW DA,DIE,DR
+6 IF '$GET(P)
QUIT -1
+7 IF '$DATA(^AUPNPROB(P))
QUIT -1
+8 SET REASON=$GET(REASON)
+9 SET OTHER=$GET(OTHER)
+10 ;,DIK="^AUPNPROB(" D ^DIK
SET DA=P
+11 SET DIE="^AUPNPROB("
+12 SET DR=".12////D;2.01////"_DUZ_";2.02///^S X=$$NOW^XLFDT;2.03///"_REASON_";2.04///"_OTHER
+13 DO ^DIE
KILL DA,DR,DIE
+14 IF $DATA(Y)
QUIT "-1^INVALID DATA"
+15 QUIT ""
PCC ;EP
+1 DO FULL^VALM1
+2 ;I '$D(^XUSEC("AMHZ PCC PROBLEM LIST",DUZ)) W !!,"You do not have the security access to the PCC Problem List. Please see your",!,"supervisor or program manager. The security Key is AMHZ PCC PROBLEM LIST.",! D PAUSE^AMHBPL1,EXIT^AMHBPL1 Q
+3 WRITE !!,"You are now leaving the Behavioral Health Problem List and will be taken"
+4 WRITE !,"into the PCC Problem List for viewing.",!!
+5 SET DIR(0)="Y"
SET DIR("A")="Do you wish to continue"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
DO EXIT^AMHBPL1
QUIT
+7 IF 'Y
DO EXIT^AMHBPL1
QUIT
+8 ;
+9 SET DFN=AMHPAT
+10 DO EN^AMHPL
+11 DO EXIT^AMHBPL1
+12 QUIT
