- 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
