Routine: AMHHS1

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

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

PROBSCH ;

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

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

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

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

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

AMHHS1.m