BMCRL3.m

BMCRL3 ; IHS/PHXAO/TMJ - MORE LISTER ;   

 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 ;LAB added help text to dir call

 ;IHS/ITSC/FCJ ADDED DTTST SUB FOR CANNED REPORTS ;ADDED ABILITY

 ;   TO SAVE TOT/SUBTOT RPTS ;ADDED ABILITY TO SAVE CUSTOM TITLE

 ;   Save type of referral: Prim, Sec or both

 ;

TITLE ;EP

 Q:BMCCTYP="T"  ;--- don't ask for title if total count only

 K DIR,X,Y S DIR(0)="Y",DIR("A")="Would you like a custom title for this report",DIR("B")="N"

 I $D(BMCCAND),$D(^BMCRTMP(BMCRPT,1)) D

 .S BMCTITL=$P(^BMCRTMP(BMCRPT,1),U)

 .W !,"Previous Custom Report Title: ",BMCTITL

 .S DIR("A")="Would you like to change custom title for this report"

 D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) S BMCQUIT=1 Q

 Q:Y=0

 S BMCLENG=$S(BMCTCW:BMCTCW-8,1:60)

 I Y=1 K DIR,X,Y S DIR(0)="F^3:"_BMCLENG,DIR("A")="Enter custom title",DIR("?")="    Enter from 3 to "_BMCLENG_" characters" D ^DIR K DIR

 G:$D(DIRUT) TITLE

 S BMCTITL=Y

 I $D(BMCCAND) S $P(^BMCRTMP(BMCRPT,1),U)=BMCTITL

 Q

SAVE ;EP

 Q:$D(BMCCAND)  ;--- don't ask if already a pre-defined rpt

 I BMCCTYP="N",BMCCTYP="R" Q

 S BMCSAVE=""

 K DIR,X,Y S DIR(0)="Y",DIR("A")="Do you wish to SAVE this "_$S('$D(BMCEP1):"SEARCH/",1:"")_"PRINT/SORT logic for future use",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q:$D(DIRUT)

 Q:'Y

 K DIR,X,Y S DIR(0)="90001.82,.03",DIR("A")="Enter NAME for this REPORT DEFINITION" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 G:$D(DIRUT) SAVE

 S BMCNAME=Y

 S DIE="^BMCRTMP(",DA=BMCRPT,DR=".02////1;.03///"_BMCNAME_";.06///"_BMCPTVS_";.05///"_BMCCTYP

 S:$D(BMCEP1) DR=DR_";.09///"_BMCPACK

 ;4.0 IHS/ITSC/FCJ ADDED REF TYPE: PRIM SEC BOTH

 S DR=DR_";.14///"_BMCTYPR

 S:$D(BMCTITL) DR=DR_";1///"_BMCTITL D ^DIE K DIE,DA,DR

 Q

COUNT ;EP

 W !! S DIR(0)="S^T:Total Count Only;S:Sub-counts and Total Count;D:Detailed Referral Listing;N:Numeric Item Basic Statistics;R:Referral Record Display",DIR("A")="     Choose Type of Report",DIR("B")="D" D ^DIR K DIR W !!

 S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) S BMCQUIT=1 Q

 S BMCCTYP=Y

 I BMCCTYP="T" S $P(^BMCRTMP(BMCRPT,0),U,5)=1 S:BMCPTVS="R" BMCSORT=6,BMCSORV="Referral Date" S:BMCPTVS="P" BMCSORT=1,BMCSORV="Patient Name" Q

 I BMCCTYP="R" S $P(^BMCRTMP(BMCRPT,0),U,5)=1 S:BMCPTVS="R" BMCSORT=6,BMCSORV="Referral Date" S:BMCPTVS="P" BMCSORT=1,BMCSORV="Patient Name" Q

 I BMCCTYP="D" D PRINT Q:$D(BMCQUIT)  D SORT Q

 I BMCCTYP="N" D NUMERIC Q

 D SORT

 Q

PRINT ;

 S BMCCNTL="P" D ^BMCRL4 K BMCCNTL

 Q

SORT ;

 K BMCSORT,BMCSORV,BMCQUIT

 I BMCCTYP="D",'$D(^BMCRTMP(BMCRPT,12)) W !!,"NO PRINT FIELDS SELECTED!!",$C(7),$C(7) S BMCQUIT=1 Q

 S BMCSORT=""

 D SHOWR^BMCRLS

 S BMCCNTL="R" D ^BMCRL4 K BMCCNTL

 I '$D(BMCSORV) S BMCQUIT=1 Q

 Q:BMCCTYP'="D"

PAGE ;

 K BMCSPAG

 Q:BMCCTYP'="D"

 S DIR(0)="Y",DIR("A")="Do you want a separate page for each "_BMCSORV,DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G SORT

 S BMCSPAG=Y,DIE="^BMCRTMP(",DA=BMCRPT,DR=".04///"_BMCSPAG D ^DIE K DA,DR,DIE

 Q

NUMERIC ;

 D ^XBCLS

 W !!,?20,"***NUMERIC ITEM BASIC STATISTICS**",!!

 W !!,"This print option will provide basic statistics (sum, count, mean, max, min)",!,"on any one of the 'Numeric Items' listed below.",!!,"Upon selection of a 'Numeric Item' a list of 'Sort' Choices will also be",!,"displayed.  "

 W "This 'Sort' Choice is provided for the purpose of Totaling and/or",!,"Sub-totaling all records selected.",!!,"For example, choosing 'Actual Cost' as the Numeric Item and, then, choosing"

 W !,"Primary Vendor as the 'Sort' Choice would produce a report of Actual Cost",!,"statistics (Sub-totaled by Vendor).",!!

 W "If you choose NOT to select a 'Sort' Item, the report would produce only",!,"one Grand Total (sum, count, mean, max, and min, etc.) for all",!,"'Actual Cost' statistics.",!!

 K BMCDISP,BMCSEL,BMCHIGH

 S BMCLHDR="NUMERIC ITEM Selection Menu" W ?((80-$L(BMCLHDR))/2),BMCLHDR,!

 S BMCHIGH=0,X=0 F  S X=$O(^BMCTSORT("C",X)) Q:X'=+X  S Y=$O(^BMCTSORT("C",X,"")) I $P(^BMCTSORT(Y,0),U,5)["S",$P(^BMCTSORT(Y,0),U,2)="N" S BMCHIGH=BMCHIGH+1,BMCSEL(BMCHIGH)=Y

 S BMCCUT=((BMCHIGH/2)+1)\1

 S I=0,J=1,K=1 F  S I=$O(BMCSEL(I)) Q:I'=+I!($D(BMCDISP(I)))  W !?5,I,")  ",$P(^BMCTSORT(BMCSEL(I),0),U) S BMCDISP(I)="",J=I+BMCCUT I $D(BMCSEL(J)),'$D(BMCDISP(J)) W ?40,J,")  ",$P(^BMCTSORT(BMCSEL(J),0),U) S BMCDISP(J)=""

 W ! S DIR(0)="NO^1:"_BMCHIGH_":0",DIR("A")="Produce statistics for which of the above" D ^DIR K DIR

 I $D(DIRUT) G COUNT

 S BMCNSRT=BMCSEL(+Y)

 D SORT

 Q

DTTST ;CANNED REPORTS

 ;TEST DATE RANGE FIELDS FOR CANNED REPORTS

 S BMCQT=""

 S I=0  F  S I=$O(^BMCRTMP(BMCRPT,11,I)) Q:I'?1N.N  D

 .I $P($G(^BMCTSORT(I,0)),U,2)="D" S BMCR("CR",I)=""

 I $D(BMCR("CR")) D

 .W !,"There are date range(s) in this report..."

 .S I="" F  S I=$O(BMCR("CR",I)) Q:I'?1.N  D  Q:$D(DIRUT)

 ..S BMCTEXT=$P(^BMCTSORT(I,0),U)

 ..S Y=$P(^BMCRTMP(BMCRPT,11,I,11,1,0),U) D DD^%DT S BMCBD=Y

 ..S Y=$P(^BMCRTMP(BMCRPT,11,I,11,1,0),U,2) D DD^%DT S BMCED=Y

 ..W !,BMCTEXT," Previous Date Range: ",BMCBD," TO ",BMCED

 ..S DIR(0)="Y",DIR("A")="Would you like to update these dates"

 ..D ^DIR

 ..Q:(Y="^")!(Y=0)

 ..D D^BMCRL0 Q:$D(DIRUT)

 ..S ^BMCRTMP(BMCRPT,11,I,11,1,0)=BMCBD_U_BMCED

 ..K ^BMCRTMP(BMCRPT,11,I,11,"B")

 ..S ^BMCRTMP(BMCRPT,11,I,11,"B",BMCBD,1)=""

 S BMCTYPR=$P(^BMCRTMP(BMCRPT,0),U,14) S:BMCTYPR="" BMCTYPR="P"

 W !,"The Report contains ",$S(BMCTYPR="P":"Only PRIMARY",BMCTYPR="S":"Only SECONDARY",1:"Primary and Secondary")," Referrals"

 S DIR(0)="Y",DIR("A")="Would you like to update the Referral type",DIR("B")="N"

 D ^DIR Q:(Y="^")!(Y=0)

 D RTYP^BMCRL Q:$D(DIRUT)

 S $P(^BMCRTMP(BMCRPT,0),U,14)=BMCTYPR

 Q

BMCRL3    ; IHS/PHXAO/TMJ - MORE LISTER ;   

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 +2       ;LAB added help text to dir call

 +3       ;IHS/ITSC/FCJ ADDED DTTST SUB FOR CANNED REPORTS ;ADDED ABILITY

 +4       ;   TO SAVE TOT/SUBTOT RPTS ;ADDED ABILITY TO SAVE CUSTOM TITLE

 +5       ;   Save type of referral: Prim, Sec or both

 +6       ;

TITLE     ;EP

 +1       ;--- don't ask for title if total count only

           IF BMCCTYP="T"

               QUIT 

 +2        KILL DIR,X,Y

           SET DIR(0)="Y"

           SET DIR("A")="Would you like a custom title for this report"

           SET DIR("B")="N"

 +3        IF $DATA(BMCCAND)

               IF $DATA(^BMCRTMP(BMCRPT,1))

                   Begin DoDot:1

 +4                    SET BMCTITL=$PIECE(^BMCRTMP(BMCRPT,1),U)

 +5                    WRITE !,"Previous Custom Report Title: ",BMCTITL

 +6                    SET DIR("A")="Would you like to change custom title for this report"

                   End DoDot:1

 +7        DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +8        IF $DATA(DIRUT)

               SET BMCQUIT=1

               QUIT 

 +9        IF Y=0

               QUIT 

 +10       SET BMCLENG=$SELECT(BMCTCW:BMCTCW-8,1:60)

 +11       IF Y=1

               KILL DIR,X,Y

               SET DIR(0)="F^3:"_BMCLENG

               SET DIR("A")="Enter custom title"

               SET DIR("?")="    Enter from 3 to "_BMCLENG_" characters"

               DO ^DIR

               KILL DIR

 +12       IF $DATA(DIRUT)

               GOTO TITLE

 +13       SET BMCTITL=Y

 +14       IF $DATA(BMCCAND)

               SET $PIECE(^BMCRTMP(BMCRPT,1),U)=BMCTITL

 +15       QUIT 

SAVE      ;EP

 +1       ;--- don't ask if already a pre-defined rpt

           IF $DATA(BMCCAND)

               QUIT 

 +2        IF BMCCTYP="N"

               IF BMCCTYP="R"

                   QUIT 

 +3        SET BMCSAVE=""

 +4        KILL DIR,X,Y

           SET DIR(0)="Y"

           SET DIR("A")="Do you wish to SAVE this "_$SELECT('$DATA(BMCEP1):"SEARCH/",1:"")_"PRINT/SORT logic for future use"

           SET DIR("B")="N"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +5        IF $DATA(DIRUT)

               QUIT 

 +6        IF 'Y

               QUIT 

 +7        KILL DIR,X,Y

           SET DIR(0)="90001.82,.03"

           SET DIR("A")="Enter NAME for this REPORT DEFINITION"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +8        IF $DATA(DIRUT)

               GOTO SAVE

 +9        SET BMCNAME=Y

 +10       SET DIE="^BMCRTMP("

           SET DA=BMCRPT

           SET DR=".02////1;.03///"_BMCNAME_";.06///"_BMCPTVS_";.05///"_BMCCTYP

 +11       IF $DATA(BMCEP1)

               SET DR=DR_";.09///"_BMCPACK

 +12      ;4.0 IHS/ITSC/FCJ ADDED REF TYPE: PRIM SEC BOTH

 +13       SET DR=DR_";.14///"_BMCTYPR

 +14       IF $DATA(BMCTITL)

               SET DR=DR_";1///"_BMCTITL

           DO ^DIE

           KILL DIE,DA,DR

 +15       QUIT 

COUNT     ;EP

 +1        WRITE !!

           SET DIR(0)="S^T:Total Count Only;S:Sub-counts and Total Count;D:Detailed Referral Listing;N:Numeric Item Basic Statistics;R:Referral Record Display"

           SET DIR("A")="     Choose Type of Report"

           SET DIR("B")="D"

           DO ^DIR

           KILL DIR

           WRITE !!

 +2        IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               SET BMCQUIT=1

               QUIT 

 +4        SET BMCCTYP=Y

 +5        IF BMCCTYP="T"

               SET $PIECE(^BMCRTMP(BMCRPT,0),U,5)=1

               IF BMCPTVS="R"

                   SET BMCSORT=6

                   SET BMCSORV="Referral Date"

               IF BMCPTVS="P"

                   SET BMCSORT=1

                   SET BMCSORV="Patient Name"

               QUIT 

 +6        IF BMCCTYP="R"

               SET $PIECE(^BMCRTMP(BMCRPT,0),U,5)=1

               IF BMCPTVS="R"

                   SET BMCSORT=6

                   SET BMCSORV="Referral Date"

               IF BMCPTVS="P"

                   SET BMCSORT=1

                   SET BMCSORV="Patient Name"

               QUIT 

 +7        IF BMCCTYP="D"

               DO PRINT

               IF $DATA(BMCQUIT)

                   QUIT 

               DO SORT

               QUIT 

 +8        IF BMCCTYP="N"

               DO NUMERIC

               QUIT 

 +9        DO SORT

 +10       QUIT 

PRINT     ;

 +1        SET BMCCNTL="P"

           DO ^BMCRL4

           KILL BMCCNTL

 +2        QUIT 

SORT      ;

 +1        KILL BMCSORT,BMCSORV,BMCQUIT

 +2        IF BMCCTYP="D"

               IF '$DATA(^BMCRTMP(BMCRPT,12))

                   WRITE !!,"NO PRINT FIELDS SELECTED!!",$CHAR(7),$CHAR(7)

                   SET BMCQUIT=1

                   QUIT 

 +3        SET BMCSORT=""

 +4        DO SHOWR^BMCRLS

 +5        SET BMCCNTL="R"

           DO ^BMCRL4

           KILL BMCCNTL

 +6        IF '$DATA(BMCSORV)

               SET BMCQUIT=1

               QUIT 

 +7        IF BMCCTYP'="D"

               QUIT 

PAGE      ;

 +1        KILL BMCSPAG

 +2        IF BMCCTYP'="D"

               QUIT 

 +3        SET DIR(0)="Y"

           SET DIR("A")="Do you want a separate page for each "_BMCSORV

           SET DIR("B")="N"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +4        IF $DATA(DIRUT)

               GOTO SORT

 +5        SET BMCSPAG=Y

           SET DIE="^BMCRTMP("

           SET DA=BMCRPT

           SET DR=".04///"_BMCSPAG

           DO ^DIE

           KILL DA,DR,DIE

 +6        QUIT 

NUMERIC   ;

 +1        DO ^XBCLS

 +2        WRITE !!,?20,"***NUMERIC ITEM BASIC STATISTICS**",!!

 +3        WRITE !!,"This print option will provide basic statistics (sum, count, mean, max, min)",!,"on any one of the 'Numeric Items' listed below.",!!,"Upon selection of a 'Numeric Item' a list of 'Sort' Choices will also be",!,"displayed.  "

 +4        WRITE "This 'Sort' Choice is provided for the purpose of Totaling and/or",!,"Sub-totaling all records selected.",!!,"For example, choosing 'Actual Cost' as the Numeric Item and, then, choosing"

 +5        WRITE !,"Primary Vendor as the 'Sort' Choice would produce a report of Actual Cost",!,"statistics (Sub-totaled by Vendor).",!!

 +6        WRITE "If you choose NOT to select a 'Sort' Item, the report would produce only",!,"one Grand Total (sum, count, mean, max, and min, etc.) for all",!,"'Actual Cost' statistics.",!!

 +7        KILL BMCDISP,BMCSEL,BMCHIGH

 +8        SET BMCLHDR="NUMERIC ITEM Selection Menu"

           WRITE ?((80-$LENGTH(BMCLHDR))/2),BMCLHDR,!

 +9        SET BMCHIGH=0

           SET X=0

           FOR 

               SET X=$ORDER(^BMCTSORT("C",X))

               IF X'=+X

                   QUIT 

               SET Y=$ORDER(^BMCTSORT("C",X,""))

               IF $PIECE(^BMCTSORT(Y,0),U,5)["S"

                   IF $PIECE(^BMCTSORT(Y,0),U,2)="N"

                       SET BMCHIGH=BMCHIGH+1

                       SET BMCSEL(BMCHIGH)=Y

 +10       SET BMCCUT=((BMCHIGH/2)+1)\1

 +11       SET I=0

           SET J=1

           SET K=1

           FOR 

               SET I=$ORDER(BMCSEL(I))

               IF I'=+I!($DATA(BMCDISP(I)))

                   QUIT 

               WRITE !?5,I,")  ",$PIECE(^BMCTSORT(BMCSEL(I),0),U)

               SET BMCDISP(I)=""

               SET J=I+BMCCUT

               IF $DATA(BMCSEL(J))

                   IF '$DATA(BMCDISP(J))

                       WRITE ?40,J,")  ",$PIECE(^BMCTSORT(BMCSEL(J),0),U)

                       SET BMCDISP(J)=""

 +12       WRITE !

           SET DIR(0)="NO^1:"_BMCHIGH_":0"

           SET DIR("A")="Produce statistics for which of the above"

           DO ^DIR

           KILL DIR

 +13       IF $DATA(DIRUT)

               GOTO COUNT

 +14       SET BMCNSRT=BMCSEL(+Y)

 +15       DO SORT

 +16       QUIT 

DTTST     ;CANNED REPORTS

 +1       ;TEST DATE RANGE FIELDS FOR CANNED REPORTS

 +2        SET BMCQT=""

 +3        SET I=0

           FOR 

               SET I=$ORDER(^BMCRTMP(BMCRPT,11,I))

               IF I'?1N.N

                   QUIT 

               Begin DoDot:1

 +4                IF $PIECE($GET(^BMCTSORT(I,0)),U,2)="D"

                       SET BMCR("CR",I)=""

               End DoDot:1

 +5        IF $DATA(BMCR("CR"))

               Begin DoDot:1

 +6                WRITE !,"There are date range(s) in this report..."

 +7                SET I=""

                   FOR 

                       SET I=$ORDER(BMCR("CR",I))

                       IF I'?1.N

                           QUIT 

                       Begin DoDot:2

 +8                        SET BMCTEXT=$PIECE(^BMCTSORT(I,0),U)

 +9                        SET Y=$PIECE(^BMCRTMP(BMCRPT,11,I,11,1,0),U)

                           DO DD^%DT

                           SET BMCBD=Y

 +10                       SET Y=$PIECE(^BMCRTMP(BMCRPT,11,I,11,1,0),U,2)

                           DO DD^%DT

                           SET BMCED=Y

 +11                       WRITE !,BMCTEXT," Previous Date Range: ",BMCBD," TO ",BMCED

 +12                       SET DIR(0)="Y"

                           SET DIR("A")="Would you like to update these dates"

 +13                       DO ^DIR

 +14                       IF (Y="^")!(Y=0)

                               QUIT 

 +15                       DO D^BMCRL0

                           IF $DATA(DIRUT)

                               QUIT 

 +16                       SET ^BMCRTMP(BMCRPT,11,I,11,1,0)=BMCBD_U_BMCED

 +17                       KILL ^BMCRTMP(BMCRPT,11,I,11,"B")

 +18                       SET ^BMCRTMP(BMCRPT,11,I,11,"B",BMCBD,1)=""

                       End DoDot:2

                       IF $DATA(DIRUT)

                           QUIT 

               End DoDot:1

 +19       SET BMCTYPR=$PIECE(^BMCRTMP(BMCRPT,0),U,14)

           IF BMCTYPR=""

               SET BMCTYPR="P"

 +20       WRITE !,"The Report contains ",$SELECT(BMCTYPR="P":"Only PRIMARY",BMCTYPR="S":"Only SECONDARY",1:"Primary and Secondary")," Referrals"

 +21       SET DIR(0)="Y"

           SET DIR("A")="Would you like to update the Referral type"

           SET DIR("B")="N"

 +22       DO ^DIR

           IF (Y="^")!(Y=0)

               QUIT 

 +23       DO RTYP^BMCRL

           IF $DATA(DIRUT)

               QUIT 

 +24       SET $PIECE(^BMCRTMP(BMCRPT,0),U,14)=BMCTYPR

 +25       QUIT