AMHRL0.m

AMHRL0 ; IHS/CMI/LAB - TUCSON-OHPRD/LAB - SCREEN LOGIC ;

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

 ;

 ;

SELECT ;EP

 S AMHANS=Y,AMHC="" F AMHI=1:1 S AMHC=$P(AMHANS,",",AMHI) Q:AMHC=""  S AMHCRIT=AMHSEL(AMHC) D

 .S AMHTEXT=$P(^AMHSORT(AMHCRIT,0),U)

 .S AMHRAR=$P(^AMHSORT(AMHCRIT,0),U,6) K ^AMHTRPT(AMHRPT,11,AMHCRIT),^AMHTRPT(AMHRPT,11,"B",AMHCRIT)

 .W !!,AMHC,")  ",AMHTEXT," Selection."

 .I $P(^AMHSORT(AMHCRIT,0),U,2)]"" S AMHCNT=0,^AMHTRPT(AMHRPT,11,0)="^9002013.81101PA^0^0" D @$P(^AMHSORT(AMHCRIT,0),U,2) S DIK="^AMHTRPT(",DA=AMHRPT D IX1^DIK

 .I $P(^AMHSORT(AMHCRIT,0),U,13) S AMHRDTR=1

 .Q

 Q

PSELECT ;EP

 S AMHANS=Y,AMHC="" F AMHI=1:1 S AMHC=$P(AMHANS,",",AMHI) Q:AMHC=""  S AMHCRIT=AMHSEL(AMHC),AMHPCNT=AMHPCNT+1 D

 .S DIR(0)="N^2:80:0",DIR("A")="Enter Column width for "_$P(^AMHSORT(AMHCRIT,0),U)_" (suggested: "_$P(^AMHSORT(AMHCRIT,0),U,7)_")",DIR("B")=$P(^(0),U,7) D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 .I $D(DIRUT) S Y=$P(^AMHSORT(AMHCRIT,0),U,7)

 .S ^AMHTRPT(AMHRPT,12,0)="^9002013.81102PA^1^1"

 .I $D(^AMHTRPT(AMHRPT,12,"B",AMHCRIT)) S X=$O(^AMHTRPT(AMHRPT,12,"B",AMHCRIT,"")),AMHTCW=AMHTCW-$P(^AMHTRPT(AMHRPT,12,X,0),U,2)-2,^AMHTRPT(AMHRPT,12,X,0)=AMHCRIT_U_Y D  Q

 ..Q

 .S ^AMHTRPT(AMHRPT,12,AMHPCNT,0)=AMHCRIT_U_Y,^AMHTRPT(AMHRPT,12,"B",AMHCRIT,AMHPCNT)="",AMHTCW=AMHTCW+Y+2

 .W !!?15,"Total Report width (including column margins - 2 spaces):   ",AMHTCW

 .Q

 Q

Q ;EP

 K DIC,DIR

 K ^XTMP("AMHRL",$J,"QMAN"),^UTILITY("AMQQ TAX",$J)

 K DIC,X,Y,DD S X=$P(^AMHSORT(AMHCRIT,0),U,3),DIC="^AMQQ(5,",DIC(0)="EQXM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA,DINUM,DICR I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" Q

 S AMHQMAN=+Y

 D PEP^AMQQGTX0(AMHQMAN,"^XTMP(""AMHRL"",$J,""QMAN"",")

 I '$D(^XTMP("AMHRL",$J,"QMAN")) W !!,$C(7),"** No ",$P(^AMHSORT(AMHCRIT,0),U)," selected, all will be included." Q

 I $D(^XTMP("AMHRL",$J,"QMAN","*")) K ^XTMP("AMHRL",$J,"QMAN")

 S ^AMHTRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT,^AMHTRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""

 S X="",Y=0 F  S X=$O(^XTMP("AMHRL",$J,"QMAN",X)) Q:X=""  S Y=Y+1,^AMHTRPT(AMHRPT,11,AMHCRIT,11,Y,0)=X,^AMHTRPT(AMHRPT,11,AMHCRIT,11,"B",X,Y)="",^AMHTRPT(AMHRPT,11,AMHCRIT,11,0)="^9002013.8110101A^"_Y_"^"_Y

 K X,Y,Z,AMHQMAN,V

 K ^XTMP("AMHRL",$J,"QMAN")

 Q

R ;EP

 K DIR,DIRUT,DUOUT,DTOUT,DA

 S DIR(0)=$P(^AMHSORT(AMHCRIT,0),U,4)_"O",DIR("A")="ENTER "_$P(^(0),U) D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q:$D(DIRUT)

 I Y="" Q

 I Y=-1 Q

 S ^AMHTRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT,^AMHTRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""

 S AMHCNT=AMHCNT+1,^AMHTRPT(AMHRPT,11,AMHCRIT,11,AMHCNT,0)=$P(Y,U),^AMHTRPT(AMHRPT,11,AMHCRIT,11,"B",$P(Y,U),AMHCNT)="",^AMHTRPT(AMHRPT,11,AMHCRIT,11,0)="^9002013.8110101A^"_AMHCNT_"^"_AMHCNT

 G R

 Q

D ;DATE RANGE

BD ;get beginning date

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

 I $D(DIRUT) Q

 S AMHGDB=Y

ED ;get ending date

 W ! S DIR(0)="D^"_AMHGDB_"::EP",DIR("A")="Enter ending "_AMHTEXT_" for Search" S Y=AMHGDB D DD^%DT D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G BD

 S AMHGDE=Y

 S X1=AMHGDB,X2=-1 D C^%DTC S AMHGDS=X

 ;

 S ^AMHTRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT,^AMHTRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""

 S AMHCNT=0,^AMHTRPT(AMHRPT,11,AMHCRIT,11,AMHCNT,0)="^9002013.8110101A^1^1" S AMHCNT=AMHCNT+1,^AMHTRPT(AMHRPT,11,AMHCRIT,11,1,0)=AMHGDB_U_AMHGDE,^AMHTRPT(AMHRPT,11,AMHCRIT,11,"B",AMHGDB,AMHCNT)=""

 Q

N ;

 K Y

 K ^AMHTRPT(AMHRPT,11,AMHCRIT),^AMHTRPT(AMHRPT,11,"B",AMHCRIT)

 S DIR(0)="FO^1:7",DIR("A")="Enter a Range of numbers (e.g. 5-12,1-1)" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q:$D(DIRUT)

 I Y="" W !!,"No numeric range entered.  All numerics will be included." Q

 I Y'?1.3N1"-"1.3N W !!,$C(7),$C(7),"Enter a numeric range in the format nnn-nnn.  E.g. 0-5, 0-99, 5-20." G N

 S ^AMHTRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT,^AMHTRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""

 S AMHCNT=0,^AMHTRPT(AMHRPT,11,AMHCRIT,11,0)="^9002013.8110101A^1^1" F X=$P(Y,"-"):.1:$P(Y,"-",2) S AMHCNT=AMHCNT+1,^AMHTRPT(AMHRPT,11,AMHCRIT,11,AMHCNT,0)=X,^AMHTRPT(AMHRPT,11,AMHCRIT,11,"B",X,AMHCNT)=""  I AMHCNT>99999 W AMHBOMB

 S $P(^AMHTRPT(AMHRPT,11,AMHCRIT,11,1,0),U,2)=$P(Y,"-",2)

 Q

F ;FREE TEXT RANGE

 K ^AMHTRPT(AMHRPT,11,AMHCRIT),^AMHTRPT(AMHRPT,11,"B",AMHCRIT)

 S DIR(0)="FO^1:20",DIR("A")="Enter a Range of Characters for Search (e.g. A:B) " D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I Y="" W !!,"No range entered.  All ",AMHTEXT,"  will be included." Q

 I Y'?1.ANP1":"1.ANP W !!,$C(7),$C(7),"Enter an free text range in the format AAA:AAA.  E.g. 94-01:94-200, CA:CZ, A:Z." G F

 S ^AMHTRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT,^AMHTRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""

 S AMHCNT=0,^AMHTRPT(AMHRPT,11,AMHCRIT,11,AMHCNT,0)="^9002013.8110101A^1^1" S AMHCNT=AMHCNT+1,^AMHTRPT(AMHRPT,11,AMHCRIT,11,1,0)=$P(X,":")_U_$P(X,":",2),^AMHTRPT(AMHRPT,11,AMHCRIT,11,"B",$P(X,":"),AMHCNT)=""

 Q

Y ;

 D Y^AMHRL01

 Q

SPECIAL ;

 D SPECIAL^AMHRL01

 Q

AMHRL0    ; IHS/CMI/LAB - TUCSON-OHPRD/LAB - SCREEN LOGIC ;

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

 +2       ;

 +3       ;

SELECT    ;EP

 +1        SET AMHANS=Y

           SET AMHC=""

           FOR AMHI=1:1

               SET AMHC=$PIECE(AMHANS,",",AMHI)

               IF AMHC=""

                   QUIT 

               SET AMHCRIT=AMHSEL(AMHC)

               Begin DoDot:1

 +2                SET AMHTEXT=$PIECE(^AMHSORT(AMHCRIT,0),U)

 +3                SET AMHRAR=$PIECE(^AMHSORT(AMHCRIT,0),U,6)

                   KILL ^AMHTRPT(AMHRPT,11,AMHCRIT),^AMHTRPT(AMHRPT,11,"B",AMHCRIT)

 +4                WRITE !!,AMHC,")  ",AMHTEXT," Selection."

 +5                IF $PIECE(^AMHSORT(AMHCRIT,0),U,2)]""

                       SET AMHCNT=0

                       SET ^AMHTRPT(AMHRPT,11,0)="^9002013.81101PA^0^0"

                       DO @$PIECE(^AMHSORT(AMHCRIT,0),U,2)

                       SET DIK="^AMHTRPT("

                       SET DA=AMHRPT

                       DO IX1^DIK

 +6                IF $PIECE(^AMHSORT(AMHCRIT,0),U,13)

                       SET AMHRDTR=1

 +7                QUIT 

               End DoDot:1

 +8        QUIT 

PSELECT   ;EP

 +1        SET AMHANS=Y

           SET AMHC=""

           FOR AMHI=1:1

               SET AMHC=$PIECE(AMHANS,",",AMHI)

               IF AMHC=""

                   QUIT 

               SET AMHCRIT=AMHSEL(AMHC)

               SET AMHPCNT=AMHPCNT+1

               Begin DoDot:1

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

                   SET DIR("A")="Enter Column width for "_$PIECE(^AMHSORT(AMHCRIT,0),U)_" (suggested: "_$PIECE(^AMHSORT(AMHCRIT,0),U,7)_")"

                   SET DIR("B")=$PIECE(^(0),U,7)

                   DO ^DIR

                   KILL DIR

                   IF $DATA(DUOUT)

                       SET DIRUT=1

 +3                IF $DATA(DIRUT)

                       SET Y=$PIECE(^AMHSORT(AMHCRIT,0),U,7)

 +4                SET ^AMHTRPT(AMHRPT,12,0)="^9002013.81102PA^1^1"

 +5                IF $DATA(^AMHTRPT(AMHRPT,12,"B",AMHCRIT))

                       SET X=$ORDER(^AMHTRPT(AMHRPT,12,"B",AMHCRIT,""))

                       SET AMHTCW=AMHTCW-$PIECE(^AMHTRPT(AMHRPT,12,X,0),U,2)-2

                       SET ^AMHTRPT(AMHRPT,12,X,0)=AMHCRIT_U_Y

                       Begin DoDot:2

 +6                        QUIT 

                       End DoDot:2

                       QUIT 

 +7                SET ^AMHTRPT(AMHRPT,12,AMHPCNT,0)=AMHCRIT_U_Y

                   SET ^AMHTRPT(AMHRPT,12,"B",AMHCRIT,AMHPCNT)=""

                   SET AMHTCW=AMHTCW+Y+2

 +8                WRITE !!?15,"Total Report width (including column margins - 2 spaces):   ",AMHTCW

 +9                QUIT 

               End DoDot:1

 +10       QUIT 

Q         ;EP

 +1        KILL DIC,DIR

 +2        KILL ^XTMP("AMHRL",$JOB,"QMAN"),^UTILITY("AMQQ TAX",$JOB)

 +3        KILL DIC,X,Y,DD

           SET X=$PIECE(^AMHSORT(AMHCRIT,0),U,3)

           SET DIC="^AMQQ(5,"

           SET DIC(0)="EQXM"

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

           DO ^DIC

           KILL DIC,DA,DINUM,DICR

           IF Y=-1

               WRITE "OOPS - QMAN NOT CURRENT - QUITTING"

               QUIT 

 +4        SET AMHQMAN=+Y

 +5        DO PEP^AMQQGTX0(AMHQMAN,"^XTMP(""AMHRL"",$J,""QMAN"",")

 +6        IF '$DATA(^XTMP("AMHRL",$JOB,"QMAN"))

               WRITE !!,$CHAR(7),"** No ",$PIECE(^AMHSORT(AMHCRIT,0),U)," selected, all will be included."

               QUIT 

 +7        IF $DATA(^XTMP("AMHRL",$JOB,"QMAN","*"))

               KILL ^XTMP("AMHRL",$JOB,"QMAN")

 +8        SET ^AMHTRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT

           SET ^AMHTRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""

 +9        SET X=""

           SET Y=0

           FOR 

               SET X=$ORDER(^XTMP("AMHRL",$JOB,"QMAN",X))

               IF X=""

                   QUIT 

               SET Y=Y+1

               SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,Y,0)=X

               SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,"B",X,Y)=""

               SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,0)="^9002013.8110101A^"_Y_"^"_Y

 +10       KILL X,Y,Z,AMHQMAN,V

 +11       KILL ^XTMP("AMHRL",$JOB,"QMAN")

 +12       QUIT 

R         ;EP

 +1        KILL DIR,DIRUT,DUOUT,DTOUT,DA

 +2        SET DIR(0)=$PIECE(^AMHSORT(AMHCRIT,0),U,4)_"O"

           SET DIR("A")="ENTER "_$PIECE(^(0),U)

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               QUIT 

 +4        IF Y=""

               QUIT 

 +5        IF Y=-1

               QUIT 

 +6        SET ^AMHTRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT

           SET ^AMHTRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""

 +7        SET AMHCNT=AMHCNT+1

           SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,AMHCNT,0)=$PIECE(Y,U)

           SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,"B",$PIECE(Y,U),AMHCNT)=""

           SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,0)="^9002013.8110101A^"_AMHCNT_"^"_AMHCNT

 +8        GOTO R

 +9        QUIT 

D         ;DATE RANGE

BD        ;get beginning date

 +1        WRITE !

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

           SET DIR("A")="Enter beginning "_AMHTEXT_" for Search"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               QUIT 

 +3        SET AMHGDB=Y

ED        ;get ending date

 +1        WRITE !

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

           SET DIR("A")="Enter ending "_AMHTEXT_" for Search"

           SET Y=AMHGDB

           DO DD^%DT

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO BD

 +3        SET AMHGDE=Y

 +4        SET X1=AMHGDB

           SET X2=-1

           DO C^%DTC

           SET AMHGDS=X

 +5       ;

 +6        SET ^AMHTRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT

           SET ^AMHTRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""

 +7        SET AMHCNT=0

           SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,AMHCNT,0)="^9002013.8110101A^1^1"

           SET AMHCNT=AMHCNT+1

           SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,1,0)=AMHGDB_U_AMHGDE

           SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,"B",AMHGDB,AMHCNT)=""

 +8        QUIT 

N         ;

 +1        KILL Y

 +2        KILL ^AMHTRPT(AMHRPT,11,AMHCRIT),^AMHTRPT(AMHRPT,11,"B",AMHCRIT)

 +3        SET DIR(0)="FO^1:7"

           SET DIR("A")="Enter a Range of numbers (e.g. 5-12,1-1)"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +4        IF $DATA(DIRUT)

               QUIT 

 +5        IF Y=""

               WRITE !!,"No numeric range entered.  All numerics will be included."

               QUIT 

 +6        IF Y'?1.3N1"-"1.3N

               WRITE !!,$CHAR(7),$CHAR(7),"Enter a numeric range in the format nnn-nnn.  E.g. 0-5, 0-99, 5-20."

               GOTO N

 +7        SET ^AMHTRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT

           SET ^AMHTRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""

 +8        SET AMHCNT=0

           SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,0)="^9002013.8110101A^1^1"

           FOR X=$PIECE(Y,"-"):.1:$PIECE(Y,"-",2)

               SET AMHCNT=AMHCNT+1

               SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,AMHCNT,0)=X

               SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,"B",X,AMHCNT)=""

               IF AMHCNT>99999

                   WRITE AMHBOMB

 +9        SET $PIECE(^AMHTRPT(AMHRPT,11,AMHCRIT,11,1,0),U,2)=$PIECE(Y,"-",2)

 +10       QUIT 

F         ;FREE TEXT RANGE

 +1        KILL ^AMHTRPT(AMHRPT,11,AMHCRIT),^AMHTRPT(AMHRPT,11,"B",AMHCRIT)

 +2        SET DIR(0)="FO^1:20"

           SET DIR("A")="Enter a Range of Characters for Search (e.g. A:B) "

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF Y=""

               WRITE !!,"No range entered.  All ",AMHTEXT,"  will be included."

               QUIT 

 +4        IF Y'?1.ANP1":"1.ANP

               WRITE !!,$CHAR(7),$CHAR(7),"Enter an free text range in the format AAA:AAA.  E.g. 94-01:94-200, CA:CZ, A:Z."

               GOTO F

 +5        SET ^AMHTRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT

           SET ^AMHTRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""

 +6        SET AMHCNT=0

           SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,AMHCNT,0)="^9002013.8110101A^1^1"

           SET AMHCNT=AMHCNT+1

           SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,1,0)=$PIECE(X,":")_U_$PIECE(X,":",2)

           SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,"B",$PIECE(X,":"),AMHCNT)=""

 +7        QUIT 

Y         ;

 +1        DO Y^AMHRL01

 +2        QUIT 

SPECIAL   ;

 +1        DO SPECIAL^AMHRL01

 +2        QUIT