- 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
