AMHRLP2.m

AMHRLP2 ; IHS/CMI/LAB - PRINT GEN RET ;

 ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010

 ;

DONE ;EP

 D:AMHCTYP'="F" DONE^AMHLEIN

 D ^AMHEKL

 K ^XTMP("AMHRL",AMHJOB,AMHBT)

 D DEL^AMHRL

 K AMHBD,AMHSD,AMHED,AMHEDD,AMHBDD,AMHRPT,AMHHEAD,AMHLINE,AMHL,AMHRCNT,AMHI,AMHCRIT,AMHR,AMHRREC,AMHJOB,AMHBT,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

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 ;EP

 W:$D(IOF) @IOF S AMHPG=AMHPG+1

 W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"

 I $G(AMHTITL)="" S AMHTEXT="BH "_AMHPTTX_" Listing",AMHLENG=$L(AMHTEXT) W !?(($S(AMHTCW<81:80,1:AMHTCW)-AMHLENG)/2),AMHTEXT,?($S(AMHTCW<81:80,1:AMHTCW)-8),"Page ",AMHPG

 I $G(AMHTITL)]"" S AMHLENG=$L(AMHTITL) W !?(($S(AMHTCW<81:80,1:AMHTCW)-AMHLENG)/2),AMHTITL,?($S(AMHTCW<81:80,1:AMHTCW)-8),"Page ",AMHPG

 I AMHTYPE="D" S AMHLENG=46 S:$S(AMHTCW<81:80,1:AMHTCW)<AMHLENG AMHLENG=$S(AMHTCW<81:80,1:AMHTCW) W !?(($S(AMHTCW<81:80,1:AMHTCW)-AMHLENG)/2),"Record Dates:  ",AMHBDD," and ",AMHEDD,!

 I AMHTYPE="S" S AMHLENG=16+$L($P(^DIBT(AMHSEAT,0),U)) S:$S(AMHTCW<81:80,1:AMHTCW)<AMHLENG AMHLENG=$S(AMHTCW<81:80,1:AMHTCW)  W !?(($S(AMHTCW<81:80,1:AMHTCW)-AMHLENG)/2),"Search Template: ",$P(^DIBT(AMHSEAT,0),U),!

 I AMHCTYP="S" S AMHLENG=$L(AMHSORV)+23 W !?(($S(AMHTCW<81:80,1:AMHTCW)-AMHLENG)/2),AMHPTTX," SUB-TOTALS BY:  ",AMHSORV,!

 I $G(AMHSPAG) S AMHLENG=$L(AMHSRTR)+$L(AMHSORV)+2 S:$S(AMHTCW<81:80,1:AMHTCW)<AMHLENG AMHLENG=$S(AMHTCW<81:80,1:AMHTCW) W !?(($S(AMHTCW<81:80,1:AMHTCW)-AMHLENG)/2),AMHSORV,":  ",AMHSRTR,!

 I AMHHEAD]"" W !,AMHHEAD,!

 W AMHDASH,!

 I AMHCTYP="S" W !,AMHSORV,":"

 Q

WRITEF ;EP - write out flat file

 S XBGL="XTMP("_$J_",""AMHFLAT"","

 S XBMED="F",XBFN=AMHFILE,XBTLE="SAVE OF BH RECORDS GENERATED BY -"_$P(^VA(200,DUZ,0),U)

 S XBF=0,XBQ="N",XBFLT=1,XBE=$J

 D ^XBGSAVE

 ;check for error

 K ^XTMP($J,"AMHFLAT")

 K XBGL,XBMED,XBTLE,XBFN,XBF,XBQ,XBFLT

 Q

AMHRLP2   ; IHS/CMI/LAB - PRINT GEN RET ;

 +1       ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010

 +2       ;

DONE      ;EP

 +1        IF AMHCTYP'="F"

               DO DONE^AMHLEIN

 +2        DO ^AMHEKL

 +3        KILL ^XTMP("AMHRL",AMHJOB,AMHBT)

 +4        DO DEL^AMHRL

 +5        KILL AMHBD,AMHSD,AMHED,AMHEDD,AMHBDD,AMHRPT,AMHHEAD,AMHLINE,AMHL,AMHRCNT,AMHI,AMHCRIT,AMHR,AMHRREC,AMHJOB,AMHBT,AMHBTH,AMHQUIT,AMHHDR,AMHDASH,AMHLENG,AMHPCNT,AMHTCW,AMHODAT,AMHPG,AUPNDAYS,AUPNPAT,AUPNDOD,AUPNDOB,AUPNSEX

 +6        KILL AMHSORT,AMHSRT,AMHSORX,AMHFILE,AMHFIEL,AMHPRNT,AMHX,AMHTYPE,AMHFOUN,D0,J,K,L,AMHPRNM,AMHTEST,AMHSEAT,AMHLHDR,AMHFRST

 +7        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     ;EP

 +1        IF $DATA(IOF)

               WRITE @IOF

           SET AMHPG=AMHPG+1

 +2        WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"

 +3        IF $GET(AMHTITL)=""

               SET AMHTEXT="BH "_AMHPTTX_" Listing"

               SET AMHLENG=$LENGTH(AMHTEXT)

               WRITE !?(($SELECT(AMHTCW<81:80,1:AMHTCW)-AMHLENG)/2),AMHTEXT,?($SELECT(AMHTCW<81:80,1:AMHTCW)-8),"Page ",AMHPG

 +4        IF $GET(AMHTITL)]""

               SET AMHLENG=$LENGTH(AMHTITL)

               WRITE !?(($SELECT(AMHTCW<81:80,1:AMHTCW)-AMHLENG)/2),AMHTITL,?($SELECT(AMHTCW<81:80,1:AMHTCW)-8),"Page ",AMHPG

 +5        IF AMHTYPE="D"

               SET AMHLENG=46

               IF $SELECT(AMHTCW<81

                   SET AMHLENG=$SELECT(AMHTCW<81:80,1:AMHTCW)

               WRITE !?(($SELECT(AMHTCW<81:80,1:AMHTCW)-AMHLENG)/2),"Record Dates:  ",AMHBDD," and ",AMHEDD,!

 +6        IF AMHTYPE="S"

               SET AMHLENG=16+$LENGTH($PIECE(^DIBT(AMHSEAT,0),U))

               IF $SELECT(AMHTCW<81

                   SET AMHLENG=$SELECT(AMHTCW<81:80,1:AMHTCW)

               WRITE !?(($SELECT(AMHTCW<81:80,1:AMHTCW)-AMHLENG)/2),"Search Template: ",$PIECE(^DIBT(AMHSEAT,0),U),!

 +7        IF AMHCTYP="S"

               SET AMHLENG=$LENGTH(AMHSORV)+23

               WRITE !?(($SELECT(AMHTCW<81:80,1:AMHTCW)-AMHLENG)/2),AMHPTTX," SUB-TOTALS BY:  ",AMHSORV,!

 +8        IF $GET(AMHSPAG)

               SET AMHLENG=$LENGTH(AMHSRTR)+$LENGTH(AMHSORV)+2

               IF $SELECT(AMHTCW<81

                   SET AMHLENG=$SELECT(AMHTCW<81:80,1:AMHTCW)

               WRITE !?(($SELECT(AMHTCW<81:80,1:AMHTCW)-AMHLENG)/2),AMHSORV,":  ",AMHSRTR,!

 +9        IF AMHHEAD]""

               WRITE !,AMHHEAD,!

 +10       WRITE AMHDASH,!

 +11       IF AMHCTYP="S"

               WRITE !,AMHSORV,":"

 +12       QUIT 

WRITEF    ;EP - write out flat file

 +1        SET XBGL="XTMP("_$JOB_",""AMHFLAT"","

 +2        SET XBMED="F"

           SET XBFN=AMHFILE

           SET XBTLE="SAVE OF BH RECORDS GENERATED BY -"_$PIECE(^VA(200,DUZ,0),U)

 +3        SET XBF=0

           SET XBQ="N"

           SET XBFLT=1

           SET XBE=$JOB

 +4        DO ^XBGSAVE

 +5       ;check for error

 +6        KILL ^XTMP($JOB,"AMHFLAT")

 +7        KILL XBGL,XBMED,XBTLE,XBFN,XBF,XBQ,XBFLT

 +8        QUIT