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
