AMHRC3 ; IHS/CMI/LAB - TIME IN GRP REPORT ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
START ;
I '$D(IOF) D HOME^%ZIS
W @(IOF),!!
W "********** LISTING OF PATIENTS WHO HAVE SPENT TIME IN GROUP **********",!!
W "This report will produce a list of patients who have spent time in a group.",!,"It will list the patient, the primary provider, diagnoses and time",!,"spent in the group for a date range you enter.",!!
D DBHUSR^AMHUTIL
GETDATES ;
BD ;get beginning date
W !,"Please enter the date range during which the patient should be seen",!,"in a group.",!
W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Date" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G XIT
S AMHBD=Y
ED ;get ending date
W ! S DIR(0)="D^"_AMHBD_":DT:EP",DIR("A")="Enter ending Date" S Y=AMHBD D DD^%DT D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G BD
S AMHED=Y
S X1=AMHBD,X2=-1 D C^%DTC S AMHSD=X S Y=AMHBD D DD^%DT S AMHBDD=Y S Y=AMHED D DD^%DT S AMHEDD=Y
;
DEMO ;
D DEMOCHK^AMHUTIL1(.AMHDEMO)
I AMHDEMO=-1 G BD
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^AMHRC3",XBRP="PRINT^AMHRC3",XBNS="AMH",XBRX="XIT^AMHRC3"
D ^XBDBQUE
XIT K ZTSK,Y,AMHBD,AMHED,IO("Q"),AMH80D,AMHBTH,AMHHRCN,AMHJOB,AMHLENG,AMHPCNT,AMHPG,AMHNUM,AMHX,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,XBNS,XBRC,XBRP,XBTX,D,AMHFOUN,AMHPOV,AMHRA,AMHRX,AMHRY
K AMHPRNM,AMHPRNT,AMHPROB,AMHPRV,AMHR,AMHRCNT,AMHRLOC,AMHSD,AMHTOT,AMHBDD,AMHBT,AMHEDD,AMHEDO,AMHBDO,AMHBT,AMHFOUND,AMHHIT,AMHID,AMHLINE,AMHP
Q
BROWSE ;
S XBRP="VIEWR^XBLM(""PRINT^AMHRC3"")"
S XBNS="AMH",XBRC="PROC^AMHRC3",XBRX="XIT^AMHRC3",XBIOP=0 D ^XBDBQUE
Q
;
PROC ;EP - entry point for processing
S AMHJOB=$J,AMHBTH=$H,AMHTOT=0,DFN=0,AMHBT=$H
D XTMP^AMHUTIL("AMHRC3","BH - PTS WITH GROUP VISITS")
S AMHSD=AMHSD_".9999"
F S AMHSD=$O(^AMHREC("B",AMHSD)) Q:AMHSD'=+AMHSD!($P(AMHSD,".")>AMHED) D PROC1
S AMHET=$H
K DFN
Q
PROC1 ;
S AMHR=0 F S AMHR=$O(^AMHREC("B",AMHSD,AMHR)) Q:AMHR'=+AMHR D
.Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHR)
.Q:$P($G(^AMHREC(AMHR,11)),U,4)=""
.Q:$P(^AMHREC(AMHR,0),U,8)=""
.S DFN=$P(^AMHREC(AMHR,0),U,8)
.Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
.Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))
.S AMHPROV=$$PPINT^AMHUTIL(AMHR) I AMHPROV="" S AMHPROV="Not Recorded"
.S AMHDX=$O(^AMHRPRO("AD",AMHR,0)) Q:AMHDX=""
.S AMHDX=$P(^AMHRPRO(AMHDX,0),U)
.S AMHTSG=$P($G(^AMHREC(AMHR,11)),U,4)
.S ^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",$P(^DPT(DFN,0),U),DFN,$P(AMHSD,"."),AMHR,AMHPROV,AMHDX)=AMHTSG
.S ^XTMP("AMHRC3",AMHJOB,AMHBTH,"PROV",DFN,AMHPROV)=$G(^XTMP("AMHRC3",AMHJOB,AMHBTH,"PROV",DFN,AMHPROV))+AMHTSG
.S ^XTMP("AMHRC3",AMHJOB,AMHBTH,"TOTAL",DFN)=$G(^XTMP("AMHRC3",AMHJOB,AMHBTH,"TOTAL",DFN))+AMHTSG
Q
;
PRINT ;
S AMH80D="-------------------------------------------------------------------------------"
S Y=AMHBD D DD^%DT S AMHBDD=Y S Y=AMHED D DD^%DT S AMHEDD=Y
S AMHPG=0 D HEAD
I '$D(^XTMP("AMHRC3",AMHJOB,AMHBTH)) W !!,"NO PATIENTS TO REPORT" G DONE
S DFN="" K AMHQ
S AMHNAME="" F S AMHNAME=$O(^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",AMHNAME)) Q:AMHNAME=""!($D(AMHQ)) D
.S DFN=0 F S DFN=$O(^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",AMHNAME,DFN)) Q:DFN=""!($D(AMHQ)) D DFN
G:$D(AMHQ) DONE
DONE D DONE^AMHLEIN,^AMHEKL
K ^XTMP("AMHRC3",AMHJOB,AMHBTH),AMHJOB,AMHBTH
Q
DFN ;
I $Y>(IOSL-4) D HEAD Q:$D(AMHQ)
S AMHHRCN=$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P(^(0),U,2),1:"<none>")
W !!,$E($P(^DPT(DFN,0),U),1,15),?18,AMHHRCN
W ?26,$P(^DPT(DFN,0),U,2) S Y=$P(^DPT(DFN,0),U,3) W ?30,$E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)
VSTS ; process visits
S AMHDATE=0,AMHRC=0 F S AMHDATE=$O(^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",AMHNAME,DFN,AMHDATE)) Q:AMHDATE'=+AMHDATE!($D(AMHQ)) D
.S AMHRC=AMHRC+1
.I AMHRC>1 W !
.W ?40,$E(AMHDATE,4,5),"/",$E(AMHDATE,6,7),"/",$E(AMHDATE,2,3)
.S AMHC=0,AMHR=0 F S AMHR=$O(^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",AMHNAME,DFN,AMHDATE,AMHR)) Q:AMHR'=+AMHR!($D(AMHQ)) D
..S AMHC=AMHC+1
..I AMHC>1 W !
..S AMHPROV=$O(^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",AMHNAME,DFN,AMHDATE,AMHR,0))
..I AMHPROV W ?49,$E($P(^VA(200,AMHPROV,0),U),1,15)
..I 'AMHPROV W ?49,AMHPROV
..S AMHDX=$O(^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",AMHNAME,DFN,AMHDATE,AMHR,AMHPROV,0))
..W ?65,$P(^AMHPROB(AMHDX,0),U,1)
..W ?74,^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",AMHNAME,DFN,AMHDATE,AMHR,AMHPROV,AMHDX)
Q:$D(AMHQ)
S AMHPROV=0 F S AMHPROV=$O(^XTMP("AMHRC3",AMHJOB,AMHBTH,"PROV",DFN,AMHPROV)) Q:AMHPROV'=+AMHPROV!($D(AMHQ)) D
.W !?10,"Total with provider ",$S(AMHPROV:$E($P(^VA(200,AMHPROV,0),U),1,20),1:AMHPROV),?50,^XTMP("AMHRC3",AMHJOB,AMHBTH,"PROV",DFN,AMHPROV)
Q:$D(AMHQ)
W !?10,"Total for patient ",$E($P(^DPT(DFN,0),U,1),1,20),?50,^XTMP("AMHRC3",AMHJOB,AMHBTH,"TOTAL",DFN)
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 !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
W !,$P(^VA(200,DUZ,0),U,2),?72,"Page ",AMHPG,!
W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!
W ?22,"PATIENTS SEEN IN GROUPS WITH TIME SPENT IN GROUP",!
W ?20,"DATES: ",AMHBDD," TO ",AMHEDD,!
PIH W !!,"PATIENT NAME",?18,"HRN",?25,"SEX",?30,"DOB",?40,"DATE",?49,"PROVIDER",?65,"PROBLEM",?74,"TIME",!,AMH80D
Q
AMHRC3 ; IHS/CMI/LAB - TIME IN GRP REPORT ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
START ;
+1 IF '$DATA(IOF)
DO HOME^%ZIS
+2 WRITE @(IOF),!!
+3 WRITE "********** LISTING OF PATIENTS WHO HAVE SPENT TIME IN GROUP **********",!!
+4 WRITE "This report will produce a list of patients who have spent time in a group.",!,"It will list the patient, the primary provider, diagnoses and time",!,"spent in the group for a date range you enter.",!!
+5 DO DBHUSR^AMHUTIL
GETDATES ;
BD ;get beginning date
+1 WRITE !,"Please enter the date range during which the patient should be seen",!,"in a group.",!
+2 WRITE !
SET DIR(0)="D^:DT:EP"
SET DIR("A")="Enter beginning Date"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
GOTO XIT
+4 SET AMHBD=Y
ED ;get ending date
+1 WRITE !
SET DIR(0)="D^"_AMHBD_":DT:EP"
SET DIR("A")="Enter ending Date"
SET Y=AMHBD
DO DD^%DT
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO BD
+3 SET AMHED=Y
+4 SET X1=AMHBD
SET X2=-1
DO C^%DTC
SET AMHSD=X
SET Y=AMHBD
DO DD^%DT
SET AMHBDD=Y
SET Y=AMHED
DO DD^%DT
SET AMHEDD=Y
+5 ;
DEMO ;
+1 DO DEMOCHK^AMHUTIL1(.AMHDEMO)
+2 IF AMHDEMO=-1
GOTO BD
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^AMHRC3"
SET XBRP="PRINT^AMHRC3"
SET XBNS="AMH"
SET XBRX="XIT^AMHRC3"
+5 DO ^XBDBQUE
XIT KILL ZTSK,Y,AMHBD,AMHED,IO("Q"),AMH80D,AMHBTH,AMHHRCN,AMHJOB,AMHLENG,AMHPCNT,AMHPG,AMHNUM,AMHX,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,XBNS,XBRC,XBRP,XBTX,D,AMHFOUN,AMHPOV,AMHRA,AMHRX,AMHRY
+1 KILL AMHPRNM,AMHPRNT,AMHPROB,AMHPRV,AMHR,AMHRCNT,AMHRLOC,AMHSD,AMHTOT,AMHBDD,AMHBT,AMHEDD,AMHEDO,AMHBDO,AMHBT,AMHFOUND,AMHHIT,AMHID,AMHLINE,AMHP
+2 QUIT
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""PRINT^AMHRC3"")"
+2 SET XBNS="AMH"
SET XBRC="PROC^AMHRC3"
SET XBRX="XIT^AMHRC3"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
+4 ;
PROC ;EP - entry point for processing
+1 SET AMHJOB=$JOB
SET AMHBTH=$HOROLOG
SET AMHTOT=0
SET DFN=0
SET AMHBT=$HOROLOG
+2 DO XTMP^AMHUTIL("AMHRC3","BH - PTS WITH GROUP VISITS")
+3 SET AMHSD=AMHSD_".9999"
+4 FOR
SET AMHSD=$ORDER(^AMHREC("B",AMHSD))
IF AMHSD'=+AMHSD!($PIECE(AMHSD,".")>AMHED)
QUIT
DO PROC1
+5 SET AMHET=$HOROLOG
+6 KILL DFN
+7 QUIT
PROC1 ;
+1 SET AMHR=0
FOR
SET AMHR=$ORDER(^AMHREC("B",AMHSD,AMHR))
IF AMHR'=+AMHR
QUIT
Begin DoDot:1
+2 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHR)
QUIT
+3 IF $PIECE($GET(^AMHREC(AMHR,11)),U,4)=""
QUIT
+4 IF $PIECE(^AMHREC(AMHR,0),U,8)=""
QUIT
+5 SET DFN=$PIECE(^AMHREC(AMHR,0),U,8)
+6 IF '$$ALLOWP^AMHUTIL(DUZ,DFN)
QUIT
+7 IF $$DEMO^AMHUTIL1(DFN,$GET(AMHDEMO))
QUIT
+8 SET AMHPROV=$$PPINT^AMHUTIL(AMHR)
IF AMHPROV=""
SET AMHPROV="Not Recorded"
+9 SET AMHDX=$ORDER(^AMHRPRO("AD",AMHR,0))
IF AMHDX=""
QUIT
+10 SET AMHDX=$PIECE(^AMHRPRO(AMHDX,0),U)
+11 SET AMHTSG=$PIECE($GET(^AMHREC(AMHR,11)),U,4)
+12 SET ^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",$PIECE(^DPT(DFN,0),U),DFN,$PIECE(AMHSD,"."),AMHR,AMHPROV,AMHDX)=AMHTSG
+13 SET ^XTMP("AMHRC3",AMHJOB,AMHBTH,"PROV",DFN,AMHPROV)=$GET(^XTMP("AMHRC3",AMHJOB,AMHBTH,"PROV",DFN,AMHPROV))+AMHTSG
+14 SET ^XTMP("AMHRC3",AMHJOB,AMHBTH,"TOTAL",DFN)=$GET(^XTMP("AMHRC3",AMHJOB,AMHBTH,"TOTAL",DFN))+AMHTSG
End DoDot:1
+15 QUIT
+16 ;
PRINT ;
+1 SET AMH80D="-------------------------------------------------------------------------------"
+2 SET Y=AMHBD
DO DD^%DT
SET AMHBDD=Y
SET Y=AMHED
DO DD^%DT
SET AMHEDD=Y
+3 SET AMHPG=0
DO HEAD
+4 IF '$DATA(^XTMP("AMHRC3",AMHJOB,AMHBTH))
WRITE !!,"NO PATIENTS TO REPORT"
GOTO DONE
+5 SET DFN=""
KILL AMHQ
+6 SET AMHNAME=""
FOR
SET AMHNAME=$ORDER(^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",AMHNAME))
IF AMHNAME=""!($DATA(AMHQ))
QUIT
Begin DoDot:1
+7 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",AMHNAME,DFN))
IF DFN=""!($DATA(AMHQ))
QUIT
DO DFN
End DoDot:1
+8 IF $DATA(AMHQ)
GOTO DONE
DONE DO DONE^AMHLEIN
DO ^AMHEKL
+1 KILL ^XTMP("AMHRC3",AMHJOB,AMHBTH),AMHJOB,AMHBTH
+2 QUIT
DFN ;
+1 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(AMHQ)
QUIT
+2 SET AMHHRCN=$SELECT($DATA(^AUPNPAT(DFN,41,DUZ(2),0)):$PIECE(^(0),U,2),1:"<none>")
+3 WRITE !!,$EXTRACT($PIECE(^DPT(DFN,0),U),1,15),?18,AMHHRCN
+4 WRITE ?26,$PIECE(^DPT(DFN,0),U,2)
SET Y=$PIECE(^DPT(DFN,0),U,3)
WRITE ?30,$EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
VSTS ; process visits
+1 SET AMHDATE=0
SET AMHRC=0
FOR
SET AMHDATE=$ORDER(^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",AMHNAME,DFN,AMHDATE))
IF AMHDATE'=+AMHDATE!($DATA(AMHQ))
QUIT
Begin DoDot:1
+2 SET AMHRC=AMHRC+1
+3 IF AMHRC>1
WRITE !
+4 WRITE ?40,$EXTRACT(AMHDATE,4,5),"/",$EXTRACT(AMHDATE,6,7),"/",$EXTRACT(AMHDATE,2,3)
+5 SET AMHC=0
SET AMHR=0
FOR
SET AMHR=$ORDER(^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",AMHNAME,DFN,AMHDATE,AMHR))
IF AMHR'=+AMHR!($DATA(AMHQ))
QUIT
Begin DoDot:2
+6 SET AMHC=AMHC+1
+7 IF AMHC>1
WRITE !
+8 SET AMHPROV=$ORDER(^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",AMHNAME,DFN,AMHDATE,AMHR,0))
+9 IF AMHPROV
WRITE ?49,$EXTRACT($PIECE(^VA(200,AMHPROV,0),U),1,15)
+10 IF 'AMHPROV
WRITE ?49,AMHPROV
+11 SET AMHDX=$ORDER(^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",AMHNAME,DFN,AMHDATE,AMHR,AMHPROV,0))
+12 WRITE ?65,$PIECE(^AMHPROB(AMHDX,0),U,1)
+13 WRITE ?74,^XTMP("AMHRC3",AMHJOB,AMHBTH,"INDS",AMHNAME,DFN,AMHDATE,AMHR,AMHPROV,AMHDX)
End DoDot:2
End DoDot:1
+14 IF $DATA(AMHQ)
QUIT
+15 SET AMHPROV=0
FOR
SET AMHPROV=$ORDER(^XTMP("AMHRC3",AMHJOB,AMHBTH,"PROV",DFN,AMHPROV))
IF AMHPROV'=+AMHPROV!($DATA(AMHQ))
QUIT
Begin DoDot:1
+16 WRITE !?10,"Total with provider ",$SELECT(AMHPROV:$EXTRACT($PIECE(^VA(200,AMHPROV,0),U),1,20),1:AMHPROV),?50,^XTMP("AMHRC3",AMHJOB,AMHBTH,"PROV",DFN,AMHPROV)
End DoDot:1
+17 IF $DATA(AMHQ)
QUIT
+18 WRITE !?10,"Total for patient ",$EXTRACT($PIECE(^DPT(DFN,0),U,1),1,20),?50,^XTMP("AMHRC3",AMHJOB,AMHBTH,"TOTAL",DFN)
+19 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 !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
+3 WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?72,"Page ",AMHPG,!
+4 WRITE ?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),!
+5 WRITE ?22,"PATIENTS SEEN IN GROUPS WITH TIME SPENT IN GROUP",!
+6 WRITE ?20,"DATES: ",AMHBDD," TO ",AMHEDD,!
PIH WRITE !!,"PATIENT NAME",?18,"HRN",?25,"SEX",?30,"DOB",?40,"DATE",?49,"PROVIDER",?65,"PROBLEM",?74,"TIME",!,AMH80D
+1 QUIT
