Routine: BMCRCHS1

BMCRCHS1 ; IHS/PHXAO/TMJ - LIST PAID CHS REFERRALS ; 15 Mar 2013  9:02 AM

 ;;4.0;REFERRED CARE INFO SYSTEM;**8,9**;JAN 09, 2006;Build 101

 ;IHS/ITSC/FCJ ADDED BEG-END DATE REQ FOR REPORT AND RESORT OF DATA

 ; ADDED AMT PAID AND RMVD PRIM PRV

 ; This routine lists active CHS referrals where all CHS AUTHORIZATIONS

 ; have been paid.

START ;

 W !!,"This report prints out a list of all active CHS referrals for which all",!,"authorizations have already been paid.",!!

 W "Report will include Primary and Secondary Referrals.",!

BD ;GET BEG AND END DATE OF REPORT

 D BD^BMCRUTL

 G:$D(DIRUT) EOJ1  ;BMC*4.0*8

 D INIT

 Q:BMCQ

 D DBQUE

INIT ; INITIALIZAION

 S BMCQ=0

 D:$G(BMCPARM)="" PARMSET^BMC

 S BMCJOB=$J

 F  D  Q:BMCBT]""

 . S BMCBT=$H

 . LOCK +^XTMP("BMCRCHS1",BMCJOB,BMCBT):1

 . E  S BMCBT=""

. Q

 K ^XTMP("BMCRCHS1",$J,BMCBT)

DBQUE ;call to XBDBQUE

 K BMCOPT

 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=1 Q

 S BMCOPT=Y

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

 S XBRP="REFPRT^BMCRCHS1",XBRC="REFCHK^BMCRCHS1",XBRX="EOJ^BMCRCHS1",XBNS="BMC"

 D ^XBDBQUE

BROWSE ;

 S XBRP="VIEWR^XBLM(""REFPRT^BMCRCHS1"")"

 S XBRC="REFCHK^BMCRCHS1",XBRX="EOJ^BMCRCHS1",XBNS="BMC",XBIOP=0

 D ^XBDBQUE

REFCHK ; CHECK ACTIVE/CHS REFERRAL SORTED BY DATE INIT

 S BMCODAT=$O(^BMCREF("B",BMCSD)) I BMCODAT="" S BMCET=$H Q

 S BMCODAT=BMCSD_".9999" F  S BMCODAT=$O(^BMCREF("B",BMCODAT)) Q:BMCODAT=""!((BMCODAT\1)>BMCED)  D R1

R1 ;

 S BMCRIEN="" F  S BMCRIEN=$O(^BMCREF("B",BMCODAT,BMCRIEN)) Q:BMCRIEN'=+BMCRIEN  S BMCRREC=^BMCREF(BMCRIEN,0) D PROC

PROC ;

 ;Q:$P(BMCRREC,U,15)'="A"    ;QUIT IF NOT ACTIVE  ;BMC*4.0*9 IHS.OIT.FCJ

 Q:($P(BMCRREC,U,15)="C1")!($P(BMCRREC,U,15)="X")  ;QUIT IF NOT ACTIVE OR APPROVED ;BMC*4.0*9 IHS.OIT.FCJ

 S X=^BMCREF(BMCRIEN,0)

 I $P(X,U,4)="C" D  S:BMCHIT ^XTMP("BMCRCHS1",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)=""

 . S (BMCAUTH,BMCHIT,BMCSKIP)=0

 . Q:'$O(^BMCREF(BMCRIEN,41,0))  ;    no authorizations

 . F  S BMCAUTH=$O(^BMCREF(BMCRIEN,41,BMCAUTH)) Q:'BMCAUTH  D  Q:BMCSKIP

 .. S Y=^BMCREF(BMCRIEN,41,BMCAUTH,0)

 .. S:$P(Y,U,3)="" BMCSKIP=1 ;        no dollars paid

 . S:'BMCSKIP BMCHIT=1

REFPRT ; PRINT REFERRALS SELECTED

 S $P(BMC80E,"=",80)=""

 S $P(BMC80D,"-",80)=""

 D REFPRT2

 K ^XTMP("BMCRCHS1",BMCJOB,BMCBT)

REFPRT2 ;

 S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) I '$D(^XTMP("BMCRCHS1",BMCJOB,BMCBT)) W !,"No referrals to report",! D PAUSE^BMC Q

 S BMCRIEN=0 K BMCQUIT

 F  S BMCRIEN=$O(^XTMP("BMCRCHS1",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)) Q:BMCRIEN=""!($D(BMCQUIT))  D PRINT

 Q:$D(BMCQUIT)

 D PAUSE^BMC

PRINT ;print one referral

 S BMCRREC=^BMCREF(BMCRIEN,0)

 S Y=BMCRIEN

 D ^BMCREF

 I $Y>(IOSL-5) D HEAD Q:$D(BMCQUIT)

 W $$FMTE^XLFDT($P(BMCRREC,U),"2D")

 W ?10,$E(BMCREC("PAT NAME"),1,20)

 W ?32,$P(BMCRREC,U,2) W:$G(^BMCREF(BMCRIEN,1)) $P(^BMCREF(BMCRIEN,1),U)

 W ?48,$E($$TOFAC^BMC(BMCRIEN),1,20)

 S I=0 F  S I=$O(^BMCREF(BMCRIEN,41,I)) Q:I'?1N.N  W ?69,$J($P(^BMCREF(BMCRIEN,41,I,0),U,3),9,2),!

W !

 I '$O(^BMCREF(BMCRIEN,12,0)) Q  ;      no purpose of referral

 K ^UTILITY($J,"W")

 F BMCL=0:0 S BMCL=$O(^BMCREF(BMCRIEN,1,BMCL)) Q:'BMCL  S X=^(BMCL,0) D

 . S DIWL=10,DIWR=70,DIWF="W"

 . D ^DIWP

. Q

 D ^DIWW

W !

HEAD ;

 D PAUSE^BMC

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

 D HEAD1

HEAD1 ;

 W:$D(IOF) @IOF

HEAD2 ; WRITE HEADER

 S BMCPG=BMCPG+1

 W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"

 W !?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!

 W $$CTR^BMC("ACTIVE CHS REFERRALS WHERE ALL AUTHORIZATIONS PAID",80),!

 S Y=BMCBD D DD^%DT W ?17,"BEG DATE: "_Y

 S Y=BMCED D DD^%DT W ?40,"END DATE: "_Y,!

 W !,"REF DATE",?11,"PATIENT NAME",?32," REF #",?48,"FACILITY REF TO",?70,"AMT PAID"

 W !,BMC80D

W !

EOJ ; END OF JOB

 LOCK -^XTMP("BMCRCHS1",BMCJOB,BMCBT)

 K ^XTMP("BMCRCHS1",BMCJOB,BMCBT)

EOJ1 ;BMC*4.0*8 ADDED LINE LABEL

 D ^BMCKILL

 K BMC80D,BMC80E,BMCBOS,BMCBT,BMCJOB,BMCCL,BMCOPT,BMCPG,BMCRREC,BMCRSTAT,BMCSKIP

 K BMCBD,BMCED,BMCBDD,BMCEDD,BMCSD

BMCRCHS1  ; IHS/PHXAO/TMJ - LIST PAID CHS REFERRALS ; 15 Mar 2013  9:02 AM

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;**8,9**;JAN 09, 2006;Build 101

 +2       ;IHS/ITSC/FCJ ADDED BEG-END DATE REQ FOR REPORT AND RESORT OF DATA

 +3       ; ADDED AMT PAID AND RMVD PRIM PRV

 +4       ;

 +5       ; This routine lists active CHS referrals where all CHS AUTHORIZATIONS

 +6       ; have been paid.

 +7       ;

START     ;

 +1        WRITE !!,"This report prints out a list of all active CHS referrals for which all",!,"authorizations have already been paid.",!!

 +2        WRITE "Report will include Primary and Secondary Referrals.",!

BD        ;GET BEG AND END DATE OF REPORT

 +1        DO BD^BMCRUTL

 +2       ;BMC*4.0*8

           IF $DATA(DIRUT)

               GOTO EOJ1

 +3        DO INIT

 +4        IF BMCQ

               QUIT

 +5        DO DBQUE

 +6        QUIT

 +7       ;

INIT      ; INITIALIZAION

 +1        SET BMCQ=0

 +2        IF $GET(BMCPARM)=""

               DO PARMSET^BMC

 +3        SET BMCJOB=$JOB

 +4        FOR

               Begin DoDot:1

 +5                SET BMCBT=$HOROLOG

 +6                LOCK +^XTMP("BMCRCHS1",BMCJOB,BMCBT):1

 +7               IF '$TEST

                       SET BMCBT=""

 +8                QUIT

               End DoDot:1

               IF BMCBT]""

                   QUIT

 +9        KILL ^XTMP("BMCRCHS1",$JOB,BMCBT)

 +10       QUIT

 +11      ;

DBQUE     ;call to XBDBQUE

 +1        KILL BMCOPT

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

 +3        IF $DATA(DIRUT)

               SET BMCQUIT=1

               QUIT

 +4        SET BMCOPT=Y

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

               DO BROWSE

               QUIT

 +6        SET XBRP="REFPRT^BMCRCHS1"

           SET XBRC="REFCHK^BMCRCHS1"

           SET XBRX="EOJ^BMCRCHS1"

           SET XBNS="BMC"

 +7        DO ^XBDBQUE

 +8        QUIT

 +9       ;

BROWSE    ;

 +1        SET XBRP="VIEWR^XBLM(""REFPRT^BMCRCHS1"")"

 +2        SET XBRC="REFCHK^BMCRCHS1"

           SET XBRX="EOJ^BMCRCHS1"

           SET XBNS="BMC"

           SET XBIOP=0

 +3        DO ^XBDBQUE

 +4        QUIT

 +5       ;

REFCHK    ; CHECK ACTIVE/CHS REFERRAL SORTED BY DATE INIT

 +1        SET BMCODAT=$ORDER(^BMCREF("B",BMCSD))

           IF BMCODAT=""

               SET BMCET=$HOROLOG

               QUIT

 +2        SET BMCODAT=BMCSD_".9999"

FOR

               SET BMCODAT=$ORDER(^BMCREF("B",BMCODAT))

               IF BMCODAT=""!((BMCODAT\1)>BMCED)

                   QUIT

               DO R1

 +3        QUIT

R1        ;

 +1        SET BMCRIEN=""

FOR

               SET BMCRIEN=$ORDER(^BMCREF("B",BMCODAT,BMCRIEN))

               IF BMCRIEN'=+BMCRIEN

                   QUIT

               SET BMCRREC=^BMCREF(BMCRIEN,0)

               DO PROC

 +2        QUIT

 +3       ;

PROC      ;

 +1       ;Q:$P(BMCRREC,U,15)'="A"    ;QUIT IF NOT ACTIVE  ;BMC*4.0*9 IHS.OIT.FCJ

 +2       ;QUIT IF NOT ACTIVE OR APPROVED ;BMC*4.0*9 IHS.OIT.FCJ

           IF ($PIECE(BMCRREC,U,15)="C1")!($PIECE(BMCRREC,U,15)="X")

               QUIT

 +3        SET X=^BMCREF(BMCRIEN,0)

 +4        IF $PIECE(X,U,4)="C"

               Begin DoDot:1

 +5                SET (BMCAUTH,BMCHIT,BMCSKIP)=0

 +6       ;    no authorizations

                   IF '$ORDER(^BMCREF(BMCRIEN,41,0))

                       QUIT

 +7                FOR

                       SET BMCAUTH=$ORDER(^BMCREF(BMCRIEN,41,BMCAUTH))

                       IF 'BMCAUTH

                           QUIT

                       Begin DoDot:2

 +8                        SET Y=^BMCREF(BMCRIEN,41,BMCAUTH,0)

 +9       ;        no dollars paid

                           IF $PIECE(Y,U,3)=""

                               SET BMCSKIP=1

                       End DoDot:2

                       IF BMCSKIP

                           QUIT

 +10               IF 'BMCSKIP

                       SET BMCHIT=1

               End DoDot:1

               IF BMCHIT

                   SET ^XTMP("BMCRCHS1",BMCJOB,BMCBT,"DATA HITS",BMCRIEN)=""

 +11       QUIT

 +12      ;

REFPRT    ; PRINT REFERRALS SELECTED

 +1        SET $PIECE(BMC80E,"=",80)=""

 +2        SET $PIECE(BMC80D,"-",80)=""

 +3        DO REFPRT2

 +4        KILL ^XTMP("BMCRCHS1",BMCJOB,BMCBT)

 +5        QUIT

 +6       ;

REFPRT2   ;

 +1        SET BMCPG=0

           DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))

           IF '$DATA(^XTMP("BMCRCHS1",BMCJOB,BMCBT))

               WRITE !,"No referrals to report",!

               DO PAUSE^BMC

               QUIT

 +2        SET BMCRIEN=0

           KILL BMCQUIT

 +3        FOR

               SET BMCRIEN=$ORDER(^XTMP("BMCRCHS1",BMCJOB,BMCBT,"DATA HITS",BMCRIEN))

               IF BMCRIEN=""!($DATA(BMCQUIT))

                   QUIT

               DO PRINT

 +4        IF $DATA(BMCQUIT)

               QUIT

 +5        DO PAUSE^BMC

 +6        QUIT

 +7       ;

PRINT     ;print one referral

 +1        SET BMCRREC=^BMCREF(BMCRIEN,0)

 +2        SET Y=BMCRIEN

 +3        DO ^BMCREF

 +4        IF $Y>(IOSL-5)

               DO HEAD

               IF $DATA(BMCQUIT)

                   QUIT

 +5        WRITE $$FMTE^XLFDT($PIECE(BMCRREC,U),"2D")

 +6        WRITE ?10,$EXTRACT(BMCREC("PAT NAME"),1,20)

 +7        WRITE ?32,$PIECE(BMCRREC,U,2)

           IF $GET(^BMCREF(BMCRIEN,1))

               WRITE $PIECE(^BMCREF(BMCRIEN,1),U)

 +8        WRITE ?48,$EXTRACT($$TOFAC^BMC(BMCRIEN),1,20)

 +9        SET I=0

FOR

               SET I=$ORDER(^BMCREF(BMCRIEN,41,I))

               IF I'?1N.N

                   QUIT

               WRITE ?69,$JUSTIFY($PIECE(^BMCREF(BMCRIEN,41,I,0),U,3),9,2),!

 +10       WRITE !

 +11      ;      no purpose of referral

           IF '$ORDER(^BMCREF(BMCRIEN,12,0))

               QUIT

 +12      ;

 +13       KILL ^UTILITY($JOB,"W")

 +14       FOR BMCL=0:0

               SET BMCL=$ORDER(^BMCREF(BMCRIEN,1,BMCL))

               IF 'BMCL

                   QUIT

               SET X=^(BMCL,0)

               Begin DoDot:1

 +15               SET DIWL=10

                   SET DIWR=70

                   SET DIWF="W"

 +16               DO ^DIWP

 +17               QUIT

               End DoDot:1

 +18       DO ^DIWW

 +19       WRITE !

 +20       QUIT

 +21      ;

HEAD      ;

 +1        DO PAUSE^BMC

 +2        IF $DATA(DIRUT)

               SET BMCQUIT=""

               QUIT

 +3        DO HEAD1

 +4        QUIT

 +5       ;

HEAD1     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

HEAD2     ; WRITE HEADER

 +1        SET BMCPG=BMCPG+1

 +2        WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"

 +3        WRITE !?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!

 +4        WRITE $$CTR^BMC("ACTIVE CHS REFERRALS WHERE ALL AUTHORIZATIONS PAID",80),!

 +5        SET Y=BMCBD

           DO DD^%DT

           WRITE ?17,"BEG DATE: "_Y

 +6        SET Y=BMCED

           DO DD^%DT

           WRITE ?40,"END DATE: "_Y,!

 +7        WRITE !,"REF DATE",?11,"PATIENT NAME",?32," REF #",?48,"FACILITY REF TO",?70,"AMT PAID"

 +8        WRITE !,BMC80D

 +9        WRITE !

 +10       QUIT

 +11      ;

EOJ       ; END OF JOB

 +1        LOCK -^XTMP("BMCRCHS1",BMCJOB,BMCBT)

 +2        KILL ^XTMP("BMCRCHS1",BMCJOB,BMCBT)

EOJ1      ;BMC*4.0*8 ADDED LINE LABEL

 +1        DO ^BMCKILL

 +2        KILL BMC80D,BMC80E,BMCBOS,BMCBT,BMCJOB,BMCCL,BMCOPT,BMCPG,BMCRREC,BMCRSTAT,BMCSKIP

 +3        KILL BMCBD,BMCED,BMCBDD,BMCEDD,BMCSD

 +4        QUIT

BMCRCHS1.m