- 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
