- BCHRPT1 ; IHS/CMI/LAB - SELECTION OF ITEMS FOR REPORTS ;
- ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
- ;
- SELECT ;EP
- S BCHANS=Y,BCHC="" F BCHI=1:1 S BCHC=$P(BCHANS,",",BCHI) Q:BCHC="" S BCHCRIT=BCHSEL(BCHC) D
- .S BCHTEXT=$P(^BCHSORT(BCHCRIT,0),U)
- .S BCHVAR=$P(^BCHSORT(BCHCRIT,0),U,6) K ^BCHTRPT(BCHRPT,11,BCHCRIT),^BCHTRPT(BCHRPT,11,"B",BCHCRIT)
- .W !!,BCHC,") ",BCHTEXT," Selection."
- .I $P(^BCHSORT(BCHCRIT,0),U,2)]"" S BCHCNT=0,^BCHTRPT(BCHRPT,11,0)="^90002.421101PA^0^0" D @$P(^BCHSORT(BCHCRIT,0),U,2)
- .Q
- Q
- PSELECT ;EP
- S BCHANS=Y,BCHC="" F BCHI=1:1 S BCHC=$P(BCHANS,",",BCHI) Q:BCHC="" S BCHCRIT=BCHSEL(BCHC),BCHPCNT=BCHPCNT+1 D
- .S DIR(0)="N^2:80:0",DIR("A")="Enter Column width for "_$P(^BCHSORT(BCHCRIT,0),U)_" (suggested: "_$P(^BCHSORT(BCHCRIT,0),U,7)_")",DIR("B")=$P(^(0),U,7) D ^DIR K DIR S:$D(DUOUT) DIRUT=1
- .I $D(DIRUT) S Y=$P(^BCHSORT(BCHCRIT,0),U,7)
- .S ^BCHTRPT(BCHRPT,12,0)="^90002.421102PA^1^1"
- .I $D(^BCHTRPT(BCHRPT,12,"B",BCHCRIT)) S X=$O(^BCHTRPT(BCHRPT,12,"B",BCHCRIT,"")),BCHTCW=BCHTCW-$P(^BCHTRPT(BCHRPT,12,X,0),U,2)-2,^BCHTRPT(BCHRPT,12,X,0)=BCHCRIT_U_Y D Q
- ..Q
- .S ^BCHTRPT(BCHRPT,12,BCHPCNT,0)=BCHCRIT_U_Y,^BCHTRPT(BCHRPT,12,"B",BCHCRIT,BCHPCNT)="",BCHTCW=BCHTCW+Y+2
- .W !!?15,"Total Report width (including column margins - 2 spaces): ",BCHTCW
- .Q
- Q
- Q ;EP
- K ^TMP("BCHVL",$J,"QMAN"),^UTILITY("AMQQ TAX",$J)
- K DIC,X,Y,DD S X=$P(^BCHSORT(BCHCRIT,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 BCHQMAN=+Y
- D PEP^AMQQGTX0(BCHQMAN,"^TMP(""BCHVL"",$J,""QMAN"",")
- I '$D(^TMP("BCHVL",$J,"QMAN")) W !!,$C(7),"** No ",$P(^BCHSORT(BCHCRIT,0),U)," selected, all will be included." Q
- I $D(^TMP("BCHVL",$J,"QMAN","*")) K ^TMP("BCHVL",$J,"QMAN")
- S ^BCHTRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT,^BCHTRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""
- S X="",Y=0 F S X=$O(^TMP("BCHVL",$J,"QMAN",X)) Q:X="" S Y=Y+1,^BCHTRPT(BCHRPT,11,BCHCRIT,11,Y,0)=X,^BCHTRPT(BCHRPT,11,BCHCRIT,11,"B",X,Y)="",^BCHTRPT(BCHRPT,11,BCHCRIT,11,0)="^90002.42110101A^"_Y_"^"_Y
- K X,Y,Z,BCHQMAN,V
- K ^TMP("BCHVL",$J,"QMAN")
- Q
- R ;EP
- S DIR(0)=$P(^BCHSORT(BCHCRIT,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 ^BCHTRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT,^BCHTRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""
- S BCHCNT=BCHCNT+1,^BCHTRPT(BCHRPT,11,BCHCRIT,11,BCHCNT,0)=$P(Y,U),^BCHTRPT(BCHRPT,11,BCHCRIT,11,"B",$P(Y,U),BCHCNT)="",^BCHTRPT(BCHRPT,11,BCHCRIT,11,0)="^90002.42110101A^"_BCHCNT_"^"_BCHCNT
- G R
- Q
- D ;DATE RANGE
- BD ;get beginning date
- W ! S DIR(0)="D^::EP",DIR("A")="Enter beginning "_BCHTEXT_" for Search" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
- I $D(DIRUT) Q
- S BCHBD=Y
- ED ;get ending date
- W ! S DIR(0)="D^"_BCHBD_"::EP",DIR("A")="Enter ending "_BCHTEXT_" for Search" S Y=BCHBD D DD^%DT S DIR("B")=Y,Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
- I $D(DIRUT) G BD
- S BCHED=Y
- S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X
- ;
- S ^BCHTRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT,^BCHTRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""
- S BCHCNT=0,^BCHTRPT(BCHRPT,11,BCHCRIT,11,BCHCNT,0)="^90002.42110101A^1^1" S BCHCNT=BCHCNT+1,^BCHTRPT(BCHRPT,11,BCHCRIT,11,1,0)=BCHBD_U_BCHED,^BCHTRPT(BCHRPT,11,BCHCRIT,11,"B",BCHBD,BCHCNT)=""
- Q
- N ;
- K ^BCHTRPT(BCHRPT,11,BCHCRIT),^BCHTRPT(BCHRPT,11,"B",BCHCRIT)
- S DIR(0)="FO^1:7",DIR("A")="Enter a Range for "_$P(^BCHSORT(BCHCRIT,0),U)_", (e.g. 5-12)" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
- I Y="" W !!,"No number range entered. All numbers will be included." Q
- I Y'?1.3N1"-"1.3N W !!,$C(7),$C(7),"Enter an number range in the format nnn-nnn. E.g. 0-5, 0-99, 5-20." G N
- S ^BCHTRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT,^BCHTRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""
- S BCHCNT=0,^BCHTRPT(BCHRPT,11,BCHCRIT,11,BCHCNT,0)="^90002.42110101A^1^1" F X=$P(Y,"-"):1:$P(Y,"-",2) S BCHCNT=BCHCNT+1,^BCHTRPT(BCHRPT,11,BCHCRIT,11,1,0)=X,^BCHTRPT(BCHRPT,11,BCHCRIT,11,"B",X,BCHCNT)=""
- S $P(^BCHTRPT(BCHRPT,11,BCHCRIT,11,1,0),U,2)=$P(Y,"-",2)
- Q
- SPECIAL ;
- K ^BCHTRPT(BCHRPT,11,BCHCRIT),^BCHTPRT(BCHRPT,11,"B",BCHCRIT)
- S Y="" X:$D(^BCHSORT(BCHCRIT,4)) ^(4)
- I Y="" Q
- S ^BCHTRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT,^BCHTRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""
- S BCHCNT=BCHCNT+1,^BCHTRPT(BCHRPT,11,BCHCRIT,11,BCHCNT,0)=$P(Y,U),^BCHTRPT(BCHRPT,11,BCHCRIT,11,"B",$P(Y,U),BCHCNT)="",^BCHTRPT(BCHRPT,11,BCHCRIT,11,0)="^90002.42110101A^"_BCHCNT_"^"_BCHCNT
- Q
- J ;JUST A HIT
- S ^BCHVRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT,^BCHVRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""
- S ^BCHVRPT(BCHRPT,11,BCHCRIT,11,1,0)=1,^BCHVRPT(BCHRPT,11,BCHCRIT,11,"B",1,1)="",^BCHVRPT(BCHRPT,11,BCHCRIT,11,0)="^90002.42110101A^"_1_"^"_1
- Q
- Y ;
- D Y^BCHRPT0
- Q
- BCHRPT1 ; IHS/CMI/LAB - SELECTION OF ITEMS FOR REPORTS ;
- +1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
- +2 ;
- SELECT ;EP
- +1 SET BCHANS=Y
- SET BCHC=""
- FOR BCHI=1:1
- SET BCHC=$PIECE(BCHANS,",",BCHI)
- IF BCHC=""
- QUIT
- SET BCHCRIT=BCHSEL(BCHC)
- Begin DoDot:1
- +2 SET BCHTEXT=$PIECE(^BCHSORT(BCHCRIT,0),U)
- +3 SET BCHVAR=$PIECE(^BCHSORT(BCHCRIT,0),U,6)
- KILL ^BCHTRPT(BCHRPT,11,BCHCRIT),^BCHTRPT(BCHRPT,11,"B",BCHCRIT)
- +4 WRITE !!,BCHC,") ",BCHTEXT," Selection."
- +5 IF $PIECE(^BCHSORT(BCHCRIT,0),U,2)]""
- SET BCHCNT=0
- SET ^BCHTRPT(BCHRPT,11,0)="^90002.421101PA^0^0"
- DO @$PIECE(^BCHSORT(BCHCRIT,0),U,2)
- +6 QUIT
- End DoDot:1
- +7 QUIT
- PSELECT ;EP
- +1 SET BCHANS=Y
- SET BCHC=""
- FOR BCHI=1:1
- SET BCHC=$PIECE(BCHANS,",",BCHI)
- IF BCHC=""
- QUIT
- SET BCHCRIT=BCHSEL(BCHC)
- SET BCHPCNT=BCHPCNT+1
- Begin DoDot:1
- +2 SET DIR(0)="N^2:80:0"
- SET DIR("A")="Enter Column width for "_$PIECE(^BCHSORT(BCHCRIT,0),U)_" (suggested: "_$PIECE(^BCHSORT(BCHCRIT,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(^BCHSORT(BCHCRIT,0),U,7)
- +4 SET ^BCHTRPT(BCHRPT,12,0)="^90002.421102PA^1^1"
- +5 IF $DATA(^BCHTRPT(BCHRPT,12,"B",BCHCRIT))
- SET X=$ORDER(^BCHTRPT(BCHRPT,12,"B",BCHCRIT,""))
- SET BCHTCW=BCHTCW-$PIECE(^BCHTRPT(BCHRPT,12,X,0),U,2)-2
- SET ^BCHTRPT(BCHRPT,12,X,0)=BCHCRIT_U_Y
- Begin DoDot:2
- +6 QUIT
- End DoDot:2
- QUIT
- +7 SET ^BCHTRPT(BCHRPT,12,BCHPCNT,0)=BCHCRIT_U_Y
- SET ^BCHTRPT(BCHRPT,12,"B",BCHCRIT,BCHPCNT)=""
- SET BCHTCW=BCHTCW+Y+2
- +8 WRITE !!?15,"Total Report width (including column margins - 2 spaces): ",BCHTCW
- +9 QUIT
- End DoDot:1
- +10 QUIT
- Q ;EP
- +1 KILL ^TMP("BCHVL",$JOB,"QMAN"),^UTILITY("AMQQ TAX",$JOB)
- +2 KILL DIC,X,Y,DD
- SET X=$PIECE(^BCHSORT(BCHCRIT,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 BCHQMAN=+Y
- +4 DO PEP^AMQQGTX0(BCHQMAN,"^TMP(""BCHVL"",$J,""QMAN"",")
- +5 IF '$DATA(^TMP("BCHVL",$JOB,"QMAN"))
- WRITE !!,$CHAR(7),"** No ",$PIECE(^BCHSORT(BCHCRIT,0),U)," selected, all will be included."
- QUIT
- +6 IF $DATA(^TMP("BCHVL",$JOB,"QMAN","*"))
- KILL ^TMP("BCHVL",$JOB,"QMAN")
- +7 SET ^BCHTRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT
- SET ^BCHTRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""
- +8 SET X=""
- SET Y=0
- FOR
- SET X=$ORDER(^TMP("BCHVL",$JOB,"QMAN",X))
- IF X=""
- QUIT
- SET Y=Y+1
- SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,Y,0)=X
- SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,"B",X,Y)=""
- SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,0)="^90002.42110101A^"_Y_"^"_Y
- +9 KILL X,Y,Z,BCHQMAN,V
- +10 KILL ^TMP("BCHVL",$JOB,"QMAN")
- +11 QUIT
- R ;EP
- +1 SET DIR(0)=$PIECE(^BCHSORT(BCHCRIT,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 ^BCHTRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT
- SET ^BCHTRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""
- +5 SET BCHCNT=BCHCNT+1
- SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,BCHCNT,0)=$PIECE(Y,U)
- SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,"B",$PIECE(Y,U),BCHCNT)=""
- SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,0)="^90002.42110101A^"_BCHCNT_"^"_BCHCNT
- +6 GOTO R
- +7 QUIT
- D ;DATE RANGE
- BD ;get beginning date
- +1 WRITE !
- SET DIR(0)="D^::EP"
- SET DIR("A")="Enter beginning "_BCHTEXT_" for Search"
- DO ^DIR
- KILL DIR
- IF $DATA(DUOUT)
- SET DIRUT=1
- +2 IF $DATA(DIRUT)
- QUIT
- +3 SET BCHBD=Y
- ED ;get ending date
- +1 WRITE !
- SET DIR(0)="D^"_BCHBD_"::EP"
- SET DIR("A")="Enter ending "_BCHTEXT_" for Search"
- SET Y=BCHBD
- DO DD^%DT
- SET DIR("B")=Y
- SET Y=""
- DO ^DIR
- KILL DIR
- IF $DATA(DUOUT)
- SET DIRUT=1
- +2 IF $DATA(DIRUT)
- GOTO BD
- +3 SET BCHED=Y
- +4 SET X1=BCHBD
- SET X2=-1
- DO C^%DTC
- SET BCHSD=X
- +5 ;
- +6 SET ^BCHTRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT
- SET ^BCHTRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""
- +7 SET BCHCNT=0
- SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,BCHCNT,0)="^90002.42110101A^1^1"
- SET BCHCNT=BCHCNT+1
- SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,1,0)=BCHBD_U_BCHED
- SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,"B",BCHBD,BCHCNT)=""
- +8 QUIT
- N ;
- +1 KILL ^BCHTRPT(BCHRPT,11,BCHCRIT),^BCHTRPT(BCHRPT,11,"B",BCHCRIT)
- +2 SET DIR(0)="FO^1:7"
- SET DIR("A")="Enter a Range for "_$PIECE(^BCHSORT(BCHCRIT,0),U)_", (e.g. 5-12)"
- DO ^DIR
- KILL DIR
- IF $DATA(DUOUT)
- SET DIRUT=1
- +3 IF Y=""
- WRITE !!,"No number range entered. All numbers will be included."
- QUIT
- +4 IF Y'?1.3N1"-"1.3N
- WRITE !!,$CHAR(7),$CHAR(7),"Enter an number range in the format nnn-nnn. E.g. 0-5, 0-99, 5-20."
- GOTO N
- +5 SET ^BCHTRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT
- SET ^BCHTRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""
- +6 SET BCHCNT=0
- SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,BCHCNT,0)="^90002.42110101A^1^1"
- FOR X=$PIECE(Y,"-"):1:$PIECE(Y,"-",2)
- SET BCHCNT=BCHCNT+1
- SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,1,0)=X
- SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,"B",X,BCHCNT)=""
- +7 SET $PIECE(^BCHTRPT(BCHRPT,11,BCHCRIT,11,1,0),U,2)=$PIECE(Y,"-",2)
- +8 QUIT
- SPECIAL ;
- +1 KILL ^BCHTRPT(BCHRPT,11,BCHCRIT),^BCHTPRT(BCHRPT,11,"B",BCHCRIT)
- +2 SET Y=""
- IF $DATA(^BCHSORT(BCHCRIT,4))
- XECUTE ^(4)
- +3 IF Y=""
- QUIT
- +4 SET ^BCHTRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT
- SET ^BCHTRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""
- +5 SET BCHCNT=BCHCNT+1
- SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,BCHCNT,0)=$PIECE(Y,U)
- SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,"B",$PIECE(Y,U),BCHCNT)=""
- SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,0)="^90002.42110101A^"_BCHCNT_"^"_BCHCNT
- +6 QUIT
- J ;JUST A HIT
- +1 SET ^BCHVRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT
- SET ^BCHVRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""
- +2 SET ^BCHVRPT(BCHRPT,11,BCHCRIT,11,1,0)=1
- SET ^BCHVRPT(BCHRPT,11,BCHCRIT,11,"B",1,1)=""
- SET ^BCHVRPT(BCHRPT,11,BCHCRIT,11,0)="^90002.42110101A^"_1_"^"_1
- +3 QUIT
- Y ;
- +1 DO Y^BCHRPT0
- +2 QUIT
