BHSBH ;IHS/CIA/MGH - Health Summary for Behavioral Health ;27-Aug-2014 14:15;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**2,4,9**;March 17, 2006;Build 16
;===================================================================
;Taken from AMHHS
; IHS/CMI/LAB - BH HEALTH SUMMARY COMPONENT ;
;;3.0;IHS BEHAVIORAL HEALTH;;JAN 27, 2003
;Conversion of behavioral health over to VA health summary
;=====================================================================
;
MH ;EP called from health summary
NEW AMHPATH
D CKP^GMTSUP Q:$D(GMTSQIT)
I $P($G(^AMHPATR(BHSPAT,0)),U,9)]"" W ?23,"Patient Flag: ",?38,$P(^AMHPATR(BHSPAT,0),U,9),!
D CKP^GMTSUP Q:$D(GMTSQIT)
I $P($G(^AMHPATR(BHSPAT,0)),U,11)]"" W ?21,"Flag Narrative: ",?38,$P(^AMHPATR(BHSPAT,0),U,11),!
D CKP^GMTSUP Q:$D(GMTSQIT)
I $P($G(^AMHPATR(BHSPAT,0)),U,2)]"" W ?2,"Designated Mental Health Provider: ",?38,$P(^VA(200,$P(^AMHPATR(BHSPAT,0),U,2),0),U),!
D CKP^GMTSUP Q:$D(GMTSQIT)
I $P($G(^AMHPATR(BHSPAT,0)),U,3)]"" W "Designated Social Services Provider: ",?38,$P(^VA(200,$P(^AMHPATR(BHSPAT,0),U,3),0),U),!
D CKP^GMTSUP Q:$D(GMTSQIT)
I $P($G(^AMHPATR(BHSPAT,0)),U,4)]"" W ?10,"CD Designated Provider: ",?38,$P(^VA(200,$P(^AMHPATR(BHSPAT,0),U,4),0),U),!
D CKP^GMTSUP Q:$D(GMTSQIT)
I $P($G(^AMHPATR(BHSPAT,0)),U,12)]"" W ?10,"Other Designated Provider: ",?38,$P(^VA(200,$P(^AMHPATR(BHSPAT,0),U,12),0),U),!
D CKP^GMTSUP Q:$D(GMTSQIT)
I $P($G(^AMHPATR(BHSPAT,0)),U,13)]"" W ?10,"Other (2) Designated Provider: ",?38,$P(^VA(200,$P(^AMHPATR(BHSPAT,0),U,13),0),U),!
D CKP^GMTSUP Q:$D(GMTSQIT)
;output personal history
I $D(^AMHPPHX("AC",BHSPAT)) D
.D CKP^GMTSUP Q:$D(GMTSQIT) W !,"** Personal History of:",!
.S AMHSX=0 F S AMHSX=$O(^AMHPPHX("AC",BHSPAT,AMHSX)) Q:AMHSX'=+AMHSX D
..S X=$P(^AMHPPHX(AMHSX,0),U,3) D REGDT4^GMTSU S AMHSDAT=X
..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",BHSPAT,D)) Q:D'=+D!(C>2) D
.S AMHL=0 F S AMHL=$O(^AMHPCASE("AA",BHSPAT,D,AMHL)) Q:AMHL'=+AMHL!(C>2) D
..S C=C+1
..S AMHL(C)=AMHL
..Q
.Q
CASEOUT ;display last 3 cases found
I $D(AMHL(1)) D
.D CKP^GMTSUP Q:$D(GMTSQIT)
.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")
.D CKP^GMTSUP Q:$D(GMTSQIT)
.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")
.D CKP^GMTSUP Q:$D(GMTSQIT)
.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")
.D CKP^GMTSUP Q:$D(GMTSQIT)
.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)
.D CKP^GMTSUP Q:$D(GMTSQIT)
.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)
.D CKP^GMTSUP Q:$D(GMTSQIT)
.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")
.D CKP^GMTSUP Q:$D(GMTSQIT)
.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)
.D CKP^GMTSUP Q:$D(GMTSQIT)
.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^BHSBH1
AXV ;trend and display last 7 AXIS V values
K AMHAX5 S AMHCNT=0
S AMHSIVD=0 F S AMHSIVD=$O(^AMHREC("AE",BHSPAT,AMHSIVD)) Q:AMHSIVD=""!($D(GMTSQIT))!(AMHCNT>6) D
.S AMHSX=0 F S AMHSX=$O(^AMHREC("AE",BHSPAT,AMHSIVD,AMHSX)) Q:AMHSX'=+AMHSX D
..Q:$P($G(^AMHREC(AMHSX,0)),U,14)=""
..S AMHCNT=AMHCNT+1,AMHAX5(AMHCNT)=(9999999-AMHSIVD)_U_$P(^AMHREC(AMHSX,0),U,14)
..Q
.Q
I $D(AMHAX5) D Q:$D(GMTSQIT)
.D CKP^GMTSUP Q:$D(GMTSQIT)
.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>
D CKP^GMTSUP Q:$D(GMTSQIT) S X="******************** BH ENCOUNTERS ******************** ",AMHS="",$P(AMHS," ",IOM-1-$L(X)/2)="" W !,AMHS,X,AMHS,!!
I '$D(^AMHREC("AE",BHSPAT)) D CKP^GMTSUP Q:$D(GMTSQIT) W !,"No Behavioral Health Records on File.",! Q
; <DISPLAY>
S AMHSPVD=0
F AMHSIVD=0:0 S AMHSIVD=$O(^AMHREC("AE",BHSPAT,AMHSIVD)) Q:AMHSIVD=""!($P(AMHSIVD,".")>GMTSDLM) D ONEDATE Q:$D(GMTSQIT) S:(AMHSDAT'=AMHSPVD)&AMHSDTU GMTSNDM=GMTSNDM-AMHSDTU,AMHSPVD=AMHSDAT Q:GMTSNDM=0
PTED ;display all pt ed (last of each)
I '$D(^AMHREDU("AC",BHSPAT)) G OUTPTX
D CKP^GMTSUP Q:$D(GMTSQIT) S X="******************** MH/SS PATIENT EDUCATION ******************** ",AMHS="",$P(AMHS," ",IOM-1-$L(X)/2)="" W !,AMHS,X,AMHS,!!
K AMHSN S AMHSX=0 F S AMHSX=$O(^AMHREDU("AC",BHSPAT,AMHSX)) Q:AMHSX'=+AMHSX!($D(GMTSQIT)) D
.S X=$P(^AMHREDU(AMHSX,0),U),Y=$P(^AMHREDU(AMHSX,0),U,3) I Y,$D(^AMHREC(Y,0)) 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(GMTSQIT)) D
.S AMHSX=0 F S AMHSX=$O(AMHSD(AMHSD,AMHSX)) Q:AMHSX'=+AMHSX!($D(GMTSQIT)) D
..D CKP^GMTSUP Q:$D(GMTSQIT)
..W !,$$FMTE^XLFDT(9999999-AMHSD),?15,$E($P(^AUTTEDT(AMHSX,0),U),1,30),?47,$$VAL^XBDIQ1(9002011.05,AMHSD(AMHSD,AMHSX),.05)
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,BHSTXT,BHSNRQ,BHSICL,Y,I,J,X
K Y
Q
ONEDATE S X=-AMHSIVD\1+9999999 D REGDT4^GMTSU S AMHSDAT=X S AMHSPFN="",AMHSDTU=0,AMHSNDT=(AMHSDAT'=AMHSPVD)
S AMHSVDF="" F AMHSQ=0:0 S AMHSVDF=$O(^AMHREC("AE",BHSPAT,AMHSIVD,AMHSVDF)) Q:AMHSVDF="" S AMHSN=^AMHREC(AMHSVDF,0) D GETSITE,DSPVIS Q:$D(GMTSQIT)
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
D CKP^GMTSUP Q:$D(GMTSQIT)
;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(GMTSQIT)
.D CKP^GMTSUP Q:$D(GMTSQIT)
.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),!
.Q
D CKP^GMTSUP Q:$D(GMTSQIT)
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)) D CKP^GMTSUP Q:$D(GMTSQIT) S BHSNRQ="COMMENT: "_^AMHREC(AMHSVDF,12),BHSICL=27,BHSTXT="" D PRTTXT^BHSUTL
Q
;
NOPOV ;
S BHSTXT="",(AMHSICD,BHSNRQ)="<BH problem codes not yet entered>"
G COMMON
;
HASPOV ;
N CODE,CODEIEN,CHK,FIRST,SEC,CHK,DESCT
S CODE=$P(AMHSR,U)
Q:CODE=""
;S CODEIEN="" S CODEIEN=$O(^AMHPROB("B",CODE,CODEIEN))
S CODEIEN=CODE
S BHSNRQ=$P($G(^AMHPROB(CODEIEN,0)),U)_" - "
S AMHSICD=$E($P($G(^AMHPROB(CODEIEN,0)),U,2),1,45)
S Y=$L(BHSNRQ) F X=Y:1:8 S BHSNRQ=BHSNRQ_" "
S BHSNRQ=BHSNRQ_AMHSICD,BHSTXT="",BHSICL=27
D COMMON
S CHK=$P(^AUTNPOV($P(AMHSR,U,4),0),U)
;Patch 9 added changes for SNOMED POVs
I CHK["|" D
.S FIRST=$P(CHK,"|",1),SEC=$P(CHK,"|",2)
.S DESCT=$$DESC^BSTSAPI(SEC_"^^1")
.S CHK=$P(DESCT,U,2)
.I FIRST'="" S CHK=CHK_" | "_FIRST
S:$P(AMHSR,U,4) BHSNRQ=BHSNRQ_CHK S BHSTXT="",BHSICL=27 D PRTTXT^BHSUTL
D CKP^GMTSUP Q:$D(GMTSQIT)
Q
COMMON ;
D CKP^GMTSUP Q:$D(GMTSQIT) S:GMTSNPG AMHSNDT=1
I AMHSNDT W AMHSDAT S AMHSPFN="",AMHSNDT=0
W ?9,AMHSFAC,?18,$$PPINI^AMHUTIL(AMHSVDF),?22,AMHTOC S BHSICL=27 D PRTTXT^BHSUTL
Q
DATE(D) ;
I $G(D)="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
BHSBH ;IHS/CIA/MGH - Health Summary for Behavioral Health ;27-Aug-2014 14:15;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**2,4,9**;March 17, 2006;Build 16
+2 ;===================================================================
+3 ;Taken from AMHHS
+4 ; IHS/CMI/LAB - BH HEALTH SUMMARY COMPONENT ;
+5 ;;3.0;IHS BEHAVIORAL HEALTH;;JAN 27, 2003
+6 ;Conversion of behavioral health over to VA health summary
+7 ;=====================================================================
+8 ;
MH ;EP called from health summary
+1 NEW AMHPATH
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+3 IF $PIECE($GET(^AMHPATR(BHSPAT,0)),U,9)]""
WRITE ?23,"Patient Flag: ",?38,$PIECE(^AMHPATR(BHSPAT,0),U,9),!
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+5 IF $PIECE($GET(^AMHPATR(BHSPAT,0)),U,11)]""
WRITE ?21,"Flag Narrative: ",?38,$PIECE(^AMHPATR(BHSPAT,0),U,11),!
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+7 IF $PIECE($GET(^AMHPATR(BHSPAT,0)),U,2)]""
WRITE ?2,"Designated Mental Health Provider: ",?38,$PIECE(^VA(200,$PIECE(^AMHPATR(BHSPAT,0),U,2),0),U),!
+8 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+9 IF $PIECE($GET(^AMHPATR(BHSPAT,0)),U,3)]""
WRITE "Designated Social Services Provider: ",?38,$PIECE(^VA(200,$PIECE(^AMHPATR(BHSPAT,0),U,3),0),U),!
+10 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+11 IF $PIECE($GET(^AMHPATR(BHSPAT,0)),U,4)]""
WRITE ?10,"CD Designated Provider: ",?38,$PIECE(^VA(200,$PIECE(^AMHPATR(BHSPAT,0),U,4),0),U),!
+12 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+13 IF $PIECE($GET(^AMHPATR(BHSPAT,0)),U,12)]""
WRITE ?10,"Other Designated Provider: ",?38,$PIECE(^VA(200,$PIECE(^AMHPATR(BHSPAT,0),U,12),0),U),!
+14 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+15 IF $PIECE($GET(^AMHPATR(BHSPAT,0)),U,13)]""
WRITE ?10,"Other (2) Designated Provider: ",?38,$PIECE(^VA(200,$PIECE(^AMHPATR(BHSPAT,0),U,13),0),U),!
+16 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+17 ;output personal history
+18 IF $DATA(^AMHPPHX("AC",BHSPAT))
Begin DoDot:1
+19 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE !,"** Personal History of:",!
+20 SET AMHSX=0
FOR
SET AMHSX=$ORDER(^AMHPPHX("AC",BHSPAT,AMHSX))
IF AMHSX'=+AMHSX
QUIT
Begin DoDot:2
+21 SET X=$PIECE(^AMHPPHX(AMHSX,0),U,3)
DO REGDT4^GMTSU
SET AMHSDAT=X
+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",BHSPAT,D))
IF D'=+D!(C>2)
QUIT
Begin DoDot:1
+2 SET AMHL=0
FOR
SET AMHL=$ORDER(^AMHPCASE("AA",BHSPAT,D,AMHL))
IF AMHL'=+AMHL!(C>2)
QUIT
Begin DoDot:2
+3 SET C=C+1
+4 SET AMHL(C)=AMHL
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
CASEOUT ;display last 3 cases found
+1 IF $DATA(AMHL(1))
Begin DoDot:1
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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^BHSBH1
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",BHSPAT,AMHSIVD))
IF AMHSIVD=""!($DATA(GMTSQIT))!(AMHCNT>6)
QUIT
Begin DoDot:1
+3 SET AMHSX=0
FOR
SET AMHSX=$ORDER(^AMHREC("AE",BHSPAT,AMHSIVD,AMHSX))
IF AMHSX'=+AMHSX
QUIT
Begin DoDot:2
+4 IF $PIECE($GET(^AMHREC(AMHSX,0)),U,14)=""
QUIT
+5 SET AMHCNT=AMHCNT+1
SET AMHAX5(AMHCNT)=(9999999-AMHSIVD)_U_$PIECE(^AMHREC(AMHSX,0),U,14)
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
+8 IF $DATA(AMHAX5)
Begin DoDot:1
+9 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+10 WRITE !!?4,"********** LAST 6 AXIS V VALUES RECORDED. (GAF SCORES) **********",!!
+11 SET AMHJ=2
FOR AMHCNT=6:-1:1
IF $DATA(AMHAX5(AMHCNT))
WRITE ?AMHJ,$$DATE($PIECE(AMHAX5(AMHCNT),U))
SET AMHJ=AMHJ+12
+12 WRITE !
SET AMHJ=6
FOR AMHCNT=6:-1:1
IF $DATA(AMHAX5(AMHCNT))
WRITE ?AMHJ,$PIECE(AMHAX5(AMHCNT),U,2)
SET AMHJ=AMHJ+12
+13 WRITE !
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
OUTPT ; ********** MH PROBLEM CODES AND DESIGNATED PROVIDER
+1 ; <SETUP>
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
SET X="******************** BH ENCOUNTERS ******************** "
SET AMHS=""
SET $PIECE(AMHS," ",IOM-1-$LENGTH(X)/2)=""
WRITE !,AMHS,X,AMHS,!!
+3 IF '$DATA(^AMHREC("AE",BHSPAT))
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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",BHSPAT,AMHSIVD))
IF AMHSIVD=""!($PIECE(AMHSIVD,".")>GMTSDLM)
QUIT
DO ONEDATE
IF $DATA(GMTSQIT)
QUIT
IF (AMHSDAT'=AMHSPVD)&AMHSDTU
SET GMTSNDM=GMTSNDM-AMHSDTU
SET AMHSPVD=AMHSDAT
IF GMTSNDM=0
QUIT
PTED ;display all pt ed (last of each)
+1 IF '$DATA(^AMHREDU("AC",BHSPAT))
GOTO OUTPTX
+2 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
SET X="******************** MH/SS PATIENT EDUCATION ******************** "
SET AMHS=""
SET $PIECE(AMHS," ",IOM-1-$LENGTH(X)/2)=""
WRITE !,AMHS,X,AMHS,!!
+3 KILL AMHSN
SET AMHSX=0
FOR
SET AMHSX=$ORDER(^AMHREDU("AC",BHSPAT,AMHSX))
IF AMHSX'=+AMHSX!($DATA(GMTSQIT))
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))
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(GMTSQIT))
QUIT
Begin DoDot:1
+7 SET AMHSX=0
FOR
SET AMHSX=$ORDER(AMHSD(AMHSD,AMHSX))
IF AMHSX'=+AMHSX!($DATA(GMTSQIT))
QUIT
Begin DoDot:2
+8 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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)
End DoDot:2
End DoDot:1
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,BHSTXT,BHSNRQ,BHSICL,Y,I,J,X
+3 KILL Y
+4 QUIT
ONEDATE SET X=-AMHSIVD\1+9999999
DO REGDT4^GMTSU
SET AMHSDAT=X
SET AMHSPFN=""
SET AMHSDTU=0
SET AMHSNDT=(AMHSDAT'=AMHSPVD)
+1 SET AMHSVDF=""
FOR AMHSQ=0:0
SET AMHSVDF=$ORDER(^AMHREC("AE",BHSPAT,AMHSIVD,AMHSVDF))
IF AMHSVDF=""
QUIT
SET AMHSN=^AMHREC(AMHSVDF,0)
DO GETSITE
DO DSPVIS
IF $DATA(GMTSQIT)
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 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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),!
+12 QUIT
End DoDot:1
IF $DATA(GMTSQIT)
QUIT
+13 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
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)) D CKP^GMTSUP Q:$D(GMTSQIT) S BHSNRQ="COMMENT: "_^AMHREC(AMHSVDF,12),BHSICL=27,BHSTXT="" D PRTTXT^BHSUTL
+16 QUIT
+17 ;
NOPOV ;
+1 SET BHSTXT=""
SET (AMHSICD,BHSNRQ)="<BH problem codes not yet entered>"
+2 GOTO COMMON
+3 ;
HASPOV ;
+1 NEW CODE,CODEIEN,CHK,FIRST,SEC,CHK,DESCT
+2 SET CODE=$PIECE(AMHSR,U)
+3 IF CODE=""
QUIT
+4 ;S CODEIEN="" S CODEIEN=$O(^AMHPROB("B",CODE,CODEIEN))
+5 SET CODEIEN=CODE
+6 SET BHSNRQ=$PIECE($GET(^AMHPROB(CODEIEN,0)),U)_" - "
+7 SET AMHSICD=$EXTRACT($PIECE($GET(^AMHPROB(CODEIEN,0)),U,2),1,45)
+8 SET Y=$LENGTH(BHSNRQ)
FOR X=Y:1:8
SET BHSNRQ=BHSNRQ_" "
+9 SET BHSNRQ=BHSNRQ_AMHSICD
SET BHSTXT=""
SET BHSICL=27
+10 DO COMMON
+11 SET CHK=$PIECE(^AUTNPOV($PIECE(AMHSR,U,4),0),U)
+12 ;Patch 9 added changes for SNOMED POVs
+13 IF CHK["|"
Begin DoDot:1
+14 SET FIRST=$PIECE(CHK,"|",1)
SET SEC=$PIECE(CHK,"|",2)
+15 SET DESCT=$$DESC^BSTSAPI(SEC_"^^1")
+16 SET CHK=$PIECE(DESCT,U,2)
+17 IF FIRST'=""
SET CHK=CHK_" | "_FIRST
End DoDot:1
+18 IF $PIECE(AMHSR,U,4)
SET BHSNRQ=BHSNRQ_CHK
SET BHSTXT=""
SET BHSICL=27
DO PRTTXT^BHSUTL
+19 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
+20 QUIT
COMMON ;
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
IF GMTSNPG
SET AMHSNDT=1
+2 IF AMHSNDT
WRITE AMHSDAT
SET AMHSPFN=""
SET AMHSNDT=0
+3 WRITE ?9,AMHSFAC,?18,$$PPINI^AMHUTIL(AMHSVDF),?22,AMHTOC
SET BHSICL=27
DO PRTTXT^BHSUTL
+4 QUIT
DATE(D) ;
+1 IF $GET(D)=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+$EXTRACT(D,1,3))
