Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMHPST

AMHPST.m

Go to the documentation of this file. 
  1. AMHPST ; IHS/CMI/LAB - STAGING TOOL DISPLAY ;
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
  1.  ;
  1.  ;
  1. START ;
  1.  NEW AMHX,AMHY,AMHP,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,AMHV,AMHBD,AMHED
  1.  NEW D,R
  1.  K AMHV
  1.  W:$D(IOF) @IOF
  1.  W $$CTR("Staging Report",80)
  1.  D DBHUSR^AMHUTIL
  1. PAT ;
  1.  S AMHP=""
  1.  S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DLAYGO,DIADD
  1.  I Y<0 W !,"No Patient Selected." Q
  1.  S AMHP=+Y
  1.  I AMHP,'$$ALLOWP^AMHUTIL(DUZ,AMHP) D NALLOWP^AMHUTIL D PAUSE^AMHLEA G PAT
  1.  I $G(AUPNDOD)]"" W !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!! H 2
  1.  ;
  1. D ;
  1.  K AMHED,AMHBD
  1.  K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date of Visit"
  1.  D ^DIR S:Y<1 AMHQUIT=1 G:Y<1 EOJ  S AMHBD=Y
  1.  K DIR S DIR(0)="DO^::EXP",DIR("A")="Enter Ending Date of Visit"
  1.  D ^DIR S:Y<1 AMHQUIT=1 Q:Y<1  S AMHED=Y
  1.  ;
  1.  I AMHED<AMHBD D  G D
  1.  . W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
  1. ZIS ;
  1.  G BROWSE
  1.  S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to ",DIR("B")="P" K DA D ^DIR K DIR
  1.  I $D(DIRUT) G EOJ
  1.  I $G(Y)="B" D BROWSE,EOJ Q
  1.  W !! S XBRP="PRINT^AMHPST",XBRC="",XBNS="AMH",XBRX="EOJ^AMHPST"
  1.  D ^XBDBQUE
  1.  D EOJ
  1.  Q
  1. BROWSE ;
  1.  S XBRP="VIEWR^XBLM(""PRINT^AMHPST"")"
  1.  S XBNS="AMH",XBRC="",XBRX="EOJ^AMHPST",XBIOP=0 D ^XBDBQUE
  1.  Q
  1.  ;
  1. EOJ ;
  1.  K AMHP,AMHPG,AMHQUIT,AMHX,AMHY,AMHR0,AMHBD,AMHED,AMHD,AMHV,AMHB
  1.  Q
  1.  ;
  1. EP(AMHP) ;EP to list for one patient
  1.  NEW AMHX,AMHY,AMHR0,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,AMHV,AMHBD,AMHED,AMHD,X,Y,DIC,DIE
  1.  D FULL^VALM1
  1.  W:$D(IOF) @IOF
  1.  D DBHUSR^AMHUTIL
  1.  W $$CTR("Staging Report",80)
  1.  I '$G(AMHP) D PAT,EOJ Q
  1.  D D
  1.  D EOJ
  1.  Q
  1. PRINT ;EP - called from xbdbque
  1.  S AMHQUIT=0,AMHPG=0
  1.  ;gather up all staging tool records in ^TMP("AMHPST",$J
  1.  K ^TMP("AMHPST",$J)
  1.  D HEADING
  1.  I '$O(^AMHRCDST("AC",AMHP,0)) W !,"No Staging Data has been entered for this patient." K ^TMP("AMHPST",$J) D PAUSE Q
  1.  D GATHER
  1.  D PRINT1
  1.  K ^TMP("AMHPST",$J) D PAUSE
  1.  Q
  1.  ;
  1. PRINT1 ;
  1.  I '$D(^TMP("AMHPST",$J)) W !,"No Staging Data in that time period." D PAUSE Q
  1.  S AMHD=0 F  S AMHD=$O(^TMP("AMHPST",$J,AMHD)) Q:AMHD'=+AMHD!(AMHQUIT)  D
  1.  .S AMHX=0 F  S AMHX=$O(^TMP("AMHPST",$J,AMHD,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT)  D
  1.  ..I $Y>(IOSL-8) D HEADING Q:AMHQUIT
  1.  ..S AMHV=$P(^AMHRCDST(AMHX,0),U),AMHR0=^AMHRCDST(AMHX,0)
  1.  ..W !,"Date of Encounter: ",$$FMTE^XLFDT(AMHD),?50,"Days Used Alcohol:",?70,$P(AMHR0,U,6)
  1.  ..W !,"Provider: ",$$PPNAME^AMHUTIL(AMHV),?50,"Days Used Drugs:",?70,$P(AMHR0,U,7)
  1.  ..W !,"Type of Contact: ",$$VAL^XBDIQ1(9002011,AMHV,.32),?50,"Days Hospitalized:",?70,$P(AMHR0,U,8)
  1.  ..W !,"Component Code: ",$$VAL^XBDIQ1(9002011,AMHV,1101),?50,"Alch/Drug Arrests:",?70,$P(AMHR0,U,9)
  1.  ..W !,"Tobacco Use: ",$$VAL^XBDIQ1(9002011.06,AMHX,.11)
  1.  ..W !,$$CTR("STAGES",80)
  1.  ..W !,"Alc/Sub",?10,"Physical",?20,"Emotional",?30,"Social",?40,"Cul/Spir",?50,"Behav",?60,"Voc/Educ",?70,"Average"
  1.  ..W ! S T=3 F X=12:1:18 W ?T,$P(AMHR0,U,X) S T=T+10
  1.  ..W ?70,$$VAL^XBDIQ1(9002011.06,AMHX,.018),!
  1.  ..Q
  1.  .Q
  1.  Q
  1. HEADING ;EP
  1.  G:'AMHPG HEADING1
  1.  K DIR I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S AMHQUIT="" Q
  1. HEADING1 ;
  1.  W:$D(IOF) @IOF S AMHPG=AMHPG+1
  1.  W !,$$LOC,?35,$$FMTE^XLFDT(DT),?70,"Page ",AMHPG,!
  1.  S X="STAGING REPORT for "_$P(^DPT(AMHP,0),U) W !,$$CTR(X,80),!
  1.  S X="Date Range: "_$$FMTE^XLFDT(AMHBD)_" - "_$$FMTE^XLFDT(AMHED) W $$CTR(X),!
  1.  W $TR($J("",80)," ","-"),!
  1.  Q
  1. GATHER ;
  1.  S AMHX=0 F  S AMHX=$O(^AMHRCDST("AC",AMHP,AMHX)) Q:AMHX'=+AMHX  D
  1.  .S Y=$P(^AMHRCDST(AMHX,0),U)
  1.  .Q:'$D(^AMHREC(Y,0))
  1.  .Q:'$$ALLOWVI^AMHUTIL(DUZ,Y)
  1.  .S D=$P($P(^AMHREC(Y,0),U),".")
  1.  .Q:D<AMHBD
  1.  .Q:D>AMHED
  1.  .S ^TMP("AMHPST",$J,D,AMHX)=""
  1.  .Q
  1.  Q
  1. PAUSE ; 
  1.  Q:$E(IOST)'="C"
  1.  Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1.  S DIR(0)="E",DIR("A")="Press return to continue or '^' to quit" D ^DIR K DIR,DA
  1.  S:$D(DIRUT) AMHQUIT=1
  1.  W:$D(IOF) @IOF
  1.  Q
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. FF ;EP
  1.  I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S AMHQUIT=1 Q
  1.  I $E(IOST)'="C" Q:'$P(AMHR0,U,8)  W !!,$TR($J(" ",79)," ","*"),!,$P(^DPT($P(AMHR0,U,8),0),U),?32,"HRN: " D
  1.  .S H=$P($G(^AUPNPAT($P(AMHR0,U,8),41,DUZ(2),0)),U,2)
  1.  .W H,?46,"DOB: ",$$FMTE^XLFDT($P(^DPT($P(AMHR0,U,8),0),U,3),"2D"),?59,"SSN: ",$$SSN^AMHUTIL($P(AMHR0,U,8)),!
  1.  W:$D(IOF) @IOF
  1.  Q
  1. HDR ; -- header code
  1.  Q
  1.  ;
  1. S(Y,F,C,T) ;EP - set up array
  1.  I '$G(F) S F=0
  1.  I '$G(T) S T=0
  1.  ;blank lines
  1.  F F=1:1:F S X="" D S1
  1.  S X=Y
  1.  I $G(C) S L=$L(Y),T=(80-L)/2 D  D S1 Q
  1.  .F %=1:1:(T-1) S X=" "_X
  1.  F %=1:1:T S X=" "_Y
  1.  D S1
  1.  Q
  1. S1 ;
  1.  S AMHC=AMHC+1
  1.  S ^TMP("AMHPST",$J,AMHC,0)=X
  1.  Q
  1. INIT ; -- init variables and list array
  1.  S VALMCNT=$O(^TMP("AMHPST",$J,""),-1)
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q