AMHRPTP ; IHS/CMI/LAB - PRINT VISIT REPORT ;
;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
;
START ;EP
;Set up header line, dash line.
S X=0,AMHHEAD="" F S X=$O(^AMHTRPT(AMHRPT,12,X)) Q:X'=+X S AMHHDR=$P(^AMHSORT($P(^AMHTRPT(AMHRPT,12,X,0),U),0),U,6),AMHLENG=$P(^AMHTRPT(AMHRPT,12,X,0),U,2),AMHHDR=$E(AMHHDR,1,AMHLENG) D
.S J=$L(AMHHDR),AMHHEAD=AMHHEAD_AMHHDR,K=$P(^AMHTRPT(AMHRPT,12,X,0),U,2)+1 F I=J:1:K S AMHHEAD=AMHHEAD_" "
.Q
S AMHDASH="",$P(AMHDASH,"-",AMHTCW)="-"
D COVPAGE^AMHRPTCP ;print cover page - note: if user ^'s out of cover page, processing continues
PROC ;process printing of report
S AMHPG=0 I '$D(^XTMP("AMHRPT",AMHJOB,AMHBTH)) G DONE
S (AMHSORT,AMHFRST)="" K AMHQUIT
S AMHRCNT=0 F S AMHSORT=$O(^XTMP("AMHRPT",AMHJOB,AMHBTH,"RECORDS",AMHSORT)) Q:AMHSORT=""!($D(AMHQUIT)) D V
G:$D(AMHQUIT) DONE
I $Y>(IOSL-3) D HEAD G:$D(AMHQUIT) DONE
W:$D(AMHRCNT) !!!,"TOTAL Visits: ",AMHRCNT
DONE ;
D DONE^AMHLEIN,^AMHEKL
K ^XTMP("AMHRPT",AMHJOB,AMHBT)
D DEL^AMHRPT
K AMHBD,AMHSD,AMHED,AMHEDD,AMHBDD,AMHRPT,AMHHEAD,AMHLINE,AMHL,AMHRCNT,AMHI,AMHCRIT,AMHR,AMHR0,AMHJOB,AMHBTH,AMHQUIT,AMHHDR,AMHDASH,AMHLENG,AMHPCNT,AMHTCW,AMHODAT,AMHPG,AUPNDAYS,AUPNPAT,AUPNDOD,AUPNDOB,AUPNSEX
K AMHSORT,AMHSRT,AMHSORX,AMHFILE,AMHFIEL,AMHPRNT,AMHX,AMHTYPE,AMHFOUN,D0,J,K,L,AMHPRNM,AMHTEST,AMHSEAT,AMHLHDR,AMHFRST
Q
V ;GETS RECORDS
S AMHSCNT=0
I $G(AMHSPAG)!($D(AMHFRST)) D HEAD Q:$D(AMHQUIT)
K AMHFRST
S AMHR=0 F S AMHR=$O(^XTMP("AMHRPT",AMHJOB,AMHBTH,"RECORDS",AMHSORT,AMHR)) Q:AMHR'=+AMHR!($D(AMHQUIT)) S AMHR0=^AMHREC(AMHR,0) D PRINT
Q:$D(AMHQUIT)
I $Y>(IOSL-3) D HEAD Q:$D(AMHQUIT)
W:$G(AMHSPAG) !!!,"SUB-TOTAL for ",AMHSORV," ",AMHSORT,": ",AMHSCNT
Q
PRINT ;
S:$G(AMHSPAG) AMHSCNT=AMHSCNT+1
K AMHLINE S AMHLINE(1)="",AMHL=1
I $Y>(IOSL-5) D HEAD Q:$D(AMHQUIT)
S AMHRCNT=AMHRCNT+1
S AMHI=0 F S AMHI=$O(^AMHTRPT(AMHRPT,12,AMHI)) Q:AMHI'=+AMHI!($D(AMHQUIT)) S AMHCRIT=$P(^AMHTRPT(AMHRPT,12,AMHI,0),U) D
.I '$P(^AMHSORT(AMHCRIT,0),U,8) D SINGLE Q
.D MULT
.Q
I $Y>(IOSL-(AMHL+3)) D HEAD Q:$D(AMHQUIT)
S X=0 F S X=$O(AMHLINE(X)) Q:X'=+X W !,AMHLINE(X)
Q
SINGLE ;process single valued item
S AMHPRNT=""
X:$D(^AMHSORT(AMHCRIT,3)) ^(3)
S AMHLENG=$P(^AMHTRPT(AMHRPT,12,AMHI,0),U,2),AMHPRNT=$E(AMHPRNT,1,AMHLENG) D
.S J=$L(AMHPRNT),AMHLINE(1)=AMHLINE(1)_AMHPRNT,K=$P(^AMHTRPT(AMHRPT,12,AMHI,0),U,2)+1 F I=J:1:K S AMHLINE(1)=AMHLINE(1)_" "
.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
MULT ;
K AMHPRNT,AMHPRNM S (AMHX,AMHPCNT)=0,AMHL=1
X:$D(^AMHSORT(AMHCRIT,3)) ^(3)
I '$D(AMHPRNM) S AMHPRNT="--" D
.S AMHLENG=$P(^AMHTRPT(AMHRPT,12,AMHI,0),U,2),AMHPRNT=$E(AMHPRNT,1,AMHLENG) D
..S J=$L(AMHPRNT),AMHLINE(1)=AMHLINE(1)_AMHPRNT,K=$P(^AMHTRPT(AMHRPT,12,AMHI,0),U,2)+1 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 AMHLENG=$P(^AMHTRPT(AMHRPT,12,AMHI,0),U,2),AMHPRNT=$E(AMHPRNM(1),1,AMHLENG) D
...S J=$L(AMHPRNT),AMHLINE(1)=AMHLINE(1)_AMHPRNT,K=$P(^AMHTRPT(AMHRPT,12,AMHI,0),U,2)+1 F I=J:1:K S AMHLINE(1)=AMHLINE(1)_" "
.S AMHLENG=$P(^AMHTRPT(AMHRPT,12,AMHI,0),U,2),AMHPRNT=$E(AMHPRNM(X),1,AMHLENG) D
..I '$D(AMHLINE(X)) S AMHLINE(X)="",K=$P(^AMHTRPT(AMHRPT,12,AMHI,0),U,2)+1,$P(AMHLINE(X)," ",($L(AMHLINE(1))-K))=""
..S J=$L(AMHPRNT),AMHLINE(X)=AMHLINE(X)_AMHPRNT,K=$P(^AMHTRPT(AMHRPT,12,AMHI,0),U,2)+1 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
DIQ ;
K AMHPRNT,AMHFILE,AMHFIEL
S AMHFILE=$P($P(^AMHSORT(AMHCRIT,0),U,4),","),AMHFIEL=$P($P(^(0),U,4),",",2)
S DIQ(0)="EN",DIQ="AMHPRNT(",DIC=AMHFILE,DR=AMHFIEL D EN^DIQ1 K DIC,DR,DIQ
I '$D(AMHPRNT(AMHFILE,DA,AMHFIEL,"E")) S AMHPRNT(AMHFILE,DA,AMHFIEL,"E")="--"
S AMHPRNT=AMHPRNT(AMHFILE,DA,AMHFIEL,"E")
Q
HEAD ;ENTRY POINT
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 AMHQUIT="" Q
HEAD1 ;
W:$D(IOF) @IOF S AMHPG=AMHPG+1
W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
S AMHTEXT="BEHAVIORAL HEALTH RECORD LISTING",AMHLENG=$L(AMHTEXT) W !?((AMHTCW-AMHLENG)/2),AMHTEXT,?(AMHTCW-8)," Page ",AMHPG
S AMHLENG=46 S:AMHTCW<AMHLENG AMHLENG=AMHTCW W !?((AMHTCW-AMHLENG)/2),"Visit Dates: ",AMHBDD," and ",AMHEDD,!
I $G(AMHSPAG) S AMHLENG=$L(AMHSORT)+$L(AMHSORV)+2 S:AMHTCW<AMHLENG AMHLENG=AMHTCW W !?((AMHTCW-AMHLENG)/2),AMHSORV,": ",AMHSORT,!
W !,AMHHEAD,!
W AMHDASH,!
Q
AMHRPTP ; IHS/CMI/LAB - PRINT VISIT REPORT ;
+1 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
+2 ;
START ;EP
+1 ;Set up header line, dash line.
+2 SET X=0
SET AMHHEAD=""
FOR
SET X=$ORDER(^AMHTRPT(AMHRPT,12,X))
IF X'=+X
QUIT
SET AMHHDR=$PIECE(^AMHSORT($PIECE(^AMHTRPT(AMHRPT,12,X,0),U),0),U,6)
SET AMHLENG=$PIECE(^AMHTRPT(AMHRPT,12,X,0),U,2)
SET AMHHDR=$EXTRACT(AMHHDR,1,AMHLENG)
Begin DoDot:1
+3 SET J=$LENGTH(AMHHDR)
SET AMHHEAD=AMHHEAD_AMHHDR
SET K=$PIECE(^AMHTRPT(AMHRPT,12,X,0),U,2)+1
FOR I=J:1:K
SET AMHHEAD=AMHHEAD_" "
+4 QUIT
End DoDot:1
+5 SET AMHDASH=""
SET $PIECE(AMHDASH,"-",AMHTCW)="-"
+6 ;print cover page - note: if user ^'s out of cover page, processing continues
DO COVPAGE^AMHRPTCP
PROC ;process printing of report
+1 SET AMHPG=0
IF '$DATA(^XTMP("AMHRPT",AMHJOB,AMHBTH))
GOTO DONE
+2 SET (AMHSORT,AMHFRST)=""
KILL AMHQUIT
+3 SET AMHRCNT=0
FOR
SET AMHSORT=$ORDER(^XTMP("AMHRPT",AMHJOB,AMHBTH,"RECORDS",AMHSORT))
IF AMHSORT=""!($DATA(AMHQUIT))
QUIT
DO V
+4 IF $DATA(AMHQUIT)
GOTO DONE
+5 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(AMHQUIT)
GOTO DONE
+6 IF $DATA(AMHRCNT)
WRITE !!!,"TOTAL Visits: ",AMHRCNT
DONE ;
+1 DO DONE^AMHLEIN
DO ^AMHEKL
+2 KILL ^XTMP("AMHRPT",AMHJOB,AMHBT)
+3 DO DEL^AMHRPT
+4 KILL AMHBD,AMHSD,AMHED,AMHEDD,AMHBDD,AMHRPT,AMHHEAD,AMHLINE,AMHL,AMHRCNT,AMHI,AMHCRIT,AMHR,AMHR0,AMHJOB,AMHBTH,AMHQUIT,AMHHDR,AMHDASH,AMHLENG,AMHPCNT,AMHTCW,AMHODAT,AMHPG,AUPNDAYS,AUPNPAT,AUPNDOD,AUPNDOB,AUPNSEX
+5 KILL AMHSORT,AMHSRT,AMHSORX,AMHFILE,AMHFIEL,AMHPRNT,AMHX,AMHTYPE,AMHFOUN,D0,J,K,L,AMHPRNM,AMHTEST,AMHSEAT,AMHLHDR,AMHFRST
+6 QUIT
V ;GETS RECORDS
+1 SET AMHSCNT=0
+2 IF $GET(AMHSPAG)!($DATA(AMHFRST))
DO HEAD
IF $DATA(AMHQUIT)
QUIT
+3 KILL AMHFRST
+4 SET AMHR=0
FOR
SET AMHR=$ORDER(^XTMP("AMHRPT",AMHJOB,AMHBTH,"RECORDS",AMHSORT,AMHR))
IF AMHR'=+AMHR!($DATA(AMHQUIT))
QUIT
SET AMHR0=^AMHREC(AMHR,0)
DO PRINT
+5 IF $DATA(AMHQUIT)
QUIT
+6 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(AMHQUIT)
QUIT
+7 IF $GET(AMHSPAG)
WRITE !!!,"SUB-TOTAL for ",AMHSORV," ",AMHSORT,": ",AMHSCNT
+8 QUIT
PRINT ;
+1 IF $GET(AMHSPAG)
SET AMHSCNT=AMHSCNT+1
+2 KILL AMHLINE
SET AMHLINE(1)=""
SET AMHL=1
+3 IF $Y>(IOSL-5)
DO HEAD
IF $DATA(AMHQUIT)
QUIT
+4 SET AMHRCNT=AMHRCNT+1
+5 SET AMHI=0
FOR
SET AMHI=$ORDER(^AMHTRPT(AMHRPT,12,AMHI))
IF AMHI'=+AMHI!($DATA(AMHQUIT))
QUIT
SET AMHCRIT=$PIECE(^AMHTRPT(AMHRPT,12,AMHI,0),U)
Begin DoDot:1
+6 IF '$PIECE(^AMHSORT(AMHCRIT,0),U,8)
DO SINGLE
QUIT
+7 DO MULT
+8 QUIT
End DoDot:1
+9 IF $Y>(IOSL-(AMHL+3))
DO HEAD
IF $DATA(AMHQUIT)
QUIT
+10 SET X=0
FOR
SET X=$ORDER(AMHLINE(X))
IF X'=+X
QUIT
WRITE !,AMHLINE(X)
+11 QUIT
SINGLE ;process single valued item
+1 SET AMHPRNT=""
+2 IF $DATA(^AMHSORT(AMHCRIT,3))
XECUTE ^(3)
+3 SET AMHLENG=$PIECE(^AMHTRPT(AMHRPT,12,AMHI,0),U,2)
SET AMHPRNT=$EXTRACT(AMHPRNT,1,AMHLENG)
Begin DoDot:1
+4 SET J=$LENGTH(AMHPRNT)
SET AMHLINE(1)=AMHLINE(1)_AMHPRNT
SET K=$PIECE(^AMHTRPT(AMHRPT,12,AMHI,0),U,2)+1
FOR I=J:1:K
SET AMHLINE(1)=AMHLINE(1)_" "
+5 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)_" "
End DoDot:1
+6 QUIT
MULT ;
+1 KILL AMHPRNT,AMHPRNM
SET (AMHX,AMHPCNT)=0
SET AMHL=1
+2 IF $DATA(^AMHSORT(AMHCRIT,3))
XECUTE ^(3)
+3 IF '$DATA(AMHPRNM)
SET AMHPRNT="--"
Begin DoDot:1
+4 SET AMHLENG=$PIECE(^AMHTRPT(AMHRPT,12,AMHI,0),U,2)
SET AMHPRNT=$EXTRACT(AMHPRNT,1,AMHLENG)
Begin DoDot:2
+5 SET J=$LENGTH(AMHPRNT)
SET AMHLINE(1)=AMHLINE(1)_AMHPRNT
SET K=$PIECE(^AMHTRPT(AMHRPT,12,AMHI,0),U,2)+1
FOR I=J:1:K
SET AMHLINE(1)=AMHLINE(1)_" "
End DoDot:2
End DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(AMHPRNM(X))
IF X'=+X
QUIT
Begin DoDot:1
+7 IF X=1
Begin DoDot:2
+8 SET AMHLENG=$PIECE(^AMHTRPT(AMHRPT,12,AMHI,0),U,2)
SET AMHPRNT=$EXTRACT(AMHPRNM(1),1,AMHLENG)
Begin DoDot:3
+9 SET J=$LENGTH(AMHPRNT)
SET AMHLINE(1)=AMHLINE(1)_AMHPRNT
SET K=$PIECE(^AMHTRPT(AMHRPT,12,AMHI,0),U,2)+1
FOR I=J:1:K
SET AMHLINE(1)=AMHLINE(1)_" "
End DoDot:3
End DoDot:2
QUIT
+10 SET AMHLENG=$PIECE(^AMHTRPT(AMHRPT,12,AMHI,0),U,2)
SET AMHPRNT=$EXTRACT(AMHPRNM(X),1,AMHLENG)
Begin DoDot:2
+11 IF '$DATA(AMHLINE(X))
SET AMHLINE(X)=""
SET K=$PIECE(^AMHTRPT(AMHRPT,12,AMHI,0),U,2)+1
SET $PIECE(AMHLINE(X)," ",($LENGTH(AMHLINE(1))-K))=""
+12 SET J=$LENGTH(AMHPRNT)
SET AMHLINE(X)=AMHLINE(X)_AMHPRNT
SET K=$PIECE(^AMHTRPT(AMHRPT,12,AMHI,0),U,2)+1
FOR I=J:1:K
SET AMHLINE(X)=AMHLINE(X)_" "
End DoDot:2
End DoDot:1
+13 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)_" "
+14 QUIT
DIQ ;
+1 KILL AMHPRNT,AMHFILE,AMHFIEL
+2 SET AMHFILE=$PIECE($PIECE(^AMHSORT(AMHCRIT,0),U,4),",")
SET AMHFIEL=$PIECE($PIECE(^(0),U,4),",",2)
+3 SET DIQ(0)="EN"
SET DIQ="AMHPRNT("
SET DIC=AMHFILE
SET DR=AMHFIEL
DO EN^DIQ1
KILL DIC,DR,DIQ
+4 IF '$DATA(AMHPRNT(AMHFILE,DA,AMHFIEL,"E"))
SET AMHPRNT(AMHFILE,DA,AMHFIEL,"E")="--"
+5 SET AMHPRNT=AMHPRNT(AMHFILE,DA,AMHFIEL,"E")
+6 QUIT
HEAD ;ENTRY POINT
+1 IF 'AMHPG
GOTO HEAD1
+2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET AMHQUIT=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET AMHPG=AMHPG+1
+2 WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
+3 SET AMHTEXT="BEHAVIORAL HEALTH RECORD LISTING"
SET AMHLENG=$LENGTH(AMHTEXT)
WRITE !?((AMHTCW-AMHLENG)/2),AMHTEXT,?(AMHTCW-8)," Page ",AMHPG
+4 SET AMHLENG=46
IF AMHTCW<AMHLENG
SET AMHLENG=AMHTCW
WRITE !?((AMHTCW-AMHLENG)/2),"Visit Dates: ",AMHBDD," and ",AMHEDD,!
+5 IF $GET(AMHSPAG)
SET AMHLENG=$LENGTH(AMHSORT)+$LENGTH(AMHSORV)+2
IF AMHTCW<AMHLENG
SET AMHLENG=AMHTCW
WRITE !?((AMHTCW-AMHLENG)/2),AMHSORV,": ",AMHSORT,!
+6 WRITE !,AMHHEAD,!
+7 WRITE AMHDASH,!
+8 QUIT
