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