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
