- AMHRPT1 ; IHS/CMI/LAB - SELECTION OF ITEMS FOR REPORTS ;
- ;;4.0;IHS BEHAVIORAL HEALTH;**4**;JUN 18, 2010;Build 28
- ;
- 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 AMHVAR=$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)
- .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 ^XTMP("AMHVL",$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(""AMHVL"",$J,""QMAN"",")
- I '$D(^XTMP("AMHVL",$J,"QMAN")) W !!,$C(7),"** No ",$P(^AMHSORT(AMHCRIT,0),U)," selected, all will be included." Q
- I $D(^XTMP("AMHVL",$J,"QMAN","*")) K ^XTMP("AMHVL",$J,"QMAN")
- S ^AMHTRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT,^AMHTRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""
- S X="",Y=0 F S X=$O(^XTMP("AMHVL",$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("AMHVL",$J,"QMAN")
- Q
- R ;EP
- 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
- 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 AMHBD=Y
- ED ;get ending date
- W ! S DIR(0)="D^"_AMHBD_"::EP",DIR("A")="Enter ending "_AMHTEXT_" 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 AMHSD=X
- ;
- S ^AMHVRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT,^AMHVRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""
- S AMHCNT=0,^AMHVRPT(AMHRPT,11,AMHCRIT,11,AMHCNT,0)="^9002013.8110101A^1^1" S AMHCNT=AMHCNT+1,^AMHVRPT(AMHRPT,11,AMHCRIT,11,1,0)=AMHBD_U_AMHED,^AMHVRPT(AMHRPT,11,AMHCRIT,11,"B",AMHBD,AMHCNT)=""
- Q
- N ;
- D N^AMHRPT0
- Q
- SPECIAL ;
- K ^AMHTRPT(AMHRPT,11,AMHCRIT),^AMHTPRT(AMHRPT,11,"B",AMHCRIT)
- S Y="" X:$D(^AMHSORT(AMHCRIT,4)) ^(4)
- I Y="" 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
- 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 $D(^AMHSORT(AMHCRIT,21)) S X=Y X ^(21) I '$D(X),$D(^AMHSORT(AMHCRIT,22)) W !! X ^(22) G F ;if input tx exists and fails G N
- I '$D(^AMHSORT(AMHCRIT,21)),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^AMHRPT0
- Q
- AMHRPT1 ; IHS/CMI/LAB - SELECTION OF ITEMS FOR REPORTS ;
- +1 ;;4.0;IHS BEHAVIORAL HEALTH;**4**;JUN 18, 2010;Build 28
- +2 ;
- 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 AMHVAR=$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)
- +6 QUIT
- End DoDot:1
- +7 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 ^XTMP("AMHVL",$JOB,"QMAN"),^UTILITY("AMQQ TAX",$JOB)
- +2 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
- +3 SET AMHQMAN=+Y
- +4 DO PEP^AMQQGTX0(AMHQMAN,"^XTMP(""AMHVL"",$J,""QMAN"",")
- +5 IF '$DATA(^XTMP("AMHVL",$JOB,"QMAN"))
- WRITE !!,$CHAR(7),"** No ",$PIECE(^AMHSORT(AMHCRIT,0),U)," selected, all will be included."
- QUIT
- +6 IF $DATA(^XTMP("AMHVL",$JOB,"QMAN","*"))
- KILL ^XTMP("AMHVL",$JOB,"QMAN")
- +7 SET ^AMHTRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT
- SET ^AMHTRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""
- +8 SET X=""
- SET Y=0
- FOR
- SET X=$ORDER(^XTMP("AMHVL",$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
- +9 KILL X,Y,Z,AMHQMAN,V
- +10 KILL ^XTMP("AMHVL",$JOB,"QMAN")
- +11 QUIT
- R ;EP
- +1 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
- +2 IF $DATA(DIRUT)
- QUIT
- +3 IF Y=""
- QUIT
- +4 SET ^AMHTRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT
- SET ^AMHTRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""
- +5 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
- +6 GOTO R
- +7 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 AMHBD=Y
- ED ;get ending date
- +1 WRITE !
- SET DIR(0)="D^"_AMHBD_"::EP"
- SET DIR("A")="Enter ending "_AMHTEXT_" 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 AMHSD=X
- +5 ;
- +6 SET ^AMHVRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT
- SET ^AMHVRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""
- +7 SET AMHCNT=0
- SET ^AMHVRPT(AMHRPT,11,AMHCRIT,11,AMHCNT,0)="^9002013.8110101A^1^1"
- SET AMHCNT=AMHCNT+1
- SET ^AMHVRPT(AMHRPT,11,AMHCRIT,11,1,0)=AMHBD_U_AMHED
- SET ^AMHVRPT(AMHRPT,11,AMHCRIT,11,"B",AMHBD,AMHCNT)=""
- +8 QUIT
- N ;
- +1 DO N^AMHRPT0
- +2 QUIT
- SPECIAL ;
- +1 KILL ^AMHTRPT(AMHRPT,11,AMHCRIT),^AMHTPRT(AMHRPT,11,"B",AMHCRIT)
- +2 SET Y=""
- IF $DATA(^AMHSORT(AMHCRIT,4))
- XECUTE ^(4)
- +3 IF Y=""
- QUIT
- +4 SET ^AMHTRPT(AMHRPT,11,AMHCRIT,0)=AMHCRIT
- SET ^AMHTRPT(AMHRPT,11,"B",AMHCRIT,AMHCRIT)=""
- +5 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
- +6 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 input tx exists and fails G N
- IF $DATA(^AMHSORT(AMHCRIT,21))
- SET X=Y
- XECUTE ^(21)
- IF '$DATA(X)
- IF $DATA(^AMHSORT(AMHCRIT,22))
- WRITE !!
- XECUTE ^(22)
- GOTO F
- +5 IF '$DATA(^AMHSORT(AMHCRIT,21))
- 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
- +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)=$PIECE(X,":")_U_$PIECE(X,":",2)
- SET ^AMHTRPT(AMHRPT,11,AMHCRIT,11,"B",$PIECE(X,":"),AMHCNT)=""
- +8 QUIT
- Y ;
- +1 DO Y^AMHRPT0
- +2 QUIT
