AMHHS1 ; IHS/CMI/LAB - BH HEALTH SUMMARY COMPONENT PART 2 ;
;;4.0;IHS BEHAVIORAL HEALTH;**2,5**;JUN 02, 2010;Build 18
;
;
PROB ;EP
;get date last reviewed and display
X APCHSCKP Q:$D(APCHSQIT) S X="******************** BH ACTIVE PROBLEMS ********************",AMHS="",$P(AMHS," ",80-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
X APCHSCKP Q:$D(APCHSQIT) S X="******************** BH INACTIVE PROBLEMS ******************** ",AMHS="",$P(AMHS," ",80-1-$L(X)/2)="" W !,AMHS,X,AMHS,!
S AMHTTAT="I" D COMMON
S AMHSX=$$LASTPLR^AMHAPI6(APCHSPAT,,DT,"A")
X APCHSCKP Q:$D(APCHSQIT)
W !,"BH Problem List Reviewed: ",?36,$$FMTE^XLFDT($P(AMHSX,U,1)) W ?51,"By: ",?54,$E($S($P(AMHSX,U,3):$P($G(^VA(200,$P(AMHSX,U,3),0)),U),1:""),1,25),!
S AMHSX=$$LASTPLU^AMHAPI6(APCHSPAT,,DT,"A")
X APCHSCKP Q:$D(APCHSQIT)
W "BH Problem List Updated: ",?36,$$FMTE^XLFDT($P(AMHSX,U,1)) W ?51,"By: ",?54,$E($S($P(AMHSX,U,3):$P($G(^VA(200,$P(AMHSX,U,3),0)),U),1:""),1,25),!
S AMHSX=$$LASTNAP^AMHAPI6(APCHSPAT,,DT,"A")
X APCHSCKP Q:$D(APCHSQIT)
;I '$$ANYACTP^APCDAPRB(APCHSPAT) W !,"No Active Problems: ",?24,$$FMTE^XLFDT($P(AMHSX,U,1)) I $P(AMHSX,U,3) W ?39,"Documented By: ",?54,$E($P($G(^VA(200,$P(AMHSX,U,3),0)),U),1,25),!
W "No Active BH Problems Documented: ",?36,$$FMTE^XLFDT($P(AMHSX,U,1)) W ?51,"By: ",$E($S($P(AMHSX,U,3):$P($G(^VA(200,$P(AMHSX,U,3),0)),U),1:""),1,25),!
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",APCHSPAT,AMHTPRB)) Q:AMHTPRB="" S AMHTDFN=$O(^(AMHTPRB,"")) S:$P(^AMHPPROB(AMHTDFN,0),U,12)=AMHTTAT AMHTNDF=AMHTNDF+1,AMHTDFT(AMHTPRB)=AMHTDFN
I AMHTNDF=0 X APCHSCKP Q:$D(APCHSQIT) S X=" <NONE> ",AMHS="",$P(AMHS," ",80-1-$L(X)/2)="" W AMHS,X,AMHS,!
;X APCHSCKP Q:$D(APCHSQIT) 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,APCHSNRQ,AMHTPNM,AMHTDFN,AMHTFCN,AMHTICD,APCHSICL,AMHTILN,AMHTN,AMHSNRQ1,AMHTDOO
K AMHTNFL,AMHTNSH,AMHTNAB,AMHTVSC,AMHTITE
Q
PROBSCH ;
Q
PROBDSP ;
S AMHTN=^AMHPPROB(AMHTDFN,0)
S APCHSNRQ=$P(AMHTN,U,5)
S APCHSNRQ=$$GET1^DIQ(9002011.51,AMHTDFN,.05)
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
X APCHSCKP Q:$D(APCHSQIT) W !,AMHTPNM,?4,AMHTDTM S APCHSICL=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:"???")
X APCHSCKP Q:$D(APCHSQIT) W ?1,AMHTPNM_"-"_$P(AMHTN,U),?7,AMHTTPT,?11,AMHTDOI,?20,AMHHS("AUTHOR")
S APCHSNRQ=$P(AMHTN,U,4),APCHSICL=24,APCHSTXT="" S:APCHSNRQ="" APCHSNRQ="<<<NO NOTE NARRATIVE>>>" D PRTTXT^APCHSUTL
K AMHTDOI
Q
;
PRTICD ;
S:APCHSNRQ="" APCHSNRQ="<no narrative provided>" S AMHTICD=""
I AMHTDOO]"" S APCHSNRQ=APCHSNRQ_" (ONSET: "_AMHTDOO_")"
S AMHSNRQ1=APCHSNRQ
S APCHSNRQ="("_$P(^AMHPROB($P(AMHTN,U),0),U)_")"
S Y=$L(APCHSNRQ) F X=Y:1:9 S APCHSNRQ=APCHSNRQ_" "
S APCHSNRQ=APCHSNRQ_$P(^AMHPROB($P(AMHTN,U),0),U,2),APCHSTXT=""
D PRTTXT^APCHSUTL
S APCHSNRQ=AMHSNRQ1,APCHSICL=24,APCHSTXT="" D PRTTXT^APCHSUTL
Q
AMHHS1 ; IHS/CMI/LAB - BH HEALTH SUMMARY COMPONENT PART 2 ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**2,5**;JUN 02, 2010;Build 18
+2 ;
+3 ;
PROB ;EP
+1 ;get date last reviewed and display
+2 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
SET X="******************** BH ACTIVE PROBLEMS ********************"
SET AMHS=""
SET $PIECE(AMHS," ",80-1-$LENGTH(X)/2)=""
WRITE !,AMHS,X,AMHS,!
+3 SET AMHTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,2,3)"
+4 SET AMHTTAT="A"
DO COMMON
+5 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
SET X="******************** BH INACTIVE PROBLEMS ******************** "
SET AMHS=""
SET $PIECE(AMHS," ",80-1-$LENGTH(X)/2)=""
WRITE !,AMHS,X,AMHS,!
+6 SET AMHTTAT="I"
DO COMMON
+7 SET AMHSX=$$LASTPLR^AMHAPI6(APCHSPAT,,DT,"A")
+8 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+9 WRITE !,"BH Problem List Reviewed: ",?36,$$FMTE^XLFDT($PIECE(AMHSX,U,1))
WRITE ?51,"By: ",?54,$EXTRACT($SELECT($PIECE(AMHSX,U,3):$PIECE($GET(^VA(200,$PIECE(AMHSX,U,3),0)),U),1:""),1,25),!
+10 SET AMHSX=$$LASTPLU^AMHAPI6(APCHSPAT,,DT,"A")
+11 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+12 WRITE "BH Problem List Updated: ",?36,$$FMTE^XLFDT($PIECE(AMHSX,U,1))
WRITE ?51,"By: ",?54,$EXTRACT($SELECT($PIECE(AMHSX,U,3):$PIECE($GET(^VA(200,$PIECE(AMHSX,U,3),0)),U),1:""),1,25),!
+13 SET AMHSX=$$LASTNAP^AMHAPI6(APCHSPAT,,DT,"A")
+14 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
+15 ;I '$$ANYACTP^APCDAPRB(APCHSPAT) W !,"No Active Problems: ",?24,$$FMTE^XLFDT($P(AMHSX,U,1)) I $P(AMHSX,U,3) W ?39,"Documented By: ",?54,$E($P($G(^VA(200,$P(AMHSX,U,3),0)),U),1,25),!
+16 WRITE "No Active BH Problems Documented: ",?36,$$FMTE^XLFDT($PIECE(AMHSX,U,1))
WRITE ?51,"By: ",$EXTRACT($SELECT($PIECE(AMHSX,U,3):$PIECE($GET(^VA(200,$PIECE(AMHSX,U,3),0)),U),1:""),1,25),!
+17 KILL AMHTCVD,AMHTQ,Y,AMHHS,AMHPTP,AMHTTPT
+18 DO PROBX
+19 QUIT
COMMON ;
+1 KILL AMHTDFT
SET AMHTNDF=0
+2 SET AMHTPRB=""
FOR AMHTQ=0:0
SET AMHTPRB=$ORDER(^AMHPPROB("AA",APCHSPAT,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
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
SET X=" <NONE> "
SET AMHS=""
SET $PIECE(AMHS," ",80-1-$LENGTH(X)/2)=""
WRITE AMHS,X,AMHS,!
+4 ;X APCHSCKP Q:$D(APCHSQIT) 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,APCHSNRQ,AMHTPNM,AMHTDFN,AMHTFCN,AMHTICD,APCHSICL,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 APCHSNRQ=$PIECE(AMHTN,U,5)
+3 SET APCHSNRQ=$$GET1^DIQ(9002011.51,AMHTDFN,.05)
+4 SET AMHTDOO=$PIECE(AMHTN,U,13)
IF AMHTDOO]""
SET Y=AMHTDOO
XECUTE AMHTCVD
SET AMHTDOO=Y
+5 SET AMHTPNM=+$PIECE(AMHTN,U,7)
+6 SET Y=$PIECE(AMHTN,U,3)
XECUTE AMHTCVD
SET AMHTDTM=Y
+7 SET Y=$PIECE(AMHTN,U,8)
XECUTE AMHTCVD
SET AMHTDTN=Y
+8 ;S AMHTPLN=AMHTPNM_$E(" ",1,8-$L(AMHTPNM))_AMHTDTM
+9 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE !,AMHTPNM,?4,AMHTDTM
SET APCHSICL=14
SET AMHTILN=61
DO PRTICD
+10 DO NOTEDSP
+11 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 XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE ?1,AMHTPNM_"-"_$PIECE(AMHTN,U),?7,AMHTTPT,?11,AMHTDOI,?20,AMHHS("AUTHOR")
+7 SET APCHSNRQ=$PIECE(AMHTN,U,4)
SET APCHSICL=24
SET APCHSTXT=""
IF APCHSNRQ=""
SET APCHSNRQ="<<<NO NOTE NARRATIVE>>>"
DO PRTTXT^APCHSUTL
+8 KILL AMHTDOI
+9 QUIT
+10 ;
PRTICD ;
+1 IF APCHSNRQ=""
SET APCHSNRQ="<no narrative provided>"
SET AMHTICD=""
+2 IF AMHTDOO]""
SET APCHSNRQ=APCHSNRQ_" (ONSET: "_AMHTDOO_")"
+3 SET AMHSNRQ1=APCHSNRQ
+4 SET APCHSNRQ="("_$PIECE(^AMHPROB($PIECE(AMHTN,U),0),U)_")"
+5 SET Y=$LENGTH(APCHSNRQ)
FOR X=Y:1:9
SET APCHSNRQ=APCHSNRQ_" "
+6 SET APCHSNRQ=APCHSNRQ_$PIECE(^AMHPROB($PIECE(AMHTN,U),0),U,2)
SET APCHSTXT=""
+7 DO PRTTXT^APCHSUTL
+8 SET APCHSNRQ=AMHSNRQ1
SET APCHSICL=24
SET APCHSTXT=""
DO PRTTXT^APCHSUTL
+9 QUIT
