BCHRL0.m

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

 ;;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 BCHRAR=$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)="^9001003.81101PA^0^0" D @$P(^BCHSORT(BCHCRIT,0),U,2)

 .I $P(^BCHSORT(BCHCRIT,0),U,13) S BCHRDTR=1

 .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)="^9001003.81102PA^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("BCHRL",$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(""BCHRL"",$J,""QMAN"",")

 I '$D(^TMP("BCHRL",$J,"QMAN")) W !!,$C(7),"** No ",$P(^BCHSORT(BCHCRIT,0),U)," selected, all will be included." Q

 I $D(^TMP("BCHRL",$J,"QMAN","*")) K ^TMP("BCHRL",$J,"QMAN")

 S ^BCHTRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT,^BCHTRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""

 S X="",Y=0 F  S X=$O(^TMP("BCHRL",$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)="^9001003.8110101A^"_Y_"^"_Y

 K X,Y,Z,BCHQMAN,V

 K ^TMP("BCHRL",$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)="^9001003.8110101A^"_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 BCHGDB=Y

ED ;get ending date

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

 I $D(DIRUT) G BD

 S BCHGDE=Y

 S X1=BCHGDB,X2=-1 D C^%DTC S BCHGDS=X

 ;

 S ^BCHTRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT,^BCHTRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""

 S BCHCNT=0,^BCHTRPT(BCHRPT,11,BCHCRIT,11,BCHCNT,0)="^90028.8110101A^1^1" S BCHCNT=BCHCNT+1,^BCHTRPT(BCHRPT,11,BCHCRIT,11,1,0)=BCHGDB_U_BCHGDE,^BCHTRPT(BCHRPT,11,BCHCRIT,11,"B",BCHGDB,BCHCNT)=""

 Q

N ;

 K ^BCHTRPT(BCHRPT,11,BCHCRIT),^BCHTRPT(BCHRPT,11,"B",BCHCRIT)

 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

 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 ^BCHTRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT,^BCHTRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""

 S BCHCNT=0,^BCHTRPT(BCHRPT,11,BCHCRIT,11,0)="^90028.8110101A^1^1" F X=$P(Y,"-"):1:$P(Y,"-",2) S BCHCNT=BCHCNT+1,^BCHTRPT(BCHRPT,11,BCHCRIT,11,BCHCNT,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

F ;FREE TEXT RANGE

 K ^BCHTRPT(BCHRPT,11,BCHCRIT),^BCHTRPT(BCHRPT,11,"B",BCHCRIT)

 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 ",BCHTEXT,"  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 ^BCHTRPT(BCHRPT,11,BCHCRIT,0)=BCHCRIT,^BCHTRPT(BCHRPT,11,"B",BCHCRIT,BCHCRIT)=""

 S BCHCNT=0,^BCHTRPT(BCHRPT,11,BCHCRIT,11,BCHCNT,0)="^90028.8110101A^1^1" S BCHCNT=BCHCNT+1,^BCHTRPT(BCHRPT,11,BCHCRIT,11,1,0)=$P(X,":")_U_$P(X,":",2),^BCHTRPT(BCHRPT,11,BCHCRIT,11,"B",$P(X,":"),BCHCNT)=""

 Q

Y ;

 D Y^BCHRL01

 Q

SPECIAL ;

 D SPECIAL^BCHRL01

 Q

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

 +1       ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 +2       ;

 +3       ;

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 BCHRAR=$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)="^9001003.81101PA^0^0"

                       DO @$PIECE(^BCHSORT(BCHCRIT,0),U,2)

 +6                IF $PIECE(^BCHSORT(BCHCRIT,0),U,13)

                       SET BCHRDTR=1

 +7                QUIT 

               End DoDot:1

 +8        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)="^9001003.81102PA^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("BCHRL",$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(""BCHRL"",$J,""QMAN"",")

 +5        IF '$DATA(^TMP("BCHRL",$JOB,"QMAN"))

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

               QUIT 

 +6        IF $DATA(^TMP("BCHRL",$JOB,"QMAN","*"))

               KILL ^TMP("BCHRL",$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("BCHRL",$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)="^9001003.8110101A^"_Y_"^"_Y

 +9        KILL X,Y,Z,BCHQMAN,V

 +10       KILL ^TMP("BCHRL",$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)="^9001003.8110101A^"_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 BCHGDB=Y

ED        ;get ending date

 +1        WRITE !

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

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

           SET Y=BCHGDB

           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 BCHGDE=Y

 +4        SET X1=BCHGDB

           SET X2=-1

           DO C^%DTC

           SET BCHGDS=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)="^90028.8110101A^1^1"

           SET BCHCNT=BCHCNT+1

           SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,1,0)=BCHGDB_U_BCHGDE

           SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,"B",BCHGDB,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 of numbers (e.g. 5-12,1-1)"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF Y=""

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

               QUIT 

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

 +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,0)="^90028.8110101A^1^1"

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

               SET BCHCNT=BCHCNT+1

               SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,BCHCNT,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 

F         ;FREE TEXT RANGE

 +1        KILL ^BCHTRPT(BCHRPT,11,BCHCRIT),^BCHTRPT(BCHRPT,11,"B",BCHCRIT)

 +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 ",BCHTEXT,"  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 ^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)="^90028.8110101A^1^1"

           SET BCHCNT=BCHCNT+1

           SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,1,0)=$PIECE(X,":")_U_$PIECE(X,":",2)

           SET ^BCHTRPT(BCHRPT,11,BCHCRIT,11,"B",$PIECE(X,":"),BCHCNT)=""

 +7        QUIT 

Y         ;

 +1        DO Y^BCHRL01

 +2        QUIT 

SPECIAL   ;

 +1        DO SPECIAL^BCHRL01

 +2        QUIT