AMHHS ; IHS/CMI/LAB - BH HEALTH SUMMARY COMPONENT 03 Jun 2009 12:08 PM ;
;;4.0;IHS BEHAVIORAL HEALTH;**1,5,6,8**;JUN 02, 2010;Build 7
;
;
MH ;EP called from health summary
NEW AMHPATH
X APCHSCKP Q:$D(APCHSQIT) X:'APCHSNPG APCHSBRK
I $P($G(^AMHPATR(APCHSPAT,0)),U,9)]"" W ?23,"Patient Flag: ",?38,$P(^AMHPATR(APCHSPAT,0),U,9),!
X APCHSCKP Q:$D(APCHSQIT)
I $P($G(^AMHPATR(APCHSPAT,0)),U,11)]"" W ?21,"Flag Narrative: ",?38,$P(^AMHPATR(APCHSPAT,0),U,11),!
X APCHSCKP Q:$D(APCHSQIT)
I $P($G(^AMHPATR(APCHSPAT,0)),U,2)]"" W ?2,"Designated Mental Health Provider: ",?38,$P(^VA(200,$P(^AMHPATR(APCHSPAT,0),U,2),0),U),!
X APCHSCKP Q:$D(APCHSQIT)
I $P($G(^AMHPATR(APCHSPAT,0)),U,3)]"" W "Designated Social Services Provider: ",?38,$P(^VA(200,$P(^AMHPATR(APCHSPAT,0),U,3),0),U),!
X APCHSCKP Q:$D(APCHSQIT)
I $P($G(^AMHPATR(APCHSPAT,0)),U,4)]"" W ?10,"CD Designated Provider: ",?38,$P(^VA(200,$P(^AMHPATR(APCHSPAT,0),U,4),0),U),!
X APCHSCKP Q:$D(APCHSQIT)
I $P($G(^AMHPATR(APCHSPAT,0)),U,12)]"" W ?10,"Other Designated Provider: ",?38,$P(^VA(200,$P(^AMHPATR(APCHSPAT,0),U,12),0),U),!
X APCHSCKP Q:$D(APCHSQIT)
I $P($G(^AMHPATR(APCHSPAT,0)),U,13)]"" W ?10,"Other (2) Designated Provider: ",?38,$P(^AMHPATR(APCHSPAT,0),U,13),!
X APCHSCKP Q:$D(APCHSQIT)
;output personal history
I $D(^AMHPPHX("AC",APCHSPAT)) D
.X APCHSCKP Q:$D(APCHSQIT) W !,"** Personal History of:",!
.S AMHSX=0 F S AMHSX=$O(^AMHPPHX("AC",APCHSPAT,AMHSX)) Q:AMHSX'=+AMHSX D
..S Y=$P(^AMHPPHX(AMHSX,0),U,3) X APCHSCVD S AMHSDAT=Y
..W !?5,$P(^AMHTPHF($P(^AMHPPHX(AMHSX,0),U),0),U),?30,"(noted: ",AMHSDAT,")"
..Q
.W ! K AMHSX
.Q
CASE ;output last 3 cases
K AMHL S D=0,C=0 F S D=$O(^AMHPCASE("AA",APCHSPAT,D)) Q:D'=+D!(C>2) D
.S AMHL=0 F S AMHL=$O(^AMHPCASE("AA",APCHSPAT,D,AMHL)) Q:AMHL'=+AMHL!(C>2) D
..Q:'$$ALLOWCD^AMHLCD(DUZ,AMHL)
..S C=C+1
..S AMHL(C)=AMHL
..Q
.Q
CASEOUT ;display last 3 cases found
I $D(AMHL(1)) D
.X APCHSCKP Q:$D(APCHSQIT)
.S K="21;41;61"
.W ?4,"Case Open Date:"
.F I=1:1:3 Q:'$D(AMHL(I)) S J=$P(K,";",I) W ?J,$$FMTE^XLFDT($P(^AMHPCASE(AMHL(I),0),U),"2E")
.X APCHSCKP Q:$D(APCHSQIT)
.W !?3,"Case Admit Date:"
.F I=1:1:3 Q:'$D(AMHL(I)) I $P(^AMHPCASE(AMHL(I),0),U,4)]"" S J=$P(K,";",I) W ?J,$$FMTE^XLFDT($P(^AMHPCASE(AMHL(I),0),U,4),"2E")
.X APCHSCKP Q:$D(APCHSQIT)
.W !?3,"Case Close Date:"
.F I=1:1:3 Q:'$D(AMHL(I)) I $P(^AMHPCASE(AMHL(I),0),U,5)]"" S J=$P(K,";",I) W ?J,$$FMTE^XLFDT($P(^AMHPCASE(AMHL(I),0),U,5),"2E")
.X APCHSCKP Q:$D(APCHSQIT)
.W !?5,"Program Affil:"
.F I=1:1:3 Q:'$D(AMHL(I)) I $P(^AMHPCASE(AMHL(I),0),U,3)]"" S J=$P(K,";",I) W ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.03)
.X APCHSCKP Q:$D(APCHSQIT)
.W !?7,"Disposition:"
.F I=1:1:3 Q:'$D(AMHL(I)) I $P(^AMHPCASE(AMHL(I),0),U,6)]"" S J=$P(K,";",I) W ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.06)
.X APCHSCKP Q:$D(APCHSQIT)
.W !?2,"Next Review Date:"
.F I=1:1:3 Q:'$D(AMHL(I)) I $P(^AMHPCASE(AMHL(I),0),U,12)]"" S J=$P(K,";",I) W ?J,$$FMTE^XLFDT($P(^AMHPCASE(AMHL(I),0),U,12),"2E")
.X APCHSCKP Q:$D(APCHSQIT)
.W !?10,"Provider:"
.F I=1:1:3 Q:'$D(AMHL(I)) I $P(^AMHPCASE(AMHL(I),0),U,8)]"" S J=$P(K,";",I) W ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.08)
.X APCHSCKP Q:$D(APCHSQIT)
.W !?11,"Problem:"
.F I=1:1:3 Q:'$D(AMHL(I)) I $P(^AMHPCASE(AMHL(I),0),U,9)]"" S J=$P(K,";",I) W ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.09)
K AMHL,C,D,L,K
D PROB^AMHHS1
AXV ;trend and display last 7 AXIS V values
K AMHAX5 S AMHCNT=0
S AMHSIVD=0 F S AMHSIVD=$O(^AMHREC("AE",APCHSPAT,AMHSIVD)) Q:AMHSIVD=""!($D(APCHSQIT))!(AMHCNT>6) D
.S AMHSX=0 F S AMHSX=$O(^AMHREC("AE",APCHSPAT,AMHSIVD,AMHSX)) Q:AMHSX'=+AMHSX D
..Q:$P($G(^AMHREC(AMHSX,0)),U,14)=""
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHSX)
..S AMHCNT=AMHCNT+1,AMHAX5(AMHCNT)=(9999999-$P(AMHSIVD,"."))_U_$P(^AMHREC(AMHSX,0),U,14)
..Q
.Q
I $D(AMHAX5) D Q:$D(APCHSQIT)
.X APCHSCKP Q:$D(APCHSQIT)
.W !!?4,"********** LAST 6 AXIS V VALUES RECORDED. (GAF SCORES) **********",!!
.S AMHJ=2 F AMHCNT=6:-1:1 I $D(AMHAX5(AMHCNT)) W ?AMHJ,$$DATE($P(AMHAX5(AMHCNT),U)) S AMHJ=AMHJ+12
.W ! S AMHJ=6 F AMHCNT=6:-1:1 I $D(AMHAX5(AMHCNT)) W ?AMHJ,$P(AMHAX5(AMHCNT),U,2) S AMHJ=AMHJ+12
.W !
OUTPT ; ********** MH PROBLEM CODES AND DESIGNATED PROVIDER
; <SETUP>
X APCHSCKP Q:$D(APCHSQIT) S X="******************** BH ENCOUNTERS ******************** ",AMHS="",$P(AMHS," ",80-1-$L(X)/2)="" W !,AMHS,X,AMHS,!!
I '$D(^AMHREC("AE",APCHSPAT)) X APCHSCKP Q:$D(APCHSQIT) W !,"No Behavioral Health Records on File.",! Q
; <DISPLAY>
S AMHSPVD=0
F AMHSIVD=0:0 S AMHSIVD=$O(^AMHREC("AE",APCHSPAT,AMHSIVD)) Q:AMHSIVD=""!($P(AMHSIVD,".")>APCHSDLM) D ONEDATE Q:$D(APCHSQIT) S:(AMHSDAT'=AMHSPVD)&AMHSDTU APCHSNDM=APCHSNDM-AMHSDTU,AMHSPVD=AMHSDAT Q:APCHSNDM=0
PTED ;display all pt ed (last of each)
I '$D(^AMHREDU("AC",APCHSPAT)) G HF
X APCHSCKP Q:$D(APCHSQIT) S X="************ BEHAVIORAL HEALTH PATIENT EDUCATION ******************** ",AMHS="",$P(AMHS," ",80-1-$L(X)/2)="" W !,AMHS,X,AMHS,!
K AMHSN S AMHSX=0 F S AMHSX=$O(^AMHREDU("AC",APCHSPAT,AMHSX)) Q:AMHSX'=+AMHSX!($D(APCHSQIT)) D
.S X=$P(^AMHREDU(AMHSX,0),U),Y=$P(^AMHREDU(AMHSX,0),U,3) I Y,$D(^AMHREC(Y,0)),$$ALLOWVI^AMHUTIL(DUZ,Y) S Y=$P($P(^AMHREC(Y,0),U),".") I $P($G(AMHSN(X)),U)<Y S AMHSN(X)=Y_U_AMHSX
K AMHSD S X=0 F S X=$O(AMHSN(X)) Q:X'=+X S Y=$P(AMHSN(X),U),Y=9999999-Y,AMHSD(Y,X)=$P(AMHSN(X),U,2)
S AMHSD=0 F S AMHSD=$O(AMHSD(AMHSD)) Q:AMHSD'=+AMHSD!($D(APCHSQIT)) D
.S AMHSX=0 F S AMHSX=$O(AMHSD(AMHSD,AMHSX)) Q:AMHSX'=+AMHSX!($D(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..W !,$$FMTE^XLFDT(9999999-AMHSD),?15,$E($P(^AUTTEDT(AMHSX,0),U),1,30),?47,$$VAL^XBDIQ1(9002011.05,AMHSD(AMHSD,AMHSX),.05)
..X APCHSCKP Q:$D(APCHSQIT)
..W !?3,"Level of Understanding: ",$$VAL^XBDIQ1(9002011.05,AMHSD(AMHSD,AMHSX),.08),?47,$P(^AMHREDU(AMHSD(AMHSD,AMHSX),0),U,6),$S($P(^AMHREDU(AMHSD(AMHSD,AMHSX),0),U,6)]"":" mins",1:"")
..I $P(^AMHREDU(AMHSD(AMHSD,AMHSX),0),U,9)]"" W !?3,"Goal: ",$$VAL^XBDIQ1(9002011.05,AMHSD(AMHSD,AMHSX),.09)
..I $P(^AMHREDU(AMHSD(AMHSD,AMHSX),0),U,11)]"" W !?3,"Status: ",$$VAL^XBDIQ1(9002011.05,AMHSD(AMHSD,AMHSX),.11)
..I $P($G(^AMHREDU(AMHSD(AMHSD,AMHSX),11)),U)]"" X APCHSCKP Q:$D(APCHSQIT) W !?3,"Comment: ",$P(^AMHREDU(AMHSD(AMHSD,AMHSX),11),U)
..Q
.Q
HF ;
I '$D(^AMHRHF("AC",APCHSPAT)) G IPV
X APCHSCKP Q:$D(APCHSQIT) S X="************ BEHAVIORAL HEALTH HEALTH FACTORS ************* ",AMHS="",$P(AMHS," ",80-1-$L(X)/2)="" W !!,AMHS,X,AMHS,!
K AMHSN S AMHSX=0 F S AMHSX=$O(^AMHRHF("AC",APCHSPAT,AMHSX)) Q:AMHSX'=+AMHSX!($D(APCHSQIT)) D
.S X=$P(^AMHRHF(AMHSX,0),U),Y=$P(^AMHRHF(AMHSX,0),U,3) I Y,$D(^AMHREC(Y,0)),$$ALLOWVI^AMHUTIL(DUZ,Y) S Y=$P($P(^AMHREC(Y,0),U),".") I $P($G(AMHSN(X)),U)<Y S AMHSN(X)=Y_U_AMHSX
K AMHSD S X=0 F S X=$O(AMHSN(X)) Q:X'=+X S Y=$P(AMHSN(X),U),Y=9999999-Y,AMHSD(Y,X)=$P(AMHSN(X),U,2)
S AMHSD=0 F S AMHSD=$O(AMHSD(AMHSD)) Q:AMHSD'=+AMHSD!($D(APCHSQIT)) D
.S AMHSX=0 F S AMHSX=$O(AMHSD(AMHSD,AMHSX)) Q:AMHSX'=+AMHSX!($D(APCHSQIT)) D
..X APCHSCKP Q:$D(APCHSQIT)
..W !,$$FMTE^XLFDT(9999999-AMHSD),?15,$E($P(^AUTTHF(AMHSX,0),U),1,30)
..W ?47,"Quantity: ",$$VAL^XBDIQ1(9002011.08,AMHSD(AMHSD,AMHSX),.08)
..I $P($G(^AMHRHF(AMHSD(AMHSD,AMHSX),0)),U,4)]"" X APCHSCKP Q:$D(APCHSQIT) W !?3,"Level/Severity: ",$P(^AMHRHF(AMHSD(AMHSD,AMHSX),0),U,4)
..Q
.Q
IPV ;
X APCHSCKP Q:$D(APCHSQIT) S X="********* BEHAVIORAL HEALTH Screening Exams ********* ",AMHS="",$P(AMHS," ",80-1-$L(X)/2)="" W !!,AMHS,X,AMHS,!
F AMHSIVD=0:0 S AMHSIVD=$O(^AMHREC("AE",APCHSPAT,AMHSIVD)) Q:AMHSIVD=""!($P(AMHSIVD,".")>APCHSDLM)!($D(APCHSQIT)) D
.S AMHSX=0 F S AMHSX=$O(^AMHREC("AE",APCHSPAT,AMHSIVD,AMHSX)) Q:AMHSX'=+AMHSX D
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHSX)
..;I $P($G(^AMHREC(AMHSX,14)),U)="",$P($G(^AMHREC(AMHSX,14)),U,3)="",$P($G(^AMHREC(AMHSX,14)),U,5)="",$P($G(^AMHREC(AMHSX,14)),U,7)="" Q
..X APCHSCKP Q:$D(APCHSQIT)
..I $P($G(^AMHREC(AMHSX,14)),U)]"" W !,"IPV/DV SCREENING",?24,$$D((9999999-$P(AMHSIVD,"."))),?62,$E($$VAL^XBDIQ1(9002011,AMHSX,1402),1,15)
..I $P($G(^AMHREC(AMHSX,14)),U,3)]"" W !,"ALCOHOL SCREENING",?24,$$D((9999999-$P(AMHSIVD,"."))),?33,$$VAL^XBDIQ1(9002011,AMHSX,1403),?62,$E($$VAL^XBDIQ1(9002011,AMHSX,1404),1,15)
..I $P($G(^AMHREC(AMHSX,14)),U,5)]"" W !,"DEPRESSION SCREENING ",?24,$$D((9999999-$P(AMHSIVD,"."))),?33,$$VAL^XBDIQ1(9002011,AMHSX,1405),?62,$E($$VAL^XBDIQ1(9002011,AMHSX,1406),1,15)
..I $P($G(^AMHREC(AMHSX,14)),U,7)]"" W !,"SUICIDE RISK ASSESSMENT",?24,$$D((9999999-$P(AMHSIVD,"."))),?33,$$VAL^XBDIQ1(9002011,AMHSX,1407),?62,$E($$VAL^XBDIQ1(9002011,AMHSX,1408),1,15)
..;I $P($G(^AMHREC(AMHSX,15)),U)]"" X APCHSCKP Q:$D(APCHSQIT) W !?3,$P(^AMHREC(AMHSX,15),U)
MEASBH ;
D MEAS
OUTPTX K AMHS,AMHSX,AMHSDAT,AMHL,AMHAX5,AMHCNT,AMHSIVD,AMHIVD,AMHJ,AMHSPVD,AMHSDTU,AMHSN,AMHSD
K AMHSIVD,AMHSDTU,AMHSVDF,AMHSFAC,AMHSPFN,AMHSMTX,AMHSPVD,AMHSOVT,AMHSNDT,AMHSCLI,AMHSPDN,AMHSICD,AMHSICL,AMHSDAT,AMHSN,AMHSQ,AMHSR,AMHSX,AMHS,AMHTOC
K AMHSNFL,AMHSNSH,AMHSNAB,AMHSVSC,AMHSFAC,Y
K Y
Q
ONEDATE S Y=-AMHSIVD\1+9999999 X APCHSCVD S AMHSDAT=Y S AMHSPFN="",AMHSDTU=0,AMHSNDT=(AMHSDAT'=AMHSPVD)
S AMHSVDF="" F AMHSQ=0:0 S AMHSVDF=$O(^AMHREC("AE",APCHSPAT,AMHSIVD,AMHSVDF)) Q:AMHSVDF="" I $$ALLOWVI^AMHUTIL(DUZ,AMHSVDF) S AMHSN=^AMHREC(AMHSVDF,0) D GETSITE,DSPVIS Q:$D(APCHSQIT)
Q
;
GETSITE ;
S AMHSFAC=$P(AMHSN,U,4) S AMHSFAC=$S(AMHSFAC:$E($P(^AUTTLOC(AMHSFAC,0),U,2),1,8),1:"<missing>")
I AMHSFAC="" S AMHSFAC=$E($P(^DIC(4,$P(AMHSN,U,4),0),U),1,8)
S AMHTOC=$P(AMHSN,U,7) I AMHTOC]"" S AMHTOC=$P(^AMHTSET(AMHTOC,0),U,4)
Q
DSPVIS ;
S AMHSDTU=1
I $O(^AMHRPRO("AD",AMHSVDF,""))="" D NOPOV Q
S AMHSPDN="" F AMHSQ=0:0 S AMHSPDN=$O(^AMHRPRO("AD",AMHSVDF,AMHSPDN)) Q:'AMHSPDN S AMHSR=^AMHRPRO(AMHSPDN,0) D HASPOV
X APCHSCKP Q:$D(APCHSQIT)
;I $P(AMHSN,U,13)]"" W ?25,"Axis IV (Stress): ",$P(^AMHTAXIV($P(AMHSN,U,13),0),U,2)," - ",$P(^AMHTAXIV($P(AMHSN,U,13),0),U) W:$P(AMHSN,U,14)="" !
;W:$P(AMHSN,U,14)]"" ?50,"Axis V (Function): ",$P(AMHSN,U,14),!
I $D(^AMHREC(AMHSVDF,61))!($P(^AMHREC(AMHSVDF,0),U,14)]"") D Q:$D(APCHSQIT)
.X APCHSCKP Q:$D(APCHSQIT)
.W ?27,"AXIS IV: " S Y=0 F S Y=$O(^AMHREC(AMHSVDF,61,Y)) Q:Y'=+Y S I=$P(^AMHREC(AMHSVDF,61,Y,0),U) W ?35,$P(^AMHTAXIV(I,0),U)_" - "_$P(^AMHTAXIV(I,0),U,2),!
.I '$O(^AMHREC(AMHSVDF,61,0)) W !
.W ?27,"AXIS V: ",$P(^AMHREC(AMHSVDF,0),U,14) W:$P($G(^AMHREC(AMHSVDF,11)),U,15)]"" " GAF Scale Type: ",$$VAL^XBDIQ1(9002011,AMHSVDF,1115),!
.Q
X APCHSCKP Q:$D(APCHSQIT)
I $P(AMHSN,U,17)]"" W ?27,"Inpatient Disp: ",$$VAL^XBDIQ1(9002011,AMHSVDF,.17),!?27,"Referred To: ",$P(AMHSN,U,18),!
;I $D(^AMHREC(AMHSVDF,12)) X APCHSCKP Q:$D(APCHSQIT) S APCHSNRQ="COMMENT: "_^AMHREC(AMHSVDF,12),APCHSICL=27,APCHSTXT="" D PRTTXT^APCHSUTL
Q
;
NOPOV ;
S APCHSTXT="",(AMHSICD,APCHSNRQ)="<BH problem codes not yet entered>"
G COMMON
;
HASPOV ;
S APCHSNRQ=$P(^AMHPROB($P(AMHSR,U),0),U)_" - "
S AMHSICD=$E($P(^AMHPROB($P(AMHSR,U),0),U,2),1,45)
S Y=$L(APCHSNRQ) F X=Y:1:8 S APCHSNRQ=APCHSNRQ_" "
S APCHSNRQ=APCHSNRQ_AMHSICD,APCHSTXT="",APCHSICL=27
D COMMON
S:$P(AMHSR,U,4) APCHSNRQ=APCHSNRQ_$$GET1^DIQ(9002011.01,AMHSPDN,.04) S APCHSTXT="",APCHSICL=27 D PRTTXT^APCHSUTL
X APCHSCKP Q:$D(APCHSQIT)
Q
COMMON ;
X APCHSCKP Q:$D(APCHSQIT) S:APCHSNPG AMHSNDT=1
I AMHSNDT W AMHSDAT S AMHSPFN="",AMHSNDT=0
W ?9,AMHSFAC,?18,$$PPINI^AMHUTIL(AMHSVDF),?22,AMHTOC S APCHSICL=27 D PRTTXT^APCHSUTL
Q
DATE(D) ;
I $G(D)="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
D(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
MEAS ; ******************** MEASUREMENTS * *******
; <SETUP>
Q:'$D(^AMHRMSR("AA",APCHSPAT))
; <DISPLAY>
X APCHSCKP Q:$D(APCHSQIT) S X="********* BEHAVIORAL HEALTH Measurements ********* ",AMHS="",$P(AMHS," ",80-1-$L(X)/2)="" W !!,AMHS,X,AMHS,!
S APCHSMT="" F APCHSQ=0:0 S APCHSMT=$O(^AMHRMSR("AA",APCHSPAT,APCHSMT)) Q:APCHSMT="" S APCHSND2=5 D MEASDTYP Q:$D(APCHSQIT)
; <CLEANUP>
MEASX ;
K APCHSMT,APCHSMT2,APCHSMT3,APCHSDFN,APCHSND2,APCHSDAT
Q
MEASDTYP ;
S APCHSMT2=$S($D(^AUTTMSR(APCHSMT,0)):$P(^(0),U,1),1:APCHSMT) S APCHSMT3=APCHSMT2
S (APCHSIVD,APCHSDFN)="" F S APCHSIVD=$O(^AMHRMSR("AA",APCHSPAT,APCHSMT,APCHSIVD)) Q:APCHSIVD="" S APCHSND2=APCHSND2-1 Q:APCHSND2=-1 D MEASDSP
I APCHSMT3="" X APCHSCKP Q:$D(APCHSQIT) W !
Q
MEASDSP S APCHSDFN=$O(^AMHRMSR("AA",APCHSPAT,APCHSMT,APCHSIVD,"")),Y=-APCHSIVD\1+9999999 X APCHSCVD S APCHSDAT=Y X APCHSCKP Q:$D(APCHSQIT) W:APCHSNPG!(APCHSMT3]"") APCHSMT2 S APCHSMT3="" W ?5,APCHSDAT,?18,$P(^AMHRMSR(APCHSDFN,0),U,4),!
Q
;
AMHHS ; IHS/CMI/LAB - BH HEALTH SUMMARY COMPONENT 03 Jun 2009 12:08 PM ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**1,5,6,8**;JUN 02, 2010;Build 7
+2 ;
+3 ;
MH ;EP called from health summary
+1 NEW AMHPATH
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF 'APCHSNPG
XECUTE APCHSBRK
+3 IF $PIECE($GET(^AMHPATR(APCHSPAT,0)),U,9)]""
WRITE ?23,"Patient Flag: ",?38,$PIECE(^AMHPATR(APCHSPAT,0),U,9),!
+4 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+5 IF $PIECE($GET(^AMHPATR(APCHSPAT,0)),U,11)]""
WRITE ?21,"Flag Narrative: ",?38,$PIECE(^AMHPATR(APCHSPAT,0),U,11),!
+6 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+7 IF $PIECE($GET(^AMHPATR(APCHSPAT,0)),U,2)]""
WRITE ?2,"Designated Mental Health Provider: ",?38,$PIECE(^VA(200,$PIECE(^AMHPATR(APCHSPAT,0),U,2),0),U),!
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 IF $PIECE($GET(^AMHPATR(APCHSPAT,0)),U,3)]""
WRITE "Designated Social Services Provider: ",?38,$PIECE(^VA(200,$PIECE(^AMHPATR(APCHSPAT,0),U,3),0),U),!
+10 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+11 IF $PIECE($GET(^AMHPATR(APCHSPAT,0)),U,4)]""
WRITE ?10,"CD Designated Provider: ",?38,$PIECE(^VA(200,$PIECE(^AMHPATR(APCHSPAT,0),U,4),0),U),!
+12 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+13 IF $PIECE($GET(^AMHPATR(APCHSPAT,0)),U,12)]""
WRITE ?10,"Other Designated Provider: ",?38,$PIECE(^VA(200,$PIECE(^AMHPATR(APCHSPAT,0),U,12),0),U),!
+14 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+15 IF $PIECE($GET(^AMHPATR(APCHSPAT,0)),U,13)]""
WRITE ?10,"Other (2) Designated Provider: ",?38,$PIECE(^AMHPATR(APCHSPAT,0),U,13),!
+16 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+17 ;output personal history
+18 IF $DATA(^AMHPPHX("AC",APCHSPAT))
Begin DoDot:1
+19 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !,"** Personal History of:",!
+20 SET AMHSX=0
FOR
SET AMHSX=$ORDER(^AMHPPHX("AC",APCHSPAT,AMHSX))
IF AMHSX'=+AMHSX
QUIT
Begin DoDot:2
+21 SET Y=$PIECE(^AMHPPHX(AMHSX,0),U,3)
XECUTE APCHSCVD
SET AMHSDAT=Y
+22 WRITE !?5,$PIECE(^AMHTPHF($PIECE(^AMHPPHX(AMHSX,0),U),0),U),?30,"(noted: ",AMHSDAT,")"
+23 QUIT
End DoDot:2
+24 WRITE !
KILL AMHSX
+25 QUIT
End DoDot:1
CASE ;output last 3 cases
+1 KILL AMHL
SET D=0
SET C=0
FOR
SET D=$ORDER(^AMHPCASE("AA",APCHSPAT,D))
IF D'=+D!(C>2)
QUIT
Begin DoDot:1
+2 SET AMHL=0
FOR
SET AMHL=$ORDER(^AMHPCASE("AA",APCHSPAT,D,AMHL))
IF AMHL'=+AMHL!(C>2)
QUIT
Begin DoDot:2
+3 IF '$$ALLOWCD^AMHLCD(DUZ,AMHL)
QUIT
+4 SET C=C+1
+5 SET AMHL(C)=AMHL
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
CASEOUT ;display last 3 cases found
+1 IF $DATA(AMHL(1))
Begin DoDot:1
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+3 SET K="21;41;61"
+4 WRITE ?4,"Case Open Date:"
+5 FOR I=1:1:3
IF '$DATA(AMHL(I))
QUIT
SET J=$PIECE(K,";",I)
WRITE ?J,$$FMTE^XLFDT($PIECE(^AMHPCASE(AMHL(I),0),U),"2E")
+6 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+7 WRITE !?3,"Case Admit Date:"
+8 FOR I=1:1:3
IF '$DATA(AMHL(I))
QUIT
IF $PIECE(^AMHPCASE(AMHL(I),0),U,4)]""
SET J=$PIECE(K,";",I)
WRITE ?J,$$FMTE^XLFDT($PIECE(^AMHPCASE(AMHL(I),0),U,4),"2E")
+9 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+10 WRITE !?3,"Case Close Date:"
+11 FOR I=1:1:3
IF '$DATA(AMHL(I))
QUIT
IF $PIECE(^AMHPCASE(AMHL(I),0),U,5)]""
SET J=$PIECE(K,";",I)
WRITE ?J,$$FMTE^XLFDT($PIECE(^AMHPCASE(AMHL(I),0),U,5),"2E")
+12 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+13 WRITE !?5,"Program Affil:"
+14 FOR I=1:1:3
IF '$DATA(AMHL(I))
QUIT
IF $PIECE(^AMHPCASE(AMHL(I),0),U,3)]""
SET J=$PIECE(K,";",I)
WRITE ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.03)
+15 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+16 WRITE !?7,"Disposition:"
+17 FOR I=1:1:3
IF '$DATA(AMHL(I))
QUIT
IF $PIECE(^AMHPCASE(AMHL(I),0),U,6)]""
SET J=$PIECE(K,";",I)
WRITE ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.06)
+18 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+19 WRITE !?2,"Next Review Date:"
+20 FOR I=1:1:3
IF '$DATA(AMHL(I))
QUIT
IF $PIECE(^AMHPCASE(AMHL(I),0),U,12)]""
SET J=$PIECE(K,";",I)
WRITE ?J,$$FMTE^XLFDT($PIECE(^AMHPCASE(AMHL(I),0),U,12),"2E")
+21 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+22 WRITE !?10,"Provider:"
+23 FOR I=1:1:3
IF '$DATA(AMHL(I))
QUIT
IF $PIECE(^AMHPCASE(AMHL(I),0),U,8)]""
SET J=$PIECE(K,";",I)
WRITE ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.08)
+24 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+25 WRITE !?11,"Problem:"
+26 FOR I=1:1:3
IF '$DATA(AMHL(I))
QUIT
IF $PIECE(^AMHPCASE(AMHL(I),0),U,9)]""
SET J=$PIECE(K,";",I)
WRITE ?J,$$VAL^XBDIQ1(9002011.58,AMHL(I),.09)
End DoDot:1
+27 KILL AMHL,C,D,L,K
+28 DO PROB^AMHHS1
AXV ;trend and display last 7 AXIS V values
+1 KILL AMHAX5
SET AMHCNT=0
+2 SET AMHSIVD=0
FOR
SET AMHSIVD=$ORDER(^AMHREC("AE",APCHSPAT,AMHSIVD))
IF AMHSIVD=""!($DATA(APCHSQIT))!(AMHCNT>6)
QUIT
Begin DoDot:1
+3 SET AMHSX=0
FOR
SET AMHSX=$ORDER(^AMHREC("AE",APCHSPAT,AMHSIVD,AMHSX))
IF AMHSX'=+AMHSX
QUIT
Begin DoDot:2
+4 IF $PIECE($GET(^AMHREC(AMHSX,0)),U,14)=""
QUIT
+5 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHSX)
QUIT
+6 SET AMHCNT=AMHCNT+1
SET AMHAX5(AMHCNT)=(9999999-$PIECE(AMHSIVD,"."))_U_$PIECE(^AMHREC(AMHSX,0),U,14)
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 IF $DATA(AMHAX5)
Begin DoDot:1
+10 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+11 WRITE !!?4,"********** LAST 6 AXIS V VALUES RECORDED. (GAF SCORES) **********",!!
+12 SET AMHJ=2
FOR AMHCNT=6:-1:1
IF $DATA(AMHAX5(AMHCNT))
WRITE ?AMHJ,$$DATE($PIECE(AMHAX5(AMHCNT),U))
SET AMHJ=AMHJ+12
+13 WRITE !
SET AMHJ=6
FOR AMHCNT=6:-1:1
IF $DATA(AMHAX5(AMHCNT))
WRITE ?AMHJ,$PIECE(AMHAX5(AMHCNT),U,2)
SET AMHJ=AMHJ+12
+14 WRITE !
End DoDot:1
IF $DATA(APCHSQIT)
QUIT
OUTPT ; ********** MH PROBLEM CODES AND DESIGNATED PROVIDER
+1 ; <SETUP>
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
SET X="******************** BH ENCOUNTERS ******************** "
SET AMHS=""
SET $PIECE(AMHS," ",80-1-$LENGTH(X)/2)=""
WRITE !,AMHS,X,AMHS,!!
+3 IF '$DATA(^AMHREC("AE",APCHSPAT))
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !,"No Behavioral Health Records on File.",!
QUIT
+4 ; <DISPLAY>
+5 SET AMHSPVD=0
+6 FOR AMHSIVD=0:0
SET AMHSIVD=$ORDER(^AMHREC("AE",APCHSPAT,AMHSIVD))
IF AMHSIVD=""!($PIECE(AMHSIVD,".")>APCHSDLM)
QUIT
DO ONEDATE
IF $DATA(APCHSQIT)
QUIT
IF (AMHSDAT'=AMHSPVD)&AMHSDTU
SET APCHSNDM=APCHSNDM-AMHSDTU
SET AMHSPVD=AMHSDAT
IF APCHSNDM=0
QUIT
PTED ;display all pt ed (last of each)
+1 IF '$DATA(^AMHREDU("AC",APCHSPAT))
GOTO HF
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
SET X="************ BEHAVIORAL HEALTH PATIENT EDUCATION ******************** "
SET AMHS=""
SET $PIECE(AMHS," ",80-1-$LENGTH(X)/2)=""
WRITE !,AMHS,X,AMHS,!
+3 KILL AMHSN
SET AMHSX=0
FOR
SET AMHSX=$ORDER(^AMHREDU("AC",APCHSPAT,AMHSX))
IF AMHSX'=+AMHSX!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+4 SET X=$PIECE(^AMHREDU(AMHSX,0),U)
SET Y=$PIECE(^AMHREDU(AMHSX,0),U,3)
IF Y
IF $DATA(^AMHREC(Y,0))
IF $$ALLOWVI^AMHUTIL(DUZ,Y)
SET Y=$PIECE($PIECE(^AMHREC(Y,0),U),".")
IF $PIECE($GET(AMHSN(X)),U)<Y
SET AMHSN(X)=Y_U_AMHSX
End DoDot:1
+5 KILL AMHSD
SET X=0
FOR
SET X=$ORDER(AMHSN(X))
IF X'=+X
QUIT
SET Y=$PIECE(AMHSN(X),U)
SET Y=9999999-Y
SET AMHSD(Y,X)=$PIECE(AMHSN(X),U,2)
+6 SET AMHSD=0
FOR
SET AMHSD=$ORDER(AMHSD(AMHSD))
IF AMHSD'=+AMHSD!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+7 SET AMHSX=0
FOR
SET AMHSX=$ORDER(AMHSD(AMHSD,AMHSX))
IF AMHSX'=+AMHSX!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 WRITE !,$$FMTE^XLFDT(9999999-AMHSD),?15,$EXTRACT($PIECE(^AUTTEDT(AMHSX,0),U),1,30),?47,$$VAL^XBDIQ1(9002011.05,AMHSD(AMHSD,AMHSX),.05)
+10 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+11 WRITE !?3,"Level of Understanding: ",$$VAL^XBDIQ1(9002011.05,AMHSD(AMHSD,AMHSX),.08),?47,$PIECE(^AMHREDU(AMHSD(AMHSD,AMHSX),0),U,6),$SELECT($PIECE(^AMHREDU(AMHSD(AMHSD,AMHSX),0),U,6)]"":" mins",1:"")
+12 IF $PIECE(^AMHREDU(AMHSD(AMHSD,AMHSX),0),U,9)]""
WRITE !?3,"Goal: ",$$VAL^XBDIQ1(9002011.05,AMHSD(AMHSD,AMHSX),.09)
+13 IF $PIECE(^AMHREDU(AMHSD(AMHSD,AMHSX),0),U,11)]""
WRITE !?3,"Status: ",$$VAL^XBDIQ1(9002011.05,AMHSD(AMHSD,AMHSX),.11)
+14 IF $PIECE($GET(^AMHREDU(AMHSD(AMHSD,AMHSX),11)),U)]""
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !?3,"Comment: ",$PIECE(^AMHREDU(AMHSD(AMHSD,AMHSX),11),U)
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
HF ;
+1 IF '$DATA(^AMHRHF("AC",APCHSPAT))
GOTO IPV
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
SET X="************ BEHAVIORAL HEALTH HEALTH FACTORS ************* "
SET AMHS=""
SET $PIECE(AMHS," ",80-1-$LENGTH(X)/2)=""
WRITE !!,AMHS,X,AMHS,!
+3 KILL AMHSN
SET AMHSX=0
FOR
SET AMHSX=$ORDER(^AMHRHF("AC",APCHSPAT,AMHSX))
IF AMHSX'=+AMHSX!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+4 SET X=$PIECE(^AMHRHF(AMHSX,0),U)
SET Y=$PIECE(^AMHRHF(AMHSX,0),U,3)
IF Y
IF $DATA(^AMHREC(Y,0))
IF $$ALLOWVI^AMHUTIL(DUZ,Y)
SET Y=$PIECE($PIECE(^AMHREC(Y,0),U),".")
IF $PIECE($GET(AMHSN(X)),U)<Y
SET AMHSN(X)=Y_U_AMHSX
End DoDot:1
+5 KILL AMHSD
SET X=0
FOR
SET X=$ORDER(AMHSN(X))
IF X'=+X
QUIT
SET Y=$PIECE(AMHSN(X),U)
SET Y=9999999-Y
SET AMHSD(Y,X)=$PIECE(AMHSN(X),U,2)
+6 SET AMHSD=0
FOR
SET AMHSD=$ORDER(AMHSD(AMHSD))
IF AMHSD'=+AMHSD!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+7 SET AMHSX=0
FOR
SET AMHSX=$ORDER(AMHSD(AMHSD,AMHSX))
IF AMHSX'=+AMHSX!($DATA(APCHSQIT))
QUIT
Begin DoDot:2
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 WRITE !,$$FMTE^XLFDT(9999999-AMHSD),?15,$EXTRACT($PIECE(^AUTTHF(AMHSX,0),U),1,30)
+10 WRITE ?47,"Quantity: ",$$VAL^XBDIQ1(9002011.08,AMHSD(AMHSD,AMHSX),.08)
+11 IF $PIECE($GET(^AMHRHF(AMHSD(AMHSD,AMHSX),0)),U,4)]""
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !?3,"Level/Severity: ",$PIECE(^AMHRHF(AMHSD(AMHSD,AMHSX),0),U,4)
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
IPV ;
+1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
SET X="********* BEHAVIORAL HEALTH Screening Exams ********* "
SET AMHS=""
SET $PIECE(AMHS," ",80-1-$LENGTH(X)/2)=""
WRITE !!,AMHS,X,AMHS,!
+2 FOR AMHSIVD=0:0
SET AMHSIVD=$ORDER(^AMHREC("AE",APCHSPAT,AMHSIVD))
IF AMHSIVD=""!($PIECE(AMHSIVD,".")>APCHSDLM)!($DATA(APCHSQIT))
QUIT
Begin DoDot:1
+3 SET AMHSX=0
FOR
SET AMHSX=$ORDER(^AMHREC("AE",APCHSPAT,AMHSIVD,AMHSX))
IF AMHSX'=+AMHSX
QUIT
Begin DoDot:2
+4 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHSX)
QUIT
+5 ;I $P($G(^AMHREC(AMHSX,14)),U)="",$P($G(^AMHREC(AMHSX,14)),U,3)="",$P($G(^AMHREC(AMHSX,14)),U,5)="",$P($G(^AMHREC(AMHSX,14)),U,7)="" Q
+6 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+7 IF $PIECE($GET(^AMHREC(AMHSX,14)),U)]""
WRITE !,"IPV/DV SCREENING",?24,$$D((9999999-$PIECE(AMHSIVD,"."))),?62,$EXTRACT($$VAL^XBDIQ1(9002011,AMHSX,1402),1,15)
+8 IF $PIECE($GET(^AMHREC(AMHSX,14)),U,3)]""
WRITE !,"ALCOHOL SCREENING",?24,$$D((9999999-$PIECE(AMHSIVD,"."))),?33,$$VAL^XBDIQ1(9002011,AMHSX,1403),?62,$EXTRACT($$VAL^XBDIQ1(9002011,AMHSX,1404),1,15)
+9 IF $PIECE($GET(^AMHREC(AMHSX,14)),U,5)]""
WRITE !,"DEPRESSION SCREENING ",?24,$$D((9999999-$PIECE(AMHSIVD,"."))),?33,$$VAL^XBDIQ1(9002011,AMHSX,1405),?62,$EXTRACT($$VAL^XBDIQ1(9002011,AMHSX,1406),1,15)
+10 IF $PIECE($GET(^AMHREC(AMHSX,14)),U,7)]""
WRITE !,"SUICIDE RISK ASSESSMENT",?24,$$D((9999999-$PIECE(AMHSIVD,"."))),?33,$$VAL^XBDIQ1(9002011,AMHSX,1407),?62,$EXTRACT($$VAL^XBDIQ1(9002011,AMHSX,1408),1,15)
+11 ;I $P($G(^AMHREC(AMHSX,15)),U)]"" X APCHSCKP Q:$D(APCHSQIT) W !?3,$P(^AMHREC(AMHSX,15),U)
End DoDot:2
End DoDot:1
MEASBH ;
+1 DO MEAS
OUTPTX KILL AMHS,AMHSX,AMHSDAT,AMHL,AMHAX5,AMHCNT,AMHSIVD,AMHIVD,AMHJ,AMHSPVD,AMHSDTU,AMHSN,AMHSD
+1 KILL AMHSIVD,AMHSDTU,AMHSVDF,AMHSFAC,AMHSPFN,AMHSMTX,AMHSPVD,AMHSOVT,AMHSNDT,AMHSCLI,AMHSPDN,AMHSICD,AMHSICL,AMHSDAT,AMHSN,AMHSQ,AMHSR,AMHSX,AMHS,AMHTOC
+2 KILL AMHSNFL,AMHSNSH,AMHSNAB,AMHSVSC,AMHSFAC,Y
+3 KILL Y
+4 QUIT
ONEDATE SET Y=-AMHSIVD\1+9999999
XECUTE APCHSCVD
SET AMHSDAT=Y
SET AMHSPFN=""
SET AMHSDTU=0
SET AMHSNDT=(AMHSDAT'=AMHSPVD)
+1 SET AMHSVDF=""
FOR AMHSQ=0:0
SET AMHSVDF=$ORDER(^AMHREC("AE",APCHSPAT,AMHSIVD,AMHSVDF))
IF AMHSVDF=""
QUIT
IF $$ALLOWVI^AMHUTIL(DUZ,AMHSVDF)
SET AMHSN=^AMHREC(AMHSVDF,0)
DO GETSITE
DO DSPVIS
IF $DATA(APCHSQIT)
QUIT
+2 QUIT
+3 ;
GETSITE ;
+1 SET AMHSFAC=$PIECE(AMHSN,U,4)
SET AMHSFAC=$SELECT(AMHSFAC:$EXTRACT($PIECE(^AUTTLOC(AMHSFAC,0),U,2),1,8),1:"<missing>")
+2 IF AMHSFAC=""
SET AMHSFAC=$EXTRACT($PIECE(^DIC(4,$PIECE(AMHSN,U,4),0),U),1,8)
+3 SET AMHTOC=$PIECE(AMHSN,U,7)
IF AMHTOC]""
SET AMHTOC=$PIECE(^AMHTSET(AMHTOC,0),U,4)
+4 QUIT
DSPVIS ;
+1 SET AMHSDTU=1
+2 IF $ORDER(^AMHRPRO("AD",AMHSVDF,""))=""
DO NOPOV
QUIT
+3 SET AMHSPDN=""
FOR AMHSQ=0:0
SET AMHSPDN=$ORDER(^AMHRPRO("AD",AMHSVDF,AMHSPDN))
IF 'AMHSPDN
QUIT
SET AMHSR=^AMHRPRO(AMHSPDN,0)
DO HASPOV
+4 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+5 ;I $P(AMHSN,U,13)]"" W ?25,"Axis IV (Stress): ",$P(^AMHTAXIV($P(AMHSN,U,13),0),U,2)," - ",$P(^AMHTAXIV($P(AMHSN,U,13),0),U) W:$P(AMHSN,U,14)="" !
+6 ;W:$P(AMHSN,U,14)]"" ?50,"Axis V (Function): ",$P(AMHSN,U,14),!
+7 IF $DATA(^AMHREC(AMHSVDF,61))!($PIECE(^AMHREC(AMHSVDF,0),U,14)]"")
Begin DoDot:1
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 WRITE ?27,"AXIS IV: "
SET Y=0
FOR
SET Y=$ORDER(^AMHREC(AMHSVDF,61,Y))
IF Y'=+Y
QUIT
SET I=$PIECE(^AMHREC(AMHSVDF,61,Y,0),U)
WRITE ?35,$PIECE(^AMHTAXIV(I,0),U)_" - "_$PIECE(^AMHTAXIV(I,0),U,2),!
+10 IF '$ORDER(^AMHREC(AMHSVDF,61,0))
WRITE !
+11 WRITE ?27,"AXIS V: ",$PIECE(^AMHREC(AMHSVDF,0),U,14)
IF $PIECE($GET(^AMHREC(AMHSVDF,11)),U,15)]""
WRITE " GAF Scale Type: ",$$VAL^XBDIQ1(9002011,AMHSVDF,1115),!
+12 QUIT
End DoDot:1
IF $DATA(APCHSQIT)
QUIT
+13 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+14 IF $PIECE(AMHSN,U,17)]""
WRITE ?27,"Inpatient Disp: ",$$VAL^XBDIQ1(9002011,AMHSVDF,.17),!?27,"Referred To: ",$PIECE(AMHSN,U,18),!
+15 ;I $D(^AMHREC(AMHSVDF,12)) X APCHSCKP Q:$D(APCHSQIT) S APCHSNRQ="COMMENT: "_^AMHREC(AMHSVDF,12),APCHSICL=27,APCHSTXT="" D PRTTXT^APCHSUTL
+16 QUIT
+17 ;
NOPOV ;
+1 SET APCHSTXT=""
SET (AMHSICD,APCHSNRQ)="<BH problem codes not yet entered>"
+2 GOTO COMMON
+3 ;
HASPOV ;
+1 SET APCHSNRQ=$PIECE(^AMHPROB($PIECE(AMHSR,U),0),U)_" - "
+2 SET AMHSICD=$EXTRACT($PIECE(^AMHPROB($PIECE(AMHSR,U),0),U,2),1,45)
+3 SET Y=$LENGTH(APCHSNRQ)
FOR X=Y:1:8
SET APCHSNRQ=APCHSNRQ_" "
+4 SET APCHSNRQ=APCHSNRQ_AMHSICD
SET APCHSTXT=""
SET APCHSICL=27
+5 DO COMMON
+6 IF $PIECE(AMHSR,U,4)
SET APCHSNRQ=APCHSNRQ_$$GET1^DIQ(9002011.01,AMHSPDN,.04)
SET APCHSTXT=""
SET APCHSICL=27
DO PRTTXT^APCHSUTL
+7 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+8 QUIT
COMMON ;
+1 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG
SET AMHSNDT=1
+2 IF AMHSNDT
WRITE AMHSDAT
SET AMHSPFN=""
SET AMHSNDT=0
+3 WRITE ?9,AMHSFAC,?18,$$PPINI^AMHUTIL(AMHSVDF),?22,AMHTOC
SET APCHSICL=27
DO PRTTXT^APCHSUTL
+4 QUIT
DATE(D) ;
+1 IF $GET(D)=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+$EXTRACT(D,1,3))
D(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+3 ;
MEAS ; ******************** MEASUREMENTS * *******
+1 ; <SETUP>
+2 IF '$DATA(^AMHRMSR("AA",APCHSPAT))
QUIT
+3 ; <DISPLAY>
+4 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
SET X="********* BEHAVIORAL HEALTH Measurements ********* "
SET AMHS=""
SET $PIECE(AMHS," ",80-1-$LENGTH(X)/2)=""
WRITE !!,AMHS,X,AMHS,!
+5 SET APCHSMT=""
FOR APCHSQ=0:0
SET APCHSMT=$ORDER(^AMHRMSR("AA",APCHSPAT,APCHSMT))
IF APCHSMT=""
QUIT
SET APCHSND2=5
DO MEASDTYP
IF $DATA(APCHSQIT)
QUIT
+6 ; <CLEANUP>
MEASX ;
+1 KILL APCHSMT,APCHSMT2,APCHSMT3,APCHSDFN,APCHSND2,APCHSDAT
+2 QUIT
MEASDTYP ;
+1 SET APCHSMT2=$SELECT($DATA(^AUTTMSR(APCHSMT,0)):$PIECE(^(0),U,1),1:APCHSMT)
SET APCHSMT3=APCHSMT2
+2 SET (APCHSIVD,APCHSDFN)=""
FOR
SET APCHSIVD=$ORDER(^AMHRMSR("AA",APCHSPAT,APCHSMT,APCHSIVD))
IF APCHSIVD=""
QUIT
SET APCHSND2=APCHSND2-1
IF APCHSND2=-1
QUIT
DO MEASDSP
+3 IF APCHSMT3=""
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !
+4 QUIT
MEASDSP SET APCHSDFN=$ORDER(^AMHRMSR("AA",APCHSPAT,APCHSMT,APCHSIVD,""))
SET Y=-APCHSIVD\1+9999999
XECUTE APCHSCVD
SET APCHSDAT=Y
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
IF APCHSNPG!(APCHSMT3]"")
WRITE APCHSMT2
SET APCHSMT3=""
WRITE ?5,APCHSDAT,?18,$PIECE(^AMHRMSR(APCHSDFN,0),U,4),!
+1 QUIT
+2 ;
