BMCRLP1.m

BMCRLP1 ; IHS/PHXAO/TMJ - CONT OF BMCRLP ;    

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

 ;IHS/ITSC/FCJ FX FOR PRINTING MULT WP ENTRIES

 ;IHS/ITSC/FCJ ADDED CSRVR,BOCOM AND MED MODULES WILL

 ;    TEST FOR SCREENS WHEN PRINTING CASE REVIEWER,BO COMMENTS AND

 ;    MED HX

 ;

 ;

COVPAGE ;EP

 I $E(IOST,1,2)="C-" W:$D(IOF) @IOF

 W !?20,"REFERRED CARE INFORMATION SYSTEM  ",$S(BMCPTVS="P":"PATIENT",1:"REFERRAL")," ",$S(BMCCTYP="D":"LISTING",1:"COUNT")

 W !!,"REPORT REQUESTED BY: ",$P(^VA(200,DUZ,0),U)

 W !!,"The following report contains a ",$S(BMCPTVS="R":"RCIS Referral",1:"Patient")," report based on the",!,"following criteria:",!

SHOW ;

 W !,$S(BMCPTVS="P":"PATIENT",1:"REFERRAL")," Selection Criteria"

 ;W:BMCTYPE="D" !!?6,"Encounter Date range:  ",BMCBDD," to ",BMCEDD,!

 ;W:BMCTYPE="S" !!?6,"Search Template: ",$P(^DIBT(BMCSEAT,0),U),!

 I '$D(^BMCRTMP(BMCRPT,11)) G SHOWP

 S BMCI=0 F  S BMCI=$O(^BMCRTMP(BMCRPT,11,BMCI)) Q:BMCI'=+BMCI  D

 .I $Y>(IOSL-5) D PAUSE^BMCRL01 W @IOF

 .W !?6,$P(^BMCTSORT(BMCI,0),U),":  "

 .K BMCQ S BMCY="",C=0 K BMCQ F  S BMCY=$O(^BMCRTMP(BMCRPT,11,BMCI,11,"B",BMCY)) S C=C+1 W:C'=1&(BMCY'="") " ; " Q:BMCY=""!($D(BMCQ))  S X=BMCY X:$D(^BMCTSORT(BMCI,2)) ^(2) W X

 K BMCQ

SHOWP ;

 I BMCCTYP="T" D COUNT Q

 I BMCCTYP="S" D  I 1

 .I $Y>(IOSL-6) D PAUSE^BMCRL01 W @IOF

 .W !!,"Report will contain sub-totals by ",$P(^BMCTSORT(BMCSORT,0),U),"."

 .I '$D(^XTMP("BMCRL",BMCJOB,BMCBTH)) W !!,"NO DATA TO REPORT.",! D PAUSE^BMCRL01

 .Q

 I BMCCTYP'="D" D PAUSE^BMCRL01 Q

 I $Y>(IOSL-4) D PAUSE^BMCRL01 W @IOF

 W !!,"PRINT Field Selection"

 I '$D(^BMCRTMP(BMCRPT,12)) G PAUSE

 S BMCI=0 F  S BMCI=$O(^BMCRTMP(BMCRPT,12,BMCI)) Q:BMCI'=+BMCI  S BMCCRIT=$P(^BMCRTMP(BMCRPT,12,BMCI,0),U) D

 .I $Y>(IOSL-4) D PAUSE^BMCRL01 W:$D(IOF) @IOF

 .W !?6,$P(^BMCTSORT(BMCCRIT,0),U),"  (" S X=$O(^BMCRTMP(BMCRPT,12,"B",BMCCRIT,"")) W $P(^BMCRTMP(BMCRPT,12,X,0),U,2),")"

 I $Y>(IOSL-4) D PAUSE^BMCRL01 W:$D(IOF) @IOF

 W !?10,"     TOTAL column width: ",BMCTCW

 Q:'$G(BMCSORT)

 I $Y>(IOSL-4) D PAUSE^BMCRL01 W:$D(IOF) @IOF

 W !!,$S(BMCPTVS="R":"Referrals",1:"Patients")," will be SORTED by:  ",$P(^BMCTSORT(BMCSORT,0),U),!

 I $Y>(IOSL-4) D PAUSE^BMCRL01 W:$D(IOF) @IOF

 I $G(BMCSPAG) W !?6,"Each ",$P(^BMCTSORT(BMCSORT,0),U)," will be on a separate page.",!

 I '$D(^XTMP("BMCRL",BMCJOB,BMCBTH)) W !!,"NO DATA TO REPORT.",!

 D PAUSE^BMCRL01

 Q

DONE ;ENTRY POINT - END OF REPORT TIME DISPLAY

 I $D(BMCET) S BMCTS=(86400*($P(BMCET,",")-$P(BMCBT,",")))+($P(BMCET,",",2)-$P(BMCBT,",",2)),BMCH=$P(BMCTS/3600,".") S:BMCH="" BMCH=0 D

 .S BMCTS=BMCTS-(BMCH*3600),BMCM=$P(BMCTS/60,".") S:BMCM="" BMCM=0 S BMCTS=BMCTS-(BMCM*60),BMCS=BMCTS W !!,"RUN TIME (H.M.S): ",BMCH,".",BMCM,".",BMCS

 I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of report.  HIT RETURN" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 K BMCTS,BMCS,BMCH,BMCM,BMCET

 Q

PAUSE ;

 D PAUSE^BMCRL01

 Q

COUNT ;if COUNTING entries only   

 I $Y>(IOSL-5) D PAUSE^BMCRL01 W:$D(IOF) @IOF

 I '$D(^XTMP("BMCRL",BMCJOB,BMCBTH)) W !!!,"NO DATA TO REPORT.",!

 W:$D(BMCRCNT) !!!,"Total COUNT of ",$S(BMCPTVS="P":"Patients",1:"Referrals"),":  ",BMCRCNT

 Q

WP ;EP - Entry point to print wp fields pass node in BMCNODE

 ;PASS FILE IN BMCFILE, ENTRY IN BMCDA

 K ^UTILITY($J,"W")

 S BMCRLX=0

 S BMCG1=^DIC(BMCFILE,0,"GL"),BMCG=BMCG1_BMCDA_","_BMCNODE_",BMCRLX)",BMCGR=BMCG1_BMCDA_","_BMCNODE_",BMCRLX"

 S DIWL=1,DIWR=$P(^BMCRTMP(BMCRPT,12,BMCI,0),U,2) F  S BMCRLX=$O(@BMCG) Q:BMCRLX'=+BMCRLX  D

 .S Y=BMCGR_",0)" S X=@Y D ^DIWP

 .Q

 S Z=0 F  S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z  S BMCPCNT=BMCPCNT+1,BMCPRNM(BMCPCNT)=^UTILITY($J,"W",DIWL,Z,0)

 K DIWL,DIWR,DIWF,Z

 K ^UTILITY($J,"W"),BMCNODE,BMCFILE,BMCDA,BMCG1,BMCGR,BMCRLX

 Q

WPS ;EP

 S Z=0 F  S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z  S BMCPCNT=BMCPCNT+1,BMCPRNM(BMCPCNT)=^UTILITY($J,"W",DIWL,Z,0)

 K DIWL,DIWR,DIWF,Z

 K ^UTILITY($J,"W"),BMCNODE,BMCFILE,BMCDA

 Q

CSRVR ;EP ;TEST FOR SCREEN ON PRINTING CASE REVIEWER

 S BMCTST=1

 I $D(^BMCRTMP(BMCRPT,11,188)) S BMCTST=0 D

 .S Z=0 F  S Z=$O(^BMCRTMP(BMCRPT,11,188,11,Z)) Q:Z'=+Z  D  Q:BMCTST

 ..I $P(^BMCRTMP(BMCRPT,11,188,11,Z,0),U)=$P(^BMCCOM(BMCX,0),U,4) S BMCTST=1

 K Z Q

BOCOM ;EP ;TEST FOR SCREEN ON PRINTING BUSINESS OFFICE COMMENTS

 S BMCTST=1

 I $D(^BMCRTMP(BMCRPT,11,136)) S BMCTST=0 D

 .S Y=0 F  S Y=$O(^BMCCOM(BMCX,1,Y)) Q:Y'=+Y  S B=^(Y,0) D

 ..S Z=0 F  S Z=$O(^BMCRTMP(BMCRPT,11,136,11,Z)) Q:Z'=+Z  D  Q:BMCTST

 ...I B[^BMCRTMP(BMCRPT,11,136,11,Z,0) S BMCTST=1

 K Y,B,Z Q

BOMED ;EP ;TEST FOR SCREEN ON BUSINESS OFFICE COMMENTS AND PRINTING MED HX 

 S BMCTST=1

 I $D(^BMCRTMP(BMCRPT,11,BMCCRIT)) S BMCTST=0 D

 .S Y=0 F  S Y=$O(^BMCCOM(BMCX,1,Y)) Q:Y'=+Y  S B=^(Y,0) D

 ..S Z=0 F  S Z=$O(^BMCRTMP(BMCRPT,11,BMCCRIT,11,Z)) Q:Z'=+Z  D  Q:BMCTST

 ...I B[^BMCRTMP(BMCRPT,11,BMCCRIT,11,Z,0) S BMCTST=1

 K Y,B,Z Q

BMCRLP1   ; IHS/PHXAO/TMJ - CONT OF BMCRLP ;    

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

 +2       ;IHS/ITSC/FCJ FX FOR PRINTING MULT WP ENTRIES

 +3       ;IHS/ITSC/FCJ ADDED CSRVR,BOCOM AND MED MODULES WILL

 +4       ;    TEST FOR SCREENS WHEN PRINTING CASE REVIEWER,BO COMMENTS AND

 +5       ;    MED HX

 +6       ;

 +7       ;

COVPAGE   ;EP

 +1        IF $EXTRACT(IOST,1,2)="C-"

               IF $DATA(IOF)

                   WRITE @IOF

 +2        WRITE !?20,"REFERRED CARE INFORMATION SYSTEM  ",$SELECT(BMCPTVS="P":"PATIENT",1:"REFERRAL")," ",$SELECT(BMCCTYP="D":"LISTING",1:"COUNT")

 +3        WRITE !!,"REPORT REQUESTED BY: ",$PIECE(^VA(200,DUZ,0),U)

 +4        WRITE !!,"The following report contains a ",$SELECT(BMCPTVS="R":"RCIS Referral",1:"Patient")," report based on the",!,"following criteria:",!

SHOW      ;

 +1        WRITE !,$SELECT(BMCPTVS="P":"PATIENT",1:"REFERRAL")," Selection Criteria"

 +2       ;W:BMCTYPE="D" !!?6,"Encounter Date range:  ",BMCBDD," to ",BMCEDD,!

 +3       ;W:BMCTYPE="S" !!?6,"Search Template: ",$P(^DIBT(BMCSEAT,0),U),!

 +4        IF '$DATA(^BMCRTMP(BMCRPT,11))

               GOTO SHOWP

 +5        SET BMCI=0

           FOR 

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

               IF BMCI'=+BMCI

                   QUIT 

               Begin DoDot:1

 +6                IF $Y>(IOSL-5)

                       DO PAUSE^BMCRL01

                       WRITE @IOF

 +7                WRITE !?6,$PIECE(^BMCTSORT(BMCI,0),U),":  "

 +8                KILL BMCQ

                   SET BMCY=""

                   SET C=0

                   KILL BMCQ

                   FOR 

                       SET BMCY=$ORDER(^BMCRTMP(BMCRPT,11,BMCI,11,"B",BMCY))

                       SET C=C+1

                       IF C'=1&(BMCY'="")

                           WRITE " ; "

                       IF BMCY=""!($DATA(BMCQ))

                           QUIT 

                       SET X=BMCY

                       IF $DATA(^BMCTSORT(BMCI,2))

                           XECUTE ^(2)

                       WRITE X

               End DoDot:1

 +9        KILL BMCQ

SHOWP     ;

 +1        IF BMCCTYP="T"

               DO COUNT

               QUIT 

 +2        IF BMCCTYP="S"

               Begin DoDot:1

 +3                IF $Y>(IOSL-6)

                       DO PAUSE^BMCRL01

                       WRITE @IOF

 +4                WRITE !!,"Report will contain sub-totals by ",$PIECE(^BMCTSORT(BMCSORT,0),U),"."

 +5                IF '$DATA(^XTMP("BMCRL",BMCJOB,BMCBTH))

                       WRITE !!,"NO DATA TO REPORT.",!

                       DO PAUSE^BMCRL01

 +6                QUIT 

               End DoDot:1

               IF 1

 +7        IF BMCCTYP'="D"

               DO PAUSE^BMCRL01

               QUIT 

 +8        IF $Y>(IOSL-4)

               DO PAUSE^BMCRL01

               WRITE @IOF

 +9        WRITE !!,"PRINT Field Selection"

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

               GOTO PAUSE

 +11       SET BMCI=0

           FOR 

               SET BMCI=$ORDER(^BMCRTMP(BMCRPT,12,BMCI))

               IF BMCI'=+BMCI

                   QUIT 

               SET BMCCRIT=$PIECE(^BMCRTMP(BMCRPT,12,BMCI,0),U)

               Begin DoDot:1

 +12               IF $Y>(IOSL-4)

                       DO PAUSE^BMCRL01

                       IF $DATA(IOF)

                           WRITE @IOF

 +13               WRITE !?6,$PIECE(^BMCTSORT(BMCCRIT,0),U),"  ("

                   SET X=$ORDER(^BMCRTMP(BMCRPT,12,"B",BMCCRIT,""))

                   WRITE $PIECE(^BMCRTMP(BMCRPT,12,X,0),U,2),")"

               End DoDot:1

 +14       IF $Y>(IOSL-4)

               DO PAUSE^BMCRL01

               IF $DATA(IOF)

                   WRITE @IOF

 +15       WRITE !?10,"     TOTAL column width: ",BMCTCW

 +16       IF '$GET(BMCSORT)

               QUIT 

 +17       IF $Y>(IOSL-4)

               DO PAUSE^BMCRL01

               IF $DATA(IOF)

                   WRITE @IOF

 +18       WRITE !!,$SELECT(BMCPTVS="R":"Referrals",1:"Patients")," will be SORTED by:  ",$PIECE(^BMCTSORT(BMCSORT,0),U),!

 +19       IF $Y>(IOSL-4)

               DO PAUSE^BMCRL01

               IF $DATA(IOF)

                   WRITE @IOF

 +20       IF $GET(BMCSPAG)

               WRITE !?6,"Each ",$PIECE(^BMCTSORT(BMCSORT,0),U)," will be on a separate page.",!

 +21       IF '$DATA(^XTMP("BMCRL",BMCJOB,BMCBTH))

               WRITE !!,"NO DATA TO REPORT.",!

 +22       DO PAUSE^BMCRL01

 +23       QUIT 

DONE      ;ENTRY POINT - END OF REPORT TIME DISPLAY

 +1        IF $DATA(BMCET)

               SET BMCTS=(86400*($PIECE(BMCET,",")-$PIECE(BMCBT,",")))+($PIECE(BMCET,",",2)-$PIECE(BMCBT,",",2))

               SET BMCH=$PIECE(BMCTS/3600,".")

               IF BMCH=""

                   SET BMCH=0

               Begin DoDot:1

 +2                SET BMCTS=BMCTS-(BMCH*3600)

                   SET BMCM=$PIECE(BMCTS/60,".")

                   IF BMCM=""

                       SET BMCM=0

                   SET BMCTS=BMCTS-(BMCM*60)

                   SET BMCS=BMCTS

                   WRITE !!,"RUN TIME (H.M.S): ",BMCH,".",BMCM,".",BMCS

               End DoDot:1

 +3        IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   SET DIR(0)="EO"

                   SET DIR("A")="End of report.  HIT RETURN"

                   DO ^DIR

                   KILL DIR

                   IF $DATA(DUOUT)

                       SET DIRUT=1

 +4        KILL BMCTS,BMCS,BMCH,BMCM,BMCET

 +5        QUIT 

PAUSE     ;

 +1        DO PAUSE^BMCRL01

 +2        QUIT 

COUNT     ;if COUNTING entries only   

 +1        IF $Y>(IOSL-5)

               DO PAUSE^BMCRL01

               IF $DATA(IOF)

                   WRITE @IOF

 +2        IF '$DATA(^XTMP("BMCRL",BMCJOB,BMCBTH))

               WRITE !!!,"NO DATA TO REPORT.",!

 +3        IF $DATA(BMCRCNT)

               WRITE !!!,"Total COUNT of ",$SELECT(BMCPTVS="P":"Patients",1:"Referrals"),":  ",BMCRCNT

 +4        QUIT 

WP        ;EP - Entry point to print wp fields pass node in BMCNODE

 +1       ;PASS FILE IN BMCFILE, ENTRY IN BMCDA

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

 +3        SET BMCRLX=0

 +4        SET BMCG1=^DIC(BMCFILE,0,"GL")

           SET BMCG=BMCG1_BMCDA_","_BMCNODE_",BMCRLX)"

           SET BMCGR=BMCG1_BMCDA_","_BMCNODE_",BMCRLX"

 +5        SET DIWL=1

           SET DIWR=$PIECE(^BMCRTMP(BMCRPT,12,BMCI,0),U,2)

           FOR 

               SET BMCRLX=$ORDER(@BMCG)

               IF BMCRLX'=+BMCRLX

                   QUIT 

               Begin DoDot:1

 +6                SET Y=BMCGR_",0)"

                   SET X=@Y

                   DO ^DIWP

 +7                QUIT 

               End DoDot:1

 +8        SET Z=0

           FOR 

               SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))

               IF Z'=+Z

                   QUIT 

               SET BMCPCNT=BMCPCNT+1

               SET BMCPRNM(BMCPCNT)=^UTILITY($JOB,"W",DIWL,Z,0)

 +9        KILL DIWL,DIWR,DIWF,Z

 +10       KILL ^UTILITY($JOB,"W"),BMCNODE,BMCFILE,BMCDA,BMCG1,BMCGR,BMCRLX

 +11       QUIT 

WPS       ;EP

 +1        SET Z=0

           FOR 

               SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))

               IF Z'=+Z

                   QUIT 

               SET BMCPCNT=BMCPCNT+1

               SET BMCPRNM(BMCPCNT)=^UTILITY($JOB,"W",DIWL,Z,0)

 +2        KILL DIWL,DIWR,DIWF,Z

 +3        KILL ^UTILITY($JOB,"W"),BMCNODE,BMCFILE,BMCDA

 +4        QUIT 

CSRVR     ;EP ;TEST FOR SCREEN ON PRINTING CASE REVIEWER

 +1        SET BMCTST=1

 +2        IF $DATA(^BMCRTMP(BMCRPT,11,188))

               SET BMCTST=0

               Begin DoDot:1

 +3                SET Z=0

                   FOR 

                       SET Z=$ORDER(^BMCRTMP(BMCRPT,11,188,11,Z))

                       IF Z'=+Z

                           QUIT 

                       Begin DoDot:2

 +4                        IF $PIECE(^BMCRTMP(BMCRPT,11,188,11,Z,0),U)=$PIECE(^BMCCOM(BMCX,0),U,4)

                               SET BMCTST=1

                       End DoDot:2

                       IF BMCTST

                           QUIT 

               End DoDot:1

 +5        KILL Z

           QUIT 

BOCOM     ;EP ;TEST FOR SCREEN ON PRINTING BUSINESS OFFICE COMMENTS

 +1        SET BMCTST=1

 +2        IF $DATA(^BMCRTMP(BMCRPT,11,136))

               SET BMCTST=0

               Begin DoDot:1

 +3                SET Y=0

                   FOR 

                       SET Y=$ORDER(^BMCCOM(BMCX,1,Y))

                       IF Y'=+Y

                           QUIT 

                       SET B=^(Y,0)

                       Begin DoDot:2

 +4                        SET Z=0

                           FOR 

                               SET Z=$ORDER(^BMCRTMP(BMCRPT,11,136,11,Z))

                               IF Z'=+Z

                                   QUIT 

                               Begin DoDot:3

 +5                                IF B[^BMCRTMP(BMCRPT,11,136,11,Z,0)

                                       SET BMCTST=1

                               End DoDot:3

                               IF BMCTST

                                   QUIT 

                       End DoDot:2

               End DoDot:1

 +6        KILL Y,B,Z

           QUIT 

BOMED     ;EP ;TEST FOR SCREEN ON BUSINESS OFFICE COMMENTS AND PRINTING MED HX 

 +1        SET BMCTST=1

 +2        IF $DATA(^BMCRTMP(BMCRPT,11,BMCCRIT))

               SET BMCTST=0

               Begin DoDot:1

 +3                SET Y=0

                   FOR 

                       SET Y=$ORDER(^BMCCOM(BMCX,1,Y))

                       IF Y'=+Y

                           QUIT 

                       SET B=^(Y,0)

                       Begin DoDot:2

 +4                        SET Z=0

                           FOR 

                               SET Z=$ORDER(^BMCRTMP(BMCRPT,11,BMCCRIT,11,Z))

                               IF Z'=+Z

                                   QUIT 

                               Begin DoDot:3

 +5                                IF B[^BMCRTMP(BMCRPT,11,BMCCRIT,11,Z,0)

                                       SET BMCTST=1

                               End DoDot:3

                               IF BMCTST

                                   QUIT 

                       End DoDot:2

               End DoDot:1

 +6        KILL Y,B,Z

           QUIT