AMHRPTP.m

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