AMHRPSI.m

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

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

 ;

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

 W @(IOF),!!

 W !,"PATIENTS WITH SUICIDE IDEATION, NOT SEEN IN N DAYS"

 W "This report will produce a list of patients who have had a suicide ideation POV",!,"who haven't been seen in N days since their last ",!,"suicide diagnosis.",!

GETDATES ;

BD ;get beginning date

 W !,"Please enter the date range during which the patient had the Suicide Ideation POV.",!

 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

 ;

DAYS ;

 S AMHDAYS=0

 S DIR(0)="N^1:999999:",DIR("A")="How many days must have passed since their last diagnosis",DIR("B")="5" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G GETDATES

 S AMHDAYS=Y

 ;

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^AMHRPSI",XBRP="PRINT^AMHRPSI",XBNS="AMH",XBRX="XIT^AMHRPSI"

 D ^XBDBQUE

XIT ;

 D EN^XBVK("AMH")

 D KILL^AUPNPAT

 Q

 ;

BROWSE ;

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

 S XBNS="AMH",XBRC="PROC^AMHRPSI",XBRX="XIT^AMHRPSI",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("AMHRPSI","BH - SUICIDE IDEATION")

 S AMHPROB=$O(^AMHPROB("B",39,0))

 K AMHG S DFN=0 F  S DFN=$O(^AMHRPRO("AC",DFN)) Q:DFN=""  D PROC1

 S AMHET=$H

 Q

PROC1 ;

 S AMHG=""

 S AMHP=0 F  S AMHP=$O(^AMHRPRO("AC",DFN,AMHP)) Q:AMHP'=+AMHP  D

 .Q:'$D(^AMHRPRO(AMHP,0))

 .Q:$P(^AMHRPRO(AMHP,0),U)'=AMHPROB

 .S V=$P(^AMHRPRO(AMHP,0),U,3)

 .Q:'V

 .Q:'$D(^AMHREC(V,0))

 .S D=$P($P(^AMHREC(V,0),U),".")

 .Q:D<AMHBD

 .Q:D>AMHED

 .I D>$P(AMHG,U) S AMHG=D_U_AMHP

 .Q

 Q:AMHG=""

 I $$FMDIFF^XLFDT(DT,$P(AMHG,U))'<AMHDAYS D SET

 Q

 Q

SET ;

 S ^XTMP("AMHRPSI",AMHJOB,AMHBTH,"PATIENTS",DFN)=AMHG,AMHTOT=AMHTOT+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("AMHRPSI",AMHJOB,AMHBTH)) W !!,"NO PATIENTS TO REPORT" G DONE

 S AMHR="" K AMHQ

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

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

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

 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("AMHRPSI",AMHJOB,AMHBTH),AMHJOB,AMHBTH

 Q

PRINT1 ;

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

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

 W !,$E($P(^DPT(DFN,0),U),1,20),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?29,$$D($P(^AMHREC(AMHR,0),U)),?40,$E($$VAL^XBDIQ1(9002011,AMHR,.18),1,24),?66,$E($$VAL^XBDIQ1(9002011,AMHR,.17),1,14)

 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",?22,"HRN",?29,"DATE PLACE",?40,"FACILITY REFERRED TO",?66,"PLACEMENT",!,AMH80D

 Q

AMHRPSI   ; 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 !,"PATIENTS WITH SUICIDE IDEATION, NOT SEEN IN N DAYS"

 +6        WRITE "This report will produce a list of patients who have had a suicide ideation POV",!,"who haven't been seen in N days since their last ",!,"suicide diagnosis.",!

GETDATES  ;

BD        ;get beginning date

 +1        WRITE !,"Please enter the date range during which the patient had the Suicide Ideation POV.",!

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

DAYS      ;

 +1        SET AMHDAYS=0

 +2        SET DIR(0)="N^1:999999:"

           SET DIR("A")="How many days must have passed since their last diagnosis"

           SET DIR("B")="5"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO GETDATES

 +4        SET AMHDAYS=Y

 +5       ;

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^AMHRPSI"

           SET XBRP="PRINT^AMHRPSI"

           SET XBNS="AMH"

           SET XBRX="XIT^AMHRPSI"

 +5        DO ^XBDBQUE

XIT       ;

 +1        DO EN^XBVK("AMH")

 +2        DO KILL^AUPNPAT

 +3        QUIT 

 +4       ;

BROWSE    ;

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

 +2        SET XBNS="AMH"

           SET XBRC="PROC^AMHRPSI"

           SET XBRX="XIT^AMHRPSI"

           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("AMHRPSI","BH - SUICIDE IDEATION")

 +4        SET AMHPROB=$ORDER(^AMHPROB("B",39,0))

 +5        KILL AMHG

           SET DFN=0

           FOR 

               SET DFN=$ORDER(^AMHRPRO("AC",DFN))

               IF DFN=""

                   QUIT 

               DO PROC1

 +6        SET AMHET=$HOROLOG

 +7        QUIT 

PROC1     ;

 +1        SET AMHG=""

 +2        SET AMHP=0

           FOR 

               SET AMHP=$ORDER(^AMHRPRO("AC",DFN,AMHP))

               IF AMHP'=+AMHP

                   QUIT 

               Begin DoDot:1

 +3                IF '$DATA(^AMHRPRO(AMHP,0))

                       QUIT 

 +4                IF $PIECE(^AMHRPRO(AMHP,0),U)'=AMHPROB

                       QUIT 

 +5                SET V=$PIECE(^AMHRPRO(AMHP,0),U,3)

 +6                IF 'V

                       QUIT 

 +7                IF '$DATA(^AMHREC(V,0))

                       QUIT 

 +8                SET D=$PIECE($PIECE(^AMHREC(V,0),U),".")

 +9                IF D<AMHBD

                       QUIT 

 +10               IF D>AMHED

                       QUIT 

 +11               IF D>$PIECE(AMHG,U)

                       SET AMHG=D_U_AMHP

 +12               QUIT 

               End DoDot:1

 +13       IF AMHG=""

               QUIT 

 +14       IF $$FMDIFF^XLFDT(DT,$PIECE(AMHG,U))'<AMHDAYS

               DO SET

 +15       QUIT 

 +16       QUIT 

SET       ;

 +1        SET ^XTMP("AMHRPSI",AMHJOB,AMHBTH,"PATIENTS",DFN)=AMHG

           SET AMHTOT=AMHTOT+1

 +2        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("AMHRPSI",AMHJOB,AMHBTH))

               WRITE !!,"NO PATIENTS TO REPORT"

               GOTO DONE

 +5        SET AMHR=""

           KILL AMHQ

 +6        SET AMHF=""

           FOR 

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

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

                   QUIT 

               Begin DoDot:1

 +7                SET AMHP=""

                   FOR 

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

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

                           QUIT 

                       Begin DoDot:2

 +8                        SET AMHR=0

                           FOR 

                               SET AMHR=$ORDER(^XTMP("AMHRPSI",AMHJOB,AMHBTH,"PLACEMENTS",AMHF,AMHP,AMHR))

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

                                   QUIT 

                               DO PRINT1

                       End DoDot:2

               End DoDot:1

 +9        IF $DATA(AMHQ)

               GOTO DONE

 +10       IF $Y>(IOSL-3)

               DO HEAD

               IF $DATA(AMHQ)

                   GOTO DONE

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

 +12       SET AMHX=""

           FOR 

               SET AMHX=$ORDER(AMHTOTP(AMHX))

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

                   QUIT 

               Begin DoDot:1

 +13               IF $Y>(IOSL-3)

                       DO HEAD

                       IF $DATA(AMHQ)

                           QUIT 

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

               End DoDot:1

 +15       IF $DATA(AMHQ)

               GOTO DONE

 +16       IF $Y>(IOSL-3)

               DO HEAD

               IF $DATA(AMHQ)

                   GOTO DONE

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

 +18       SET AMHX=""

           FOR 

               SET AMHX=$ORDER(AMHTOTF(AMHX))

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

                   QUIT 

               Begin DoDot:1

 +19               IF $Y>(IOSL-3)

                       DO HEAD

                       IF $DATA(AMHQ)

                           QUIT 

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

               End DoDot:1

 +21       IF $Y>(IOSL-3)

               DO HEAD

               IF $DATA(AMHQ)

                   GOTO DONE

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

DONE      ;

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

 +2        QUIT 

PRINT1    ;

 +1        IF $Y>(IOSL-4)

               DO HEAD

               IF $DATA(AMHQ)

                   QUIT 

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

 +3        WRITE !,$EXTRACT($PIECE(^DPT(DFN,0),U),1,20),?22,$$HRN^AUPNPAT(DFN,DUZ(2)),?29,$$D($PIECE(^AMHREC(AMHR,0),U)),?40,$EXTRACT($$VAL^XBDIQ1(9002011,AMHR,.18),1,24),?66,$EXTRACT($$VAL^XBDIQ1(9002011,AMHR,.17),1,14)

 +4        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",?22,"HRN",?29,"DATE PLACE",?40,"FACILITY REFERRED TO",?66,"PLACEMENT",!,AMH80D

 +1        QUIT