AMHRPPD ; IHS/CMI/LAB - ACTIVE CLIENT LIST ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
I '$D(IOF) D HOME^%ZIS
W @(IOF),!!
W "********** PLACEMENTS IN PAST YEAR BY SITE/PATIENT **********",!!
W "This report will produce a list of patients who have had a placement disposition",!,"recorded in a date range specified by the user.",!
D DBHUSRP^AMHUTIL,DBHUSR^AMHUTIL
GETDATES ;
BD ;get beginning date
W !,"Please enter the date range during which the patient had a placement.",!
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
;
SORT ;
S AMHSORT=""
S DIR(0)="S^P:Alphabetically by Patient Name;S:Alphabetically by Site Referred to",DIR("A")="How would you like this report sorted",DIR("B")="P" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G BD
S AMHSORT=Y
DEMO ;
D DEMOCHK^AMHUTIL1(.AMHDEMO)
I AMHDEMO=-1 G SORT
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^AMHRPPD",XBRP="PRINT^AMHRPPD",XBNS="AMH",XBRX="XIT^AMHRPPD"
D ^XBDBQUE
XIT ;
K A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
D EN^XBVK("AMH")
D KILL^AUPNPAT
Q
;
BROWSE ;
S XBRP="VIEWR^XBLM(""PRINT^AMHRPPD"")"
S XBNS="AMH",XBRC="PROC^AMHRPPD",XBRX="XIT^AMHRPPD",XBIOP=0 D ^XBDBQUE
Q
PROC ;EP - entry point for processing
S AMHJOB=$J,AMHBTH=$H,AMHTOT=0,DFN=0,AMHBT=$H
K AMHTOTP,AMHTOTF
D XTMP^AMHUTIL("AMHRPPD","BH - PLACEMENT REPORT")
S X1=AMHBD,X2=-1 D C^%DTC S AMHSD=X
S AMHODAT=AMHSD_".9999" F S AMHODAT=$O(^AMHREC("B",AMHODAT)) Q:AMHODAT=""!((AMHODAT\1)>AMHED) D PROC1
S AMHET=$H
Q
PROC1 ;
S (AMHR,AMHRCNT)=0 F S AMHR=$O(^AMHREC("B",AMHODAT,AMHR)) Q:AMHR'=+AMHR I $D(^AMHREC(AMHR,0)),$P(^AMHREC(AMHR,0),U,8)]"" D SET
Q
SET ;
I $P(^AMHREC(AMHR,0),U,17)=""&($P(^AMHREC(AMHR,0),U,18)="") Q
Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHR)
I $P(^AMHREC(AMHR,0),U,8) Q:$$DEMO^AMHUTIL1($P(^AMHREC(AMHR,0),U,8),$G(AMHDEMO))
S S=$S($P(^AMHREC(AMHR,0),U,17)]"":$$VAL^XBDIQ1(9002011,AMHR,.17),1:"???")
S S1=$S($P(^AMHREC(AMHR,0),U,18)]"":$P(^AMHREC(AMHR,0),U,18),1:"???")
S P=$$VAL^XBDIQ1(9002011,AMHR,.08)
S DFN=$P(^AMHREC(AMHR,0),U,8)
Q:'DFN
Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)
I AMHSORT="S" S ^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",S1,P,DFN,AMHR)="",AMHTOT=AMHTOT+1
I AMHSORT="P" S ^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",P,DFN,S1,AMHR)="",AMHTOT=AMHTOT+1
S AMHTOTP(S)=$G(AMHTOTP(S))+1
S AMHTOTF(S1)=$G(AMHTOTF(S1))+1
Q
PRINT ;
S Y=AMHBD D DD^%DT S AMHBDD=Y S Y=AMHED D DD^%DT S AMHEDD=Y
S AMH80D="-------------------------------------------------------------------------------"
S AMHPG=0 D HEAD
I '$D(^XTMP("AMHRPPD",AMHJOB,AMHBTH)) W !!,"NO PATIENTS TO REPORT" G DONE
S AMHR="" K AMHQ
I AMHSORT="P" D PS G SUB
S AMHF="" F S AMHF=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF)) Q:AMHF=""!($D(AMHQ)) D
.S AMHPT="" F S AMHPT=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF,AMHPT)) Q:AMHPT=""!($D(AMHQ)) D
..S DFN=0 F S DFN=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF,AMHPT,DFN)) Q:DFN'=+DFN!($D(AMHQ)) D
...S AMHR=0 F S AMHR=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF,AMHPT,DFN,AMHR)) Q:AMHR'=+AMHR!($D(AMHQ)) D PRINT1
SUB ;
G:$D(AMHQ) DONE
I $Y>(IOSL-3) D HEAD I $D(AMHQ) G DONE
W !!,"Subtotal by Placement Type:"
S AMHX="" F S AMHX=$O(AMHTOTP(AMHX)) Q:AMHX=""!($D(AMHQ)) D
.I $Y>(IOSL-3) D HEAD Q:$D(AMHQ)
.W !?5,AMHX,?40,AMHTOTP(AMHX)
G:$D(AMHQ) DONE
I $Y>(IOSL-3) D HEAD I $D(AMHQ) G DONE
W !!,"Subtotal by Facility Referred to:"
S AMHX="" F S AMHX=$O(AMHTOTF(AMHX)) Q:AMHX=""!($D(AMHQ)) D
.I $Y>(IOSL-3) D HEAD Q:$D(AMHQ)
.W !?5,AMHX,?40,AMHTOTF(AMHX)
I $Y>(IOSL-3) D HEAD I $D(AMHQ) G DONE
W !!,"Total Number of Placements: ",AMHTOT
DONE ;
K ^XTMP("AMHRPPD",AMHJOB,AMHBTH),AMHJOB,AMHBTH
Q
PRINT1 ;
I $Y>(IOSL-4) D HEAD Q:$D(AMHQ)
W !,$E($P(^DPT(DFN,0),U),1,18),?20,$$HRN^AUPNPAT(DFN,DUZ(2)),?28,$$D^AMHLEIN($P(^AMHREC(AMHR,0),U)),?37,$$PRIMPOV^AMHUTIL1(AMHR,"C"),?44,$E($$VAL^XBDIQ1(9002011,AMHR,.17),1,14),?60,$E($$VAL^XBDIQ1(9002011,AMHR,.18),1,19)
W !?3,"Placement Made by: ",$$PPNAME^AMHUTIL(AMHR)
Q:'$D(^AMHPATR(DFN,0))
I $P(^AMHPATR(DFN,0),U,2)]"" W !?3,"Designated MH Prov: ",$$VAL^XBDIQ1(9002011.55,DFN,.02)
I $P(^AMHPATR(DFN,0),U,3)]"" W !?3,"Designated SS Prov: ",$$VAL^XBDIQ1(9002011.55,DFN,.03)
I $P(^AMHPATR(DFN,0),U,4)]"" W !?3,"Designated A/SA/CD Prov: ",$$VAL^XBDIQ1(9002011.55,DFN,.04)
Q
PS ;
S AMHPT="" F S AMHPT=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT)) Q:AMHPT=""!($D(AMHQ)) D
.S DFN="" F S DFN=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT,DFN)) Q:DFN=""!($D(AMHQ)) D
..S AMHF="" F S AMHF=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT,DFN,AMHF)) Q:AMHF=""!($D(AMHQ)) D
...S AMHR=0 F S AMHR=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT,DFN,AMHF,AMHR)) Q:AMHR'=+AMHR!($D(AMHQ)) D PRINT1
Q
D(D) ;
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+($E(D,1,3)))
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 ?35,"PLACEMENTS",!
W ?15,"PLACEMENT DATES: ",AMHBDD," TO ",AMHEDD,!
PIH W !,"PATIENT NAME",?20,"HRN",?27,"DATE",?38,"POV",?44,"PLACEMENT",?59,"FACILITY REFERRED TO",!,?27,"PLACED",!,AMH80D
Q
AMHRPPD ; IHS/CMI/LAB - ACTIVE CLIENT LIST ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
+3 IF '$DATA(IOF)
DO HOME^%ZIS
+4 WRITE @(IOF),!!
+5 WRITE "********** PLACEMENTS IN PAST YEAR BY SITE/PATIENT **********",!!
+6 WRITE "This report will produce a list of patients who have had a placement disposition",!,"recorded in a date range specified by the user.",!
+7 DO DBHUSRP^AMHUTIL
DO DBHUSR^AMHUTIL
GETDATES ;
BD ;get beginning date
+1 WRITE !,"Please enter the date range during which the patient had a placement.",!
+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 ;
SORT ;
+1 SET AMHSORT=""
+2 SET DIR(0)="S^P:Alphabetically by Patient Name;S:Alphabetically by Site Referred to"
SET DIR("A")="How would you like this report sorted"
SET DIR("B")="P"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO BD
+4 SET AMHSORT=Y
DEMO ;
+1 DO DEMOCHK^AMHUTIL1(.AMHDEMO)
+2 IF AMHDEMO=-1
GOTO SORT
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^AMHRPPD"
SET XBRP="PRINT^AMHRPPD"
SET XBNS="AMH"
SET XBRX="XIT^AMHRPPD"
+5 DO ^XBDBQUE
XIT ;
+1 KILL A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z
+2 DO EN^XBVK("AMH")
+3 DO KILL^AUPNPAT
+4 QUIT
+5 ;
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""PRINT^AMHRPPD"")"
+2 SET XBNS="AMH"
SET XBRC="PROC^AMHRPPD"
SET XBRX="XIT^AMHRPPD"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
PROC ;EP - entry point for processing
+1 SET AMHJOB=$JOB
SET AMHBTH=$HOROLOG
SET AMHTOT=0
SET DFN=0
SET AMHBT=$HOROLOG
+2 KILL AMHTOTP,AMHTOTF
+3 DO XTMP^AMHUTIL("AMHRPPD","BH - PLACEMENT REPORT")
+4 SET X1=AMHBD
SET X2=-1
DO C^%DTC
SET AMHSD=X
+5 SET AMHODAT=AMHSD_".9999"
FOR
SET AMHODAT=$ORDER(^AMHREC("B",AMHODAT))
IF AMHODAT=""!((AMHODAT\1)>AMHED)
QUIT
DO PROC1
+6 SET AMHET=$HOROLOG
+7 QUIT
PROC1 ;
+1 SET (AMHR,AMHRCNT)=0
FOR
SET AMHR=$ORDER(^AMHREC("B",AMHODAT,AMHR))
IF AMHR'=+AMHR
QUIT
IF $DATA(^AMHREC(AMHR,0))
IF $PIECE(^AMHREC(AMHR,0),U,8)]""
DO SET
+2 QUIT
SET ;
+1 IF $PIECE(^AMHREC(AMHR,0),U,17)=""&($PIECE(^AMHREC(AMHR,0),U,18)="")
QUIT
+2 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHR)
QUIT
+3 IF $PIECE(^AMHREC(AMHR,0),U,8)
IF $$DEMO^AMHUTIL1($PIECE(^AMHREC(AMHR,0),U,8),$GET(AMHDEMO))
QUIT
+4 SET S=$SELECT($PIECE(^AMHREC(AMHR,0),U,17)]"":$$VAL^XBDIQ1(9002011,AMHR,.17),1:"???")
+5 SET S1=$SELECT($PIECE(^AMHREC(AMHR,0),U,18)]"":$PIECE(^AMHREC(AMHR,0),U,18),1:"???")
+6 SET P=$$VAL^XBDIQ1(9002011,AMHR,.08)
+7 SET DFN=$PIECE(^AMHREC(AMHR,0),U,8)
+8 IF 'DFN
QUIT
+9 IF '$$ALLOWP^AMHUTIL(DUZ,DFN)
QUIT
+10 IF AMHSORT="S"
SET ^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",S1,P,DFN,AMHR)=""
SET AMHTOT=AMHTOT+1
+11 IF AMHSORT="P"
SET ^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",P,DFN,S1,AMHR)=""
SET AMHTOT=AMHTOT+1
+12 SET AMHTOTP(S)=$GET(AMHTOTP(S))+1
+13 SET AMHTOTF(S1)=$GET(AMHTOTF(S1))+1
+14 QUIT
PRINT ;
+1 SET Y=AMHBD
DO DD^%DT
SET AMHBDD=Y
SET Y=AMHED
DO DD^%DT
SET AMHEDD=Y
+2 SET AMH80D="-------------------------------------------------------------------------------"
+3 SET AMHPG=0
DO HEAD
+4 IF '$DATA(^XTMP("AMHRPPD",AMHJOB,AMHBTH))
WRITE !!,"NO PATIENTS TO REPORT"
GOTO DONE
+5 SET AMHR=""
KILL AMHQ
+6 IF AMHSORT="P"
DO PS
GOTO SUB
+7 SET AMHF=""
FOR
SET AMHF=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF))
IF AMHF=""!($DATA(AMHQ))
QUIT
Begin DoDot:1
+8 SET AMHPT=""
FOR
SET AMHPT=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF,AMHPT))
IF AMHPT=""!($DATA(AMHQ))
QUIT
Begin DoDot:2
+9 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF,AMHPT,DFN))
IF DFN'=+DFN!($DATA(AMHQ))
QUIT
Begin DoDot:3
+10 SET AMHR=0
FOR
SET AMHR=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF,AMHPT,DFN,AMHR))
IF AMHR'=+AMHR!($DATA(AMHQ))
QUIT
DO PRINT1
End DoDot:3
End DoDot:2
End DoDot:1
SUB ;
+1 IF $DATA(AMHQ)
GOTO DONE
+2 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(AMHQ)
GOTO DONE
+3 WRITE !!,"Subtotal by Placement Type:"
+4 SET AMHX=""
FOR
SET AMHX=$ORDER(AMHTOTP(AMHX))
IF AMHX=""!($DATA(AMHQ))
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(AMHQ)
QUIT
+6 WRITE !?5,AMHX,?40,AMHTOTP(AMHX)
End DoDot:1
+7 IF $DATA(AMHQ)
GOTO DONE
+8 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(AMHQ)
GOTO DONE
+9 WRITE !!,"Subtotal by Facility Referred to:"
+10 SET AMHX=""
FOR
SET AMHX=$ORDER(AMHTOTF(AMHX))
IF AMHX=""!($DATA(AMHQ))
QUIT
Begin DoDot:1
+11 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(AMHQ)
QUIT
+12 WRITE !?5,AMHX,?40,AMHTOTF(AMHX)
End DoDot:1
+13 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(AMHQ)
GOTO DONE
+14 WRITE !!,"Total Number of Placements: ",AMHTOT
DONE ;
+1 KILL ^XTMP("AMHRPPD",AMHJOB,AMHBTH),AMHJOB,AMHBTH
+2 QUIT
PRINT1 ;
+1 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(AMHQ)
QUIT
+2 WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,18),?20,$$HRN^AUPNPAT(DFN,DUZ(2)),?28,$$D^AMHLEIN($PIECE(^AMHREC(AMHR,0),U)),?37,$$PRIMPOV^AMHUTIL1(AMHR,"C"),?44,$EXTRACT($$VAL^XBDIQ1(9002011,AMHR,.17),1,14),?60,$EXTRACT($$VAL^XBDIQ1(9002011,AMHR,.18)
,1,19)
+3 WRITE !?3,"Placement Made by: ",$$PPNAME^AMHUTIL(AMHR)
+4 IF '$DATA(^AMHPATR(DFN,0))
QUIT
+5 IF $PIECE(^AMHPATR(DFN,0),U,2)]""
WRITE !?3,"Designated MH Prov: ",$$VAL^XBDIQ1(9002011.55,DFN,.02)
+6 IF $PIECE(^AMHPATR(DFN,0),U,3)]""
WRITE !?3,"Designated SS Prov: ",$$VAL^XBDIQ1(9002011.55,DFN,.03)
+7 IF $PIECE(^AMHPATR(DFN,0),U,4)]""
WRITE !?3,"Designated A/SA/CD Prov: ",$$VAL^XBDIQ1(9002011.55,DFN,.04)
+8 QUIT
PS ;
+1 SET AMHPT=""
FOR
SET AMHPT=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT))
IF AMHPT=""!($DATA(AMHQ))
QUIT
Begin DoDot:1
+2 SET DFN=""
FOR
SET DFN=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT,DFN))
IF DFN=""!($DATA(AMHQ))
QUIT
Begin DoDot:2
+3 SET AMHF=""
FOR
SET AMHF=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT,DFN,AMHF))
IF AMHF=""!($DATA(AMHQ))
QUIT
Begin DoDot:3
+4 SET AMHR=0
FOR
SET AMHR=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT,DFN,AMHF,AMHR))
IF AMHR'=+AMHR!($DATA(AMHQ))
QUIT
DO PRINT1
End DoDot:3
End DoDot:2
End DoDot:1
+5 QUIT
D(D) ;
+1 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+($EXTRACT(D,1,3)))
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 ?35,"PLACEMENTS",!
+6 WRITE ?15,"PLACEMENT DATES: ",AMHBDD," TO ",AMHEDD,!
PIH WRITE !,"PATIENT NAME",?20,"HRN",?27,"DATE",?38,"POV",?44,"PLACEMENT",?59,"FACILITY REFERRED TO",!,?27,"PLACED",!,AMH80D
+1 QUIT
