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

AMHPL1.m

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