AMHRP4P ; IHS/CMI/LAB - print active client list (using case open/close) 03 Jun 2009 12:10 PM ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
;
PRINT ;
START ;
S X1=DT,X2=-365 D C^%DTC S AMHBD=X,AMHED=DT
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("AMHRP4",AMHJOB,AMHBTH)) W !!,"NO PATIENTS TO REPORT" G DONE
S DFN="" K AMHQ
S AMHNAME="" F S AMHNAME=$O(^XTMP("AMHRP4",AMHJOB,AMHBTH,"CASES",AMHNAME)) Q:AMHNAME=""!($D(AMHQ)) D
.S DFN=0 F S DFN=$O(^XTMP("AMHRP4",AMHJOB,AMHBTH,"CASES",AMHNAME,DFN)) Q:DFN'=+DFN!($D(AMHQ)) D DFN
G:$D(AMHQ) DONE
W !!,"Total Number of Patients: ",AMHPCNT,!
W "Total Number of Cases: ",AMHCCNT,!
DONE D DONE^AMHLEIN,^AMHEKL
K ^XTMP("AMHRP4",AMHJOB,AMHBTH),AMHJOB,AMHBTH
Q
DFN ;
S AMHCASE=0 F S AMHCASE=$O(^XTMP("AMHRP4",AMHJOB,AMHBTH,"CASES",AMHNAME,DFN,AMHCASE)) Q:AMHCASE'=+AMHCASE!($D(AMHQ)) D PRN
Q
PRN ;
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
S AMHX=^AMHPCASE(AMHCASE,0)
W ?26,$P(^DPT(DFN,0),U,2) S Y=$P(^DPT(DFN,0),U,3) W ?28,$E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)
S Y=$P(AMHX,U) W ?38,$E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)
S Y=$P(AMHX,U,4) I Y]"" W ?48,$E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)
VSTS ; process visits
K AMHRLOC,AMHPRV,AMHPROB
S AMHR=0,AMHBDO=9999999-AMHBD,AMHEDO=9999999-AMHED,AMHSD=AMHED-1,AMHSD=AMHSD_".9999",AMHRCNT=0
F S AMHSD=$O(^AMHREC("AE",DFN,AMHSD)) Q:$P(AMHSD,".")>AMHBDO!(AMHSD="") D
.S AMHR=0 F S AMHR=$O(^AMHREC("AE",DFN,AMHSD,AMHR)) Q:AMHR'=+AMHR D
..S AMHRCNT=AMHRCNT+1 ;COUNT # VISITS
..;TABLE LOC SEEN
..I $P(^AMHREC(AMHR,0),U,4)]"",'$D(AMHRLOC($P(^DIC(4,$P(^(0),U,4),0),U))) S AMHRLOC($P(^DIC(4,$P(^AMHREC(AMHR,0),U,4),0),U))=""
..;TABLE PROVIDERS
..S AMHP=0 F S AMHP=$O(^AMHRPROV("AD",AMHR,AMHP)) Q:AMHP'=+AMHP S P=$P(^AMHRPROV(AMHP,0),U),AMHPRV($P(^VA(200,P,0),U))=""
..;TABLE PROBLEMS
..S AMHP=0 F S AMHP=$O(^AMHRPRO("AD",AMHR,AMHP)) Q:AMHP'=+AMHP S P=$P(^AMHRPRO(AMHP,0),U),AMHPROB($P(^AMHPROB(P,0),U))=""
..Q
.Q
K AMHLINE,AMHPRNT,AMHPRNM
S AMHLINE(1)=""
K AMHPRNM S X="",C=0,K=11 F S X=$O(AMHPRV(X)) Q:X="" S C=C+1,AMHPRNM(C)=X
D LINE
K AMHPRNM S X="",C=0,K=7 F S X=$O(AMHPROB(X)) Q:X="" S C=C+1,AMHPRNM(C)=X
D LINE
S X=0 F S X=$O(AMHLINE(X)) Q:X'=+X W ?60,AMHLINE(X),!
I $Y>(IOSL-3) D HEAD Q:$D(AMHQ)
W ?2,"Case Provider: ",$$VAL^XBDIQ1(9002011.58,AMHCASE,.08),?50,"Next Case Review: ",$S($P(AMHX,U,12)]"":$$FMTE^XLFDT($P(AMHX,U,12),"2E"),1:""),!
Q
LINE ;
I '$D(AMHPRNM) S AMHPRNT="--" D
.S AMHPRNT=$E(AMHPRNT,1,10) D
..S J=$L(AMHPRNT),AMHLINE(1)=AMHLINE(1)_AMHPRNT F I=J:1:K S AMHLINE(1)=AMHLINE(1)_" "
S X=0 F S X=$O(AMHPRNM(X)) Q:X'=+X D
.I X=1 D Q
..S AMHPRNT=$E(AMHPRNM(1),1,10) D
...S J=$L(AMHPRNT),AMHLINE(1)=AMHLINE(1)_AMHPRNT F I=J:1:K S AMHLINE(1)=AMHLINE(1)_" "
.S AMHPRNT=$E(AMHPRNM(X),1,10) D
..I '$D(AMHLINE(X)) S AMHLINE(X)="",$P(AMHLINE(X)," ",($L(AMHLINE(1))-K))=""
..S J=$L(AMHPRNT),AMHLINE(X)=AMHLINE(X)_AMHPRNT F I=J:1:K S AMHLINE(X)=AMHLINE(X)_" "
S X=1 F S X=$O(AMHLINE(X)) Q:X'=+X I $L(AMHLINE(X))<$L(AMHLINE(1)) S K=$L(AMHLINE(X))+1,J=$L(AMHLINE(1)) F I=K:1:J S AMHLINE(X)=AMHLINE(X)_" "
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 ?15,"Encounter Dates: ",AMHBDD," to ",AMHEDD,!
I AMHPROG]"" S X="Program: "_$$EXTSET^XBFUNC(9002011.58,.03,AMHPROG) W $$CTR(X,80),!
W ?10,"ACTIVE CLIENT LIST (CASE OPEN DATE WITH NO CASE CLOSED DATE)"
PIH W !,"PATIENT NAME",?18,"CHART",?25,"SEX",?31,"DOB",?38,"CASE OPEN",?48,"CASE ADMIT",?60,"PROVIDER",?72,"PROBLEM"
W !?18,"NUMBER",?38,"DATE",?48,"DATE",?60,"SEEN",?72,"CODES",!,AMH80D
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
AMHRP4P ; IHS/CMI/LAB - print active client list (using case open/close) 03 Jun 2009 12:10 PM ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
+3 ;
PRINT ;
START ;
+1 SET X1=DT
SET X2=-365
DO C^%DTC
SET AMHBD=X
SET AMHED=DT
+2 SET Y=AMHBD
DO DD^%DT
SET AMHBDD=Y
SET Y=AMHED
DO DD^%DT
SET AMHEDD=Y
+3 SET AMH80D="-------------------------------------------------------------------------------"
+4 SET AMHPG=0
DO HEAD
+5 IF '$DATA(^XTMP("AMHRP4",AMHJOB,AMHBTH))
WRITE !!,"NO PATIENTS TO REPORT"
GOTO DONE
+6 SET DFN=""
KILL AMHQ
+7 SET AMHNAME=""
FOR
SET AMHNAME=$ORDER(^XTMP("AMHRP4",AMHJOB,AMHBTH,"CASES",AMHNAME))
IF AMHNAME=""!($DATA(AMHQ))
QUIT
Begin DoDot:1
+8 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("AMHRP4",AMHJOB,AMHBTH,"CASES",AMHNAME,DFN))
IF DFN'=+DFN!($DATA(AMHQ))
QUIT
DO DFN
End DoDot:1
+9 IF $DATA(AMHQ)
GOTO DONE
+10 WRITE !!,"Total Number of Patients: ",AMHPCNT,!
+11 WRITE "Total Number of Cases: ",AMHCCNT,!
DONE DO DONE^AMHLEIN
DO ^AMHEKL
+1 KILL ^XTMP("AMHRP4",AMHJOB,AMHBTH),AMHJOB,AMHBTH
+2 QUIT
DFN ;
+1 SET AMHCASE=0
FOR
SET AMHCASE=$ORDER(^XTMP("AMHRP4",AMHJOB,AMHBTH,"CASES",AMHNAME,DFN,AMHCASE))
IF AMHCASE'=+AMHCASE!($DATA(AMHQ))
QUIT
DO PRN
+2 QUIT
PRN ;
+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 SET AMHX=^AMHPCASE(AMHCASE,0)
+5 WRITE ?26,$PIECE(^DPT(DFN,0),U,2)
SET Y=$PIECE(^DPT(DFN,0),U,3)
WRITE ?28,$EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
+6 SET Y=$PIECE(AMHX,U)
WRITE ?38,$EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
+7 SET Y=$PIECE(AMHX,U,4)
IF Y]""
WRITE ?48,$EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
VSTS ; process visits
+1 KILL AMHRLOC,AMHPRV,AMHPROB
+2 SET AMHR=0
SET AMHBDO=9999999-AMHBD
SET AMHEDO=9999999-AMHED
SET AMHSD=AMHED-1
SET AMHSD=AMHSD_".9999"
SET AMHRCNT=0
+3 FOR
SET AMHSD=$ORDER(^AMHREC("AE",DFN,AMHSD))
IF $PIECE(AMHSD,".")>AMHBDO!(AMHSD="")
QUIT
Begin DoDot:1
+4 SET AMHR=0
FOR
SET AMHR=$ORDER(^AMHREC("AE",DFN,AMHSD,AMHR))
IF AMHR'=+AMHR
QUIT
Begin DoDot:2
+5 ;COUNT # VISITS
SET AMHRCNT=AMHRCNT+1
+6 ;TABLE LOC SEEN
+7 IF $PIECE(^AMHREC(AMHR,0),U,4)]""
IF '$DATA(AMHRLOC($PIECE(^DIC(4,$PIECE(^(0),U,4),0),U)))
SET AMHRLOC($PIECE(^DIC(4,$PIECE(^AMHREC(AMHR,0),U,4),0),U))=""
+8 ;TABLE PROVIDERS
+9 SET AMHP=0
FOR
SET AMHP=$ORDER(^AMHRPROV("AD",AMHR,AMHP))
IF AMHP'=+AMHP
QUIT
SET P=$PIECE(^AMHRPROV(AMHP,0),U)
SET AMHPRV($PIECE(^VA(200,P,0),U))=""
+10 ;TABLE PROBLEMS
+11 SET AMHP=0
FOR
SET AMHP=$ORDER(^AMHRPRO("AD",AMHR,AMHP))
IF AMHP'=+AMHP
QUIT
SET P=$PIECE(^AMHRPRO(AMHP,0),U)
SET AMHPROB($PIECE(^AMHPROB(P,0),U))=""
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 KILL AMHLINE,AMHPRNT,AMHPRNM
+15 SET AMHLINE(1)=""
+16 KILL AMHPRNM
SET X=""
SET C=0
SET K=11
FOR
SET X=$ORDER(AMHPRV(X))
IF X=""
QUIT
SET C=C+1
SET AMHPRNM(C)=X
+17 DO LINE
+18 KILL AMHPRNM
SET X=""
SET C=0
SET K=7
FOR
SET X=$ORDER(AMHPROB(X))
IF X=""
QUIT
SET C=C+1
SET AMHPRNM(C)=X
+19 DO LINE
+20 SET X=0
FOR
SET X=$ORDER(AMHLINE(X))
IF X'=+X
QUIT
WRITE ?60,AMHLINE(X),!
+21 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(AMHQ)
QUIT
+22 WRITE ?2,"Case Provider: ",$$VAL^XBDIQ1(9002011.58,AMHCASE,.08),?50,"Next Case Review: ",$SELECT($PIECE(AMHX,U,12)]"":$$FMTE^XLFDT($PIECE(AMHX,U,12),"2E"),1:""),!
+23 QUIT
LINE ;
+1 IF '$DATA(AMHPRNM)
SET AMHPRNT="--"
Begin DoDot:1
+2 SET AMHPRNT=$EXTRACT(AMHPRNT,1,10)
Begin DoDot:2
+3 SET J=$LENGTH(AMHPRNT)
SET AMHLINE(1)=AMHLINE(1)_AMHPRNT
FOR I=J:1:K
SET AMHLINE(1)=AMHLINE(1)_" "
End DoDot:2
End DoDot:1
+4 SET X=0
FOR
SET X=$ORDER(AMHPRNM(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 IF X=1
Begin DoDot:2
+6 SET AMHPRNT=$EXTRACT(AMHPRNM(1),1,10)
Begin DoDot:3
+7 SET J=$LENGTH(AMHPRNT)
SET AMHLINE(1)=AMHLINE(1)_AMHPRNT
FOR I=J:1:K
SET AMHLINE(1)=AMHLINE(1)_" "
End DoDot:3
End DoDot:2
QUIT
+8 SET AMHPRNT=$EXTRACT(AMHPRNM(X),1,10)
Begin DoDot:2
+9 IF '$DATA(AMHLINE(X))
SET AMHLINE(X)=""
SET $PIECE(AMHLINE(X)," ",($LENGTH(AMHLINE(1))-K))=""
+10 SET J=$LENGTH(AMHPRNT)
SET AMHLINE(X)=AMHLINE(X)_AMHPRNT
FOR I=J:1:K
SET AMHLINE(X)=AMHLINE(X)_" "
End DoDot:2
End DoDot:1
+11 SET X=1
FOR
SET X=$ORDER(AMHLINE(X))
IF X'=+X
QUIT
IF $LENGTH(AMHLINE(X))<$LENGTH(AMHLINE(1))
SET K=$LENGTH(AMHLINE(X))+1
SET J=$LENGTH(AMHLINE(1))
FOR I=K:1:J
SET AMHLINE(X)=AMHLINE(X)_" "
+12 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 ;W ?15,"Encounter Dates: ",AMHBDD," to ",AMHEDD,!
+6 IF AMHPROG]""
SET X="Program: "_$$EXTSET^XBFUNC(9002011.58,.03,AMHPROG)
WRITE $$CTR(X,80),!
+7 WRITE ?10,"ACTIVE CLIENT LIST (CASE OPEN DATE WITH NO CASE CLOSED DATE)"
PIH WRITE !,"PATIENT NAME",?18,"CHART",?25,"SEX",?31,"DOB",?38,"CASE OPEN",?48,"CASE ADMIT",?60,"PROVIDER",?72,"PROBLEM"
+1 WRITE !?18,"NUMBER",?38,"DATE",?48,"DATE",?60,"SEEN",?72,"CODES",!,AMH80D
+2 QUIT
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 ;----------
