AMHDMHPL ; IHS/CMI/LAB - Display Problems and Notes ;
;;4.0;IHS BEHAVIORAL HEALTH;**5**;JUN 02, 2010;Build 18
;Called from data entry templates to display problems, AMHPAT must equal the patient DFN
EN ;EP
Q:'$G(AMHPAT)
W:$D(IOF) @IOF
W !!,"BEHAVIORAL HEALTH Diagnosis List for ",$P(^DPT(AMHPAT,0),U),"."
S AMHTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,2,3)"
S AMHTTAT="A" D COMMON S AMHTTAT="I" D COMMON
I $G(AMHPLC)=9 D PAUSE^AMHLEA
K AMHTCVD,AMHTQ,Y,%
D PROBX
Q
COMMON ;
I '$D(^AMHPPROB("AC",AMHPAT)) W !,"***** No BH Problems on file for this Patient",! Q
K AMHTDFT S AMHTNDF=0
S AMHTPRB="" F AMHTQ=0:0 S AMHTPRB=$O(^AMHPPROB("AA",AMHPAT,AMHTPRB)) Q:AMHTPRB="" S AMHTDFN=$O(^(AMHTPRB,"")) S:$P(^AMHPPROB(AMHTDFN,0),U,12)=AMHTTAT AMHTNDF=AMHTNDF+1,AMHTDFT(AMHTPRB)=AMHTDFN
Q:AMHTNDF=0
W !!?10,"***** ",$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,AMHTFAC,AMHTPLN,AMHTPBN,AMHTDTM,AMHTDTN,AMHTPRB,AMHTTAT,AMHTNFP,AMHTNRQ,AMHTPNM,AMHTDFN,AMHTFCN,AMHTICD,AMHTICL,AMHTILN,AMHTN,AMHTNRQ1
K AMHTNFL,AMHTNSH,AMHTNAB,AMHTVSC,AMHTITE,AMHDMHPL,AMHTTPT,AMHTTPT,AMHTL
K Y
Q
PROBDSP ;
S AMHTN=^AMHPPROB(AMHTDFN,0)
S AMHTNRQ=$P(AMHTN,U,5)
S AMHTNRQ=$$GET1^DIQ(9002011.51,AMHTDFN,.05)
S AMHTDOO=$P(AMHTN,U,13) I AMHTDOO]"" S Y=AMHTDOO X AMHTCVD S AMHTDOO=Y
S AMHTITE=$P(AMHTN,U,6)
D GETSITE
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,12-$L(AMHTPNM))_AMHTDTM
I AMHTDOO]"" S AMHTNRQ=AMHTNRQ_" (ONSET: "_AMHTDOO_")"
S AMHTNRQ1=AMHTNRQ
S AMHTNRQ="("_$P(^AMHPROB($P(AMHTN,U),0),U)_")"
S Y=$L(AMHTNRQ) F X=Y:1:9 S AMHTNRQ=AMHTNRQ_" "
S AMHTNRQ=AMHTNRQ_$P(^AMHPROB($P(AMHTN,U),0),U,2),AMHTTXT=""
I $Y>(IOSL-3) D FF
W !,AMHTPNM,?4,AMHTDTM S AMHTICL=14,AMHTILN=61 D PRTICD
S AMHTICL=24,AMHTTXT="",AMHTNRQ=AMHTNRQ1 D PRTICD
D NOTEDSP
Q
NOTEDSP ; DISPLAY NOTES UNDER PROBLEM
Q:'$D(^AMHPTP("AE",AMHTDFN))
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)
;F AMHTQ=0:0 Q:$E(AMHTFCN)'=" " S AMHTFCN=$E(AMHTFCN,2,99)
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 AMHDMHPL("AUTH")=$P(AMHTN,U,6) S AMHDMHPL("AUTH")=$S(AMHDMHPL("AUTH")]"":$P(^VA(200,AMHDMHPL("AUTH"),0),U,2),1:"???")
I $Y>(IOSL-3) D FF
W ?1,AMHTPNM_"-"_$P(AMHTN,U),?7,AMHTTPT,?11,AMHTDOI,?20,AMHDMHPL("AUTH")
S AMHTNRQ=$P(AMHTN,U,4),AMHTICL=24,AMHTTXT="" S:AMHTNRQ="" AMHTNRQ="<<<NO NOTE NARRATIVE>>>" D PRTTXT
K AMHTDOI,AMHTTPT,AMHDMHPL("AUTH")
Q
;
PRTICD ;
S:AMHTNRQ="" AMHTNRQ="<no narrative provided>"
D PRTTXT
Q
;
PRTTXT ; GENERALIZED TEXT PRINTER
S AMHTDLT=1,AMHTILN=80-AMHTICL-1
F AMHTQ=0:0 S:AMHTNRQ]""&(($L(AMHTNRQ)+$L(AMHTTXT)+2)<255) AMHTTXT=$S(AMHTTXT]"":AMHTTXT_"; ",1:"")_AMHTNRQ,AMHTNRQ="" Q:AMHTTXT="" D PRTTXT2
K AMHTILN,AMHTDLT,AMHTF,AMHTC,AMHTTXT,AMHTDOO
Q
PRTTXT2 D GETFRAG
I $Y>(IOSL-3) D FF
W ?AMHTICL W AMHTF,! S AMHTICL=AMHTICL+AMHTDLT,AMHTILN=AMHTILN-AMHTDLT,AMHTDLT=0
Q
GETFRAG I $L(AMHTTXT)<AMHTILN S AMHTF=AMHTTXT,AMHTTXT="" Q
F AMHTC=AMHTILN:-1:1 Q:$E(AMHTTXT,AMHTC)=" "
S AMHTF=$E(AMHTTXT,1,AMHTC-1),AMHTTXT=$E(AMHTTXT,AMHTC+1,255)
Q
;
GETSITE ;
S:AMHTITE="" AMHTITE="null"
S %=$G(^AUTTLOC(AMHTITE,0))
S AMHTNFL=$P(%,U),AMHTNFL=$S($D(^DIC(4,AMHTITE,0)):$P(^(0),U),1:"<"_AMHTITE_">")
S AMHTNSH=$P(%,U,2) I AMHTNSH="" S AMHTNSH="<"_AMHTITE_">"
S AMHTNAB=$J($P(%,U,7),4) I AMHTNAB="" S AMHTNAB="<"_AMHTITE_">"
Q
FF ;
I $E(IOST)="C",IO=IO(0) W ! S DIR("A")="Press enter to continue",DIR(0)="EO" D ^DIR K DIR
W:$D(IOF) @IOF
Q
AMHDMHPL ; IHS/CMI/LAB - Display Problems and Notes ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**5**;JUN 02, 2010;Build 18
+2 ;Called from data entry templates to display problems, AMHPAT must equal the patient DFN
EN ;EP
+1 IF '$GET(AMHPAT)
QUIT
+2 IF $DATA(IOF)
WRITE @IOF
+3 WRITE !!,"BEHAVIORAL HEALTH Diagnosis List for ",$PIECE(^DPT(AMHPAT,0),U),"."
+4 SET AMHTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,2,3)"
+5 SET AMHTTAT="A"
DO COMMON
SET AMHTTAT="I"
DO COMMON
+6 IF $GET(AMHPLC)=9
DO PAUSE^AMHLEA
+7 KILL AMHTCVD,AMHTQ,Y,%
+8 DO PROBX
+9 QUIT
COMMON ;
+1 IF '$DATA(^AMHPPROB("AC",AMHPAT))
WRITE !,"***** No BH Problems on file for this Patient",!
QUIT
+2 KILL AMHTDFT
SET AMHTNDF=0
+3 SET AMHTPRB=""
FOR AMHTQ=0:0
SET AMHTPRB=$ORDER(^AMHPPROB("AA",AMHPAT,AMHTPRB))
IF AMHTPRB=""
QUIT
SET AMHTDFN=$ORDER(^(AMHTPRB,""))
IF $PIECE(^AMHPPROB(AMHTDFN,0),U,12)=AMHTTAT
SET AMHTNDF=AMHTNDF+1
SET AMHTDFT(AMHTPRB)=AMHTDFN
+4 IF AMHTNDF=0
QUIT
+5 WRITE !!?10,"***** ",$SELECT(AMHTTAT="A":" ACTIVE ",1:" INACTIVE "),"PROBLEMS AND TREATMENT NOTES/NOTES ***** ",!!
+6 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,AMHTFAC,AMHTPLN,AMHTPBN,AMHTDTM,AMHTDTN,AMHTPRB,AMHTTAT,AMHTNFP,AMHTNRQ,AMHTPNM,AMHTDFN,AMHTFCN,AMHTICD,AMHTICL,AMHTILN,AMHTN,AMHTNRQ1
+1 KILL AMHTNFL,AMHTNSH,AMHTNAB,AMHTVSC,AMHTITE,AMHDMHPL,AMHTTPT,AMHTTPT,AMHTL
+2 KILL Y
+3 QUIT
PROBDSP ;
+1 SET AMHTN=^AMHPPROB(AMHTDFN,0)
+2 SET AMHTNRQ=$PIECE(AMHTN,U,5)
+3 SET AMHTNRQ=$$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 AMHTITE=$PIECE(AMHTN,U,6)
+6 DO GETSITE
+7 SET AMHTPNM=+$PIECE(AMHTN,U,7)
+8 SET Y=$PIECE(AMHTN,U,3)
XECUTE AMHTCVD
SET AMHTDTM=Y
+9 SET Y=$PIECE(AMHTN,U,8)
XECUTE AMHTCVD
SET AMHTDTN=Y
+10 ;S AMHTPLN=AMHTPNM_$E(" ",1,12-$L(AMHTPNM))_AMHTDTM
+11 IF AMHTDOO]""
SET AMHTNRQ=AMHTNRQ_" (ONSET: "_AMHTDOO_")"
+12 SET AMHTNRQ1=AMHTNRQ
+13 SET AMHTNRQ="("_$PIECE(^AMHPROB($PIECE(AMHTN,U),0),U)_")"
+14 SET Y=$LENGTH(AMHTNRQ)
FOR X=Y:1:9
SET AMHTNRQ=AMHTNRQ_" "
+15 SET AMHTNRQ=AMHTNRQ_$PIECE(^AMHPROB($PIECE(AMHTN,U),0),U,2)
SET AMHTTXT=""
+16 IF $Y>(IOSL-3)
DO FF
+17 WRITE !,AMHTPNM,?4,AMHTDTM
SET AMHTICL=14
SET AMHTILN=61
DO PRTICD
+18 SET AMHTICL=24
SET AMHTTXT=""
SET AMHTNRQ=AMHTNRQ1
DO PRTICD
+19 DO NOTEDSP
+20 QUIT
NOTEDSP ; DISPLAY NOTES UNDER PROBLEM
+1 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 ;F AMHTQ=0:0 Q:$E(AMHTFCN)'=" " S AMHTFCN=$E(AMHTFCN,2,99)
+4 SET AMHTDOI=$PIECE(AMHTN,U,5)
IF AMHTDOI]""
SET Y=AMHTDOI
XECUTE AMHTCVD
SET AMHTDOI=Y
+5 SET AMHTTPT=$PIECE(AMHTN,U,7)
SET AMHTTPT=$SELECT(AMHTTPT=1:"STP",AMHTTPT=2:"LTP",1:" ")
+6 SET AMHDMHPL("AUTH")=$PIECE(AMHTN,U,6)
SET AMHDMHPL("AUTH")=$SELECT(AMHDMHPL("AUTH")]"":$PIECE(^VA(200,AMHDMHPL("AUTH"),0),U,2),1:"???")
+7 IF $Y>(IOSL-3)
DO FF
+8 WRITE ?1,AMHTPNM_"-"_$PIECE(AMHTN,U),?7,AMHTTPT,?11,AMHTDOI,?20,AMHDMHPL("AUTH")
+9 SET AMHTNRQ=$PIECE(AMHTN,U,4)
SET AMHTICL=24
SET AMHTTXT=""
IF AMHTNRQ=""
SET AMHTNRQ="<<<NO NOTE NARRATIVE>>>"
DO PRTTXT
+10 KILL AMHTDOI,AMHTTPT,AMHDMHPL("AUTH")
+11 QUIT
+12 ;
PRTICD ;
+1 IF AMHTNRQ=""
SET AMHTNRQ="<no narrative provided>"
+2 DO PRTTXT
+3 QUIT
+4 ;
PRTTXT ; GENERALIZED TEXT PRINTER
+1 SET AMHTDLT=1
SET AMHTILN=80-AMHTICL-1
+2 FOR AMHTQ=0:0
IF AMHTNRQ]""&(($LENGTH(AMHTNRQ)+$LENGTH(AMHTTXT)+2)<255)
SET AMHTTXT=$SELECT(AMHTTXT]"":AMHTTXT_"; ",1:"")_AMHTNRQ
SET AMHTNRQ=""
IF AMHTTXT=""
QUIT
DO PRTTXT2
+3 KILL AMHTILN,AMHTDLT,AMHTF,AMHTC,AMHTTXT,AMHTDOO
+4 QUIT
PRTTXT2 DO GETFRAG
+1 IF $Y>(IOSL-3)
DO FF
+2 WRITE ?AMHTICL
WRITE AMHTF,!
SET AMHTICL=AMHTICL+AMHTDLT
SET AMHTILN=AMHTILN-AMHTDLT
SET AMHTDLT=0
+3 QUIT
GETFRAG IF $LENGTH(AMHTTXT)<AMHTILN
SET AMHTF=AMHTTXT
SET AMHTTXT=""
QUIT
+1 FOR AMHTC=AMHTILN:-1:1
IF $EXTRACT(AMHTTXT,AMHTC)=" "
QUIT
+2 SET AMHTF=$EXTRACT(AMHTTXT,1,AMHTC-1)
SET AMHTTXT=$EXTRACT(AMHTTXT,AMHTC+1,255)
+3 QUIT
+4 ;
GETSITE ;
+1 IF AMHTITE=""
SET AMHTITE="null"
+2 SET %=$GET(^AUTTLOC(AMHTITE,0))
+3 SET AMHTNFL=$PIECE(%,U)
SET AMHTNFL=$SELECT($DATA(^DIC(4,AMHTITE,0)):$PIECE(^(0),U),1:"<"_AMHTITE_">")
+4 SET AMHTNSH=$PIECE(%,U,2)
IF AMHTNSH=""
SET AMHTNSH="<"_AMHTITE_">"
+5 SET AMHTNAB=$JUSTIFY($PIECE(%,U,7),4)
IF AMHTNAB=""
SET AMHTNAB="<"_AMHTITE_">"
+6 QUIT
FF ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR("A")="Press enter to continue"
SET DIR(0)="EO"
DO ^DIR
KILL DIR
+2 IF $DATA(IOF)
WRITE @IOF
+3 QUIT
