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