BHSBH1 ;IHS/CIA/MGH - Health Summary for Behavioral Health ;17-Mar-2006 10:36;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
;===================================================================
;Taken from AMHHS1
; IHS/CMI/LAB - BH HEALTH SUMMARY COMPONENT PART 2 ;
;;3.0;IHS BEHAVIORAL HEALTH;;JAN 27, 2003
;Continuation of converion of behavioral health over to VA health summary
;=====================================================================
PROB ;EP
D CKP^GMTSUP Q:$D(GMTSQIT) S X="******************** BH ACTIVE PROBLEMS ********************",AMHS="",$P(AMHS," ",IOM-1-$L(X)/2)="" W !,AMHS,X,AMHS,!
S AMHTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,2,3)"
S AMHTTAT="A" D COMMON
D CKP^GMTSUP Q:$D(GMTSQIT) S X="******************** BH INACTIVE PROBLEMS ******************** ",AMHS="",$P(AMHS," ",IOM-1-$L(X)/2)="" W !,AMHS,X,AMHS,!
S AMHTTAT="I" D COMMON
K AMHTCVD,AMHTQ,Y,AMHHS,AMHPTP,AMHTTPT
D PROBX
Q
COMMON ;
K AMHTDFT S AMHTNDF=0
S AMHTPRB="" F AMHTQ=0:0 S AMHTPRB=$O(^AMHPPROB("AA",BHSPAT,AMHTPRB)) Q:AMHTPRB="" S AMHTDFN=$O(^(AMHTPRB,"")) S:$P(^AMHPPROB(AMHTDFN,0),U,12)=AMHTTAT AMHTNDF=AMHTNDF+1,AMHTDFT(AMHTPRB)=AMHTDFN
I AMHTNDF=0 D CKP^GMTSUP Q:$D(GMTSQIT) S X=" <NONE> ",AMHS="",$P(AMHS," ",IOM-1-$L(X)/2)="" W AMHS,X,AMHS,!
;D CKP^GMTSUP Q:$D(GMTSQIT) W !!,"***** ",$S(AMHTTAT="A":" ACTIVE ",1:" INACTIVE "),"PROBLEMS AND TREATMENT NOTES/NOTES ***** ",!!
S AMHTFPP="" F AMHTQ=0:0 S AMHTFPP=$O(AMHTDFT(AMHTFPP)) Q:AMHTFPP="" S AMHTDFN=AMHTDFT(AMHTFPP) D PROBDSP
PROBX K AMHTDFT,AMHTNDF,AMHTFPP,AMHTPLN,AMHTPBN,AMHTDTM,AMHTDTN,AMHTPRB,AMHTTAT,AMHTNFP,BHSNRQ,AMHTPNM,AMHTDFN,AMHTFCN,AMHTICD,BHSICL,AMHTILN,AMHTN,AMHSNRQ1,AMHTDOO
K AMHTNFL,AMHTNSH,AMHTNAB,AMHTVSC,AMHTITE
Q
PROBSCH ;
Q
PROBDSP ;
S AMHTN=^AMHPPROB(AMHTDFN,0)
S BHSNRQ=$P(AMHTN,U,5)
D GETNARR I 1
E S BHSNRQ=""
S AMHTDOO=$P(AMHTN,U,13) I AMHTDOO]"" S Y=AMHTDOO X AMHTCVD S AMHTDOO=Y
S AMHTPNM=+$P(AMHTN,U,7)
S Y=$P(AMHTN,U,3) X AMHTCVD S AMHTDTM=Y
S Y=$P(AMHTN,U,8) X AMHTCVD S AMHTDTN=Y
;S AMHTPLN=AMHTPNM_$E(" ",1,8-$L(AMHTPNM))_AMHTDTM
D CKP^GMTSUP Q:$D(GMTSQIT) W !,AMHTPNM,?4,AMHTDTM S BHSICL=14,AMHTILN=61 D PRTICD
D NOTEDSP
Q
NOTEDSP ; DISPLAY NOTES UNDER PROBLEM
Q:'$D(^AMHPTP("AE",AMHTDFN)) ;no notes
S AMHTNDF=0 F AMHTQ=0:0 S AMHTNDF=$O(^AMHPTP("AE",AMHTDFN,AMHTNDF)) Q:'AMHTNDF D DSPN
Q
DSPN ; DISPLAY SINGLE NOTE
S X=$O(^AMHPTP("AE",AMHTDFN,AMHTNDF,"")) Q:X=""
S AMHTN=^AMHPTP(X,0)
S AMHTDOI=$P(AMHTN,U,5) I AMHTDOI]"" S Y=AMHTDOI X AMHTCVD S AMHTDOI=Y
S AMHTTPT=$P(AMHTN,U,7) S AMHTTPT=$S(AMHTTPT=1:"STP",AMHTTPT=2:"LTP",1:" ")
S AMHHS("AUTHOR")=$P(AMHTN,U,6) S AMHHS("AUTHOR")=$S(AMHHS("AUTHOR")]"":$$PROVINI^XBFUNC1($P(AMHTN,U,6)),1:"???")
D CKP^GMTSUP Q:$D(GMTSQIT) W ?1,AMHTPNM_"-"_$P(AMHTN,U),?7,AMHTTPT,?11,AMHTDOI,?20,AMHHS("AUTHOR")
S BHSNRQ=$P(AMHTN,U,4),BHSICL=24,BHSTXT="" S:BHSNRQ="" BHSNRQ="<<<NO NOTE NARRATIVE>>>" D PRTTXT^BHSUTL
K AMHTDOI
Q
;
PRTICD ;
S:BHSNRQ="" BHSNRQ="<no narrative provided>" S AMHTICD=""
I AMHTDOO]"" S BHSNRQ=BHSNRQ_" (ONSET: "_AMHTDOO_")"
S AMHSNRQ1=BHSNRQ
S BHSNRQ="("_$P(^AMHPROB($P(AMHTN,U),0),U)_")"
S Y=$L(BHSNRQ) F X=Y:1:9 S BHSNRQ=BHSNRQ_" "
S BHSNRQ=BHSNRQ_$P(^AMHPROB($P(AMHTN,U),0),U,2),BHSTXT=""
D PRTTXT^BHSUTL
S BHSNRQ=AMHSNRQ1,BHSICL=24,BHSTXT="" D PRTTXT^BHSUTL
Q
;
;
GETNARR ;
I BHSNRQ]"" S BHSNRQ=$S($D(^AUTNPOV(BHSNRQ)):$P(^AUTNPOV(BHSNRQ,0),U),1:"***** "_BHSNRQ_" *****")
E S BHSNRQ=""
Q
;
BHSBH1 ;IHS/CIA/MGH - Health Summary for Behavioral Health ;17-Mar-2006 10:36;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;;March 17, 2006
+2 ;===================================================================
+3 ;Taken from AMHHS1
+4 ; IHS/CMI/LAB - BH HEALTH SUMMARY COMPONENT PART 2 ;
+5 ;;3.0;IHS BEHAVIORAL HEALTH;;JAN 27, 2003
+6 ;Continuation of converion of behavioral health over to VA health summary
+7 ;=====================================================================
PROB ;EP
+1 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
SET X="******************** BH ACTIVE PROBLEMS ********************"
SET AMHS=""
SET $PIECE(AMHS," ",IOM-1-$LENGTH(X)/2)=""
WRITE !,AMHS,X,AMHS,!
+2 SET AMHTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,2,3)"
+3 SET AMHTTAT="A"
DO COMMON
+4 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
SET X="******************** BH INACTIVE PROBLEMS ******************** "
SET AMHS=""
SET $PIECE(AMHS," ",IOM-1-$LENGTH(X)/2)=""
WRITE !,AMHS,X,AMHS,!
+5 SET AMHTTAT="I"
DO COMMON
+6 KILL AMHTCVD,AMHTQ,Y,AMHHS,AMHPTP,AMHTTPT
+7 DO PROBX
+8 QUIT
COMMON ;
+1 KILL AMHTDFT
SET AMHTNDF=0
+2 SET AMHTPRB=""
FOR AMHTQ=0:0
SET AMHTPRB=$ORDER(^AMHPPROB("AA",BHSPAT,AMHTPRB))
IF AMHTPRB=""
QUIT
SET AMHTDFN=$ORDER(^(AMHTPRB,""))
IF $PIECE(^AMHPPROB(AMHTDFN,0),U,12)=AMHTTAT
SET AMHTNDF=AMHTNDF+1
SET AMHTDFT(AMHTPRB)=AMHTDFN
+3 IF AMHTNDF=0
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
SET X=" <NONE> "
SET AMHS=""
SET $PIECE(AMHS," ",IOM-1-$LENGTH(X)/2)=""
WRITE AMHS,X,AMHS,!
+4 ;D CKP^GMTSUP Q:$D(GMTSQIT) W !!,"***** ",$S(AMHTTAT="A":" ACTIVE ",1:" INACTIVE "),"PROBLEMS AND TREATMENT NOTES/NOTES ***** ",!!
+5 SET AMHTFPP=""
FOR AMHTQ=0:0
SET AMHTFPP=$ORDER(AMHTDFT(AMHTFPP))
IF AMHTFPP=""
QUIT
SET AMHTDFN=AMHTDFT(AMHTFPP)
DO PROBDSP
PROBX KILL AMHTDFT,AMHTNDF,AMHTFPP,AMHTPLN,AMHTPBN,AMHTDTM,AMHTDTN,AMHTPRB,AMHTTAT,AMHTNFP,BHSNRQ,AMHTPNM,AMHTDFN,AMHTFCN,AMHTICD,BHSICL,AMHTILN,AMHTN,AMHSNRQ1,AMHTDOO
+1 KILL AMHTNFL,AMHTNSH,AMHTNAB,AMHTVSC,AMHTITE
+2 QUIT
PROBSCH ;
+1 QUIT
PROBDSP ;
+1 SET AMHTN=^AMHPPROB(AMHTDFN,0)
+2 SET BHSNRQ=$PIECE(AMHTN,U,5)
+3 DO GETNARR
IF 1
+4 IF '$TEST
SET BHSNRQ=""
+5 SET AMHTDOO=$PIECE(AMHTN,U,13)
IF AMHTDOO]""
SET Y=AMHTDOO
XECUTE AMHTCVD
SET AMHTDOO=Y
+6 SET AMHTPNM=+$PIECE(AMHTN,U,7)
+7 SET Y=$PIECE(AMHTN,U,3)
XECUTE AMHTCVD
SET AMHTDTM=Y
+8 SET Y=$PIECE(AMHTN,U,8)
XECUTE AMHTCVD
SET AMHTDTN=Y
+9 ;S AMHTPLN=AMHTPNM_$E(" ",1,8-$L(AMHTPNM))_AMHTDTM
+10 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE !,AMHTPNM,?4,AMHTDTM
SET BHSICL=14
SET AMHTILN=61
DO PRTICD
+11 DO NOTEDSP
+12 QUIT
NOTEDSP ; DISPLAY NOTES UNDER PROBLEM
+1 ;no notes
IF '$DATA(^AMHPTP("AE",AMHTDFN))
QUIT
+2 SET AMHTNDF=0
FOR AMHTQ=0:0
SET AMHTNDF=$ORDER(^AMHPTP("AE",AMHTDFN,AMHTNDF))
IF 'AMHTNDF
QUIT
DO DSPN
+3 QUIT
DSPN ; DISPLAY SINGLE NOTE
+1 SET X=$ORDER(^AMHPTP("AE",AMHTDFN,AMHTNDF,""))
IF X=""
QUIT
+2 SET AMHTN=^AMHPTP(X,0)
+3 SET AMHTDOI=$PIECE(AMHTN,U,5)
IF AMHTDOI]""
SET Y=AMHTDOI
XECUTE AMHTCVD
SET AMHTDOI=Y
+4 SET AMHTTPT=$PIECE(AMHTN,U,7)
SET AMHTTPT=$SELECT(AMHTTPT=1:"STP",AMHTTPT=2:"LTP",1:" ")
+5 SET AMHHS("AUTHOR")=$PIECE(AMHTN,U,6)
SET AMHHS("AUTHOR")=$SELECT(AMHHS("AUTHOR")]"":$$PROVINI^XBFUNC1($PIECE(AMHTN,U,6)),1:"???")
+6 DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE ?1,AMHTPNM_"-"_$PIECE(AMHTN,U),?7,AMHTTPT,?11,AMHTDOI,?20,AMHHS("AUTHOR")
+7 SET BHSNRQ=$PIECE(AMHTN,U,4)
SET BHSICL=24
SET BHSTXT=""
IF BHSNRQ=""
SET BHSNRQ="<<<NO NOTE NARRATIVE>>>"
DO PRTTXT^BHSUTL
+8 KILL AMHTDOI
+9 QUIT
+10 ;
PRTICD ;
+1 IF BHSNRQ=""
SET BHSNRQ="<no narrative provided>"
SET AMHTICD=""
+2 IF AMHTDOO]""
SET BHSNRQ=BHSNRQ_" (ONSET: "_AMHTDOO_")"
+3 SET AMHSNRQ1=BHSNRQ
+4 SET BHSNRQ="("_$PIECE(^AMHPROB($PIECE(AMHTN,U),0),U)_")"
+5 SET Y=$LENGTH(BHSNRQ)
FOR X=Y:1:9
SET BHSNRQ=BHSNRQ_" "
+6 SET BHSNRQ=BHSNRQ_$PIECE(^AMHPROB($PIECE(AMHTN,U),0),U,2)
SET BHSTXT=""
+7 DO PRTTXT^BHSUTL
+8 SET BHSNRQ=AMHSNRQ1
SET BHSICL=24
SET BHSTXT=""
DO PRTTXT^BHSUTL
+9 QUIT
+10 ;
+11 ;
GETNARR ;
+1 IF BHSNRQ]""
SET BHSNRQ=$SELECT($DATA(^AUTNPOV(BHSNRQ)):$PIECE(^AUTNPOV(BHSNRQ,0),U),1:"***** "_BHSNRQ_" *****")
+2 IF '$TEST
SET BHSNRQ=""
+3 QUIT
+4 ;
