Routine: BMCRINH

BMCRINH ; IHS/ITSC/FCJ - IN-HOUSE REPORT;

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

 ;IHS/ITSC/FCJ Referral number was not printing

 ; This routine lists active In-house referrals,

 ; User can select date range, will sort by date initiated and clinic

START ;

 W !!,"This report prints out a list of all Active In-House referrals. ",!,"The user can select a date range by Date initiated and Status of Referral.",!

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

 D INIT

 Q:BMCQ

 D GETDATES^BMCRUTL Q:$D(DIRUT)!$D(DTOUT)

 D DBQUE

INIT ; INITIALIZAION

 S BMCQ=0

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

 S BMCJOB=$J

 F  D  Q:BMCBT]""

 . S BMCBT=$H

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

 . E  S BMCBT=""

. Q

 K ^XTMP("BMCRINH",BMCJOB,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^BMCRINH",XBRC="REFCHK^BMCRINH",XBRX="EOJ^BMCRINH",XBNS="BMC"

 D ^XBDBQUE

BROWSE ;

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

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

 D ^XBDBQUE

REFCHK ; CHECK EACH ACTIVE/CHS REFERRAL

 S BMCCL="",BMCBDT=BMCBD-1

 F  S BMCBDT=$O(^BMCREF("B",BMCBDT)) Q:('BMCBDT)!(BMCBDT>BMCED)  D

 .S BMCRIEN=0

 .F  S BMCRIEN=$O(^BMCREF("B",BMCBDT,BMCRIEN)) Q:'BMCRIEN  D

 .. S X=^BMCREF(BMCRIEN,0)

 ..; Q:$P(X,U,15)'="A"   ;BMC*4.0*9 IHS.OIT.FCJ

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

 .. I $P(X,U,4)="N" D

 ...S BMCCL=$S($P(X,U,23)?1N.N:$P(^DIC(40.7,$P(X,U,23),0),U),1:"UNKNOWN")

 ...S ^XTMP("BMCRINH",BMCJOB,BMCBT,"DATA HITS",BMCCL,BMCRIEN)=""

REFPRT ; PRINT REFERRALS SELECTED

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

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

 D REFPRT2

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

REFPRT2 ;

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

 S BMCCL=""

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

 .W !,"CLINIC REFERRED TO:  ",BMCCL,!

 .S BMCRIEN=0 K BMCQUIT

 .F  S BMCRIEN=$O(^XTMP("BMCRINH",BMCJOB,BMCBT,"DATA HITS",BMCCL,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),"5D")  ;DATE OF REF

 W ?11

 I $P(^BMCREF(BMCRIEN,11),U,6)="" W $$FMTE^XLFDT($P(^BMCREF(BMCRIEN,11),U,5),"5D")  ;EST DOS

 E  W $$FMTE^XLFDT($P(^BMCREF(BMCRIEN,11),U,6),"5D")  ;ACT DOS

 W ?23,$P(^BMCREF(BMCRIEN,0),U,2)

 W $P($G(^BMCREF(BMCRIEN,1)),U) ;BMC*4.0 6.6.05 IHS/ITSC/FCJ PRT SUF

 W ?39,$E(BMCREC("PAT NAME"),1,24)

 S BMCHRN="????" I $D(^AUPNPAT(BMCDFN,41,DUZ(2))) S BMCHRN=$P(^AUTTLOC(DUZ(2),0),U,7)_$P(^AUPNPAT(BMCDFN,41,DUZ(2),0),U,2)

 W ?65,BMCHRN

 W ?73,$S($P(BMCRREC,U,6):$$PROVINI^XBFUNC1($P(BMCRREC,U,6)),1:"--")

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 IN HOUSE REFFERALS BY CLINIC REFERRED TO",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",?14,"DOS",?24,"REFERRAL #",?39,"PATIENT",?65,"HRN",?73,"PROV"

 W !,BMC80D

W !

EOJ ; END OF JOB

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

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

 D ^BMCKILL

 K BMC80E,BMC80D,BMCBD,BMCBDD,BMCBDT,BMCBT,BMCHRN,BMCOPT,BMCPG,BMCJOB

 K BMCCL,BMCED,BMCEDD,BMCREC,BMCSD,BMCRREC,BMCRSTAT

BMCRINH   ; IHS/ITSC/FCJ - IN-HOUSE REPORT;

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

 +2       ;

 +3       ;IHS/ITSC/FCJ Referral number was not printing

 +4       ; This routine lists active In-house referrals,

 +5       ; User can select date range, will sort by date initiated and clinic

 +6       ;

START     ;

 +1        WRITE !!,"This report prints out a list of all Active In-House referrals. ",!,"The user can select a date range by Date initiated and Status of Referral.",!

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

 +3        DO INIT

 +4        IF BMCQ

               QUIT

 +5        DO GETDATES^BMCRUTL

           IF $DATA(DIRUT)!$DATA(DTOUT)

               QUIT

 +6        DO DBQUE

 +7        QUIT

 +8       ;

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("BMCRINH",BMCJOB,BMCBT):1

 +7               IF '$TEST

                       SET BMCBT=""

 +8                QUIT

               End DoDot:1

               IF BMCBT]""

                   QUIT

 +9        KILL ^XTMP("BMCRINH",BMCJOB,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^BMCRINH"

           SET XBRC="REFCHK^BMCRINH"

           SET XBRX="EOJ^BMCRINH"

           SET XBNS="BMC"

 +7        DO ^XBDBQUE

 +8        QUIT

 +9       ;

BROWSE    ;

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

 +2        SET XBRC="REFCHK^BMCRINH"

           SET XBRX="EOJ^BMCRINH"

           SET XBNS="BMC"

           SET XBIOP=0

 +3        DO ^XBDBQUE

 +4        QUIT

 +5       ;

REFCHK    ; CHECK EACH ACTIVE/CHS REFERRAL

 +1        SET BMCCL=""

           SET BMCBDT=BMCBD-1

 +2        FOR

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

               IF ('BMCBDT)!(BMCBDT>BMCED)

                   QUIT

               Begin DoDot:1

 +3                SET BMCRIEN=0

 +4                FOR

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

                       IF 'BMCRIEN

                           QUIT

                       Begin DoDot:2

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

 +6       ; Q:$P(X,U,15)'="A"   ;BMC*4.0*9 IHS.OIT.FCJ

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

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

                               QUIT

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

                               Begin DoDot:3

 +9                                SET BMCCL=$SELECT($PIECE(X,U,23)?1N.N:$PIECE(^DIC(40.7,$PIECE(X,U,23),0),U),1:"UNKNOWN")

 +10                               SET ^XTMP("BMCRINH",BMCJOB,BMCBT,"DATA HITS",BMCCL,BMCRIEN)=""

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +11       QUIT

 +12      ;

REFPRT    ; PRINT REFERRALS SELECTED

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

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

 +3        DO REFPRT2

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

 +5        QUIT

 +6       ;

REFPRT2   ;

 +1        SET BMCPG=0

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

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

               WRITE !,"No referrals to report",!

               DO PAUSE^BMC

               QUIT

 +2        SET BMCCL=""

 +3        FOR

               SET BMCCL=$ORDER(^XTMP("BMCRINH",BMCJOB,BMCBT,"DATA HITS",BMCCL))

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

                   QUIT

               Begin DoDot:1

 +4                WRITE !,"CLINIC REFERRED TO:  ",BMCCL,!

 +5                SET BMCRIEN=0

                   KILL BMCQUIT

 +6                FOR

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

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

                           QUIT

                       DO PRINT

               End DoDot:1

 +7        IF $DATA(BMCQUIT)

               QUIT

 +8        DO PAUSE^BMC

 +9        QUIT

 +10      ;

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       ;DATE OF REF

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

 +6        WRITE ?11

 +7       ;EST DOS

           IF $PIECE(^BMCREF(BMCRIEN,11),U,6)=""

               WRITE $$FMTE^XLFDT($PIECE(^BMCREF(BMCRIEN,11),U,5),"5D")

 +8       ;ACT DOS

          IF '$TEST

               WRITE $$FMTE^XLFDT($PIECE(^BMCREF(BMCRIEN,11),U,6),"5D")

 +9        WRITE ?23,$PIECE(^BMCREF(BMCRIEN,0),U,2)

 +10      ;BMC*4.0 6.6.05 IHS/ITSC/FCJ PRT SUF

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

 +11       WRITE ?39,$EXTRACT(BMCREC("PAT NAME"),1,24)

 +12       SET BMCHRN="????"

           IF $DATA(^AUPNPAT(BMCDFN,41,DUZ(2)))

               SET BMCHRN=$PIECE(^AUTTLOC(DUZ(2),0),U,7)_$PIECE(^AUPNPAT(BMCDFN,41,DUZ(2),0),U,2)

 +13       WRITE ?65,BMCHRN

 +14       WRITE ?73,$SELECT($PIECE(BMCRREC,U,6):$$PROVINI^XBFUNC1($PIECE(BMCRREC,U,6)),1:"--")

 +15       WRITE !

 +16       QUIT

 +17      ;

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 IN HOUSE REFFERALS BY CLINIC REFERRED TO",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",?14,"DOS",?24,"REFERRAL #",?39,"PATIENT",?65,"HRN",?73,"PROV"

 +8        WRITE !,BMC80D

 +9        WRITE !

 +10       QUIT

 +11      ;

EOJ       ; END OF JOB

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

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

 +3        DO ^BMCKILL

 +4        KILL BMC80E,BMC80D,BMCBD,BMCBDD,BMCBDT,BMCBT,BMCHRN,BMCOPT,BMCPG,BMCJOB

 +5        KILL BMCCL,BMCED,BMCEDD,BMCREC,BMCSD,BMCRREC,BMCRSTAT

 +6        QUIT

BMCRINH.m