AMHRP8.m

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

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

 ;

START ;

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

 W @(IOF),!!

 W "**********  ACTIVE CLIENT LIST  **********",!!

 W "This report will produce a list of patients who have been seen in a date range",!,"specified by the user.",!

 D DBHUSRP^AMHUTIL

 D DBHUSR^AMHUTIL

GETDATES ;

BD ;get beginning date

 W !,"Please enter the date range during which the patient should be seen in",!,"order to be considered active.",!

 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

 ;

PROV ;limit by provider

 S AMHPROV=""

 S DIR(0)="Y",DIR("A")="Limit the list to those patients who have seen a particular provider",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 G:$D(DIRUT) GETDATES

 G:'Y DEMO

 I Y=1 S DIC("A")="Enter PROVIDER Name: ",DIC=200,DIC(0)="AEQMZ" D ^DIC G PROV:Y<0 S AMHPROV=+Y

DEMO ;

 D DEMOCHK^AMHUTIL1(.AMHDEMO)

 I AMHDEMO=-1 G PROV

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

 D ^XBDBQUE

XIT ;EP

 K ZTSK,Y,AMHBD,AMHED,IO("Q"),AMH80D,AMHBTH,AMHHRCN,AMHJOB,AMHLENG,AMHPCNT,AMHPG,AMHPROV,AMHX,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,XBNS,XBRC,XBRP,XBTX,D,AMHTOT

 K AMHPRNM,AMHPRNT,AMHPROB,AMHPRV,AMHR,AMHRCNT,AMHRLOC,AMHSD,AMHTOT,AMHBDD,AMHBT,AMHEDD,AMHEDO,AMHBDO,AMHBT,AMHFOUND,AMHHIT,AMHID,AMHLINE,AMHP

 Q

 ;

BROWSE ;

 S XBRP="VIEWR^XBLM(""^AMHRP8P"")"

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

 Q

PROC ;EP - entry point for processing

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

 D XTMP^AMHUTIL("AMHRP8","BH - ACTIVE CLIENT LIST")

 F  S DFN=$O(^AMHREC("AE",DFN)) Q:DFN'=+DFN  I $$ALLOWP^AMHUTIL(DUZ,DFN) D PROC1

 S AMHET=$H

 K DFN

 Q

PROC1 ;

 Q:$$DEMO^AMHUTIL1(DFN,$G(AMHDEMO))

 S (AMHID,AMHFOUND)=0 F  S AMHID=$O(^AMHREC("AE",DFN,AMHID)) Q:AMHID'=+AMHID!(AMHFOUND)  D CHK

 Q

CHK ;check to see if patient meets criteria

 S D=9999999-$P(AMHID,".")

 Q:D<AMHBD

 Q:D>AMHED

 S V=0 F  S V=$O(^AMHREC("AE",DFN,AMHID,V)) Q:V'=+V!(AMHFOUND)  D

 .Q:'$$ALLOWVI^AMHUTIL(DUZ,V)

 .I AMHPROV S AMHHIT="" D CHKPROV Q:'AMHHIT

 .S ^XTMP("AMHRP8",AMHJOB,AMHBTH,$P(^DPT(DFN,0),U),DFN)="",AMHTOT=AMHTOT+1,AMHFOUND=1

 Q

 ;

CHKPROV ;if 1 provider selected check for that provider

 NEW X,R

 S R=0 F  S R=$O(^AMHREC("AE",DFN,AMHID,R)) Q:R'=+R!(AMHHIT)  D

 .S P=0 F  S P=$O(^AMHRPROV("AD",R,P)) Q:P'=+P  I $P(^AMHRPROV(P,0),U)=AMHPROV S AMHHIT=1

 .Q

 Q

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

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

 +2       ;

START     ;

 +1        IF '$DATA(IOF)

               DO HOME^%ZIS

 +2        WRITE @(IOF),!!

 +3        WRITE "**********  ACTIVE CLIENT LIST  **********",!!

 +4        WRITE "This report will produce a list of patients who have been seen in a date range",!,"specified by the user.",!

 +5        DO DBHUSRP^AMHUTIL

 +6        DO DBHUSR^AMHUTIL

GETDATES  ;

BD        ;get beginning date

 +1        WRITE !,"Please enter the date range during which the patient should be seen in",!,"order to be considered active.",!

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

PROV      ;limit by provider

 +1        SET AMHPROV=""

 +2        SET DIR(0)="Y"

           SET DIR("A")="Limit the list to those patients who have seen a particular provider"

           SET DIR("B")="N"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               GOTO GETDATES

 +4        IF 'Y

               GOTO DEMO

 +5        IF Y=1

               SET DIC("A")="Enter PROVIDER Name: "

               SET DIC=200

               SET DIC(0)="AEQMZ"

               DO ^DIC

               IF Y<0

                   GOTO PROV

               SET AMHPROV=+Y

DEMO      ;

 +1        DO DEMOCHK^AMHUTIL1(.AMHDEMO)

 +2        IF AMHDEMO=-1

               GOTO PROV

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

           SET XBRP="^AMHRP8P"

           SET XBNS="AMH"

           SET XBRX="XIT^AMHRP8"

 +5        DO ^XBDBQUE

XIT       ;EP

 +1        KILL ZTSK,Y,AMHBD,AMHED,IO("Q"),AMH80D,AMHBTH,AMHHRCN,AMHJOB,AMHLENG,AMHPCNT,AMHPG,AMHPROV,AMHX,DFN,DIC,DIR,DIRUT,DTOUT,DUOUT,XBNS,XBRC,XBRP,XBTX,D,AMHTOT

 +2        KILL AMHPRNM,AMHPRNT,AMHPROB,AMHPRV,AMHR,AMHRCNT,AMHRLOC,AMHSD,AMHTOT,AMHBDD,AMHBT,AMHEDD,AMHEDO,AMHBDO,AMHBT,AMHFOUND,AMHHIT,AMHID,AMHLINE,AMHP

 +3        QUIT 

 +4       ;

BROWSE    ;

 +1        SET XBRP="VIEWR^XBLM(""^AMHRP8P"")"

 +2        SET XBNS="AMH"

           SET XBRC="PROC^AMHRP8"

           SET XBRX="XIT^AMHRP8"

           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        DO XTMP^AMHUTIL("AMHRP8","BH - ACTIVE CLIENT LIST")

 +3        FOR 

               SET DFN=$ORDER(^AMHREC("AE",DFN))

               IF DFN'=+DFN

                   QUIT 

               IF $$ALLOWP^AMHUTIL(DUZ,DFN)

                   DO PROC1

 +4        SET AMHET=$HOROLOG

 +5        KILL DFN

 +6        QUIT 

PROC1     ;

 +1        IF $$DEMO^AMHUTIL1(DFN,$GET(AMHDEMO))

               QUIT 

 +2        SET (AMHID,AMHFOUND)=0

           FOR 

               SET AMHID=$ORDER(^AMHREC("AE",DFN,AMHID))

               IF AMHID'=+AMHID!(AMHFOUND)

                   QUIT 

               DO CHK

 +3        QUIT 

CHK       ;check to see if patient meets criteria

 +1        SET D=9999999-$PIECE(AMHID,".")

 +2        IF D<AMHBD

               QUIT 

 +3        IF D>AMHED

               QUIT 

 +4        SET V=0

           FOR 

               SET V=$ORDER(^AMHREC("AE",DFN,AMHID,V))

               IF V'=+V!(AMHFOUND)

                   QUIT 

               Begin DoDot:1

 +5                IF '$$ALLOWVI^AMHUTIL(DUZ,V)

                       QUIT 

 +6                IF AMHPROV

                       SET AMHHIT=""

                       DO CHKPROV

                       IF 'AMHHIT

                           QUIT 

 +7                SET ^XTMP("AMHRP8",AMHJOB,AMHBTH,$PIECE(^DPT(DFN,0),U),DFN)=""

                   SET AMHTOT=AMHTOT+1

                   SET AMHFOUND=1

               End DoDot:1

 +8        QUIT 

 +9       ;

CHKPROV   ;if 1 provider selected check for that provider

 +1        NEW X,R

 +2        SET R=0

           FOR 

               SET R=$ORDER(^AMHREC("AE",DFN,AMHID,R))

               IF R'=+R!(AMHHIT)

                   QUIT 

               Begin DoDot:1

 +3                SET P=0

                   FOR 

                       SET P=$ORDER(^AMHRPROV("AD",R,P))

                       IF P'=+P

                           QUIT 

                       IF $PIECE(^AMHRPROV(P,0),U)=AMHPROV

                           SET AMHHIT=1

 +4                QUIT 

               End DoDot:1

 +5        QUIT