AMHRC5 ; IHS/CMI/LAB - PERSONAL HX REPORT ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
START ;
I '$D(IOF) D HOME^%ZIS
W @(IOF),!!
W "******* LIST OF PATIENTS WITH PERSONAL HISTORY ITEMS *******",!!
D DBHUSRP^AMHUTIL
;
DEMO ;
D DEMOCHK^AMHUTIL1(.AMHDEMO)
I AMHDEMO=-1 G XIT
ZIS ;
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 XIT
I $G(Y)="B" D BROWSE,XIT Q
S XBRC="PROC^AMHRC5",XBRP="PRINT^AMHRC5",XBNS="AMH",XBRX="XIT^AMHRC5"
D ^XBDBQUE
XIT ;
D EN^XBVK("AMH")
Q
;
BROWSE ;
S XBRP="VIEWR^XBLM(""PRINT^AMHRC5"")"
S XBNS="AMH",XBRC="PROC^AMHRC5",XBRX="XIT^AMHRC5",XBIOP=0 D ^XBDBQUE
Q
PROC ;EP - entry point for processing
S AMHBT=$H K AMHDISP
S AMHCASE=0
F S AMHCASE=$O(^AMHPPHX(AMHCASE)) Q:AMHCASE'=+AMHCASE D PROC1
S AMHET=$H
K AMHCASE
Q
PROC1 ;
S AMHR=^AMHPPHX(AMHCASE,0)
Q:'$$ALLOWP^AMHUTIL(DUZ,$P(AMHR,U,2))
Q:$$DEMO^AMHUTIL1($P(AMHR,U,2),$G(AMHDEMO))
Q:$P(AMHR,U,1)=""
S X=$P(AMHR,U,1)
Q:'$D(^AMHTPHF(X))
S X=$P(^AMHTPHF(X,0),U)
S:'$D(AMHDISP(X)) AMHDISP(X)="" S AMHDISP(X)=AMHDISP(X)+1,AMHDISP(X,$P(^DPT($P(AMHR,U,2),0),U),$P(AMHR,U,2))=""
Q
PRINT ;EP - CALLED FROM XBDBQUE
S AMH80D="-------------------------------------------------------------------------------"
S AMHPG=0 D HEAD
K AMHQ
S AMHX="" F S AMHX=$O(AMHDISP(AMHX)) Q:AMHX=""!($D(AMHQ)) D
.I $Y>(IOSL-3) D HEAD Q:$D(AMHQ)
.W !!,?17,AMHX
.S AMHNAME="" F S AMHNAME=$O(AMHDISP(AMHX,AMHNAME)) Q:AMHNAME=""!($D(AMHQ)) D
..S AMHP=0 F S AMHP=$O(AMHDISP(AMHX,AMHNAME,AMHP)) Q:AMHP'=+AMHP!($D(AMHQ)) D
...I $Y>(IOSL-3) D HEAD
...W !?10,AMHNAME,?42,$$VAL^XBDIQ1(2,AMHP,.02),?52,$$AGE^AUPNPAT(AMHP,DT),?57,$$HRN^AUPNPAT(AMHP,DUZ(2))
.W !,"SUBCOUNT: ",AMHDISP(AMHX)
.Q
DONE ;
D EOP^AMHRDE1
Q
HEAD I 'AMHPG G HEAD1
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S AMHQ="" Q
HEAD1 ;
W:$D(IOF) @IOF S AMHPG=AMHPG+1
W !,$P(^VA(200,DUZ,0),U,2),?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!
W "PERSONAL HISTORY LIST BY PATIENT",?44,$$FMTE^XLFDT($$NOW^XLFDT),?72,"Page ",AMHPG,!
W ?10,"PATIENT",?42,"SEX",?52,"AGE",?57,"CHART NUMBER",!
W AMH80D,!
Q
AMHRC5 ; IHS/CMI/LAB - PERSONAL HX REPORT ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
START ;
+1 IF '$DATA(IOF)
DO HOME^%ZIS
+2 WRITE @(IOF),!!
+3 WRITE "******* LIST OF PATIENTS WITH PERSONAL HISTORY ITEMS *******",!!
+4 DO DBHUSRP^AMHUTIL
+5 ;
DEMO ;
+1 DO DEMOCHK^AMHUTIL1(.AMHDEMO)
+2 IF AMHDEMO=-1
GOTO XIT
ZIS ;
+1 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
+2 IF $DATA(DIRUT)
GOTO XIT
+3 IF $GET(Y)="B"
DO BROWSE
DO XIT
QUIT
+4 SET XBRC="PROC^AMHRC5"
SET XBRP="PRINT^AMHRC5"
SET XBNS="AMH"
SET XBRX="XIT^AMHRC5"
+5 DO ^XBDBQUE
XIT ;
+1 DO EN^XBVK("AMH")
+2 QUIT
+3 ;
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""PRINT^AMHRC5"")"
+2 SET XBNS="AMH"
SET XBRC="PROC^AMHRC5"
SET XBRX="XIT^AMHRC5"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
PROC ;EP - entry point for processing
+1 SET AMHBT=$HOROLOG
KILL AMHDISP
+2 SET AMHCASE=0
+3 FOR
SET AMHCASE=$ORDER(^AMHPPHX(AMHCASE))
IF AMHCASE'=+AMHCASE
QUIT
DO PROC1
+4 SET AMHET=$HOROLOG
+5 KILL AMHCASE
+6 QUIT
PROC1 ;
+1 SET AMHR=^AMHPPHX(AMHCASE,0)
+2 IF '$$ALLOWP^AMHUTIL(DUZ,$PIECE(AMHR,U,2))
QUIT
+3 IF $$DEMO^AMHUTIL1($PIECE(AMHR,U,2),$GET(AMHDEMO))
QUIT
+4 IF $PIECE(AMHR,U,1)=""
QUIT
+5 SET X=$PIECE(AMHR,U,1)
+6 IF '$DATA(^AMHTPHF(X))
QUIT
+7 SET X=$PIECE(^AMHTPHF(X,0),U)
+8 IF '$DATA(AMHDISP(X))
SET AMHDISP(X)=""
SET AMHDISP(X)=AMHDISP(X)+1
SET AMHDISP(X,$PIECE(^DPT($PIECE(AMHR,U,2),0),U),$PIECE(AMHR,U,2))=""
+9 QUIT
PRINT ;EP - CALLED FROM XBDBQUE
+1 SET AMH80D="-------------------------------------------------------------------------------"
+2 SET AMHPG=0
DO HEAD
+3 KILL AMHQ
+4 SET AMHX=""
FOR
SET AMHX=$ORDER(AMHDISP(AMHX))
IF AMHX=""!($DATA(AMHQ))
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(AMHQ)
QUIT
+6 WRITE !!,?17,AMHX
+7 SET AMHNAME=""
FOR
SET AMHNAME=$ORDER(AMHDISP(AMHX,AMHNAME))
IF AMHNAME=""!($DATA(AMHQ))
QUIT
Begin DoDot:2
+8 SET AMHP=0
FOR
SET AMHP=$ORDER(AMHDISP(AMHX,AMHNAME,AMHP))
IF AMHP'=+AMHP!($DATA(AMHQ))
QUIT
Begin DoDot:3
+9 IF $Y>(IOSL-3)
DO HEAD
+10 WRITE !?10,AMHNAME,?42,$$VAL^XBDIQ1(2,AMHP,.02),?52,$$AGE^AUPNPAT(AMHP,DT),?57,$$HRN^AUPNPAT(AMHP,DUZ(2))
End DoDot:3
End DoDot:2
+11 WRITE !,"SUBCOUNT: ",AMHDISP(AMHX)
+12 QUIT
End DoDot:1
DONE ;
+1 DO EOP^AMHRDE1
+2 QUIT
HEAD IF 'AMHPG
GOTO HEAD1
+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 AMHQ=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET AMHPG=AMHPG+1
+2 WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),!
+3 WRITE "PERSONAL HISTORY LIST BY PATIENT",?44,$$FMTE^XLFDT($$NOW^XLFDT),?72,"Page ",AMHPG,!
+4 WRITE ?10,"PATIENT",?42,"SEX",?52,"AGE",?57,"CHART NUMBER",!
+5 WRITE AMH80D,!
+6 QUIT
