Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMHBPL2

AMHBPL2.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1. NO1 ;EP
  1.  NEW AMHNOTES,AMHTNDF,AMHTQ,AMHNNUM,X,Y,AMHTN,AMHTDOI,AMHTTPT,AMHAUTH,AMHUPV
  1.  S AMHUPV=0
  1. NO12 W:$D(IOF) @IOF
  1.  W !!,"Adding a Note to the following problem on ",$P($P(^DPT(DFN,0),U),",",2)," ",$P($P(^(0),U),","),"'s BH Problem List.",!
  1.  ;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)
  1.  S DA=AMHPIEN,DIC="^AMHPPROB(" D EN^DIQ
  1.  D DDN^AMHBPL1
  1.  ;S AMHTNDF=0 F AMHTQ=0:0 S AMHTNDF=$O(^AMHPTP("AE",AMHPIEN,AMHTNDF)) Q:'AMHTNDF  D DSPN
  1.  W ! S DIR(0)="Y",DIR("A")="Add a new Problem Note for this Problem",DIR("B")="Y" K DA D ^DIR K DIR
  1.  G:$D(DIRUT) NOX
  1.  G:Y=0 NOX
  1. NUM ;
  1.  S AMHNNUM=$$GETNUM^AMHLETN(AMHPIEN)
  1.  W !
  1.  S DIC="^AMHPTP(",X=AMHNNUM,DIC("DR")=".02////"_AMHPAT_";.03////"_AMHPIEN_";.05////"_DT,DIADD=1,DLAYGO=9002011.53,DIC(0)="EL"
  1.  D FILE^DICN
  1.  K DLAYGO,DIADD,DIC,DA
  1.  I Y=-1 W !,"error creating note entry" D PAUSE^AMHBPL1 G NOX ; Q
  1.  W !
  1.  S AMHNIEN=+Y
  1.  S DIE="^AMHPTP(",DA=AMHNIEN,DR=".04;.06//^S X=$P(^VA(200,DUZ,0),U);.07" D ^DIE K DIE,DR,DA
  1.  S AMHUPV=1
  1.  G NO12 ; D EXIT
  1. NOX ;
  1.  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
  1.  K Y,X,L,AMHNNUM,AMHL,DIC,DA,DD,AMHC,AMHN,AMHNIEN,DR,DIADD
  1.  Q
  1. RNO1 ;EP - called from AMHBPL1 - remove a note
  1.  NEW AMHNOTES,AMHTNDF,AMHTQ,AMHNNUM,X,Y,AMHTN,AMHTDOI,AMHTTPT,AMHAUTH,AMHRN
  1.  W:$D(IOF) @IOF
  1.  K AMHN,AMHL,AMHX,AMHC
  1.  W !!,"Editing a Note on the following problem on ",$P($P(^DPT(DFN,0),U),",",2)," ",$P($P(^(0),U),","),"'s BH Problem List.",!
  1.  S DA=AMHPIEN,DIC="^AMHPPROB(" D EN^DIQ
  1.  D DDN^AMHBPL1
  1.  ;S AMHTNDF=0 F AMHTQ=0:0 S AMHTNDF=$O(^AMHPTP("AE",AMHPIEN,AMHTNDF)) Q:'AMHTNDF  D DSPN
  1.  I '$D(AMHNOTES) W !?8,"No notes on file for this problem" G RNO1X
  1.  W ! K DIR S DIR(0)="N^1:"_AMHC_":",DIR("A")="Remove which one" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I $D(DIRUT) W !,"Okay, bye." G RNO1X
  1.  I 'Y W !,"No Note selected"  G RNO1X
  1.  S AMHRN=AMHNOTES(+Y)
  1. RSURE ;
  1.  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
  1.  I $D(DIRUT) W !,"okay, not deleted." G RNO1X
  1.  I 'Y W !,"Okay, not deleted." G RNO1X
  1.  S DA=AMHRN,DIE="^AMHPTP(",DR=".01///@" D ^DIE K DIE,DR,DA,Y W !
  1.  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
  1. RNO1X ;xit
  1.  K AMHPIEN,AMHL,AMHX,AMHN,AMHY
  1.  Q
  1. MN1 ;EP - called to modify a note
  1.  NEW AMHNOTES,AMHTNDF,AMHTQ,AMHNNUM,X,Y,AMHTN,AMHTDOI,AMHTTPT,AMHAUTH
  1.  W:$D(IOF) @IOF
  1.  K AMHN,AMHL,AMHX,AMHC
  1.  W !!,"Editing a Note on the following problem on ",$P($P(^DPT(DFN,0),U),",",2)," ",$P($P(^(0),U),","),"'s BH Problem List.",!
  1.  S DA=AMHPIEN,DIC="^AMHPPROB(" D EN^DIQ
  1.  D DDN^AMHBPL1
  1.  ;S AMHTNDF=0 F AMHTQ=0:0 S AMHTNDF=$O(^AMHPTP("AE",AMHPIEN,AMHTNDF)) Q:'AMHTNDF  D DSPN
  1.  I '$D(AMHNOTES) W !?8,"No notes on file for this problem" G RNO1X
  1.  W ! K DIR S DIR(0)="N^1:"_AMHC_":",DIR("A")="Edit which one" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  I $D(DIRUT) W !,"Okay, bye." G RNO1X
  1.  I 'Y W !,"No Note selected"  G RNO1X
  1.  S AMHY=+Y
  1. MSURE ;
  1.  S DA=AMHNOTES(+Y),DIE="^AMHPTP(",DR=".04;.07" D ^DIE K DIE,DR,DA,Y W !
  1.  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
  1. MNO1X ;
  1.  K AMHPIEN,AMHL,AMHX,AMHN,AMHY,AMHNOTES
  1.  Q
  1. BHP ;EP - called from protocol
  1.  D FULL^VALM1
  1.  ;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
  1.  W !!,"Please select the problem entry to add to the PCC Problem List."
  1.  NEW AMHPIEN,AMHTEMP,AMHDSME,AMHDSMI,AMHDSM9,AMHN,AMHPLI
  1.  D GETPROB^AMHBPL1
  1.  I 'AMHPIEN D PAUSE^AMHBPL1 G BHPX  ; Q
  1.  S AMHDSMI=$P(^AMHPPROB(AMHPIEN,0),U,1)
  1.  S AMHDSME=$P(^AMHPROB(AMHDSMI,0),U,1)
  1.  S AMHDSM9=$P(^AMHPROB(AMHDSMI,0),U,5)  ;icd9 code
  1.  S AMHDSM0=$P(^AMHPROB(AMHDSMI,0),U,17)
  1.  I AMHDSM9="",AMHDSM0="" W !!,"This code is administrative in nature and cannot be added to the PCC ",!,"Problem List.",! D PAUSE^AMHBPL1 G BHPX
  1.  D ^AMHPROB
  1.  S AMHDSMI=$P(^AMHPPROB(AMHPIEN,0),U,1)
  1.  S AMHDSME=$P(^AMHPROB(AMHDSMI,0),U,1)
  1.  S AMHDSM9=$P(^AMHPROB(AMHDSMI,0),U,5)  ;icd9 code
  1.  S AMHN=$P(^AMHPPROB(AMHPIEN,0),U,5) I AMHN S AMHN="`"_AMHN
  1.  I $$HASPROB(AMHPAT,AMHDSM9) W !!,AMHDSM9," is already on this patient's PCC Problem List."
  1.  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
  1.  I $D(DIRUT) W !,"okay, not added." G BHPX
  1.  I 'Y W !,"Okay, not added." G BHPX
  1.  S X=$$ADDPROB(AMHDSM9,AMHPAT,,,AMHN,,,$P(^AMHPPROB(AMHPIEN,0),U,12),$P(^AMHPPROB(AMHPIEN,0),U,13))
  1.  I X W !,"Error updating PCC Problem List...Notify Help Desk." D BHPX
  1.  S AMHPLI=$P(X,U,2)
  1.  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.",!
  1.  S DA=AMHPLI,DIE="^AUPNPROB(",DR=".05//" D ^DIE K DA,DR,DIE
  1. BHPX ;
  1.  D EXIT^AMHBPL1
  1.  Q
  1. HASPROB(P,D) ;EP
  1.  NEW X,G
  1.  S G=0
  1.  S X=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X  D
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1.  .I $$VAL^XBDIQ1(9000011,X,.01)=D S G=1
  1.  Q G
  1. 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)
  1.  ;AMHP is the patient dfn (required)
  1.  ;AMHDLM is the date last modified, if null I will stuff DT, PASS IN EXTERNAL FORMAT PLEASE
  1.  ;AMHCLS is the class (not required)
  1.  ;AMHN - provider narrative pass either "`"_ien of prov narr or pass narrative text
  1.  ;AMHFAC - facility ien, if null will use DUZ(2)
  1.  ;AMHDTE - date entered, if null will use DT , PASS IN EXTERNAL FORMAT PLEASE
  1.  ;AMHSTAT - status I or A WILL DEFAULT TO A IF NONE PASSED
  1.  ;AMHDOO - date of onset (pass in EXTERNAL  format please) (not required)
  1.  ;AMHCLAS= .15 field
  1.  ;AMHEBU = ENTERED BY (field 1.03) if blank  is stuffed with DUZ
  1.  ;AMHEC1, AMHEC2, AMHEC3 - E CODES pass in "`"_ien format or pass code (required)
  1.  ;
  1.  ;error codes will be past back
  1.  ;    1 = invalid dx, either not a valid ien, inactive code, E code
  1.  ;    2 = invalid patient dfn, either not a valid dfn or patient merged
  1.  ;    3 = invalid class code
  1.  ;    4 = error creating entry with FILE^DICN
  1.  ;    5 = invalid date last modified
  1.  ;    6 = invalid provider narrative
  1.  ;    7 = invalid date entered
  1.  ;    8 = invalid facility
  1.  ;    9 = invalid status
  1.  ;   10 = invalid date of onset
  1.  ;   11 = invalid ecode 1
  1.  ;   12 = invalid ecode 2
  1.  ;   13 = invalid ecode 3
  1.  ;
  1.  NEW AMHERR
  1.  S AMHERR=0
  1.  D EN^XBNEW("AP^AMHBPL2","AMHDX;AMHP;AMHDLM;AMHCLS;AMHN;AMHFAC;AMHDTE;AMHSTAT;AMHDOO;AMHCLAS;AMHEBU;AMHERR;AMHEC1;AMHEC2;AMHEC3;AMHPLI")
  1.  Q AMHERR_U_$G(AMHPLI)
  1.  ;
  1. AP ;EP
  1.  NEW IEN,%,F,%FDA
  1. P I '$G(AMHP) S AMHERR=2 Q
  1.  I '$D(^DPT(AMHP)) S AMHERR=2 Q
  1.  I $P(^DPT(AMHP,0),U,19) S AMHERR=2 Q
  1.  I '$D(^AUPNPAT(AMHP)) S AMHERR=2 Q
  1.  S Y=AMHP D ^AUPNPAT
  1. DX ;DX CHK
  1.  I $G(AMHDX)="" S AMHERR=1 Q
  1.  D CHK^DIE(9000011,.01,"",AMHDX,.%) I %="^" S AMHERR=1 Q
  1.  S AMHDX=%
  1. DLM ;
  1.  I $G(AMHDLM)="" S AMHDLM=$$FMTE^XLFDT(DT,"1D")
  1.  D CHK^DIE(9000011,.03,"",AMHDLM,.%) I %="^" S AMHERR=5 Q
  1. CLS ;
  1.  I $G(AMHCLS)="" S AMHCLS=""
  1.  I AMHCLS]"" D  Q:AMHERR
  1.  .D CHK^DIE(9000011,.04,"",AMHCLS,.%) I %="^" S AMHERR=3 Q
  1. NARR ;
  1.  I $G(AMHN)="" S AMHERR=6 Q
  1.  I $$CHKNARR(AMHN) S AMHERR=6 Q
  1. FAC ;
  1.  I '$G(AMHFAC) S AMHFAC=DUZ(2)
  1.  I '$D(^AUTTLOC(AMHFAC)) S AMHERR=8 Q
  1. DTE ;
  1.  I $G(AMHDTE)="" S AMHDTE=$$FMTE^XLFDT(DT,"1D")
  1.  D CHK^DIE(9000011,.08,"",AMHDTE,.%) I %="^" S AMHERR=7 Q
  1. STATUS ;
  1.  I $G(AMHSTAT)="" S AMHSTAT="A" G DOO
  1.  D CHK^DIE(9000011,.12,"",AMHSTAT,.%) I %="^" S AMHERR=9 Q
  1. DOO ;
  1.  S:$G(AMHDOO)="" AMHDOO="" G CLASS
  1.  D CHK^DIE(9000011,.13,"",AMHDOO,.%) I %="^" S AMHERR=10 Q
  1. CLASS ;
  1.  S AMHCLAS=$G(AMHCLAS)
  1.  S AMHEC1=$G(AMHEC1)
  1.  I AMHEC1]"" D CHK^DIE(9000011,.16,"",AMHEC1,.%) I %="^" S AMHERR=11 Q
  1.  S AMHEC2=$G(AMHEC2)
  1.  I AMHEC2]"" D CHK^DIE(9000011,.17,"",AMHEC2,.%) I %="^" S AMHERR=12 Q
  1.  S AMHEC3=$G(AMHEC3)
  1.  I AMHEC3]"" D CHK^DIE(9000011,.18,"",AMHEC3,.%) I %="^" S AMHERR=13 Q
  1. NMBR ;calculate new number
  1.  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
  1.  S AMHNMBR=X
  1. FILE ;
  1.  S AMHOVRR=1,AMHALVR=""
  1.  S X=AMHDX,DIC(0)="L",DIC="^AUPNPROB(",DLAYGO=9000011,DIADD=1
  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
  1.  S DIC("DR")=DIC("DR")_";.16///"_AMHEC1_";.17///"_AMHEC2_";.18///"_AMHEC3
  1.  K DD,DO D FILE^DICN K DD,DO,DR,DLAYGO,DIADD,DIC
  1.  I Y=-1 S AMHERR=4 Q
  1.  S AMHPLI=+Y
  1.  Q
  1. CHKNARR(D) ;
  1.  NEW %,F
  1.  S F=0
  1.  I $E(D)="`" S D=$P(D,"`",2) D  Q F
  1.  .I '$D(^AUTNPOV(D)) S F=1
  1.  .;S AMHN=D
  1.  .Q
  1.  S X=D X $P(^DD(9999999.27,.01,0),U,5,99)
  1.  I '$D(X) S F=1
  1.  Q F
  1. 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
  1.  ;sets .12 field to D, sets 2.01 to DUZ, set 2.02 to $$NOW
  1.  ;if passed sets 2.03 to REASON
  1.  ;if passed, sets 2.04 to OTHER
  1.  NEW DA,DIE,DR
  1.  I '$G(P) Q -1
  1.  I '$D(^AUPNPROB(P)) Q -1
  1.  S REASON=$G(REASON)
  1.  S OTHER=$G(OTHER)
  1.  S DA=P  ;,DIK="^AUPNPROB(" D ^DIK
  1.  S DIE="^AUPNPROB("
  1.  S DR=".12////D;2.01////"_DUZ_";2.02///^S X=$$NOW^XLFDT;2.03///"_REASON_";2.04///"_OTHER
  1.  D ^DIE K DA,DR,DIE
  1.  I $D(Y) Q "-1^INVALID DATA"
  1.  Q ""
  1. PCC ;EP
  1.  D FULL^VALM1
  1.  ;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
  1.  W !!,"You are now leaving the Behavioral Health Problem List and will be taken"
  1.  W !,"into the PCC Problem List for viewing.",!!
  1.  S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="Y" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D EXIT^AMHBPL1 Q
  1.  I 'Y D EXIT^AMHBPL1 Q
  1.  ;
  1.  S DFN=AMHPAT
  1.  D EN^AMHPL
  1.  D EXIT^AMHBPL1
  1.  Q