AMHLEFP2 ; IHS/CMI/LAB - MENTAL HLTH ROUTINE 22 Aug 2007 6:11 PM ;
;;4.0;IHS BEHAVIORAL HEALTH;**1,4,5,6**;JUN 02, 2010;Build 10
DGSECE ;
NEW X S X=$P(^AMHREC(AMHR,0),U,8)
I X,$G(AMHDOLOG) D ;this should only be done if in GUI group, R&S group form print and Print forms for a set of patients
.NEW AMHRESU
.D PTSEC^AMHUTIL2(.AMHRESU,X,0)
.I '$G(AMHRESU(1)) Q
.K AMHRESU
.D NOTICE^DGSEC4(.AMHRESU,X,,3)
S AMHIOSL=$S($G(AMHGUI):55,1:IOSL)
I AMHEFT="B" S AMHEFT="S" D PRINT1(AMHR) Q:AMHQUIT S AMHEFT="F" W:$D(IOF) @IOF W:$G(AMHGUI) "ZZZZZZZ",! D PRINT1(AMHR) K AMHEFT Q
I AMHEFT="T" S AMHEFT="S" D PRINT1(AMHR) Q:AMHQUIT S AMHEFT="S" W:$D(IOF) @IOF W:$G(AMHGUI) "ZZZZZZZ",! D PRINT1(AMHR) K AMHEFT Q
I AMHEFT="E" S AMHEFT="F" D PRINT1(AMHR) Q:AMHQUIT S AMHEFT="F" W:$D(IOF) @IOF W:$G(AMHGUI) "ZZZZZZZ",! D PRINT1(AMHR) K AMHEFT Q
I AMHEFT="F" D PRINT1(AMHR) Q
I AMHEFT="S" D PRINT1(AMHR) Q
I AMHEFT="W" S AMHEFT="F",AMHNOINT=1 D PRINT1(AMHR) K AMHEFT Q
Q
S(Y,F,C,T) ;set up array
NEW %
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=$TR(Y,$C(10),"")
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 %=$P(^TMP("AMHS",$J,"DCS",0),U)+1,$P(^TMP("AMHS",$J,"DCS",0),U)=%
S ^TMP("AMHS",$J,"DCS",%)=X
Q
PRINT1(AMHR) ;EP - CALLED FROM LAST VISIT DISPLAY
NEW C,AMHX,H,AMHR0,AMHSTOP,AMHTC,AMHTDLT,AMHTDOO,AMHTF,AMHTICL,AMHTILN,AMHTNRQ,AMHTQ,AMHTTXT,F,AMHPAGE
S AMHPAGE=1
S AMHIOSL=$S($G(AMHGUI):55,1:IOSL)
D EP2(AMHR)
S AMHSTOP=0,AMHQUIT=0
W ;
NEW AMHX
W !!
S AMHX=0 F S AMHX=$O(^TMP("AMHS",$J,"DCS",AMHX)) Q:AMHX'=+AMHX!(AMHSTOP)!(AMHQUIT) D
.I ^TMP("AMHS",$J,"DCS",AMHX)="BEGIN PATIENT DEMOGRAPHIC DATA" D DEMOPRT S AMHSTOP=1 Q
.I $Y>(AMHIOSL-5) D FF Q:AMHQUIT
.W !,^TMP("AMHS",$J,"DCS",AMHX)
.Q
W !
K ^TMP("AMHS",$J,"DCS")
Q
DEMOPRT ;
I $Y>(AMHIOSL-13) D FF Q:AMHQUIT
F S AMHX=$O(^TMP("AMHS",$J,"DCS",AMHX)) Q:AMHX'=+AMHX!(AMHSTOP)!(AMHQUIT) D
.W !,^TMP("AMHS",$J,"DCS",AMHX)
.Q
Q
EP2(AMHR,FLAG) ;EP ; up array in ^TMP
;
I $G(AMHR)="" Q
I '$D(^AMHREC(AMHR)) Q
K ^TMP("AMHS",$J,"DCS")
S ^TMP("AMHS",$J,"DCS",0)=0
S AMHR0=^AMHREC(AMHR,0)
S X="********** CONFIDENTIAL PATIENT INFORMATION **********" D S(X,0,1)
S X="PCC BEHAVIORAL HEALTH ENCOUNTER RECORD Printed: "_$$FMTE^XLFDT($$NOW^XLFDT) D S(X,0,1)
S X="*** Computer Generated "_$S($P(AMHR0,U,34)=1:"Group ",1:"")_"Encounter Record ***" D S(X,0,1)
I $D(AMHGRPN),AMHEFT'="S" S X="Group Name: "_AMHGRPN D S(X,0,1)
E I $P($G(^AMHREC(AMHR,11)),U,9)]"",AMHEFT'="S" S X="Group Name: "_$$VAL^XBDIQ1(9002011,AMHR,1109) D S(X,0,1)
S X=$TR($J("",79)," ","*") D S(X)
S X="",$E(X,3)="Date: "_$$FMTE^XLFDT($P($P(AMHR0,U),".")),$E(X,31)="Primary Provider: "_$$PPNAME^AMHUTIL(AMHR) D S(X)
S X="",AMHX=0 F S AMHX=$O(^AMHRPROV("AD",AMHR,AMHX)) Q:AMHX'=+AMHX I $P(^AMHRPROV(AMHX,0),U,4)'="P" S X="",$E(X,49)=$P(^VA(200,$P(^AMHRPROV(AMHX,0),U),0),U) D S(X)
TIME S X="",Y=$P(AMHR0,U) D DD^%DT S $E(X,3)="Arrival Time: "_$P(Y,"@",2) S:$P(AMHR0,U,27)]"" $E(X,31)="Flag: "_$P(AMHR0,U,27) D S(X)
S X="",$E(X,3)="Program: "_$$EXTSET^XBFUNC(9002011,.02,$P(AMHR0,U,2)) D S(X)
S X="",$E(X,3)="Clinic: "_$$VAL^XBDIQ1(9002011,AMHR,.25),$E(X,41)="Appointment Type: "_$$VAL^XBDIQ1(9002011,AMHR,.11) D S(X)
S X=$TR($J("",79)," ","_") D S(X)
COMM ;
S X="",$E(X,49)="Number",$E(X,63)="Activity/Service" D S(X)
S X="",$E(X,3)="Community: "_$E($$VAL^XBDIQ1(9002011,AMHR,.05),1,30)
S $E(X,49)="Served: "_$P(AMHR0,U,9),$E(X,63)="Time: "_$P(AMHR0,U,12)_" minutes" D S(X)
I $P($G(^AMHREC(AMHR,11)),U,4)]"" S X="",$E(X,3)="Time spent in group session: "_$P(^AMHREC(AMHR,11),U,4) D S(X)
S X="",$E(X,3)="Activity: "_$S($P(AMHR0,U,6):$P(^AMHTACT($P(AMHR0,U,6),0),U)_"-"_$P(^AMHTACT($P(AMHR0,U,6),0),U,2),1:"???") D S(X)
S X="",$E(X,3)="Type of Contact: "_$$VAL^XBDIQ1(9002011,AMHR,.07) D S(X)
S X="" I $P(^AMHREC(AMHR,0),U,31)]"" S $E(X,3)="Local Service Site: "_$$VAL^XBDIQ1(9002011,AMHR,.31) D S(X)
S X=$TR($J("",79)," ","_") D S(X)
I AMHEFT="F" S AMHTNRQ="CHIEF COMPLAINT/PRESENTING PROBLEM: "_$G(^AMHREC(AMHR,21)),AMHTTXT="",AMHTICL=3 D PRTTXT
I AMHEFT="S" S X="",$E(X,3)="Chief Complaint/Presenting Problem Suppressed for Confidentiality" D S(X)
TIUN ;
I '$O(^AMHREC(AMHR,54,0)) G SUB
I AMHEFT="S" D S(" ") S X=" TIU Notes Suppressed for Confidentiality" D S(X) G SUB
K AMHAR,AMHERR,AMHTIU
S X="" D S(X) D S(" TIU DOCUMENTS") D S(" -------------")
S AMHDOC=0 F S AMHDOC=$O(^AMHREC(AMHR,54,"B",AMHDOC)) Q:AMHDOC'=+AMHDOC D
.K AMHTIU,AMHERR
.K ^TMP("AMHOENPS",$J)
.D TIUDSP
.K ^TMP("AMHEONPS",$J)
.K AMHTIU
.Q
SUB ;
G SUB1
I $P(^AMHREC(AMHR,0),U,33)="S"!($P(^AMHREC(AMHR,0),U,33)="U") D SAN^AMHLEFP3
I $P(^AMHREC(AMHR,0),U,33)="I"!($P(^AMHREC(AMHR,0),U,33)="P") D
.Q:$G(AMHNOINT)
.I AMHEFT="S" S X="",$E(X,3)="Behavioral Health Intake Visit" D S(X) S X="",$E(X,3)="See "_$$PPNAME^AMHUTIL(AMHR)_" for details." D S(X) Q
.S X="",$E(X,3)="********* INTAKE VISIT *********" D S(X)
.S X="",$E(X,3)="INITIAL INTAKE: "_$$VAL^XBDIQ1(9002011.07,$P(^AMHREC(AMHR,0),U,8),.07) D S(X)
.S X="",$E(X,3)=" PROVIDER: "_$$VAL^XBDIQ1(9002011.07,$P(^AMHREC(AMHR,0),U,8),.08) D S(X)
.S X="",$E(X,3)=" LAST UPDATED: "_$$VAL^XBDIQ1(9002011.07,$P(^AMHREC(AMHR,0),U,8),.02) D S(X)
.S X="",$E(X,3)=" PROVIDER: "_$$VAL^XBDIQ1(9002011.07,$P(^AMHREC(AMHR,0),U,8),.03) D S(X)
SUB1 ;
I $P($G(^AMHREC(AMHR,11)),U,10) G AIII
S X="",$E(X,3)="S/O/A/P: " D S(X,1)
I AMHEFT="F" S AMHX=0 F S AMHX=$O(^AMHREC(AMHR,31,AMHX)) Q:AMHX'=+AMHX D
.S X="",$E(X,3)=^AMHREC(AMHR,31,AMHX,0) D S(X)
.Q
I AMHEFT="S" S X="",$E(X,3)="Behavioral Health Visit" D S(X) S X="",$E(X,3)="See "_$$PPNAME^AMHUTIL(AMHR)_" for details." D S(X)
I $P($G(^AMHREC(AMHR,11)),U,12)]"" D
.S X="",$E(X,3)="PROVIDER SIGNATURE: /es/ "_$P(^AMHREC(AMHR,11),U,13) D S(X,1)
.I $P(^AMHREC(AMHR,11),U,16)]"" S X="",$E(X,30)=$$VAL^XBDIQ1(9002011,AMHR,1116) D S(X)
.S X="",$E(X,30)="Signed: "_$P($$FMTE^XLFDT($P(^AMHREC(AMHR,11),U,12)),"@",1)_" "_$P($$FMTE^XLFDT($P(^AMHREC(AMHR,11),U,12)),"@",2) D S(X)
S X=$TR($J("",79)," ","_") D S(X)
AIII ;axis iii patch 1
I AMHEFT'="S" D
.Q:'$O(^AMHREC(AMHR,53,0))
.I $$DSMCS^AMHUTIL1(DUZ(2),$P($P(AMHR0,U),"."))'=4 ;DSM IV ONLY
.S X="",$E(X,3)="AXIS III:" D S(X)
.S AMHX=0 F S AMHX=$O(^AMHREC(AMHR,53,AMHX)) Q:AMHX'=+AMHX D
..S X="",$E(X,3)=^AMHREC(AMHR,53,AMHX,0) D S(X)
D CDST^AMHLEFP4
FU ;
S %=""
I AMHEFT="S",$P($G(^AMHSITE(DUZ(2),0)),U,27)'="N" S %=0
I AMHEFT="F" S %=1
I AMHEFT="S",$P($G(^AMHSITE(DUZ(2),0)),U,27)="N" S %=1
S X="",$E(X,3)="COMMENT/NEXT APPOINTMENT: " D S(X,1)
I % S AMHX=0 F S AMHX=$O(^AMHREC(AMHR,81,AMHX)) Q:AMHX'=+AMHX D
.S X="",$E(X,3)=^AMHREC(AMHR,81,AMHX,0) D S(X)
.Q
I '% S X="",$E(X,3)="Behavioral Health Visit - COMMENT Suppressed" D S(X) S X="",$E(X,3)="See "_$$PPNAME^AMHUTIL(AMHR)_" for details." D S(X)
I $O(^AMHREC(AMHR,52,0)) D
.S X="",(C,Y)=0
.F S Y=$O(^AMHREC(AMHR,52,Y)) Q:Y'=+Y D
..S X="",C=C+1 S $E(X,3)=$S(C=1:"NOTE FORWARDED TO: ",1:""),$E(X,23)=$P(^VA(200,$P(^AMHREC(AMHR,52,Y,0),U),0),U) D S(X)
S X=$TR($J("",79)," ","_") D S(X)
POV ;
S X="",$E(X,3)="BH POV CODE PURPOSE OF VISIT (POV)" D S(X) S X="",$E(X,3)="OR DIAGNOSIS [PRIMARY ON FIRST LINE]" D S(X)
S X=$TR($J("",79)," ","_") D S(X)
S (AMHX,C)=0 F S AMHX=$O(^AMHRPRO("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.I AMHEFT="F" S AMHTNRQ="",$E(AMHTNRQ,1)=$P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U),$E(AMHTNRQ,16)=$S(AMHEFT="F":$P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U,2),1:""),AMHTICL=8,AMHTTXT="" D PRTTXT
.I AMHEFT="S" S AMHTNRQ="",$E(AMHTNRQ,1)=$P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U),$E(AMHTNRQ,16)=$$VAL^XBDIQ1(9002011.01,AMHX,.04),AMHTICL=8,AMHTTXT="" D PRTTXT
.I AMHEFT="F" S AMHTNRQ=$$GET1^DIQ(9002011.01,AMHX,.04),AMHTICL=23,AMHTTXT="" D
..I AMHEFT="F",AMHTNRQ=$P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U,2) Q
..D PRTTXT
.S C=C+2
.Q
F I=C:1:3 S X="" D S(X)
S X=$TR($J("",79)," ","_") D S(X)
TMP ;treated med problems
I $D(^AMHRTMDP("AD",AMHR)) D
.S X="",$E(X,3)="TREATED MEDICAL PROBLEMS:" D S(X)
.S (AMHX,C)=0 F S AMHX=$O(^AMHRTMDP("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
..S X="",$E(X,3)=$P(^AUTNPOV($P(^AMHRTMDP(AMHX,0),U),0),U) D S(X)
..Q
.S X=$TR($J("",79)," ","_") D S(X)
A4 ;AXIS IV/V
G:$$DSMCS^AMHUTIL1(DUZ(2),$P($P(AMHR0,U),"."))'=4 IPV
I $O(^AMHREC(AMHR,61,0))!($P(AMHR0,U,14)]"") D
.S X="",$E(X,3)="AXIS IV: " S Y=0 F S Y=$O(^AMHREC(AMHR,61,Y)) Q:Y'=+Y S I=$P(^AMHREC(AMHR,61,Y,0),U) S $E(X,14)=$P(^AMHTAXIV(I,0),U)_" - "_$P(^AMHTAXIV(I,0),U,2) D S(X) S X=""
.S X="",$E(X,3)="AXIS V: "_$P(AMHR0,U,14) S:$P($G(^AMHREC(AMHR,11)),U,15)]"" X=X_" GAF Scale Type: "_$$VAL^XBDIQ1(9002011,AMHR,1115) D S(X)
.S X=$TR($J("",79)," ","_") D S(X)
.Q
IPV ;EXAM
K AMHZZZ
I AMHEFT="S" G MEAS
I $P($G(^AMHREC(AMHR,14)),U)="",$P($G(^AMHREC(AMHR,14)),U,2)="",$P($G(^AMHREC(AMHR,15)),U)="" G ALCSCR ;no ipv exam
S X="",$E(X,3)="IPV/DV Screening: "_$$VAL^XBDIQ1(9002011,AMHR,1401)_" Provider: "_$$VAL^XBDIQ1(9002011,AMHR,1402) D S(X)
S X="",$E(X,3)="IPV/DV Screen Comment: "_$$VAL^XBDIQ1(9002011,AMHR,1501) D S(X)
S AMHZZZ=""
ALCSCR ;
I $P($G(^AMHREC(AMHR,14)),U,3)="",$P($G(^AMHREC(AMHR,14)),U,4)="",$P($G(^AMHREC(AMHR,16)),U)="" G DEPSCR ;no ALC exam
S X="",$E(X,3)="Alcohol Screening: "_$$VAL^XBDIQ1(9002011,AMHR,1403)_" Provider: "_$$VAL^XBDIQ1(9002011,AMHR,1404) D S(X,1)
S X="",$E(X,3)="Alcohol Screen Comment: "_$$VAL^XBDIQ1(9002011,AMHR,1601) D S(X)
S AMHZZZ=""
DEPSCR ;
I $P($G(^AMHREC(AMHR,14)),U,5)="",$P($G(^AMHREC(AMHR,14)),U,6)="",$P($G(^AMHREC(AMHR,17)),U)="" G SRSCR ;no SR exam
S X="",$E(X,3)="Depression Screening: "_$$VAL^XBDIQ1(9002011,AMHR,1405)_" Provider: "_$$VAL^XBDIQ1(9002011,AMHR,1406) D S(X,1)
S X="",$E(X,3)="Depression Screen Comment: "_$$VAL^XBDIQ1(9002011,AMHR,1701) D S(X)
S AMHZZZ=""
SRSCR ;
I $P($G(^AMHREC(AMHR,14)),U,7)="",$P($G(^AMHREC(AMHR,14)),U,8)="",$P($G(^AMHREC(AMHR,19)),U)="" G MEAS ;no DEP exam
S X="",$E(X,3)="Suicide Risk Assessment: "_$$VAL^XBDIQ1(9002011,AMHR,1407)_" Provider: "_$$VAL^XBDIQ1(9002011,AMHR,1408) D S(X,1)
S X="",$E(X,3)="Suicide Risk Assessment Comment: "_$$VAL^XBDIQ1(9002011,AMHR,1901) D S(X)
S AMHZZZ=""
MEAS ;
I $D(AMHZZZ) S X=$TR($J("",79)," ","_") D S(X)
I AMHEFT'="S",$D(^AMHRMSR("AD",AMHR)) D
.S X="",$E(X,3)="MEASUREMENTS:" D S(X)
.S (AMHX,C)=0 F S AMHX=$O(^AMHRMSR("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
..S X="",$E(X,3)=$P(^AUTTMSR($P(^AMHRMSR(AMHX,0),U),0),U),$E(X,9)=$E($P(^AUTTMSR($P(^AMHRMSR(AMHX,0),U),0),U,2),1,20),$E(X,33)=$$VAL^XBDIQ1(9002011.12,AMHX,.04),$E(X,65)=$E($$VAL^XBDIQ1(9002011.12,AMHX,1204),1,14) D S(X)
.S X=$TR($J("",79)," ","_") D S(X)
EDUC ;
I $D(AMHZZZ) S X=$TR($J("",79)," ","_") D S(X)
I AMHEFT'="S",$D(^AMHREDU("AD",AMHR)) D
.S X="",$E(X,3)="PATIENT EDUCATION:" D S(X)
.S (AMHX,C)=0 F S AMHX=$O(^AMHREDU("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
..S X="",$E(X,3)=$P(^AUTTEDT($P(^AMHREDU(AMHX,0),U),0),U),$E(X,45)=$$VAL^XBDIQ1(9002011.05,AMHX,.05),$E(X,60)=$P(^AMHREDU(AMHX,0),U,6)_$S($P(^AMHREDU(AMHX,0),U,6):" min",1:""),$E(X,67)=$$VAL^XBDIQ1(9002011.05,AMHX,.08) D S(X)
..I $P($G(^AMHREDU(AMHX,11)),U,2)]"" S X="",$E(X,3)="Readiness to Learn: "_$$VAL^XBDIQ1(9002011.05,AMHX,1102) D S(X)
..I $P(^AMHREDU(AMHX,0),U,9)]"" S X="",$E(X,3)="Goal: "_$$VAL^XBDIQ1(9002011.05,AMHX,.09) D S(X)
..I $P(^AMHREDU(AMHX,0),U,11)]"" S X="",$E(X,3)="Status: "_$$VAL^XBDIQ1(9002011.05,AMHX,.11) D S(X)
..I $P($G(^AMHREDU(AMHX,11)),U)]"" S X="",$E(X,3)="Comment: "_$P(^AMHREDU(AMHX,11),U) D S(X)
.S X=$TR($J("",79)," ","_") D S(X)
HF ;
I AMHEFT'="S",$D(^AMHRHF("AD",AMHR)) D
.S X="",$E(X,3)="HEALTH FACTORS RECORDED:" D S(X)
.S (AMHX,C)=0 F S AMHX=$O(^AMHRHF("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
..S X="",$E(X,3)=$P(^AUTTHF($P(^AMHRHF(AMHX,0),U),0),U) D S(X)
.S X=$TR($J("",79)," ","_") D S(X)
PA ;
I $D(^AMHRPA("AD",AMHR)) D
.S X="",$E(X,3)="PREVENTION ACTIVITIES:" D S(X)
.S (AMHX,C)=0 F S AMHX=$O(^AMHRPA("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
..S X="",$E(X,3)=$P(^AMHTPA($P(^AMHRPA(AMHX,0),U),0),U)_$S($P(^AMHRPA(AMHX,0),U,4)]"":" - "_$P(^AMHRPA(AMHX,0),U,4),1:"") D S(X)
.S X="",$E(X,3)="TARGET POPULATION FOR PREVENTION ACTIVITIES: "_$$VAL^XBDIQ1(9002011,AMHR,1106) D S(X,1)
.S X=$TR($J("",79)," ","_") D S(X)
INPT ;
I $P(AMHR0,U,17)]"" D
.S X="Placement Disposition: "_$$VAL^XBDIQ1(9002011,AMHR,.17) D S(X) S X="",$E(X,3)="Facility: "_$P(AMHR0,U,18) D S(X)
.S X=$TR($J("",79)," ","_") D S(X)
.Q
MEDS ;
S X="",$E(X,3)="MEDICATIONS PRESCRIBED:" D S(X)
S AMHX=0 F S AMHX=$O(^AMHREC(AMHR,41,AMHX)) Q:AMHX'=+AMHX D
.S X="",$E(X,3)=^AMHREC(AMHR,41,AMHX,0) D S(X)
.Q
S X=$TR($J("",79)," ","_") D S(X)
S X="" I $P(^AMHREC(AMHR,0),U,29)]"" S $E(X,3)="EVALUATION & MANAGEMENT CPT: "_$$VAL^XBDIQ1(9002011,AMHR,.29)_" " S Y=$$VALI^XBDIQ1(9002011,AMHR,.29) S:Y]"" Y=$$VAL^XBDIQ1(81,Y,2) S X=X_Y D S(X)
PROC ;
S X="",$E(X,3)="PROCEDURES (CPT):" D S(X)
S (AMHX,C)=0 F S AMHX=$O(^AMHRPROC("AD",AMHR,AMHX)) Q:AMHX'=+AMHX D
.S X="",$E(X,3)=$P($$CPT^ICPTCOD($P(^AMHRPROC(AMHX,0),U),$P($P(^AMHREC(AMHR,0),U),".")),U,2)_" "_$P($$CPT^ICPTCOD($P(^AMHRPROC(AMHX,0),U),$P($P(^AMHREC(AMHR,0),U),".")),U,3) D S(X)
.S AMH0=^AMHRPROC(AMHX,0)
.S X="",$E(X,6)="Quantity: "_$S($P(AMH0,U,16):$P(AMH0,U,16),1:1)
.I $P(AMH0,U,8)]"" S X=X_" Modifier: "_$$VAL^XBDIQ1(9002011.04,AMHX,.08)_"-"_$P($G(^DIC(81.3,$P(AMH0,U,8),0)),U,2) D S(X)
.I $P(AMH0,U,9)]"" S X="",$E(X,19)="2nd Modifier: "_$$VAL^XBDIQ1(9002011.04,AMHX,.09)_"-"_$P($G(^DIC(81.3,$P(AMH0,U,9),0)),U,2) D S(X)
.Q
S X=$TR($J("",79)," ","_") D S(X)
DEMO ;EP demographics
D DEMO^AMHLEFP1
Q
TIUDSP ;
D TIUDSP^AMHLEFP3
Q
PRTTXT ; GENERALIZED TEXT PRINTER
S AMHTDLT=1,AMHTILN=80-AMHTICL-1
F AMHTQ=0:0 S:AMHTNRQ]""&(($L(AMHTNRQ)+$L(AMHTTXT)+2)<255) AMHTTXT=$S(AMHTTXT]"":AMHTTXT_"; ",1:"")_AMHTNRQ,AMHTNRQ="" Q:AMHTTXT="" D PRTTXT2
K AMHTILN,AMHTDLT,AMHTF,AMHTC,AMHTTXT,AMHTDOO
Q
PRTTXT2 D GETFRAG S X="",$E(X,AMHTICL)=AMHTF D S(X) S AMHTICL=AMHTICL+AMHTDLT,AMHTILN=AMHTILN-AMHTDLT,AMHTDLT=0
Q
GETFRAG I $L(AMHTTXT)<AMHTILN S AMHTF=AMHTTXT,AMHTTXT="" Q
F AMHTC=AMHTILN:-1:1 Q:$E(AMHTTXT,AMHTC)=" "
S AMHTF=$E(AMHTTXT,1,AMHTC-1),AMHTTXT=$E(AMHTTXT,AMHTC+1,255)
Q
;
FF ;EP
I '$G(AMHGUI),$E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S AMHQUIT=1 Q
I $E(IOST)'="C" Q:'$P(AMHR0,U,8) W !!,$TR($J(" ",79)," ","*"),!,$E($P(^DPT($P(AMHR0,U,8),0),U),1,25),?27,"HRN: " D
.S H=$P($G(^AUPNPAT($P(AMHR0,U,8),41,DUZ(2),0)),U,2)
.W H,?38,"DOB: ",$$FMTE^XLFDT($P(^DPT($P(AMHR0,U,8),0),U,3),"2D"),?52,"SSN: ",$$SSN^AMHUTIL($P(AMHR0,U,8)),?67,$$FMTE^XLFDT($P($P(AMHR0,U),"."))
W:$D(IOF) @IOF
W:$G(AMHGUI) "ZZZZZZZ",!
W ! S AMHPAGE=AMHPAGE+1 W ?48,$$FMTE^XLFDT($P(AMHR0,U)),?72,"Page "_AMHPAGE,!
Q
AMHLEFP2 ; IHS/CMI/LAB - MENTAL HLTH ROUTINE 22 Aug 2007 6:11 PM ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1,4,5,6**;JUN 02, 2010;Build 10
DGSECE ;
+1 NEW X
SET X=$PIECE(^AMHREC(AMHR,0),U,8)
+2 ;this should only be done if in GUI group, R&S group form print and Print forms for a set of patients
IF X
IF $GET(AMHDOLOG)
Begin DoDot:1
+3 NEW AMHRESU
+4 DO PTSEC^AMHUTIL2(.AMHRESU,X,0)
+5 IF '$GET(AMHRESU(1))
QUIT
+6 KILL AMHRESU
+7 DO NOTICE^DGSEC4(.AMHRESU,X,,3)
End DoDot:1
+8 SET AMHIOSL=$SELECT($GET(AMHGUI):55,1:IOSL)
+9 IF AMHEFT="B"
SET AMHEFT="S"
DO PRINT1(AMHR)
IF AMHQUIT
QUIT
SET AMHEFT="F"
IF $DATA(IOF)
WRITE @IOF
IF $GET(AMHGUI)
WRITE "ZZZZZZZ",!
DO PRINT1(AMHR)
KILL AMHEFT
QUIT
+10 IF AMHEFT="T"
SET AMHEFT="S"
DO PRINT1(AMHR)
IF AMHQUIT
QUIT
SET AMHEFT="S"
IF $DATA(IOF)
WRITE @IOF
IF $GET(AMHGUI)
WRITE "ZZZZZZZ",!
DO PRINT1(AMHR)
KILL AMHEFT
QUIT
+11 IF AMHEFT="E"
SET AMHEFT="F"
DO PRINT1(AMHR)
IF AMHQUIT
QUIT
SET AMHEFT="F"
IF $DATA(IOF)
WRITE @IOF
IF $GET(AMHGUI)
WRITE "ZZZZZZZ",!
DO PRINT1(AMHR)
KILL AMHEFT
QUIT
+12 IF AMHEFT="F"
DO PRINT1(AMHR)
QUIT
+13 IF AMHEFT="S"
DO PRINT1(AMHR)
QUIT
+14 IF AMHEFT="W"
SET AMHEFT="F"
SET AMHNOINT=1
DO PRINT1(AMHR)
KILL AMHEFT
QUIT
+15 QUIT
S(Y,F,C,T) ;set up array
+1 NEW %
+2 IF '$GET(F)
SET F=0
+3 IF '$GET(T)
SET T=0
+4 ;blank lines
+5 FOR F=1:1:F
SET X=""
DO S1
+6 SET X=$TRANSLATE(Y,$CHAR(10),"")
+7 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+8 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+9 FOR %=1:1:T
SET X=" "_Y
+10 DO S1
+11 QUIT
S1 ;
+1 SET %=$PIECE(^TMP("AMHS",$JOB,"DCS",0),U)+1
SET $PIECE(^TMP("AMHS",$JOB,"DCS",0),U)=%
+2 SET ^TMP("AMHS",$JOB,"DCS",%)=X
+3 QUIT
PRINT1(AMHR) ;EP - CALLED FROM LAST VISIT DISPLAY
+1 NEW C,AMHX,H,AMHR0,AMHSTOP,AMHTC,AMHTDLT,AMHTDOO,AMHTF,AMHTICL,AMHTILN,AMHTNRQ,AMHTQ,AMHTTXT,F,AMHPAGE
+2 SET AMHPAGE=1
+3 SET AMHIOSL=$SELECT($GET(AMHGUI):55,1:IOSL)
+4 DO EP2(AMHR)
+5 SET AMHSTOP=0
SET AMHQUIT=0
W ;
+1 NEW AMHX
+2 WRITE !!
+3 SET AMHX=0
FOR
SET AMHX=$ORDER(^TMP("AMHS",$JOB,"DCS",AMHX))
IF AMHX'=+AMHX!(AMHSTOP)!(AMHQUIT)
QUIT
Begin DoDot:1
+4 IF ^TMP("AMHS",$JOB,"DCS",AMHX)="BEGIN PATIENT DEMOGRAPHIC DATA"
DO DEMOPRT
SET AMHSTOP=1
QUIT
+5 IF $Y>(AMHIOSL-5)
DO FF
IF AMHQUIT
QUIT
+6 WRITE !,^TMP("AMHS",$JOB,"DCS",AMHX)
+7 QUIT
End DoDot:1
+8 WRITE !
+9 KILL ^TMP("AMHS",$JOB,"DCS")
+10 QUIT
DEMOPRT ;
+1 IF $Y>(AMHIOSL-13)
DO FF
IF AMHQUIT
QUIT
+2 FOR
SET AMHX=$ORDER(^TMP("AMHS",$JOB,"DCS",AMHX))
IF AMHX'=+AMHX!(AMHSTOP)!(AMHQUIT)
QUIT
Begin DoDot:1
+3 WRITE !,^TMP("AMHS",$JOB,"DCS",AMHX)
+4 QUIT
End DoDot:1
+5 QUIT
EP2(AMHR,FLAG) ;EP ; up array in ^TMP
+1 ;
+2 IF $GET(AMHR)=""
QUIT
+3 IF '$DATA(^AMHREC(AMHR))
QUIT
+4 KILL ^TMP("AMHS",$JOB,"DCS")
+5 SET ^TMP("AMHS",$JOB,"DCS",0)=0
+6 SET AMHR0=^AMHREC(AMHR,0)
+7 SET X="********** CONFIDENTIAL PATIENT INFORMATION **********"
DO S(X,0,1)
+8 SET X="PCC BEHAVIORAL HEALTH ENCOUNTER RECORD Printed: "_$$FMTE^XLFDT($$NOW^XLFDT)
DO S(X,0,1)
+9 SET X="*** Computer Generated "_$SELECT($PIECE(AMHR0,U,34)=1:"Group ",1:"")_"Encounter Record ***"
DO S(X,0,1)
+10 IF $DATA(AMHGRPN)
IF AMHEFT'="S"
SET X="Group Name: "_AMHGRPN
DO S(X,0,1)
+11 IF '$TEST
IF $PIECE($GET(^AMHREC(AMHR,11)),U,9)]""
IF AMHEFT'="S"
SET X="Group Name: "_$$VAL^XBDIQ1(9002011,AMHR,1109)
DO S(X,0,1)
+12 SET X=$TRANSLATE($JUSTIFY("",79)," ","*")
DO S(X)
+13 SET X=""
SET $EXTRACT(X,3)="Date: "_$$FMTE^XLFDT($PIECE($PIECE(AMHR0,U),"."))
SET $EXTRACT(X,31)="Primary Provider: "_$$PPNAME^AMHUTIL(AMHR)
DO S(X)
+14 SET X=""
SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHRPROV("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
IF $PIECE(^AMHRPROV(AMHX,0),U,4)'="P"
SET X=""
SET $EXTRACT(X,49)=$PIECE(^VA(200,$PIECE(^AMHRPROV(AMHX,0),U),0),U)
DO S(X)
TIME SET X=""
SET Y=$PIECE(AMHR0,U)
DO DD^%DT
SET $EXTRACT(X,3)="Arrival Time: "_$PIECE(Y,"@",2)
IF $PIECE(AMHR0,U,27)]""
SET $EXTRACT(X,31)="Flag: "_$PIECE(AMHR0,U,27)
DO S(X)
+1 SET X=""
SET $EXTRACT(X,3)="Program: "_$$EXTSET^XBFUNC(9002011,.02,$PIECE(AMHR0,U,2))
DO S(X)
+2 SET X=""
SET $EXTRACT(X,3)="Clinic: "_$$VAL^XBDIQ1(9002011,AMHR,.25)
SET $EXTRACT(X,41)="Appointment Type: "_$$VAL^XBDIQ1(9002011,AMHR,.11)
DO S(X)
+3 SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
COMM ;
+1 SET X=""
SET $EXTRACT(X,49)="Number"
SET $EXTRACT(X,63)="Activity/Service"
DO S(X)
+2 SET X=""
SET $EXTRACT(X,3)="Community: "_$EXTRACT($$VAL^XBDIQ1(9002011,AMHR,.05),1,30)
+3 SET $EXTRACT(X,49)="Served: "_$PIECE(AMHR0,U,9)
SET $EXTRACT(X,63)="Time: "_$PIECE(AMHR0,U,12)_" minutes"
DO S(X)
+4 IF $PIECE($GET(^AMHREC(AMHR,11)),U,4)]""
SET X=""
SET $EXTRACT(X,3)="Time spent in group session: "_$PIECE(^AMHREC(AMHR,11),U,4)
DO S(X)
+5 SET X=""
SET $EXTRACT(X,3)="Activity: "_$SELECT($PIECE(AMHR0,U,6):$PIECE(^AMHTACT($PIECE(AMHR0,U,6),0),U)_"-"_$PIECE(^AMHTACT($PIECE(AMHR0,U,6),0),U,2),1:"???")
DO S(X)
+6 SET X=""
SET $EXTRACT(X,3)="Type of Contact: "_$$VAL^XBDIQ1(9002011,AMHR,.07)
DO S(X)
+7 SET X=""
IF $PIECE(^AMHREC(AMHR,0),U,31)]""
SET $EXTRACT(X,3)="Local Service Site: "_$$VAL^XBDIQ1(9002011,AMHR,.31)
DO S(X)
+8 SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
+9 IF AMHEFT="F"
SET AMHTNRQ="CHIEF COMPLAINT/PRESENTING PROBLEM: "_$GET(^AMHREC(AMHR,21))
SET AMHTTXT=""
SET AMHTICL=3
DO PRTTXT
+10 IF AMHEFT="S"
SET X=""
SET $EXTRACT(X,3)="Chief Complaint/Presenting Problem Suppressed for Confidentiality"
DO S(X)
TIUN ;
+1 IF '$ORDER(^AMHREC(AMHR,54,0))
GOTO SUB
+2 IF AMHEFT="S"
DO S(" ")
SET X=" TIU Notes Suppressed for Confidentiality"
DO S(X)
GOTO SUB
+3 KILL AMHAR,AMHERR,AMHTIU
+4 SET X=""
DO S(X)
DO S(" TIU DOCUMENTS")
DO S(" -------------")
+5 SET AMHDOC=0
FOR
SET AMHDOC=$ORDER(^AMHREC(AMHR,54,"B",AMHDOC))
IF AMHDOC'=+AMHDOC
QUIT
Begin DoDot:1
+6 KILL AMHTIU,AMHERR
+7 KILL ^TMP("AMHOENPS",$JOB)
+8 DO TIUDSP
+9 KILL ^TMP("AMHEONPS",$JOB)
+10 KILL AMHTIU
+11 QUIT
End DoDot:1
SUB ;
+1 GOTO SUB1
+2 IF $PIECE(^AMHREC(AMHR,0),U,33)="S"!($PIECE(^AMHREC(AMHR,0),U,33)="U")
DO SAN^AMHLEFP3
+3 IF $PIECE(^AMHREC(AMHR,0),U,33)="I"!($PIECE(^AMHREC(AMHR,0),U,33)="P")
Begin DoDot:1
+4 IF $GET(AMHNOINT)
QUIT
+5 IF AMHEFT="S"
SET X=""
SET $EXTRACT(X,3)="Behavioral Health Intake Visit"
DO S(X)
SET X=""
SET $EXTRACT(X,3)="See "_$$PPNAME^AMHUTIL(AMHR)_" for details."
DO S(X)
QUIT
+6 SET X=""
SET $EXTRACT(X,3)="********* INTAKE VISIT *********"
DO S(X)
+7 SET X=""
SET $EXTRACT(X,3)="INITIAL INTAKE: "_$$VAL^XBDIQ1(9002011.07,$PIECE(^AMHREC(AMHR,0),U,8),.07)
DO S(X)
+8 SET X=""
SET $EXTRACT(X,3)=" PROVIDER: "_$$VAL^XBDIQ1(9002011.07,$PIECE(^AMHREC(AMHR,0),U,8),.08)
DO S(X)
+9 SET X=""
SET $EXTRACT(X,3)=" LAST UPDATED: "_$$VAL^XBDIQ1(9002011.07,$PIECE(^AMHREC(AMHR,0),U,8),.02)
DO S(X)
+10 SET X=""
SET $EXTRACT(X,3)=" PROVIDER: "_$$VAL^XBDIQ1(9002011.07,$PIECE(^AMHREC(AMHR,0),U,8),.03)
DO S(X)
End DoDot:1
SUB1 ;
+1 IF $PIECE($GET(^AMHREC(AMHR,11)),U,10)
GOTO AIII
+2 SET X=""
SET $EXTRACT(X,3)="S/O/A/P: "
DO S(X,1)
+3 IF AMHEFT="F"
SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHREC(AMHR,31,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+4 SET X=""
SET $EXTRACT(X,3)=^AMHREC(AMHR,31,AMHX,0)
DO S(X)
+5 QUIT
End DoDot:1
+6 IF AMHEFT="S"
SET X=""
SET $EXTRACT(X,3)="Behavioral Health Visit"
DO S(X)
SET X=""
SET $EXTRACT(X,3)="See "_$$PPNAME^AMHUTIL(AMHR)_" for details."
DO S(X)
+7 IF $PIECE($GET(^AMHREC(AMHR,11)),U,12)]""
Begin DoDot:1
+8 SET X=""
SET $EXTRACT(X,3)="PROVIDER SIGNATURE: /es/ "_$PIECE(^AMHREC(AMHR,11),U,13)
DO S(X,1)
+9 IF $PIECE(^AMHREC(AMHR,11),U,16)]""
SET X=""
SET $EXTRACT(X,30)=$$VAL^XBDIQ1(9002011,AMHR,1116)
DO S(X)
+10 SET X=""
SET $EXTRACT(X,30)="Signed: "_$PIECE($$FMTE^XLFDT($PIECE(^AMHREC(AMHR,11),U,12)),"@",1)_" "_$PIECE($$FMTE^XLFDT($PIECE(^AMHREC(AMHR,11),U,12)),"@",2)
DO S(X)
End DoDot:1
+11 SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
AIII ;axis iii patch 1
+1 IF AMHEFT'="S"
Begin DoDot:1
+2 IF '$ORDER(^AMHREC(AMHR,53,0))
QUIT
+3 ;DSM IV ONLY
IF $$DSMCS^AMHUTIL1(DUZ(2),$PIECE($PIECE(AMHR0,U),"."))'=4
+4 SET X=""
SET $EXTRACT(X,3)="AXIS III:"
DO S(X)
+5 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHREC(AMHR,53,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:2
+6 SET X=""
SET $EXTRACT(X,3)=^AMHREC(AMHR,53,AMHX,0)
DO S(X)
End DoDot:2
End DoDot:1
+7 DO CDST^AMHLEFP4
FU ;
+1 SET %=""
+2 IF AMHEFT="S"
IF $PIECE($GET(^AMHSITE(DUZ(2),0)),U,27)'="N"
SET %=0
+3 IF AMHEFT="F"
SET %=1
+4 IF AMHEFT="S"
IF $PIECE($GET(^AMHSITE(DUZ(2),0)),U,27)="N"
SET %=1
+5 SET X=""
SET $EXTRACT(X,3)="COMMENT/NEXT APPOINTMENT: "
DO S(X,1)
+6 IF %
SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHREC(AMHR,81,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+7 SET X=""
SET $EXTRACT(X,3)=^AMHREC(AMHR,81,AMHX,0)
DO S(X)
+8 QUIT
End DoDot:1
+9 IF '%
SET X=""
SET $EXTRACT(X,3)="Behavioral Health Visit - COMMENT Suppressed"
DO S(X)
SET X=""
SET $EXTRACT(X,3)="See "_$$PPNAME^AMHUTIL(AMHR)_" for details."
DO S(X)
+10 IF $ORDER(^AMHREC(AMHR,52,0))
Begin DoDot:1
+11 SET X=""
SET (C,Y)=0
+12 FOR
SET Y=$ORDER(^AMHREC(AMHR,52,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+13 SET X=""
SET C=C+1
SET $EXTRACT(X,3)=$SELECT(C=1:"NOTE FORWARDED TO: ",1:"")
SET $EXTRACT(X,23)=$PIECE(^VA(200,$PIECE(^AMHREC(AMHR,52,Y,0),U),0),U)
DO S(X)
End DoDot:2
End DoDot:1
+14 SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
POV ;
+1 SET X=""
SET $EXTRACT(X,3)="BH POV CODE PURPOSE OF VISIT (POV)"
DO S(X)
SET X=""
SET $EXTRACT(X,3)="OR DIAGNOSIS [PRIMARY ON FIRST LINE]"
DO S(X)
+2 SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
+3 SET (AMHX,C)=0
FOR
SET AMHX=$ORDER(^AMHRPRO("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+4 IF AMHEFT="F"
SET AMHTNRQ=""
SET $EXTRACT(AMHTNRQ,1)=$PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)
SET $EXTRACT(AMHTNRQ,16)=$SELECT(AMHEFT="F":$PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U,2),1:"")
SET AMHTICL=8
SET AMHTTXT=""
DO PRTTXT
+5 IF AMHEFT="S"
SET AMHTNRQ=""
SET $EXTRACT(AMHTNRQ,1)=$PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U)
SET $EXTRACT(AMHTNRQ,16)=$$VAL^XBDIQ1(9002011.01,AMHX,.04)
SET AMHTICL=8
SET AMHTTXT=""
DO PRTTXT
+6 IF AMHEFT="F"
SET AMHTNRQ=$$GET1^DIQ(9002011.01,AMHX,.04)
SET AMHTICL=23
SET AMHTTXT=""
Begin DoDot:2
+7 IF AMHEFT="F"
IF AMHTNRQ=$PIECE(^AMHPROB($PIECE(^AMHRPRO(AMHX,0),U),0),U,2)
QUIT
+8 DO PRTTXT
End DoDot:2
+9 SET C=C+2
+10 QUIT
End DoDot:1
+11 FOR I=C:1:3
SET X=""
DO S(X)
+12 SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
TMP ;treated med problems
+1 IF $DATA(^AMHRTMDP("AD",AMHR))
Begin DoDot:1
+2 SET X=""
SET $EXTRACT(X,3)="TREATED MEDICAL PROBLEMS:"
DO S(X)
+3 SET (AMHX,C)=0
FOR
SET AMHX=$ORDER(^AMHRTMDP("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:2
+4 SET X=""
SET $EXTRACT(X,3)=$PIECE(^AUTNPOV($PIECE(^AMHRTMDP(AMHX,0),U),0),U)
DO S(X)
+5 QUIT
End DoDot:2
+6 SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
End DoDot:1
A4 ;AXIS IV/V
+1 IF $$DSMCS^AMHUTIL1(DUZ(2),$PIECE($PIECE(AMHR0,U),"."))'=4
GOTO IPV
+2 IF $ORDER(^AMHREC(AMHR,61,0))!($PIECE(AMHR0,U,14)]"")
Begin DoDot:1
+3 SET X=""
SET $EXTRACT(X,3)="AXIS IV: "
SET Y=0
FOR
SET Y=$ORDER(^AMHREC(AMHR,61,Y))
IF Y'=+Y
QUIT
SET I=$PIECE(^AMHREC(AMHR,61,Y,0),U)
SET $EXTRACT(X,14)=$PIECE(^AMHTAXIV(I,0),U)_" - "_$PIECE(^AMHTAXIV(I,0),U,2)
DO S(X)
SET X=""
+4 SET X=""
SET $EXTRACT(X,3)="AXIS V: "_$PIECE(AMHR0,U,14)
IF $PIECE($GET(^AMHREC(AMHR,11)),U,15)]""
SET X=X_" GAF Scale Type: "_$$VAL^XBDIQ1(9002011,AMHR,1115)
DO S(X)
+5 SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
+6 QUIT
End DoDot:1
IPV ;EXAM
+1 KILL AMHZZZ
+2 IF AMHEFT="S"
GOTO MEAS
+3 ;no ipv exam
IF $PIECE($GET(^AMHREC(AMHR,14)),U)=""
IF $PIECE($GET(^AMHREC(AMHR,14)),U,2)=""
IF $PIECE($GET(^AMHREC(AMHR,15)),U)=""
GOTO ALCSCR
+4 SET X=""
SET $EXTRACT(X,3)="IPV/DV Screening: "_$$VAL^XBDIQ1(9002011,AMHR,1401)_" Provider: "_$$VAL^XBDIQ1(9002011,AMHR,1402)
DO S(X)
+5 SET X=""
SET $EXTRACT(X,3)="IPV/DV Screen Comment: "_$$VAL^XBDIQ1(9002011,AMHR,1501)
DO S(X)
+6 SET AMHZZZ=""
ALCSCR ;
+1 ;no ALC exam
IF $PIECE($GET(^AMHREC(AMHR,14)),U,3)=""
IF $PIECE($GET(^AMHREC(AMHR,14)),U,4)=""
IF $PIECE($GET(^AMHREC(AMHR,16)),U)=""
GOTO DEPSCR
+2 SET X=""
SET $EXTRACT(X,3)="Alcohol Screening: "_$$VAL^XBDIQ1(9002011,AMHR,1403)_" Provider: "_$$VAL^XBDIQ1(9002011,AMHR,1404)
DO S(X,1)
+3 SET X=""
SET $EXTRACT(X,3)="Alcohol Screen Comment: "_$$VAL^XBDIQ1(9002011,AMHR,1601)
DO S(X)
+4 SET AMHZZZ=""
DEPSCR ;
+1 ;no SR exam
IF $PIECE($GET(^AMHREC(AMHR,14)),U,5)=""
IF $PIECE($GET(^AMHREC(AMHR,14)),U,6)=""
IF $PIECE($GET(^AMHREC(AMHR,17)),U)=""
GOTO SRSCR
+2 SET X=""
SET $EXTRACT(X,3)="Depression Screening: "_$$VAL^XBDIQ1(9002011,AMHR,1405)_" Provider: "_$$VAL^XBDIQ1(9002011,AMHR,1406)
DO S(X,1)
+3 SET X=""
SET $EXTRACT(X,3)="Depression Screen Comment: "_$$VAL^XBDIQ1(9002011,AMHR,1701)
DO S(X)
+4 SET AMHZZZ=""
SRSCR ;
+1 ;no DEP exam
IF $PIECE($GET(^AMHREC(AMHR,14)),U,7)=""
IF $PIECE($GET(^AMHREC(AMHR,14)),U,8)=""
IF $PIECE($GET(^AMHREC(AMHR,19)),U)=""
GOTO MEAS
+2 SET X=""
SET $EXTRACT(X,3)="Suicide Risk Assessment: "_$$VAL^XBDIQ1(9002011,AMHR,1407)_" Provider: "_$$VAL^XBDIQ1(9002011,AMHR,1408)
DO S(X,1)
+3 SET X=""
SET $EXTRACT(X,3)="Suicide Risk Assessment Comment: "_$$VAL^XBDIQ1(9002011,AMHR,1901)
DO S(X)
+4 SET AMHZZZ=""
MEAS ;
+1 IF $DATA(AMHZZZ)
SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
+2 IF AMHEFT'="S"
IF $DATA(^AMHRMSR("AD",AMHR))
Begin DoDot:1
+3 SET X=""
SET $EXTRACT(X,3)="MEASUREMENTS:"
DO S(X)
+4 SET (AMHX,C)=0
FOR
SET AMHX=$ORDER(^AMHRMSR("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:2
+5 SET X=""
SET $EXTRACT(X,3)=$PIECE(^AUTTMSR($PIECE(^AMHRMSR(AMHX,0),U),0),U)
SET $EXTRACT(X,9)=$EXTRACT($PIECE(^AUTTMSR($PIECE(^AMHRMSR(AMHX,0),U),0),U,2),1,20)
SET $EXTRACT(X,33)=$$VAL^XBDIQ1(9002011.12,AMHX,.04)
SET $EXTRACT(X,65)=$EXTRACT($$VAL^XBDIQ1(9002011.12,AMHX,1204),1,14)
DO S(X)
End DoDot:2
+6 SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
End DoDot:1
EDUC ;
+1 IF $DATA(AMHZZZ)
SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
+2 IF AMHEFT'="S"
IF $DATA(^AMHREDU("AD",AMHR))
Begin DoDot:1
+3 SET X=""
SET $EXTRACT(X,3)="PATIENT EDUCATION:"
DO S(X)
+4 SET (AMHX,C)=0
FOR
SET AMHX=$ORDER(^AMHREDU("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:2
+5 SET X=""
SET $EXTRACT(X,3)=$PIECE(^AUTTEDT($PIECE(^AMHREDU(AMHX,0),U),0),U)
SET $EXTRACT(X,45)=$$VAL^XBDIQ1(9002011.05,AMHX,.05)
SET $EXTRACT(X,60)=$PIECE(^AMHREDU(AMHX,0),U,6)_$SELECT($PIECE(^AMHREDU(AMHX,0),U,6):" min",1:"")
SET $EXTRACT(X,67)=$$VAL^XBDIQ1(9002011.05,AMHX,.08)
DO S(X)
+6 IF $PIECE($GET(^AMHREDU(AMHX,11)),U,2)]""
SET X=""
SET $EXTRACT(X,3)="Readiness to Learn: "_$$VAL^XBDIQ1(9002011.05,AMHX,1102)
DO S(X)
+7 IF $PIECE(^AMHREDU(AMHX,0),U,9)]""
SET X=""
SET $EXTRACT(X,3)="Goal: "_$$VAL^XBDIQ1(9002011.05,AMHX,.09)
DO S(X)
+8 IF $PIECE(^AMHREDU(AMHX,0),U,11)]""
SET X=""
SET $EXTRACT(X,3)="Status: "_$$VAL^XBDIQ1(9002011.05,AMHX,.11)
DO S(X)
+9 IF $PIECE($GET(^AMHREDU(AMHX,11)),U)]""
SET X=""
SET $EXTRACT(X,3)="Comment: "_$PIECE(^AMHREDU(AMHX,11),U)
DO S(X)
End DoDot:2
+10 SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
End DoDot:1
HF ;
+1 IF AMHEFT'="S"
IF $DATA(^AMHRHF("AD",AMHR))
Begin DoDot:1
+2 SET X=""
SET $EXTRACT(X,3)="HEALTH FACTORS RECORDED:"
DO S(X)
+3 SET (AMHX,C)=0
FOR
SET AMHX=$ORDER(^AMHRHF("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:2
+4 SET X=""
SET $EXTRACT(X,3)=$PIECE(^AUTTHF($PIECE(^AMHRHF(AMHX,0),U),0),U)
DO S(X)
End DoDot:2
+5 SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
End DoDot:1
PA ;
+1 IF $DATA(^AMHRPA("AD",AMHR))
Begin DoDot:1
+2 SET X=""
SET $EXTRACT(X,3)="PREVENTION ACTIVITIES:"
DO S(X)
+3 SET (AMHX,C)=0
FOR
SET AMHX=$ORDER(^AMHRPA("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:2
+4 SET X=""
SET $EXTRACT(X,3)=$PIECE(^AMHTPA($PIECE(^AMHRPA(AMHX,0),U),0),U)_$SELECT($PIECE(^AMHRPA(AMHX,0),U,4)]"":" - "_$PIECE(^AMHRPA(AMHX,0),U,4),1:"")
DO S(X)
End DoDot:2
+5 SET X=""
SET $EXTRACT(X,3)="TARGET POPULATION FOR PREVENTION ACTIVITIES: "_$$VAL^XBDIQ1(9002011,AMHR,1106)
DO S(X,1)
+6 SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
End DoDot:1
INPT ;
+1 IF $PIECE(AMHR0,U,17)]""
Begin DoDot:1
+2 SET X="Placement Disposition: "_$$VAL^XBDIQ1(9002011,AMHR,.17)
DO S(X)
SET X=""
SET $EXTRACT(X,3)="Facility: "_$PIECE(AMHR0,U,18)
DO S(X)
+3 SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
+4 QUIT
End DoDot:1
MEDS ;
+1 SET X=""
SET $EXTRACT(X,3)="MEDICATIONS PRESCRIBED:"
DO S(X)
+2 SET AMHX=0
FOR
SET AMHX=$ORDER(^AMHREC(AMHR,41,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+3 SET X=""
SET $EXTRACT(X,3)=^AMHREC(AMHR,41,AMHX,0)
DO S(X)
+4 QUIT
End DoDot:1
+5 SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
+6 SET X=""
IF $PIECE(^AMHREC(AMHR,0),U,29)]""
SET $EXTRACT(X,3)="EVALUATION & MANAGEMENT CPT: "_$$VAL^XBDIQ1(9002011,AMHR,.29)_" "
SET Y=$$VALI^XBDIQ1(9002011,AMHR,.29)
IF Y]""
SET Y=$$VAL^XBDIQ1(81,Y,2)
SET X=X_Y
DO S(X)
PROC ;
+1 SET X=""
SET $EXTRACT(X,3)="PROCEDURES (CPT):"
DO S(X)
+2 SET (AMHX,C)=0
FOR
SET AMHX=$ORDER(^AMHRPROC("AD",AMHR,AMHX))
IF AMHX'=+AMHX
QUIT
Begin DoDot:1
+3 SET X=""
SET $EXTRACT(X,3)=$PIECE($$CPT^ICPTCOD($PIECE(^AMHRPROC(AMHX,0),U),$PIECE($PIECE(^AMHREC(AMHR,0),U),".")),U,2)_" "_$PIECE($$CPT^ICPTCOD($PIECE(^AMHRPROC(AMHX,0),U),$PIECE($PIECE(^AMHREC(AMHR,0),U),".")),U,3)
DO S(X)
+4 SET AMH0=^AMHRPROC(AMHX,0)
+5 SET X=""
SET $EXTRACT(X,6)="Quantity: "_$SELECT($PIECE(AMH0,U,16):$PIECE(AMH0,U,16),1:1)
+6 IF $PIECE(AMH0,U,8)]""
SET X=X_" Modifier: "_$$VAL^XBDIQ1(9002011.04,AMHX,.08)_"-"_$PIECE($GET(^DIC(81.3,$PIECE(AMH0,U,8),0)),U,2)
DO S(X)
+7 IF $PIECE(AMH0,U,9)]""
SET X=""
SET $EXTRACT(X,19)="2nd Modifier: "_$$VAL^XBDIQ1(9002011.04,AMHX,.09)_"-"_$PIECE($GET(^DIC(81.3,$PIECE(AMH0,U,9),0)),U,2)
DO S(X)
+8 QUIT
End DoDot:1
+9 SET X=$TRANSLATE($JUSTIFY("",79)," ","_")
DO S(X)
DEMO ;EP demographics
+1 DO DEMO^AMHLEFP1
+2 QUIT
TIUDSP ;
+1 DO TIUDSP^AMHLEFP3
+2 QUIT
PRTTXT ; GENERALIZED TEXT PRINTER
+1 SET AMHTDLT=1
SET AMHTILN=80-AMHTICL-1
+2 FOR AMHTQ=0:0
IF AMHTNRQ]""&(($LENGTH(AMHTNRQ)+$LENGTH(AMHTTXT)+2)<255)
SET AMHTTXT=$SELECT(AMHTTXT]"":AMHTTXT_"; ",1:"")_AMHTNRQ
SET AMHTNRQ=""
IF AMHTTXT=""
QUIT
DO PRTTXT2
+3 KILL AMHTILN,AMHTDLT,AMHTF,AMHTC,AMHTTXT,AMHTDOO
+4 QUIT
PRTTXT2 DO GETFRAG
SET X=""
SET $EXTRACT(X,AMHTICL)=AMHTF
DO S(X)
SET AMHTICL=AMHTICL+AMHTDLT
SET AMHTILN=AMHTILN-AMHTDLT
SET AMHTDLT=0
+1 QUIT
GETFRAG IF $LENGTH(AMHTTXT)<AMHTILN
SET AMHTF=AMHTTXT
SET AMHTTXT=""
QUIT
+1 FOR AMHTC=AMHTILN:-1:1
IF $EXTRACT(AMHTTXT,AMHTC)=" "
QUIT
+2 SET AMHTF=$EXTRACT(AMHTTXT,1,AMHTC-1)
SET AMHTTXT=$EXTRACT(AMHTTXT,AMHTC+1,255)
+3 QUIT
+4 ;
FF ;EP
+1 IF '$GET(AMHGUI)
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET AMHQUIT=1
QUIT
+2 IF $EXTRACT(IOST)'="C"
IF '$PIECE(AMHR0,U,8)
QUIT
WRITE !!,$TRANSLATE($JUSTIFY(" ",79)," ","*"),!,$EXTRACT($PIECE(^DPT($PIECE(AMHR0,U,8),0),U),1,25),?27,"HRN: "
Begin DoDot:1
+3 SET H=$PIECE($GET(^AUPNPAT($PIECE(AMHR0,U,8),41,DUZ(2),0)),U,2)
+4 WRITE H,?38,"DOB: ",$$FMTE^XLFDT($PIECE(^DPT($PIECE(AMHR0,U,8),0),U,3),"2D"),?52,"SSN: ",$$SSN^AMHUTIL($PIECE(AMHR0,U,8)),?67,$$FMTE^XLFDT($PIECE($PIECE(AMHR0,U),"."))
End DoDot:1
+5 IF $DATA(IOF)
WRITE @IOF
+6 IF $GET(AMHGUI)
WRITE "ZZZZZZZ",!
+7 WRITE !
SET AMHPAGE=AMHPAGE+1
WRITE ?48,$$FMTE^XLFDT($PIECE(AMHR0,U)),?72,"Page "_AMHPAGE,!
+8 QUIT
