AMHRP9P ; IHS/CMI/LAB - print active client list ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
;
PRINT ;
START ;
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("AMHRP9",AMHJOB,AMHBTH)) W !!,"NO PATIENTS TO REPORT" G DONE
S DFN="" K AMHQ
S AMHNAME="" F S AMHNAME=$O(^XTMP("AMHRP9",AMHJOB,AMHBTH,AMHNAME)) Q:AMHNAME=""!($D(AMHQ)) D
.S DFN=0 F S DFN=$O(^XTMP("AMHRP9",AMHJOB,AMHBTH,AMHNAME,DFN)) Q:DFN=""!($D(AMHQ)) D DFN
G:$D(AMHQ) DONE
DONE D DONE^AMHLEIN,^AMHEKL
K ^XTMP("AMHRP9",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 ?27,$P(^DPT(DFN,0),U,2) S Y=$P(^DPT(DFN,0),U,3) W ?31,$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
..Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHR)
..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,AMHPCNT,AMHPRNM
S AMHLINE(1)=""
S X="",C=0,K=11 F S X=$O(AMHRLOC(X)) Q:X="" S C=C+1,AMHPRNM(C)=X
D LINE
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=9 F S X=$O(AMHPROB(X)) Q:X="" S C=C+1,AMHPRNM(C)=X
D LINE
S AMHRCNT=$J(AMHRCNT,4),AMHLINE(1)=AMHLINE(1)_AMHRCNT,X=0 F S X=$O(AMHLINE(X)) Q:X'=+X W ?41,AMHLINE(X),!
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 ?22,"PATIENTS SEEN AT LEAST ",AMHNUM," TIMES",!
W ?17,"RECORD DATES: ",AMHBDD," TO ",AMHEDD,!
PIH W !!,"PATIENT NAME",?18,"CHART #",?27,"SEX",?31,"DOB",?41,"LOCATION",?53,"PROVIDER",?65,"PROBLEM",?74,"#",!
W ?41,"SEEN",?53,"SEEN",?65,"CODES",?74,"VISITS",!,AMH80D
Q
AMHRP9P ; IHS/CMI/LAB - print active client list ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
+3 ;
PRINT ;
START ;
+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("AMHRP9",AMHJOB,AMHBTH))
WRITE !!,"NO PATIENTS TO REPORT"
GOTO DONE
+5 SET DFN=""
KILL AMHQ
+6 SET AMHNAME=""
FOR
SET AMHNAME=$ORDER(^XTMP("AMHRP9",AMHJOB,AMHBTH,AMHNAME))
IF AMHNAME=""!($DATA(AMHQ))
QUIT
Begin DoDot:1
+7 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("AMHRP9",AMHJOB,AMHBTH,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("AMHRP9",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 ?27,$PIECE(^DPT(DFN,0),U,2)
SET Y=$PIECE(^DPT(DFN,0),U,3)
WRITE ?31,$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 IF '$$ALLOWVI^AMHUTIL(DUZ,AMHR)
QUIT
+6 ;COUNT # VISITS
SET AMHRCNT=AMHRCNT+1
+7 ;TABLE LOC SEEN
+8 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))=""
+9 ;TABLE PROVIDERS
+10 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))=""
+11 ;TABLE PROBLEMS
+12 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))=""
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 KILL AMHLINE,AMHPRNT,AMHPCNT,AMHPRNM
+16 SET AMHLINE(1)=""
+17 SET X=""
SET C=0
SET K=11
FOR
SET X=$ORDER(AMHRLOC(X))
IF X=""
QUIT
SET C=C+1
SET AMHPRNM(C)=X
+18 DO LINE
+19 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
+20 DO LINE
+21 KILL AMHPRNM
SET X=""
SET C=0
SET K=9
FOR
SET X=$ORDER(AMHPROB(X))
IF X=""
QUIT
SET C=C+1
SET AMHPRNM(C)=X
+22 DO LINE
+23 SET AMHRCNT=$JUSTIFY(AMHRCNT,4)
SET AMHLINE(1)=AMHLINE(1)_AMHRCNT
SET X=0
FOR
SET X=$ORDER(AMHLINE(X))
IF X'=+X
QUIT
WRITE ?41,AMHLINE(X),!
+24 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 WRITE ?22,"PATIENTS SEEN AT LEAST ",AMHNUM," TIMES",!
+6 WRITE ?17,"RECORD DATES: ",AMHBDD," TO ",AMHEDD,!
PIH WRITE !!,"PATIENT NAME",?18,"CHART #",?27,"SEX",?31,"DOB",?41,"LOCATION",?53,"PROVIDER",?65,"PROBLEM",?74,"#",!
+1 WRITE ?41,"SEEN",?53,"SEEN",?65,"CODES",?74,"VISITS",!,AMH80D
+2 QUIT
