- 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 ;
