AMHRPPD.m

AMHRPPD ; IHS/CMI/LAB - ACTIVE CLIENT LIST ;

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

 ;

 I '$D(IOF) D HOME^%ZIS

 W @(IOF),!!

 W "**********  PLACEMENTS IN PAST YEAR BY SITE/PATIENT  **********",!!

 W "This report will produce a list of patients who have had a placement disposition",!,"recorded in a date range specified by the user.",!

 D DBHUSRP^AMHUTIL,DBHUSR^AMHUTIL

GETDATES ;

BD ;get beginning date

 W !,"Please enter the date range during which the patient had a placement.",!

 W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Date" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G XIT

 S AMHBD=Y

ED ;get ending date

 W ! S DIR(0)="D^"_AMHBD_":DT:EP",DIR("A")="Enter ending Date" S Y=AMHBD D DD^%DT D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G BD

 S AMHED=Y

 S X1=AMHBD,X2=-1 D C^%DTC S AMHSD=X S Y=AMHBD D DD^%DT S AMHBDD=Y S Y=AMHED D DD^%DT S AMHEDD=Y

 ;

SORT ;

 S AMHSORT=""

 S DIR(0)="S^P:Alphabetically by Patient Name;S:Alphabetically by Site Referred to",DIR("A")="How would you like this report sorted",DIR("B")="P" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G BD

 S AMHSORT=Y

DEMO ;

 D DEMOCHK^AMHUTIL1(.AMHDEMO)

 I AMHDEMO=-1 G SORT

ZIS ;

 S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to ",DIR("B")="P" K DA D ^DIR K DIR

 I $D(DIRUT) G XIT

 I $G(Y)="B" D BROWSE,XIT Q

 S XBRC="PROC^AMHRPPD",XBRP="PRINT^AMHRPPD",XBNS="AMH",XBRX="XIT^AMHRPPD"

 D ^XBDBQUE

XIT ;

 K A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z

 D EN^XBVK("AMH")

 D KILL^AUPNPAT

 Q

 ;

BROWSE ;

 S XBRP="VIEWR^XBLM(""PRINT^AMHRPPD"")"

 S XBNS="AMH",XBRC="PROC^AMHRPPD",XBRX="XIT^AMHRPPD",XBIOP=0 D ^XBDBQUE

 Q

PROC ;EP - entry point for processing

 S AMHJOB=$J,AMHBTH=$H,AMHTOT=0,DFN=0,AMHBT=$H

 K AMHTOTP,AMHTOTF

 D XTMP^AMHUTIL("AMHRPPD","BH - PLACEMENT REPORT")

 S X1=AMHBD,X2=-1 D C^%DTC S AMHSD=X

 S AMHODAT=AMHSD_".9999" F  S AMHODAT=$O(^AMHREC("B",AMHODAT)) Q:AMHODAT=""!((AMHODAT\1)>AMHED)  D PROC1

 S AMHET=$H

 Q

PROC1 ;

 S (AMHR,AMHRCNT)=0 F  S AMHR=$O(^AMHREC("B",AMHODAT,AMHR)) Q:AMHR'=+AMHR  I $D(^AMHREC(AMHR,0)),$P(^AMHREC(AMHR,0),U,8)]"" D SET

 Q

SET ;

 I $P(^AMHREC(AMHR,0),U,17)=""&($P(^AMHREC(AMHR,0),U,18)="") Q

 Q:'$$ALLOWVI^AMHUTIL(DUZ,AMHR)

 I $P(^AMHREC(AMHR,0),U,8) Q:$$DEMO^AMHUTIL1($P(^AMHREC(AMHR,0),U,8),$G(AMHDEMO))

 S S=$S($P(^AMHREC(AMHR,0),U,17)]"":$$VAL^XBDIQ1(9002011,AMHR,.17),1:"???")

 S S1=$S($P(^AMHREC(AMHR,0),U,18)]"":$P(^AMHREC(AMHR,0),U,18),1:"???")

 S P=$$VAL^XBDIQ1(9002011,AMHR,.08)

 S DFN=$P(^AMHREC(AMHR,0),U,8)

 Q:'DFN

 Q:'$$ALLOWP^AMHUTIL(DUZ,DFN)

 I AMHSORT="S" S ^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",S1,P,DFN,AMHR)="",AMHTOT=AMHTOT+1

 I AMHSORT="P" S ^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",P,DFN,S1,AMHR)="",AMHTOT=AMHTOT+1

 S AMHTOTP(S)=$G(AMHTOTP(S))+1

 S AMHTOTF(S1)=$G(AMHTOTF(S1))+1

 Q

PRINT ;

 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("AMHRPPD",AMHJOB,AMHBTH)) W !!,"NO PATIENTS TO REPORT" G DONE

 S AMHR="" K AMHQ

 I AMHSORT="P" D PS G SUB

 S AMHF="" F  S AMHF=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF)) Q:AMHF=""!($D(AMHQ))  D

 .S AMHPT="" F  S AMHPT=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF,AMHPT)) Q:AMHPT=""!($D(AMHQ))  D

 ..S DFN=0 F  S DFN=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF,AMHPT,DFN)) Q:DFN'=+DFN!($D(AMHQ))  D

 ...S AMHR=0 F  S AMHR=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF,AMHPT,DFN,AMHR)) Q:AMHR'=+AMHR!($D(AMHQ))  D PRINT1

SUB ;

 G:$D(AMHQ) DONE

 I $Y>(IOSL-3) D HEAD I $D(AMHQ) G DONE

 W !!,"Subtotal by Placement Type:"

 S AMHX="" F  S AMHX=$O(AMHTOTP(AMHX)) Q:AMHX=""!($D(AMHQ))  D

 .I $Y>(IOSL-3) D HEAD Q:$D(AMHQ)

 .W !?5,AMHX,?40,AMHTOTP(AMHX)

 G:$D(AMHQ) DONE

 I $Y>(IOSL-3) D HEAD I $D(AMHQ) G DONE

 W !!,"Subtotal by Facility Referred to:"

 S AMHX="" F  S AMHX=$O(AMHTOTF(AMHX)) Q:AMHX=""!($D(AMHQ))  D

 .I $Y>(IOSL-3) D HEAD Q:$D(AMHQ)

 .W !?5,AMHX,?40,AMHTOTF(AMHX)

 I $Y>(IOSL-3) D HEAD I $D(AMHQ) G DONE

 W !!,"Total Number of Placements: ",AMHTOT

DONE ;

 K ^XTMP("AMHRPPD",AMHJOB,AMHBTH),AMHJOB,AMHBTH

 Q

PRINT1 ;

 I $Y>(IOSL-4) D HEAD Q:$D(AMHQ)

 W !,$E($P(^DPT(DFN,0),U),1,18),?20,$$HRN^AUPNPAT(DFN,DUZ(2)),?28,$$D^AMHLEIN($P(^AMHREC(AMHR,0),U)),?37,$$PRIMPOV^AMHUTIL1(AMHR,"C"),?44,$E($$VAL^XBDIQ1(9002011,AMHR,.17),1,14),?60,$E($$VAL^XBDIQ1(9002011,AMHR,.18),1,19)

 W !?3,"Placement Made by: ",$$PPNAME^AMHUTIL(AMHR)

 Q:'$D(^AMHPATR(DFN,0))

 I $P(^AMHPATR(DFN,0),U,2)]"" W !?3,"Designated MH Prov: ",$$VAL^XBDIQ1(9002011.55,DFN,.02)

 I $P(^AMHPATR(DFN,0),U,3)]"" W !?3,"Designated SS Prov: ",$$VAL^XBDIQ1(9002011.55,DFN,.03)

 I $P(^AMHPATR(DFN,0),U,4)]"" W !?3,"Designated A/SA/CD Prov: ",$$VAL^XBDIQ1(9002011.55,DFN,.04)

 Q

PS ;

 S AMHPT="" F  S AMHPT=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT)) Q:AMHPT=""!($D(AMHQ))  D

 .S DFN="" F  S DFN=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT,DFN)) Q:DFN=""!($D(AMHQ))  D

 ..S AMHF="" F  S AMHF=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT,DFN,AMHF)) Q:AMHF=""!($D(AMHQ))  D

 ...S AMHR=0 F  S AMHR=$O(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT,DFN,AMHF,AMHR)) Q:AMHR'=+AMHR!($D(AMHQ))  D PRINT1

 Q

D(D) ;

 Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+($E(D,1,3)))

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 ?35,"PLACEMENTS",!

 W ?15,"PLACEMENT DATES:  ",AMHBDD,"  TO  ",AMHEDD,!

PIH W !,"PATIENT NAME",?20,"HRN",?27,"DATE",?38,"POV",?44,"PLACEMENT",?59,"FACILITY REFERRED TO",!,?27,"PLACED",!,AMH80D

 Q

AMHRPPD   ; IHS/CMI/LAB - ACTIVE CLIENT LIST ;

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

 +2       ;

 +3        IF '$DATA(IOF)

               DO HOME^%ZIS

 +4        WRITE @(IOF),!!

 +5        WRITE "**********  PLACEMENTS IN PAST YEAR BY SITE/PATIENT  **********",!!

 +6        WRITE "This report will produce a list of patients who have had a placement disposition",!,"recorded in a date range specified by the user.",!

 +7        DO DBHUSRP^AMHUTIL

           DO DBHUSR^AMHUTIL

GETDATES  ;

BD        ;get beginning date

 +1        WRITE !,"Please enter the date range during which the patient had a placement.",!

 +2        WRITE !

           SET DIR(0)="D^:DT:EP"

           SET DIR("A")="Enter beginning Date"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               GOTO XIT

 +4        SET AMHBD=Y

ED        ;get ending date

 +1        WRITE !

           SET DIR(0)="D^"_AMHBD_":DT:EP"

           SET DIR("A")="Enter ending Date"

           SET Y=AMHBD

           DO DD^%DT

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO BD

 +3        SET AMHED=Y

 +4        SET X1=AMHBD

           SET X2=-1

           DO C^%DTC

           SET AMHSD=X

           SET Y=AMHBD

           DO DD^%DT

           SET AMHBDD=Y

           SET Y=AMHED

           DO DD^%DT

           SET AMHEDD=Y

 +5       ;

SORT      ;

 +1        SET AMHSORT=""

 +2        SET DIR(0)="S^P:Alphabetically by Patient Name;S:Alphabetically by Site Referred to"

           SET DIR("A")="How would you like this report sorted"

           SET DIR("B")="P"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO BD

 +4        SET AMHSORT=Y

DEMO      ;

 +1        DO DEMOCHK^AMHUTIL1(.AMHDEMO)

 +2        IF AMHDEMO=-1

               GOTO SORT

ZIS       ;

 +1        SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"

           SET DIR("A")="Do you wish to "

           SET DIR("B")="P"

           KILL DA

           DO ^DIR

           KILL DIR

 +2        IF $DATA(DIRUT)

               GOTO XIT

 +3        IF $GET(Y)="B"

               DO BROWSE

               DO XIT

               QUIT 

 +4        SET XBRC="PROC^AMHRPPD"

           SET XBRP="PRINT^AMHRPPD"

           SET XBNS="AMH"

           SET XBRX="XIT^AMHRPPD"

 +5        DO ^XBDBQUE

XIT       ;

 +1        KILL A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,V,W,X,Y,Z

 +2        DO EN^XBVK("AMH")

 +3        DO KILL^AUPNPAT

 +4        QUIT 

 +5       ;

BROWSE    ;

 +1        SET XBRP="VIEWR^XBLM(""PRINT^AMHRPPD"")"

 +2        SET XBNS="AMH"

           SET XBRC="PROC^AMHRPPD"

           SET XBRX="XIT^AMHRPPD"

           SET XBIOP=0

           DO ^XBDBQUE

 +3        QUIT 

PROC      ;EP - entry point for processing

 +1        SET AMHJOB=$JOB

           SET AMHBTH=$HOROLOG

           SET AMHTOT=0

           SET DFN=0

           SET AMHBT=$HOROLOG

 +2        KILL AMHTOTP,AMHTOTF

 +3        DO XTMP^AMHUTIL("AMHRPPD","BH - PLACEMENT REPORT")

 +4        SET X1=AMHBD

           SET X2=-1

           DO C^%DTC

           SET AMHSD=X

 +5        SET AMHODAT=AMHSD_".9999"

           FOR 

               SET AMHODAT=$ORDER(^AMHREC("B",AMHODAT))

               IF AMHODAT=""!((AMHODAT\1)>AMHED)

                   QUIT 

               DO PROC1

 +6        SET AMHET=$HOROLOG

 +7        QUIT 

PROC1     ;

 +1        SET (AMHR,AMHRCNT)=0

           FOR 

               SET AMHR=$ORDER(^AMHREC("B",AMHODAT,AMHR))

               IF AMHR'=+AMHR

                   QUIT 

               IF $DATA(^AMHREC(AMHR,0))

                   IF $PIECE(^AMHREC(AMHR,0),U,8)]""

                       DO SET

 +2        QUIT 

SET       ;

 +1        IF $PIECE(^AMHREC(AMHR,0),U,17)=""&($PIECE(^AMHREC(AMHR,0),U,18)="")

               QUIT 

 +2        IF '$$ALLOWVI^AMHUTIL(DUZ,AMHR)

               QUIT 

 +3        IF $PIECE(^AMHREC(AMHR,0),U,8)

               IF $$DEMO^AMHUTIL1($PIECE(^AMHREC(AMHR,0),U,8),$GET(AMHDEMO))

                   QUIT 

 +4        SET S=$SELECT($PIECE(^AMHREC(AMHR,0),U,17)]"":$$VAL^XBDIQ1(9002011,AMHR,.17),1:"???")

 +5        SET S1=$SELECT($PIECE(^AMHREC(AMHR,0),U,18)]"":$PIECE(^AMHREC(AMHR,0),U,18),1:"???")

 +6        SET P=$$VAL^XBDIQ1(9002011,AMHR,.08)

 +7        SET DFN=$PIECE(^AMHREC(AMHR,0),U,8)

 +8        IF 'DFN

               QUIT 

 +9        IF '$$ALLOWP^AMHUTIL(DUZ,DFN)

               QUIT 

 +10       IF AMHSORT="S"

               SET ^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",S1,P,DFN,AMHR)=""

               SET AMHTOT=AMHTOT+1

 +11       IF AMHSORT="P"

               SET ^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",P,DFN,S1,AMHR)=""

               SET AMHTOT=AMHTOT+1

 +12       SET AMHTOTP(S)=$GET(AMHTOTP(S))+1

 +13       SET AMHTOTF(S1)=$GET(AMHTOTF(S1))+1

 +14       QUIT 

PRINT     ;

 +1        SET Y=AMHBD

           DO DD^%DT

           SET AMHBDD=Y

           SET Y=AMHED

           DO DD^%DT

           SET AMHEDD=Y

 +2        SET AMH80D="-------------------------------------------------------------------------------"

 +3        SET AMHPG=0

           DO HEAD

 +4        IF '$DATA(^XTMP("AMHRPPD",AMHJOB,AMHBTH))

               WRITE !!,"NO PATIENTS TO REPORT"

               GOTO DONE

 +5        SET AMHR=""

           KILL AMHQ

 +6        IF AMHSORT="P"

               DO PS

               GOTO SUB

 +7        SET AMHF=""

           FOR 

               SET AMHF=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF))

               IF AMHF=""!($DATA(AMHQ))

                   QUIT 

               Begin DoDot:1

 +8                SET AMHPT=""

                   FOR 

                       SET AMHPT=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF,AMHPT))

                       IF AMHPT=""!($DATA(AMHQ))

                           QUIT 

                       Begin DoDot:2

 +9                        SET DFN=0

                           FOR 

                               SET DFN=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF,AMHPT,DFN))

                               IF DFN'=+DFN!($DATA(AMHQ))

                                   QUIT 

                               Begin DoDot:3

 +10                               SET AMHR=0

                                   FOR 

                                       SET AMHR=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHF,AMHPT,DFN,AMHR))

                                       IF AMHR'=+AMHR!($DATA(AMHQ))

                                           QUIT 

                                       DO PRINT1

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

SUB       ;

 +1        IF $DATA(AMHQ)

               GOTO DONE

 +2        IF $Y>(IOSL-3)

               DO HEAD

               IF $DATA(AMHQ)

                   GOTO DONE

 +3        WRITE !!,"Subtotal by Placement Type:"

 +4        SET AMHX=""

           FOR 

               SET AMHX=$ORDER(AMHTOTP(AMHX))

               IF AMHX=""!($DATA(AMHQ))

                   QUIT 

               Begin DoDot:1

 +5                IF $Y>(IOSL-3)

                       DO HEAD

                       IF $DATA(AMHQ)

                           QUIT 

 +6                WRITE !?5,AMHX,?40,AMHTOTP(AMHX)

               End DoDot:1

 +7        IF $DATA(AMHQ)

               GOTO DONE

 +8        IF $Y>(IOSL-3)

               DO HEAD

               IF $DATA(AMHQ)

                   GOTO DONE

 +9        WRITE !!,"Subtotal by Facility Referred to:"

 +10       SET AMHX=""

           FOR 

               SET AMHX=$ORDER(AMHTOTF(AMHX))

               IF AMHX=""!($DATA(AMHQ))

                   QUIT 

               Begin DoDot:1

 +11               IF $Y>(IOSL-3)

                       DO HEAD

                       IF $DATA(AMHQ)

                           QUIT 

 +12               WRITE !?5,AMHX,?40,AMHTOTF(AMHX)

               End DoDot:1

 +13       IF $Y>(IOSL-3)

               DO HEAD

               IF $DATA(AMHQ)

                   GOTO DONE

 +14       WRITE !!,"Total Number of Placements: ",AMHTOT

DONE      ;

 +1        KILL ^XTMP("AMHRPPD",AMHJOB,AMHBTH),AMHJOB,AMHBTH

 +2        QUIT 

PRINT1    ;

 +1        IF $Y>(IOSL-4)

               DO HEAD

               IF $DATA(AMHQ)

                   QUIT 

 +2        WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,18),?20,$$HRN^AUPNPAT(DFN,DUZ(2)),?28,$$D^AMHLEIN($PIECE(^AMHREC(AMHR,0),U)),?37,$$PRIMPOV^AMHUTIL1(AMHR,"C"),?44,$EXTRACT($$VAL^XBDIQ1(9002011,AMHR,.17),1,14),?60,$EXTRACT($$VAL^XBDIQ1(9002011,AMHR,.18)

,1,19)

 +3        WRITE !?3,"Placement Made by: ",$$PPNAME^AMHUTIL(AMHR)

 +4        IF '$DATA(^AMHPATR(DFN,0))

               QUIT 

 +5        IF $PIECE(^AMHPATR(DFN,0),U,2)]""

               WRITE !?3,"Designated MH Prov: ",$$VAL^XBDIQ1(9002011.55,DFN,.02)

 +6        IF $PIECE(^AMHPATR(DFN,0),U,3)]""

               WRITE !?3,"Designated SS Prov: ",$$VAL^XBDIQ1(9002011.55,DFN,.03)

 +7        IF $PIECE(^AMHPATR(DFN,0),U,4)]""

               WRITE !?3,"Designated A/SA/CD Prov: ",$$VAL^XBDIQ1(9002011.55,DFN,.04)

 +8        QUIT 

PS        ;

 +1        SET AMHPT=""

           FOR 

               SET AMHPT=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT))

               IF AMHPT=""!($DATA(AMHQ))

                   QUIT 

               Begin DoDot:1

 +2                SET DFN=""

                   FOR 

                       SET DFN=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT,DFN))

                       IF DFN=""!($DATA(AMHQ))

                           QUIT 

                       Begin DoDot:2

 +3                        SET AMHF=""

                           FOR 

                               SET AMHF=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT,DFN,AMHF))

                               IF AMHF=""!($DATA(AMHQ))

                                   QUIT 

                               Begin DoDot:3

 +4                                SET AMHR=0

                                   FOR 

                                       SET AMHR=$ORDER(^XTMP("AMHRPPD",AMHJOB,AMHBTH,"PLACEMENTS",AMHPT,DFN,AMHF,AMHR))

                                       IF AMHR'=+AMHR!($DATA(AMHQ))

                                           QUIT 

                                       DO PRINT1

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +5        QUIT 

D(D)      ;

 +1        QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+($EXTRACT(D,1,3)))

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 ?35,"PLACEMENTS",!

 +6        WRITE ?15,"PLACEMENT DATES:  ",AMHBDD,"  TO  ",AMHEDD,!

PIH        WRITE !,"PATIENT NAME",?20,"HRN",?27,"DATE",?38,"POV",?44,"PLACEMENT",?59,"FACILITY REFERRED TO",!,?27,"PLACED",!,AMH80D

 +1        QUIT