BMCRL.m

BMCRL ; IHS/PHXAO/TMJ - PCC REFERRAL GENERAL RETRIEVAL DRIVER ROUTINE ;   

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

 ;IHS/ITSC/FCJ ADD TST FOR DATE RANGE IN CANNED REPORT

 ;IHS/ITSC/FCJ ADDED REF TYPE, VAR BMCTYPR: PRIMARY, SECONDARY BOTH

 ;

START ; 

 K BMCQUIT ;--- this variable controls whether or not a user terminated input

TYPE ;--- get type of report (patient, date range or search template)

 S BMCPTVS="R"

 D INFORM^BMCRL01

 S (BMCPCNT,BMCPTCT)=0 ;BMCPTCT -- pt total for # of "V"isits

 K BMCTYPE ;--- just in case variable left around

 D PROCESS,XIT

 Q

PROCESS ;process lister

 K BMCCAND

 S DIR(0)="S^P:A Previously defined report;N:Create a New Report",DIR("A")="Which type of report do you wish to generate",DIR("B")="N" K DA D ^DIR K DIR

 I $D(DIRUT) D XIT Q

 I Y="P" S BMCCAND=1

 D ADD I $D(BMCQUIT) D DEL K BMCQUIT Q

 I '$D(BMCCAND) D RTYP Q:$D(DIRUT)  D PP1 Q

 D CAN I $D(DIRUT) K DIRUT,BMCR("CR") G TYPE

 D TITLE I $D(BMCQUIT) K BMCQUIT G TYPE

 D ZIS

 Q

RTYP ;EP;4.0 IHS/ITSC/FCJ ADDED NEXT SECTION FOR TYPE OF REFERRAL

 S DIR(0)="S^P:Primary Referrals;S:Secondary Referrals;B:Both"

 S DIR("A")="Include Which type of Referrals in the report",DIR("B")="B" K DA D ^DIR K DIR

 Q:$D(DIRUT)

 S BMCTYPR=Y

 Q

PP1 ;if patient, no prev defined report used

PP11 K ^BMCRTMP(BMCRPT,11) D SCREEN I $D(BMCQUIT) K BMCQUIT D DEL G TYPE

PP12 K ^BMCRTMP(BMCRPT,12) S BMCTCW=0 D COUNT I $D(BMCQUIT) K BMCQUIT G PP11

PP13 D TITLE I $D(BMCQUIT) K BMCQUIT G PP12

 D SAVE,ZIS

 Q

SCREEN ;

 S BMCCNTL="S" D ^BMCRL4

 Q

COUNT ;count only or detailed report

 D COUNT^BMCRL3

 Q

TITLE ;

 D TITLE^BMCRL3

 Q

SAVE ;

 D SAVE^BMCRL3

 Q

CAN ;TEST FOR DATE RANGE FIELDS ON CANNED REPORT AND PRIM/SEC REF

 D DTTST^BMCRL3

 Q

ZIS ;call to XBDBQUE

 K BMCOPT

 I 'BMCTCW S BMCTCW=IOM

 S BMCDONE=""

 D SHOW^BMCRLS,SHOWP^BMCRLS,SHOWR^BMCRLS

 D XIT1

 I BMCCTYP="D"!(BMCCTYP="S")!(BMCCTYP="N") D

 .W ! S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to",DIR("B")="P" K DA D ^DIR K DIR

 .I $D(DIRUT) S BMCQUIT="" Q

 .S BMCOPT=Y

 G:$G(BMCQUIT) SAVE

 I $G(BMCOPT)="B" D BROWSE,XIT Q

 S XBRP="^BMCRLP",XBRC="^BMCRL1",XBRX="XIT^BMCRL",XBNS="BMC"

 D ^XBDBQUE

 D XIT

 Q

DEL ;EP DELETE LOG ENTRY IF ONE EXISTS AND USER "^" OUT

 I $G(BMCRPT),$D(^BMCRTMP(BMCRPT,0)),'$P(^BMCRTMP(BMCRPT,0),U,2) S DIK="^BMCRTMP(",DA=BMCRPT D ^DIK K DIK,DA,DIC

 Q

ADD ;

 D ADD^BMCRL01

 Q

BROWSE ;

 S XBRP="VIEWR^XBLM(""^BMCRLP"")"

 S XBRC="^BMCRL1",XBRX="XIT^BMCRL",XBIOP=0 D ^XBDBQUE

 Q

XIT ;EP - CALLED FROM BMCRL

 K BMCBD,BMCBDD,BMCED,BMCEDD,BMCSD,BMCSORT,BMCSORV,BMCTCW,BMCRPT,BMCLHDR,BMCDISP,%H,BMCET,BMCLINE,BMCPRNM,BMCPRNT,BMCSKIP,BMCTYPE,BMCSPAG,BMCEN1,BMCSEAT,BMCPTVS,BMC,BMCCAND,BMCHDR,BMCHEAD,BMCSPEC,BMCOPT

 K BMCCTYP,BMCFLG,BMCG,BMCNAME,BMCNIFN,BMCSAVE,BMCTITL,BMCQUIT,BMCPCNT,BMCQFLG,BMCPTCT,BMCTL,BMCSRTR,BMCSRTV,BMCNSRT,BMCTYPR

 K C,D,D0,DA,DIC,DD,DFN,DIADD,DLAYGO,DICR,DIE,DIK,DINUM,DIQ,DIR,DIRUT,DUOUT,DTOUT,DR,J,I,J,K,M,S,TS,X,Y,DIG,DIH,DIV,DQ,DDH,AMQQEN3,AMQQLX

 K BMCR("CR")

XIT1 ;EP

 K BMCANS,BMCBTH,BMCC,BMCCNT,BMCCRIT,BMCCUT,BMCD,BMCDISP,BMCDONE,BMCHIGH,BMCI,BMCJOB,BMCQMAN,BMCSEL,BMCTEXT,BMCVAR,BMCSKIP,BMCPRNT,BMCPRNM,BMCLINE,BMCRCNT,BMCSCNT,BMCDFET,BMCY,DFN

 K X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M,ZTIO,DUOUT,DIR,DTOUT,V,Z,I,DIC,DIK,DIADD,DLAYGO,DA,DR,DIE,DIU,AMQQTAX,DINUM,BMCPACK,BMCEP1,BMCEP2,D,BMCLENG,BMCLHDR,BMCSAVE

 Q

BMCRL     ; IHS/PHXAO/TMJ - PCC REFERRAL GENERAL RETRIEVAL DRIVER ROUTINE ;   

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

 +2       ;IHS/ITSC/FCJ ADD TST FOR DATE RANGE IN CANNED REPORT

 +3       ;IHS/ITSC/FCJ ADDED REF TYPE, VAR BMCTYPR: PRIMARY, SECONDARY BOTH

 +4       ;

START     ; 

 +1       ;--- this variable controls whether or not a user terminated input

           KILL BMCQUIT

TYPE      ;--- get type of report (patient, date range or search template)

 +1        SET BMCPTVS="R"

 +2        DO INFORM^BMCRL01

 +3       ;BMCPTCT -- pt total for # of "V"isits

           SET (BMCPCNT,BMCPTCT)=0

 +4       ;--- just in case variable left around

           KILL BMCTYPE

 +5        DO PROCESS

           DO XIT

 +6        QUIT 

PROCESS   ;process lister

 +1        KILL BMCCAND

 +2        SET DIR(0)="S^P:A Previously defined report;N:Create a New Report"

           SET DIR("A")="Which type of report do you wish to generate"

           SET DIR("B")="N"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               DO XIT

               QUIT 

 +4        IF Y="P"

               SET BMCCAND=1

 +5        DO ADD

           IF $DATA(BMCQUIT)

               DO DEL

               KILL BMCQUIT

               QUIT 

 +6        IF '$DATA(BMCCAND)

               DO RTYP

               IF $DATA(DIRUT)

                   QUIT 

               DO PP1

               QUIT 

 +7        DO CAN

           IF $DATA(DIRUT)

               KILL DIRUT,BMCR("CR")

               GOTO TYPE

 +8        DO TITLE

           IF $DATA(BMCQUIT)

               KILL BMCQUIT

               GOTO TYPE

 +9        DO ZIS

 +10       QUIT 

RTYP      ;EP;4.0 IHS/ITSC/FCJ ADDED NEXT SECTION FOR TYPE OF REFERRAL

 +1        SET DIR(0)="S^P:Primary Referrals;S:Secondary Referrals;B:Both"

 +2        SET DIR("A")="Include Which type of Referrals in the report"

           SET DIR("B")="B"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               QUIT 

 +4        SET BMCTYPR=Y

 +5        QUIT 

PP1       ;if patient, no prev defined report used

PP11       KILL ^BMCRTMP(BMCRPT,11)

           DO SCREEN

           IF $DATA(BMCQUIT)

               KILL BMCQUIT

               DO DEL

               GOTO TYPE

PP12       KILL ^BMCRTMP(BMCRPT,12)

           SET BMCTCW=0

           DO COUNT

           IF $DATA(BMCQUIT)

               KILL BMCQUIT

               GOTO PP11

PP13       DO TITLE

           IF $DATA(BMCQUIT)

               KILL BMCQUIT

               GOTO PP12

 +1        DO SAVE

           DO ZIS

 +2        QUIT 

SCREEN    ;

 +1        SET BMCCNTL="S"

           DO ^BMCRL4

 +2        QUIT 

COUNT     ;count only or detailed report

 +1        DO COUNT^BMCRL3

 +2        QUIT 

TITLE     ;

 +1        DO TITLE^BMCRL3

 +2        QUIT 

SAVE      ;

 +1        DO SAVE^BMCRL3

 +2        QUIT 

CAN       ;TEST FOR DATE RANGE FIELDS ON CANNED REPORT AND PRIM/SEC REF

 +1        DO DTTST^BMCRL3

 +2        QUIT 

ZIS       ;call to XBDBQUE

 +1        KILL BMCOPT

 +2        IF 'BMCTCW

               SET BMCTCW=IOM

 +3        SET BMCDONE=""

 +4        DO SHOW^BMCRLS

           DO SHOWP^BMCRLS

           DO SHOWR^BMCRLS

 +5        DO XIT1

 +6        IF BMCCTYP="D"!(BMCCTYP="S")!(BMCCTYP="N")

               Begin DoDot:1

 +7                WRITE !

                   SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"

                   SET DIR("A")="Do you wish to"

                   SET DIR("B")="P"

                   KILL DA

                   DO ^DIR

                   KILL DIR

 +8                IF $DATA(DIRUT)

                       SET BMCQUIT=""

                       QUIT 

 +9                SET BMCOPT=Y

               End DoDot:1

 +10       IF $GET(BMCQUIT)

               GOTO SAVE

 +11       IF $GET(BMCOPT)="B"

               DO BROWSE

               DO XIT

               QUIT 

 +12       SET XBRP="^BMCRLP"

           SET XBRC="^BMCRL1"

           SET XBRX="XIT^BMCRL"

           SET XBNS="BMC"

 +13       DO ^XBDBQUE

 +14       DO XIT

 +15       QUIT 

DEL       ;EP DELETE LOG ENTRY IF ONE EXISTS AND USER "^" OUT

 +1        IF $GET(BMCRPT)

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

                   IF '$PIECE(^BMCRTMP(BMCRPT,0),U,2)

                       SET DIK="^BMCRTMP("

                       SET DA=BMCRPT

                       DO ^DIK

                       KILL DIK,DA,DIC

 +2        QUIT 

ADD       ;

 +1        DO ADD^BMCRL01

 +2        QUIT 

BROWSE    ;

 +1        SET XBRP="VIEWR^XBLM(""^BMCRLP"")"

 +2        SET XBRC="^BMCRL1"

           SET XBRX="XIT^BMCRL"

           SET XBIOP=0

           DO ^XBDBQUE

 +3        QUIT 

XIT       ;EP - CALLED FROM BMCRL

 +1        KILL BMCBD,BMCBDD,BMCED,BMCEDD,BMCSD,BMCSORT,BMCSORV,BMCTCW,BMCRPT,BMCLHDR,BMCDISP,%H,BMCET,BMCLINE,BMCPRNM,BMCPRNT,BMCSKIP,BMCTYPE,BMCSPAG,BMCEN1,BMCSEAT,BMCPTVS,BMC,BMCCAND,BMCHDR,BMCHEAD,BMCSPEC,BMCOPT

 +2        KILL BMCCTYP,BMCFLG,BMCG,BMCNAME,BMCNIFN,BMCSAVE,BMCTITL,BMCQUIT,BMCPCNT,BMCQFLG,BMCPTCT,BMCTL,BMCSRTR,BMCSRTV,BMCNSRT,BMCTYPR

 +3        KILL C,D,D0,DA,DIC,DD,DFN,DIADD,DLAYGO,DICR,DIE,DIK,DINUM,DIQ,DIR,DIRUT,DUOUT,DTOUT,DR,J,I,J,K,M,S,TS,X,Y,DIG,DIH,DIV,DQ,DDH,AMQQEN3,AMQQLX

 +4        KILL BMCR("CR")

XIT1      ;EP

 +1        KILL BMCANS,BMCBTH,BMCC,BMCCNT,BMCCRIT,BMCCUT,BMCD,BMCDISP,BMCDONE,BMCHIGH,BMCI,BMCJOB,BMCQMAN,BMCSEL,BMCTEXT,BMCVAR,BMCSKIP,BMCPRNT,BMCPRNM,BMCLINE,BMCRCNT,BMCSCNT,BMCDFET,BMCY,DFN

 +2        KILL X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M,ZTIO,DUOUT,DIR,DTOUT,V,Z,I,DIC,DIK,DIADD,DLAYGO,DA,DR,DIE,DIU,AMQQTAX,DINUM,BMCPACK,BMCEP1,BMCEP2,D,BMCLENG,BMCLHDR,BMCSAVE

 +3        QUIT