AMHPROB ; IHS/CMI/LAB - Display Problems and Notes ;
;;4.0;IHS BEHAVIORAL HEALTH;**2,5**;JUN 02, 2010;Build 18
;Called from data entry templates to display problems, AMHPAT must equal the patient DFN
Q:'$G(AMHPAT)
NEW AMHTC,AMHTCVD,AMHTDFN,AMHDFT,AMHTDLT,AMHDOI,AMHTDOO,AMHTDTM,AMHTDTN,AMHTF,AMHTFAC,AMHTFCN,AMHTFPP,AMHTICD,AMHTICL,AMHTILN
NEW AMHTITE,AMHTN,AMHTNAB,AMHTNDF,AMHTNFL,AMHTNFP,AMHTNRQ,AMHTNSH,AMHTPBN,AMHTPLN,AMHTPNM,AMHTPRB,AMHTQ,AMHTTAT,AMHTVSC
W !!,"PCC Problem 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
K AMHTCVD,AMHTQ,Y
D PROBX
W !,"Press any key to continue" R X:DTIME
K X
Q
COMMON ;
I '$D(^AUPNPROB("AC",AMHPAT)) W !,"********** No ",$S(AMHTTAT="A":"ACTIVE",1:"INACTIVE")," Problems on file for this Patient",! Q
K AMHTDFT S AMHTNDF=0
S AMHTFAC="" F AMHTQ=0:0 S AMHTFAC=$O(^AUPNPROB("AA",AMHPAT,AMHTFAC)) Q:'AMHTFAC D PROBSCH
I AMHTNDF=0 W !,"********** No ",$S(AMHTTAT="A":"ACTIVE",1:"INACTIVE")," Problems on file for this Patient",! Q
W !!,"******************",$S(AMHTTAT="A":" ACTIVE ",1:" INACTIVE "),"PROBLEMS AND 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
K AMHTNFL,AMHTNSH,AMHTNAB,AMHTVSC,AMHTITE
Q
PROBSCH ;
S AMHTPRB="" F AMHTQ=0:0 S AMHTPRB=$O(^AUPNPROB("AA",AMHPAT,AMHTFAC,AMHTPRB)) Q:AMHTPRB="" S AMHTDFN=$O(^(AMHTPRB,"")) S:$P(^AUPNPROB(AMHTDFN,0),U,12)=AMHTTAT AMHTNDF=AMHTNDF+1,AMHTDFT(AMHTFAC_AMHTPRB)=AMHTDFN
Q
PROBDSP ;
S AMHTN=^AUPNPROB(AMHTDFN,0)
S AMHTNRQ=$P(AMHTN,U,5)
S AMHTNRQ=$$GET1^DIQ(9000011,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 AMHTPNM=AMHTNAB_AMHTPNM
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
W AMHTPLN,?22,$$VAL^XBDIQ1(9000011,AMHTDFN,.01)
S AMHTICL=30,AMHTILN=48 D PRTICD
;D NOTEDSP
Q
NOTEDSP ; DISPLAY NOTES UNDER PROBLEM
S AMHTNFP=0 F AMHTQ=0:0 S AMHTNFP=$O(^AUPNPROB(AMHTDFN,11,AMHTNFP)) Q:'AMHTNFP D DSPFACN
Q
DSPFACN ; DISPLAY NOTES FOR SELECTED FACILITY
Q:$D(^AUPNPROB(AMHTDFN,11,AMHTNFP,11,0))'=1
Q:$O(^AUPNPROB(AMHTDFN,11,AMHTNFP,11,0))=""
S AMHTITE=^AUPNPROB(AMHTDFN,11,AMHTNFP,0) D GETSITE S AMHTFCN=AMHTNAB
S AMHTNDF=0 F AMHTQ=0:0 S AMHTNDF=$O(^AUPNPROB(AMHTDFN,11,AMHTNFP,11,AMHTNDF)) Q:'AMHTNDF D DSPN ; ACC
Q
DSPN ; DISPLAY SINGLE NOTE
S AMHTN=^AUPNPROB(AMHTDFN,11,AMHTNFP,11,AMHTNDF,0)
Q:$P(AMHTN,U,4)="I"
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
W AMHTPNM,AMHTFCN,$P(AMHTN,U),?12,AMHTDOI,?24,$P(AMHTN,U,3),!
K AMHTDOI
Q
;
PRTICD ;
S:AMHTNRQ="" AMHTNRQ="<no narrative provided>" S AMHTICD=""
S AMHTTXT=AMHTICD D PRTTXT
Q
;
PRTTXT ; GENERALIZED TEXT PRINTER
S AMHTDLT=1,AMHTILN=80-AMHTICL-1
I AMHTDOO]"" S AMHTNRQ=AMHTNRQ_" (ONSET: "_AMHTDOO_")"
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 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
AMHPROB ; IHS/CMI/LAB - Display Problems and Notes ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;**2,5**;JUN 02, 2010;Build 18
+2 ;Called from data entry templates to display problems, AMHPAT must equal the patient DFN
+3 IF '$GET(AMHPAT)
QUIT
+4 NEW AMHTC,AMHTCVD,AMHTDFN,AMHDFT,AMHTDLT,AMHDOI,AMHTDOO,AMHTDTM,AMHTDTN,AMHTF,AMHTFAC,AMHTFCN,AMHTFPP,AMHTICD,AMHTICL,AMHTILN
+5 NEW AMHTITE,AMHTN,AMHTNAB,AMHTNDF,AMHTNFL,AMHTNFP,AMHTNRQ,AMHTNSH,AMHTPBN,AMHTPLN,AMHTPNM,AMHTPRB,AMHTQ,AMHTTAT,AMHTVSC
+6 WRITE !!,"PCC Problem List for ",$PIECE(^DPT(AMHPAT,0),U),"."
+7 SET AMHTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_$E(Y,2,3)"
+8 SET AMHTTAT="A"
DO COMMON
SET AMHTTAT="I"
DO COMMON
+9 KILL AMHTCVD,AMHTQ,Y
+10 DO PROBX
+11 WRITE !,"Press any key to continue"
READ X:DTIME
+12 KILL X
+13 QUIT
COMMON ;
+1 IF '$DATA(^AUPNPROB("AC",AMHPAT))
WRITE !,"********** No ",$SELECT(AMHTTAT="A":"ACTIVE",1:"INACTIVE")," Problems on file for this Patient",!
QUIT
+2 KILL AMHTDFT
SET AMHTNDF=0
+3 SET AMHTFAC=""
FOR AMHTQ=0:0
SET AMHTFAC=$ORDER(^AUPNPROB("AA",AMHPAT,AMHTFAC))
IF 'AMHTFAC
QUIT
DO PROBSCH
+4 IF AMHTNDF=0
WRITE !,"********** No ",$SELECT(AMHTTAT="A":"ACTIVE",1:"INACTIVE")," Problems on file for this Patient",!
QUIT
+5 WRITE !!,"******************",$SELECT(AMHTTAT="A":" ACTIVE ",1:" INACTIVE "),"PROBLEMS AND 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
+1 KILL AMHTNFL,AMHTNSH,AMHTNAB,AMHTVSC,AMHTITE
+2 QUIT
PROBSCH ;
+1 SET AMHTPRB=""
FOR AMHTQ=0:0
SET AMHTPRB=$ORDER(^AUPNPROB("AA",AMHPAT,AMHTFAC,AMHTPRB))
IF AMHTPRB=""
QUIT
SET AMHTDFN=$ORDER(^(AMHTPRB,""))
IF $PIECE(^AUPNPROB(AMHTDFN,0),U,12)=AMHTTAT
SET AMHTNDF=AMHTNDF+1
SET AMHTDFT(AMHTFAC_AMHTPRB)=AMHTDFN
+2 QUIT
PROBDSP ;
+1 SET AMHTN=^AUPNPROB(AMHTDFN,0)
+2 SET AMHTNRQ=$PIECE(AMHTN,U,5)
+3 SET AMHTNRQ=$$GET1^DIQ(9000011,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 AMHTPNM=AMHTNAB_AMHTPNM
+9 SET Y=$PIECE(AMHTN,U,3)
XECUTE AMHTCVD
SET AMHTDTM=Y
+10 SET Y=$PIECE(AMHTN,U,8)
XECUTE AMHTCVD
SET AMHTDTN=Y
+11 SET AMHTPLN=AMHTPNM_$EXTRACT(" ",1,12-$LENGTH(AMHTPNM))_AMHTDTM
+12 WRITE AMHTPLN,?22,$$VAL^XBDIQ1(9000011,AMHTDFN,.01)
+13 SET AMHTICL=30
SET AMHTILN=48
DO PRTICD
+14 ;D NOTEDSP
+15 QUIT
NOTEDSP ; DISPLAY NOTES UNDER PROBLEM
+1 SET AMHTNFP=0
FOR AMHTQ=0:0
SET AMHTNFP=$ORDER(^AUPNPROB(AMHTDFN,11,AMHTNFP))
IF 'AMHTNFP
QUIT
DO DSPFACN
+2 QUIT
DSPFACN ; DISPLAY NOTES FOR SELECTED FACILITY
+1 IF $DATA(^AUPNPROB(AMHTDFN,11,AMHTNFP,11,0))'=1
QUIT
+2 IF $ORDER(^AUPNPROB(AMHTDFN,11,AMHTNFP,11,0))=""
QUIT
+3 SET AMHTITE=^AUPNPROB(AMHTDFN,11,AMHTNFP,0)
DO GETSITE
SET AMHTFCN=AMHTNAB
+4 ; ACC
SET AMHTNDF=0
FOR AMHTQ=0:0
SET AMHTNDF=$ORDER(^AUPNPROB(AMHTDFN,11,AMHTNFP,11,AMHTNDF))
IF 'AMHTNDF
QUIT
DO DSPN
+5 QUIT
DSPN ; DISPLAY SINGLE NOTE
+1 SET AMHTN=^AUPNPROB(AMHTDFN,11,AMHTNFP,11,AMHTNDF,0)
+2 IF $PIECE(AMHTN,U,4)="I"
QUIT
+3 FOR AMHTQ=0:0
IF $EXTRACT(AMHTFCN)'=" "
QUIT
SET AMHTFCN=$EXTRACT(AMHTFCN,2,99)
+4 SET AMHTDOI=$PIECE(AMHTN,U,5)
IF AMHTDOI]""
SET Y=AMHTDOI
XECUTE AMHTCVD
SET AMHTDOI=Y
+5 WRITE AMHTPNM,AMHTFCN,$PIECE(AMHTN,U),?12,AMHTDOI,?24,$PIECE(AMHTN,U,3),!
+6 KILL AMHTDOI
+7 QUIT
+8 ;
PRTICD ;
+1 IF AMHTNRQ=""
SET AMHTNRQ="<no narrative provided>"
SET AMHTICD=""
+2 SET AMHTTXT=AMHTICD
DO PRTTXT
+3 QUIT
+4 ;
PRTTXT ; GENERALIZED TEXT PRINTER
+1 SET AMHTDLT=1
SET AMHTILN=80-AMHTICL-1
+2 IF AMHTDOO]""
SET AMHTNRQ=AMHTNRQ_" (ONSET: "_AMHTDOO_")"
+3 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
+4 KILL AMHTILN,AMHTDLT,AMHTF,AMHTC,AMHTTXT,AMHTDOO
+5 QUIT
PRTTXT2 DO GETFRAG
WRITE ?AMHTICL
WRITE AMHTF,!
SET AMHTICL=AMHTICL+AMHTDLT
SET AMHTILN=AMHTILN-AMHTDLT
SET AMHTDLT=0
+1 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 ;
+5 ;
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
