AMHBPL2.m

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)