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

AMHEHR1.m

Go to the documentation of this file. 
  1. AMHEHR1 ; IHS/CMI/LAB - ADD NEW MHSS ACTIVITY RECORDS 13 Aug 2007 4:21 PM ; 14 Nov 2013  2:57 PM
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;**4,6,8**;JUN 02, 2010;Build 7
  1.  ;
  1. EEPC ;EP - called from option
  1.  W !!,"This option is used to loop through all MHSS PROBLEM/DX table "
  1.  W !,"entries created by EHR users to change the grouping from the "
  1.  W !,"generic 99.9 OTHER EHR CLINICAL grouping to a more specific"
  1.  W !,"MHSS PROBLEM CODE grouping.",!!
  1.  S AMHEPC=$O(^AMHPROBC("B","99.9",0))
  1.  S AMHQ=0
  1.  I 'AMHEPC W !!,"Problem code 99.9 is not in the file.",! D EXIT Q
  1.  I '$O(^AMHPROB("AC",AMHEPC,0)) W !!,"There are no newly created entries in the MHSS Problem/DX table.",!,"No action is needed at this time.",!! D PAUSE^AMHLEA,EXIT Q
  1.  S AMHX=0 F  S AMHX=$O(^AMHPROB("AC",AMHEPC,AMHX)) Q:AMHX'=+AMHX!(AMHQ)  D
  1.  .W !!,"CODE: ",$$VAL^XBDIQ1(9002012.2,AMHX,.01)
  1.  .W !,"ICD Narrative: ",$$VAL^XBDIQ1(9002012.2,AMHX,.02)
  1.  .S AMHPCG="" K DIC S DIC="^AMHPROBC(",DIC(0)="AEMQ",DIC("S")="I '$P(^(0),U,4)",DIC("A")="Enter the Problem Code Grouping: "
  1.  .D ^DIC
  1.  .I X="^" S AMHQ=1 Q
  1.  .I Y=-1 W !,"nothing changed for CODE: ",$$VAL^XBDIQ1(9002012.2,AMHX,.01) K DIC,Y Q
  1.  .S AMHPCG=+Y
  1.  .K DIR,DIC
  1.  .W !,"Are you sure you want to change the MHSS Problem Code Grouping to"
  1.  .S DIR("A")="     "_$$VAL^XBDIQ1(9002012.4,AMHPCG,.01)_"  -  "_$$VAL^XBDIQ1(9002012.4,AMHPCG,.02)
  1.  .S DIR(0)="Y",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  .I 'Y W !,"nothing changed for CODE: ",$$VAL^XBDIQ1(9002012.2,AMHX,.01) K DIC,Y Q
  1.  .S DA=AMHX,DIE="^AMHPROB(",DR=".03////"_AMHPCG D ^DIE K DA,DIE,DR,DIU,DIV,DIW
  1.  .Q
  1.  Q
  1.  ;
  1. EXIT ;
  1.  D EN^XBVK("AMH")
  1.  Q
  1.  ;
  1. EHRALERT ;EP - called from option/scheduled
  1.  ;find all visits entered that day or day before and send alert if there is no activity time
  1.  ;go through all BH/EHR visits added/edited in the past 2 days and send bulletin if one
  1.  ;has never been sent before
  1.  NEW AMHD,AMHR,AMHP,%
  1.  S AMHD=$$FMADD^XLFDT(DT,-3)_".9999"
  1.  F  S AMHD=$O(^AMHREC("ALM",AMHD)) Q:AMHD'=+AMHD  D
  1.  .S AMHR=0 F  S AMHR=$O(^AMHREC("ALM",AMHD,AMHR)) Q:AMHR'=+AMHR  D
  1.  ..Q:$P($G(^AMHREC(AMHR,11)),U,10)'=1  ;NOT CREATED BY EHR
  1.  ..Q:$P(^AMHREC(AMHR,0),U,12)  ;HAS ANY ACTIVITY TIME
  1.  ..S AMHP=$$PPINT^AMHUTIL(AMHR)
  1.  ..I AMHP=""  S %=$O(^AMHREC("AD",AMHR,0)) I % S AMHP=$P($G(^AMHRPROV(%,0)),U,1)
  1.  ..Q:AMHP=""
  1.  ..;send alert to user only if one never sent
  1.  ..S (G,X)=0 F  S X=$O(^AMHREC(AMHR,97,X)) Q:X'=+X!(G)  D
  1.  ...Q:$P(^AMHREC(AMHR,97,X,0),U,2)'=AMHP
  1.  ...S G=1
  1.  ..Q:G  ;already got an alert for this visit
  1.  ..;S XQA(DUZ)=""
  1.  ..S XQA(AMHP)=""
  1.  ..S XQAOPT=""
  1.  ..S XQAROU=""
  1.  ..S XQAFLG="D"
  1.  ..S AMHTEXT(1)=" "
  1.  ..S AMHTEXT(2)=" "
  1.  ..S AMHTEXT(3)="This Behavioral Health visit is missing an activity time.  The activity"
  1.  ..S AMHTEXT(4)="time can be entered through EHR or with PCC data entry using the AT"
  1.  ..S AMHTEXT(5)="mnemonic."
  1.  ..S XQATEXT="AMHTEXT"
  1.  ..S XQAMSG="HRN: "_$$HRN^AUPNPAT($P(^AMHREC(AMHR,0),U,8),DUZ(2))_"  Date: "_$$VAL^XBDIQ1(9002011,AMHR,.01)_" is missing an activity time."
  1.  ..S XQAID="OR,"_$P(^AMHREC(AMHR,0),U,8)_",46"
  1.  ..D SETUP^XQALERT
  1.  ..S (G,X)=0 F  S X=$O(^AMHREC(AMHR,97,X)) Q:X'=+X  S G=X
  1.  ..S G=G+1
  1.  ..S ^AMHREC(AMHR,97,G,0)=DT_"^"_AMHP,^AMHREC(AMHR,97,"B",DT,G)=""
  1.  ..S ^AMHREC(AMHR,97,0)="^9002011.97DA^"_G_"^"_G
  1.  Q
  1. TIUDSP ;EP
  1.  S AMHSTR="" D S(AMHSTR)
  1.  I '+$$CANDO^TIULP(AMHDOC,"PRINT RECORD",DUZ) Q  ;S AMHSTR="You do not have security clearance to display the TIU NOTE." D S(AMHSTR) Q
  1.  ; Extract specified note
  1.  S AMHGBL=$NA(^TMP("AMHOENPS",$J)),AMHHLF=IOM\2
  1.  K @AMHGBL
  1.  D EXTRACT^TIULQ(AMHDOC,AMHGBL,.AMHERR,".01;.02;.03;.05;.07;.08;1202;1203;1205;1208;1209;1301;1307;1402;1501:1505;1507:1513;1701","",1,"E")
  1.  M AMHTIU=^TMP("AMHOENPS",$J,AMHDOC)
  1.  K ^TMP("AMHOENPS",$J)
  1.  S AMHSTR="TIU DOCUMENT:  "_AMHTIU(.01,"E") D S(AMHSTR)
  1.  S AMHSTR="AUTHOR: "_AMHTIU(1202,"E") D S(AMHSTR)
  1.  S AMHSTR="SIGNED BY: "_AMHTIU(1502,"E")_"               STATUS: "_AMHTIU(.05,"E") D S(AMHSTR)
  1.  S AMHSTR="LOCATION: "_AMHTIU(1205,"E") D S(AMHSTR)
  1.  F AMHX=0:0 S AMHX=$O(AMHTIU("TEXT",AMHX)) Q:'AMHX  S AMHSTR=AMHTIU("TEXT",AMHX,0) D S(AMHSTR)
  1.  I $L($G(AMHTIU(1501,"E"))) D
  1.  .S AMHSTR="/es/ "_$G(AMHTIU(1503,"E")) D S(AMHSTR)
  1.  .S AMHSTR="Signed: "_$G(AMHTIU(1501,"E")) D S(AMHSTR)
  1.  ;NOW GET ADDENDA USING "DAD" XREF
  1.  I $O(^TIU(8925,"DAD",AMHDOC,0)) S AMHSTR="" D S(AMHSTR)   ;S AMHSTR="This document has addenda." D S(AMHSTR)
  1.  S AMHX1=0 F  S AMHX1=$O(^TIU(8925,"DAD",AMHDOC,AMHX1)) Q:AMHX1'=+AMHX1  D
  1.  .I '+$$CANDO^TIULP(AMHX1,"PRINT RECORD",DUZ) Q  ;S AMHSTR="You do not have security clearance to display the addendum." D S(AMHSTR) Q
  1.  .S AMHGBL=$NA(^TMP("AMHOENPS",$J))
  1.  .K @AMHGBL
  1.  .K AMHTIU
  1.  .D EXTRACT^TIULQ(AMHX1,AMHGBL,.AMHERR,".01;.02;.03;.05;.07;.08;1202;1203;1205;1208;1209;1301;1307;1402;1501:1505;1507:1513;1701","",1,"E")
  1.  .M AMHTIU=^TMP("AMHOENPS",$J,AMHX1)
  1.  .K ^TMP("AMHOENPS",$J)
  1.  .S AMHSTR="" D S(AMHSTR)
  1.  .S AMHSTR=AMHTIU(.01,"E") D S(AMHSTR)
  1.  .S AMHSTR="AUTHOR: "_AMHTIU(1202,"E") D S(AMHSTR)
  1.  .S AMHSTR="SIGNED BY: "_AMHTIU(1502,"E")_"               STATUS: "_AMHTIU(.05,"E") D S(AMHSTR)
  1.  .S AMHSTR="LOCATION: "_AMHTIU(1205,"E") D S(AMHSTR)
  1.  .F AMHX=0:0 S AMHX=$O(AMHTIU("TEXT",AMHX)) Q:'AMHX  S AMHSTR=AMHTIU("TEXT",AMHX,0) D S(AMHSTR)
  1.  .I $L($G(AMHTIU(1501,"E"))) D
  1.  ..S AMHSTR="/es/ "_$G(AMHTIU(1503,"E")) D S(AMHSTR)
  1.  ..S AMHSTR="Signed: "_$G(AMHTIU(1501,"E")) D S(AMHSTR)
  1.  ;
  1.  Q
  1.  ;
  1. S(Y,F,C,T) ;EP - set up array
  1.  I '$G(F) S F=0
  1.  I '$G(T) S T=0
  1.  ;blank lines
  1.  F F=1:1:F S X="" D S1
  1.  S X=Y
  1.  I $G(C) S L=$L(Y),T=(80-L)/2 D  D S1 Q
  1.  .F %=1:1:(T-1) S X=" "_X
  1.  F %=1:1:T S X=" "_Y
  1.  D S1
  1.  Q
  1. S1 ;
  1.  S AMHC=AMHC+1
  1.  S AMHTIUD(AMHC,0)=X
  1.  Q
  1. GETDSM ;EP
  1.  NEW X,Y,C,G,D
  1.  S D=$P($P(^AMHREC(AMHR,0),U),".")
  1.  ;SET UP ARRAY OF ALL ACTIVE WITH CODING SYSTEM
  1.  S X=0,C=0 F  S X=$O(^AMHPROB("B",AMHCODE,X)) Q:X'=+X  D
  1.  .I $P(^AMHPROB(X,0),U,14)]"",$P(^AMHPROB(X,0),U,14)'>D Q  ;DON'T PICK INACTIVE ONES
  1.  .I $P(^AMHPROB(X,0),U,10)=4!($P(^AMHPROB(X,0),U,10)=5) Q:$P(^AMHPROB(X,0),U,10)'=AMH45  ;ONLY 4 OR 5
  1.  .S C=C+1
  1.  .S Y(X)=""
  1.  .Q
  1.  I C=1 S AMHDSM=$O(Y(0)) Q  ;FOUND ONLY 1 SO USE IT
  1.  I C=0 Q  ;NONE FOUND SO GO ADD ONE
  1.  ;FIND ONE THAT IS EHR DEFAULT, IF NONE, TAKE 1ST ONE
  1.  S X=0,G="" F  S X=$O(Y(X)) Q:X'=+X!(G)  D
  1.  .I $P(^AMHPROB(X,0),U,15) S G=X Q
  1.  I G S AMHDSM=G Q  ;FOUND AN EHR DEFAULT
  1.  S AMHDSM=$O(Y(0))
  1.  Q
  1. SETARRAY ;EP
  1.  NEW AMHERR
  1.  S AMHIENS=AMHR_","
  1.  S AMHFDA(9002011,AMHIENS,.02)=AMH02
  1.  S AMHFDA(9002011,AMHIENS,.04)=AMH04
  1.  S AMHFDA(9002011,AMHIENS,.05)=AMH05
  1.  S AMHFDA(9002011,AMHIENS,.06)=AMH06
  1.  S AMHFDA(9002011,AMHIENS,.07)=AMH07
  1.  S AMHFDA(9002011,AMHIENS,.09)=AMH09
  1.  S AMHFDA(9002011,AMHIENS,.11)=AMH11
  1.  S AMHFDA(9002011,AMHIENS,.12)=AMH12
  1.  S AMHFDA(9002011,AMHIENS,.25)=AMH25
  1.  S AMHFDA(9002011,AMHIENS,.26)=AMH26
  1.  S AMHFDA(9002011,AMHIENS,1108)=AMH1108
  1.  S AMHFDA(9002011,AMHIENS,1117)=AMH1117
  1.  S AMHFDA(9002011,AMHIENS,1401)=AMH1401
  1.  S AMHFDA(9002011,AMHIENS,1402)=AMH1402
  1.  S AMHFDA(9002011,AMHIENS,1403)=AMH1403
  1.  S AMHFDA(9002011,AMHIENS,1404)=AMH1404
  1.  S AMHFDA(9002011,AMHIENS,1405)=AMH1405
  1.  S AMHFDA(9002011,AMHIENS,1406)=AMH1406
  1.  S AMHFDA(9002011,AMHIENS,1501)=AMH1501
  1.  S AMHFDA(9002011,AMHIENS,1601)=AMH1601
  1.  S AMHFDA(9002011,AMHIENS,1701)=AMH1701
  1.  S AMHFDA(9002011,AMHIENS,1407)=AMH1407
  1.  S AMHFDA(9002011,AMHIENS,1408)=AMH1408
  1.  S AMHFDA(9002011,AMHIENS,1901)=AMH1901
  1.  S AMHFDA(9002011,AMHIENS,.34)=$P($G(^AUPNVSIT(AMHVSIT,11)),U,15)
  1.  Q
  1. SCRREF ;EP - ANY REFUSALS FOR SCREENINGS FOR THIS PATIENT/DATE?
  1.  ;if any screenings have REF/UAS then wipe it out
  1.  ;IPV/DV
  1.  I $P($G(^AMHREC(AMHR,14)),U,1)="REF"!($P($G(^AMHREC(AMHR,14)),U,1)="UAS") D
  1.  .S DA=AMHR,DR="1401///@;1402///@;1501///@",DIE="^AMHREC(" D ^DIE K DA,DIE,DR
  1.  I $P($G(^AMHREC(AMHR,14)),U,3)="REF"!($P($G(^AMHREC(AMHR,14)),U,3)="UAS") D
  1.  .S DA=AMHR,DR="1403///@;1404///@;1601///@",DIE="^AMHREC(" D ^DIE K DA,DIE,DR
  1.  I $P($G(^AMHREC(AMHR,14)),U,5)="REF"!($P($G(^AMHREC(AMHR,14)),U,5)="UAS") D
  1.  .S DA=AMHR,DR="1405///@;1406///@;1701///@",DIE="^AMHREC(" D ^DIE K DA,DIE,DR
  1.  I $P($G(^AMHREC(AMHR,14)),U,7)="REF"!($P($G(^AMHREC(AMHR,14)),U,7)="UAS") D
  1.  .S DA=AMHR,DR="1407///@;1408///@;1901///@",DIE="^AMHREC(" D ^DIE K DA,DIE,DR
  1.  ;
  1.  NEW AMHX,AMHY,AMHZ,AMHD
  1.  S AMHD=$P($P(^AMHREC(AMHR,0),U,1),".")
  1.  ;IPV
  1.  ;IF HAS A GOOD VALUE THEN SKIP THIS
  1.  S R=$$VALI^XBDIQ1(9002011,AMHR,1401) I R]"",R'="REF",R'="UAS" G RALC
  1.  S AMHZ=$O(^AUTTEXAM("C",34,0))
  1.  S AMHX=0 F  S AMHX=$O(^AUPNPREF("AA",AMHPAT,9999999.15,AMHZ,AMHX)) Q:AMHX'=+AMHX  D
  1.  .Q:(9999999-AMHX)'=AMHD  ;not correct date
  1.  .S AMHY=0 F  S AMHY=$O(^AUPNPREF("AA",AMHPAT,9999999.15,AMHZ,AMHX,AMHY)) Q:AMHY'=+AMHY  D
  1.  ..;file UAS or REF
  1.  ..S R=$$VALI^XBDIQ1(9000022,AMHY,.07)
  1.  ..I R'="R",R'="U" Q  ;only u and r
  1.  ..S DIE="^AMHREC(",DA=AMHR,DR="1401///"_$S(R="R":"REF",R="U":"UAS",1:"")_";1402////"_$$VALI^XBDIQ1(9000022,AMHY,1204)_";1501///"_$TR($$VAL^XBDIQ1(9000022,AMHY,1101),";",":") D ^DIE K DA,DR,DIE
  1. RALC ;ALCOHOL
  1.  S R=$$VALI^XBDIQ1(9002011,AMHR,1403) I R]"",R'="REF",R'="UAS" G RDEP
  1.  S AMHZ=$O(^AUTTEXAM("C",35,0))
  1.  S AMHX=0 F  S AMHX=$O(^AUPNPREF("AA",AMHPAT,9999999.15,AMHZ,AMHX)) Q:AMHX'=+AMHX  D
  1.  .Q:(9999999-AMHX)'=AMHD  ;not correct date
  1.  .S AMHY=0 F  S AMHY=$O(^AUPNPREF("AA",AMHPAT,9999999.15,AMHZ,AMHX,AMHY)) Q:AMHY'=+AMHY  D
  1.  ..;file UAS or REF
  1.  ..S R=$$VALI^XBDIQ1(9000022,AMHY,.07)
  1.  ..I R'="R",R'="U" Q  ;only u and r
  1.  ..S DIE="^AMHREC(",DA=AMHR,DR="1403///"_$S(R="R":"REF",R="U":"UAS",1:"")_";1404////"_$$VALI^XBDIQ1(9000022,AMHY,1204)_";1601///"_$TR($$VAL^XBDIQ1(9000022,AMHY,1101),";",":") D ^DIE K DA,DR,DIE
  1. RDEP ;DEPRESSION
  1.  S R=$$VALI^XBDIQ1(9002011,AMHR,1403) I R]"",R'="REF",R'="UAS" G RSUI
  1.  S AMHZ=$O(^AUTTEXAM("C",36,0))
  1.  S AMHX=0 F  S AMHX=$O(^AUPNPREF("AA",AMHPAT,9999999.15,AMHZ,AMHX)) Q:AMHX'=+AMHX  D
  1.  .Q:(9999999-AMHX)'=AMHD  ;not correct date
  1.  .S AMHY=0 F  S AMHY=$O(^AUPNPREF("AA",AMHPAT,9999999.15,AMHZ,AMHX,AMHY)) Q:AMHY'=+AMHY  D
  1.  ..;file UAS or REF
  1.  ..S R=$$VALI^XBDIQ1(9000022,AMHY,.07)
  1.  ..I R'="R",R'="U" Q  ;only u and r
  1.  ..S DIE="^AMHREC(",DA=AMHR,DR="1405///"_$S(R="R":"REF",R="U":"UAS",1:"")_";1406////"_$$VALI^XBDIQ1(9000022,AMHY,1204)_";1701///"_$TR($$VAL^XBDIQ1(9000022,AMHY,1101),";",":") D ^DIE K DA,DR,DIE
  1. RSUI ;SUICIDE RISK
  1.  S AMHZ=$O(^AUTTEXAM("C",43,0))
  1.  S AMHX=0 F  S AMHX=$O(^AUPNPREF("AA",AMHPAT,9999999.15,AMHZ,AMHX)) Q:AMHX'=+AMHX  D
  1.  .Q:(9999999-AMHX)'=AMHD  ;not correct date
  1.  .S AMHY=0 F  S AMHY=$O(^AUPNPREF("AA",AMHPAT,9999999.15,AMHZ,AMHX,AMHY)) Q:AMHY'=+AMHY  D
  1.  ..;file UAS or REF
  1.  ..S R=$$VALI^XBDIQ1(9000022,AMHY,.07)
  1.  ..I R'="R",R'="U" Q  ;only u and r
  1.  ..S DIE="^AMHREC(",DA=AMHR,DR="1407///"_$S(R="R":"REF",R="U":"UAS",1:"")_";1408////"_$$VALI^XBDIQ1(9000022,AMHY,1204)_";1901///"_$TR($$VAL^XBDIQ1(9000022,AMHY,1101),";",":") D ^DIE K DA,DR,DIE
  1.  Q