AMHRL.m

AMHRL ; IHS/CMI/LAB - BH GENERAL RETRIEVAL DRIVER ;

 ;;4.0;IHS BEHAVIORAL HEALTH;**6**;JUN 02, 2010;Build 10

START ; 

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

 I '$G(DUZ(2)) W $C(7),$C(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!! Q

 I '$G(DUZ) W $C(7),$C(7),!!,"USER NOT SET IN DUZ - NOTIFY SITE MANAGER!!",!! Q

 K AMHQUIT

 I AMHPTVS="P" S AMHPTTX="Patient",AMHPTTS="Patients"

 I AMHPTVS="S" S AMHPTTX="Suicide Form",AMHPTTS="Suicide Forms"

 I AMHPTVS="V" S AMHPTTX="Visit",AMHPTTS="Visits"

TYPE ;--- get type of report (patient, date range or search template)

 D INFORM^AMHRL01

 I AMHPTVS="S" S AMHTYPE="SU" D SU,XIT Q

 K DIR,X,Y S DIR(0)="S^S:Search Template"_$S(AMHPTVS="V":";D:Date Range",1:";P:Patient File"),DIR("A")="Select and Print "_$S(AMHPTVS="P":"Patient ",1:"Encounter ")_"List from" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 G:$D(DIRUT) XIT

 S AMHTYPE=Y

 D @AMHTYPE

 D XIT

 Q

P ;patient lister

 D ADD I $D(AMHQUIT) D DEL K AMHQUIT G TYPE

 I '$D(AMHCAND) D P1 Q

 I $D(AMHCAND),$P(^AMHTRPT(AMHRPT,0),U,11) D  I $D(DIRUT)!'($D(AMHBDD))!('$D(AMHEDD)) Q

 .S AMHRDTR=""

 .W !!,"You have selected at least one item that requires a date range selection."

 .D GETDATES

 D TITLE I $D(AMHQUIT) K AMHQUIT G TYPE

 D ZIS

 Q

P1 ;if patient, no prev defined report used

P11 K ^AMHTRPT(AMHRPT,11),AMHRDTR D SCREEN I $D(AMHQUIT) K AMHQUIT D DEL Q:AMHPTVS="S"  G TYPE

 I $D(AMHRDTR) D

 .W !!,"You have selected at least one item that requires a date range selection."

 .D GETDATES

 .I '$D(AMHBDD)!('$D(AMHEDD))!($D(DIRUT)) G P11

P12 K ^AMHTRPT(AMHRPT,12) S AMHTCW=0 D COUNT I $D(AMHQUIT) K AMHQUIT G P11

P13 D TITLE I $D(AMHQUIT) K AMHQUIT G P12

 D SAVE

 D ZIS

 Q

S ;--- search template

 D S0

 Q:$D(AMHQUIT)

S1 ;EP

 D ADD I $D(AMHQUIT) G S

S12 K ^AMHTRPT(AMHRPT,12) S AMHTCW=0 D COUNT I $D(AMHQUIT) K AMHQUIT G S

S13 D TITLE I $D(AMHQUIT) K AMHQUIT G S12

 D ZIS

 Q

S0 ;

 S:AMHPTVS="V" DIC("S")="I $P(^(0),U,4)=9002011" S:AMHPTVS="P" DIC("S")="I $P(^(0),U,4)=2!($P(^(0),U,4)=9000001)" S DIC="^DIBT(",DIC("A")="Enter SEARCH TEMPLATE name: ",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DICR

 I Y=-1 S AMHQUIT="" Q

 S AMHSEAT=+Y

 ;

 Q

D ;

GETDATES ;

BD ;get beginning date

 W ! K DIR,X,Y S DIR(0)="D^:DT:EP",DIR("A")="Enter Beginning Encounter Date for search" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) D DEL G TYPE

 S AMHBD=Y

ED ;get ending date

 W ! K DIR,X,Y S DIR(0)="D^"_AMHBD_":DT:EP",DIR("A")="Enter Ending Encounter Date for search" 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 AMHD=X S Y=AMHBD D DD^%DT S AMHBDD=Y S Y=AMHED D DD^%DT S AMHEDD=Y

 Q:$D(AMHRDTR)

 D ADD I $D(AMHQUIT) D DEL K AMHQUIT G D

 I '$D(AMHCAND) D D1 Q

 D TITLE I $D(AMHQUIT) K AMHQUIT G TYPE

 D ZIS

 Q

SU ;

SBD ;get beginning date

 W ! K DIR,X,Y S DIR(0)="D^:DT:EP",DIR("A")="Enter Beginning Date for search" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) D XIT Q

 S AMHBD=Y

SED ;get ending date

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

 I $D(DIRUT) G SBD

 S AMHED=Y

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

 D ADD I $D(AMHQUIT) D DEL K AMHQUIT D XIT Q

 I '$D(AMHCAND) D P1 Q

 D TITLE I $D(AMHQUIT) K AMHQUIT G TYPE ;**

 D ZIS ;**

 Q  ;**

D1 ;if visit, no prev defined report used

D11 K ^AMHTRPT(AMHRPT,11),AMHRDTR D SCREEN I $D(AMHQUIT) K AMHQUIT D DEL D XIT Q

D12 K ^AMHTRPT(AMHRPT,12) S AMHTCW=0 D COUNT I $D(AMHQUIT) K AMHQUIT G D11

D13 D TITLE I $D(AMHQUIT) K AMHQUIT G D12

 D SAVE

 D ZIS

 Q

SCREEN ;

 ;D SCREEN^AMHRL3

 S AMHCNTL="S" D ^AMHRL4

 Q

COUNT ;count only or detailed report

 D COUNT^AMHRL3

 Q

TITLE ;

 Q:AMHCTYP="F"

 Q:AMHCTYP="T"

 K DIR,X,Y S DIR(0)="Y",DIR("A")="Would you like a custom title for this report",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) S AMHQUIT=1 Q

 Q:Y=0

 S AMHLENG=$S(AMHTCW:AMHTCW-8,1:60)

 I Y=1 K DIR,X,Y S DIR(0)="F^3:"_AMHLENG,DIR("A")="Enter custom title",DIR("?")="    Enter from 3 to "_AMHLENG_" characters" D ^DIR K DIR

 G:$D(DIRUT) TITLE

 S AMHTITL=Y

 Q

SAVE ;

 Q:$D(AMHCAND)

 Q:AMHCTYP'="D"  ;--- must be a detailed report to be saved

 S AMHSAVE=""

 K DIR,X,Y S DIR(0)="Y",DIR("A")="Do you wish to SAVE this "_$S('$D(AMHEP1):"SEARCH/",1:"")_"PRINT/SORT logic for future use",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q:$D(DIRUT)

 Q:'Y

 K DIR,X,Y S DIR(0)="9001003.8,.03",DIR("A")="Enter NAME for this REPORT DEFINITION" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 G:$D(DIRUT) SAVE

 S AMHNAME=Y

 S DIE="^AMHTRPT(",DA=AMHRPT,DR=".02////1;.03///"_AMHNAME_";.06///"_AMHPTVS_";.05///"_AMHCTYP_";.11///"_$G(AMHRDTR) S:$D(AMHEP1) DR=DR_";.09///"_AMHPACK D CALLDIE^AMHLEIN

 Q

ZIS ;call to XBDBQUE

DEMO ;

 D DEMOCHK^AMHUTIL1(.AMHDEMO)

 I AMHDEMO=-1 Q

 I 'AMHTCW S AMHTCW=IOM

 S AMHDONE=""

 D SHOW^AMHRLS,SHOWP^AMHRLS I AMHCTYP'="T",AMHCTYP'="S" D SHOWR^AMHRLS

 D XIT1

 I AMHCTYP="D"!(AMHCTYP="S") D

 .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) S AMHQUIT="" Q

 .S AMHOPT=Y

 G:$G(AMHQUIT) SAVE

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

 S XBRP="^AMHRLP",XBRC="^AMHRL1",XBRX="XIT^AMHRL",XBNS="AMH"

 D ^XBDBQUE

 D XIT

 Q

DEL ;EP DELETE LOG ENTRY IF ONE EXISTS AND USER "^" OUT

 I $G(AMHRPT),$D(^AMHTRPT(AMHRPT,0)),'$P(^AMHTRPT(AMHRPT,0),U,2) S DIK="^AMHTRPT(",DA=AMHRPT D ^DIK K DIK,DA,DIC

 Q

ADD ;

 D ADD^AMHRL01

 Q

BROWSE ;

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

 S XBRC="^AMHRL1",XBRX="XIT^AMHRL",XBIOP=0 D ^XBDBQUE

 Q

XIT ;

 D XIT^AMHRL1

 K AMHOPT

XIT1 ;

 D XIT1^AMHRL1

 Q

AMHRL     ; IHS/CMI/LAB - BH GENERAL RETRIEVAL DRIVER ;

 +1       ;;4.0;IHS BEHAVIORAL HEALTH;**6**;JUN 02, 2010;Build 10

START     ; 

 +1        IF '$DATA(IOF)

               DO HOME^%ZIS

 +2        IF '$GET(DUZ(2))

               WRITE $CHAR(7),$CHAR(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!!

               QUIT 

 +3        IF '$GET(DUZ)

               WRITE $CHAR(7),$CHAR(7),!!,"USER NOT SET IN DUZ - NOTIFY SITE MANAGER!!",!!

               QUIT 

 +4        KILL AMHQUIT

 +5        IF AMHPTVS="P"

               SET AMHPTTX="Patient"

               SET AMHPTTS="Patients"

 +6        IF AMHPTVS="S"

               SET AMHPTTX="Suicide Form"

               SET AMHPTTS="Suicide Forms"

 +7        IF AMHPTVS="V"

               SET AMHPTTX="Visit"

               SET AMHPTTS="Visits"

TYPE      ;--- get type of report (patient, date range or search template)

 +1        DO INFORM^AMHRL01

 +2        IF AMHPTVS="S"

               SET AMHTYPE="SU"

               DO SU

               DO XIT

               QUIT 

 +3        KILL DIR,X,Y

           SET DIR(0)="S^S:Search Template"_$SELECT(AMHPTVS="V":";D:Date Range",1:";P:Patient File")

           SET DIR("A")="Select and Print "_$SELECT(AMHPTVS="P":"Patient ",1:"Encounter ")_"List from"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +4        IF $DATA(DIRUT)

               GOTO XIT

 +5        SET AMHTYPE=Y

 +6        DO @AMHTYPE

 +7        DO XIT

 +8        QUIT 

P         ;patient lister

 +1        DO ADD

           IF $DATA(AMHQUIT)

               DO DEL

               KILL AMHQUIT

               GOTO TYPE

 +2        IF '$DATA(AMHCAND)

               DO P1

               QUIT 

 +3        IF $DATA(AMHCAND)

               IF $PIECE(^AMHTRPT(AMHRPT,0),U,11)

                   Begin DoDot:1

 +4                    SET AMHRDTR=""

 +5                    WRITE !!,"You have selected at least one item that requires a date range selection."

 +6                    DO GETDATES

                   End DoDot:1

                   IF $DATA(DIRUT)!'($DATA(AMHBDD))!('$DATA(AMHEDD))

                       QUIT 

 +7        DO TITLE

           IF $DATA(AMHQUIT)

               KILL AMHQUIT

               GOTO TYPE

 +8        DO ZIS

 +9        QUIT 

P1        ;if patient, no prev defined report used

P11        KILL ^AMHTRPT(AMHRPT,11),AMHRDTR

           DO SCREEN

           IF $DATA(AMHQUIT)

               KILL AMHQUIT

               DO DEL

               IF AMHPTVS="S"

                   QUIT 

               GOTO TYPE

 +1        IF $DATA(AMHRDTR)

               Begin DoDot:1

 +2                WRITE !!,"You have selected at least one item that requires a date range selection."

 +3                DO GETDATES

 +4                IF '$DATA(AMHBDD)!('$DATA(AMHEDD))!($DATA(DIRUT))

                       GOTO P11

               End DoDot:1

P12        KILL ^AMHTRPT(AMHRPT,12)

           SET AMHTCW=0

           DO COUNT

           IF $DATA(AMHQUIT)

               KILL AMHQUIT

               GOTO P11

P13        DO TITLE

           IF $DATA(AMHQUIT)

               KILL AMHQUIT

               GOTO P12

 +1        DO SAVE

 +2        DO ZIS

 +3        QUIT 

S         ;--- search template

 +1        DO S0

 +2        IF $DATA(AMHQUIT)

               QUIT 

S1        ;EP

 +1        DO ADD

           IF $DATA(AMHQUIT)

               GOTO S

S12        KILL ^AMHTRPT(AMHRPT,12)

           SET AMHTCW=0

           DO COUNT

           IF $DATA(AMHQUIT)

               KILL AMHQUIT

               GOTO S

S13        DO TITLE

           IF $DATA(AMHQUIT)

               KILL AMHQUIT

               GOTO S12

 +1        DO ZIS

 +2        QUIT 

S0        ;

 +1        IF AMHPTVS="V"

               SET DIC("S")="I $P(^(0),U,4)=9002011"

           IF AMHPTVS="P"

               SET DIC("S")="I $P(^(0),U,4)=2!($P(^(0),U,4)=9000001)"

           SET DIC="^DIBT("

           SET DIC("A")="Enter SEARCH TEMPLATE name: "

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC,DA,DR,DICR

 +2        IF Y=-1

               SET AMHQUIT=""

               QUIT 

 +3        SET AMHSEAT=+Y

 +4       ;

 +5        QUIT 

D         ;

GETDATES  ;

BD        ;get beginning date

 +1        WRITE !

           KILL DIR,X,Y

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

           SET DIR("A")="Enter Beginning Encounter Date for search"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               DO DEL

               GOTO TYPE

 +3        SET AMHBD=Y

ED        ;get ending date

 +1        WRITE !

           KILL DIR,X,Y

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

           SET DIR("A")="Enter Ending Encounter Date for search"

           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 AMHD=X

           SET Y=AMHBD

           DO DD^%DT

           SET AMHBDD=Y

           SET Y=AMHED

           DO DD^%DT

           SET AMHEDD=Y

 +5        IF $DATA(AMHRDTR)

               QUIT 

 +6        DO ADD

           IF $DATA(AMHQUIT)

               DO DEL

               KILL AMHQUIT

               GOTO D

 +7        IF '$DATA(AMHCAND)

               DO D1

               QUIT 

 +8        DO TITLE

           IF $DATA(AMHQUIT)

               KILL AMHQUIT

               GOTO TYPE

 +9        DO ZIS

 +10       QUIT 

SU        ;

SBD       ;get beginning date

 +1        WRITE !

           KILL DIR,X,Y

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

           SET DIR("A")="Enter Beginning Date for search"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               DO XIT

               QUIT 

 +3        SET AMHBD=Y

SED       ;get ending date

 +1        WRITE !

           KILL DIR,X,Y

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

           SET DIR("A")="Enter Ending Date for search"

           SET Y=AMHBD

           DO DD^%DT

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO SBD

 +3        SET AMHED=Y

 +4        SET X1=AMHBD

           SET X2=-1

           DO C^%DTC

           SET AMHD=X

           SET Y=AMHBD

           DO DD^%DT

           SET AMHBDD=Y

           SET Y=AMHED

           DO DD^%DT

           SET AMHEDD=Y

 +5        DO ADD

           IF $DATA(AMHQUIT)

               DO DEL

               KILL AMHQUIT

               DO XIT

               QUIT 

 +6        IF '$DATA(AMHCAND)

               DO P1

               QUIT 

 +7       ;**

           DO TITLE

           IF $DATA(AMHQUIT)

               KILL AMHQUIT

               GOTO TYPE

 +8       ;**

           DO ZIS

 +9       ;**

           QUIT 

D1        ;if visit, no prev defined report used

D11        KILL ^AMHTRPT(AMHRPT,11),AMHRDTR

           DO SCREEN

           IF $DATA(AMHQUIT)

               KILL AMHQUIT

               DO DEL

               DO XIT

               QUIT 

D12        KILL ^AMHTRPT(AMHRPT,12)

           SET AMHTCW=0

           DO COUNT

           IF $DATA(AMHQUIT)

               KILL AMHQUIT

               GOTO D11

D13        DO TITLE

           IF $DATA(AMHQUIT)

               KILL AMHQUIT

               GOTO D12

 +1        DO SAVE

 +2        DO ZIS

 +3        QUIT 

SCREEN    ;

 +1       ;D SCREEN^AMHRL3

 +2        SET AMHCNTL="S"

           DO ^AMHRL4

 +3        QUIT 

COUNT     ;count only or detailed report

 +1        DO COUNT^AMHRL3

 +2        QUIT 

TITLE     ;

 +1        IF AMHCTYP="F"

               QUIT 

 +2        IF AMHCTYP="T"

               QUIT 

 +3        KILL DIR,X,Y

           SET DIR(0)="Y"

           SET DIR("A")="Would you like a custom title for this report"

           SET DIR("B")="N"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +4        IF $DATA(DIRUT)

               SET AMHQUIT=1

               QUIT 

 +5        IF Y=0

               QUIT 

 +6        SET AMHLENG=$SELECT(AMHTCW:AMHTCW-8,1:60)

 +7        IF Y=1

               KILL DIR,X,Y

               SET DIR(0)="F^3:"_AMHLENG

               SET DIR("A")="Enter custom title"

               SET DIR("?")="    Enter from 3 to "_AMHLENG_" characters"

               DO ^DIR

               KILL DIR

 +8        IF $DATA(DIRUT)

               GOTO TITLE

 +9        SET AMHTITL=Y

 +10       QUIT 

SAVE      ;

 +1        IF $DATA(AMHCAND)

               QUIT 

 +2       ;--- must be a detailed report to be saved

           IF AMHCTYP'="D"

               QUIT 

 +3        SET AMHSAVE=""

 +4        KILL DIR,X,Y

           SET DIR(0)="Y"

           SET DIR("A")="Do you wish to SAVE this "_$SELECT('$DATA(AMHEP1):"SEARCH/",1:"")_"PRINT/SORT logic for future use"

           SET DIR("B")="N"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +5        IF $DATA(DIRUT)

               QUIT 

 +6        IF 'Y

               QUIT 

 +7        KILL DIR,X,Y

           SET DIR(0)="9001003.8,.03"

           SET DIR("A")="Enter NAME for this REPORT DEFINITION"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +8        IF $DATA(DIRUT)

               GOTO SAVE

 +9        SET AMHNAME=Y

 +10       SET DIE="^AMHTRPT("

           SET DA=AMHRPT

           SET DR=".02////1;.03///"_AMHNAME_";.06///"_AMHPTVS_";.05///"_AMHCTYP_";.11///"_$GET(AMHRDTR)

           IF $DATA(AMHEP1)

               SET DR=DR_";.09///"_AMHPACK

           DO CALLDIE^AMHLEIN

 +11       QUIT 

ZIS       ;call to XBDBQUE

DEMO      ;

 +1        DO DEMOCHK^AMHUTIL1(.AMHDEMO)

 +2        IF AMHDEMO=-1

               QUIT 

 +3        IF 'AMHTCW

               SET AMHTCW=IOM

 +4        SET AMHDONE=""

 +5        DO SHOW^AMHRLS

           DO SHOWP^AMHRLS

           IF AMHCTYP'="T"

               IF AMHCTYP'="S"

                   DO SHOWR^AMHRLS

 +6        DO XIT1

 +7        IF AMHCTYP="D"!(AMHCTYP="S")

               Begin DoDot:1

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

 +9                IF $DATA(DIRUT)

                       SET AMHQUIT=""

                       QUIT 

 +10               SET AMHOPT=Y

               End DoDot:1

 +11       IF $GET(AMHQUIT)

               GOTO SAVE

 +12       IF $GET(AMHOPT)="B"

               DO BROWSE

               DO XIT

               QUIT 

 +13       SET XBRP="^AMHRLP"

           SET XBRC="^AMHRL1"

           SET XBRX="XIT^AMHRL"

           SET XBNS="AMH"

 +14       DO ^XBDBQUE

 +15       DO XIT

 +16       QUIT 

DEL       ;EP DELETE LOG ENTRY IF ONE EXISTS AND USER "^" OUT

 +1        IF $GET(AMHRPT)

               IF $DATA(^AMHTRPT(AMHRPT,0))

                   IF '$PIECE(^AMHTRPT(AMHRPT,0),U,2)

                       SET DIK="^AMHTRPT("

                       SET DA=AMHRPT

                       DO ^DIK

                       KILL DIK,DA,DIC

 +2        QUIT 

ADD       ;

 +1        DO ADD^AMHRL01

 +2        QUIT 

BROWSE    ;

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

 +2        SET XBRC="^AMHRL1"

           SET XBRX="XIT^AMHRL"

           SET XBIOP=0

           DO ^XBDBQUE

 +3        QUIT 

XIT       ;

 +1        DO XIT^AMHRL1

 +2        KILL AMHOPT

XIT1      ;

 +1        DO XIT1^AMHRL1

 +2        QUIT