BMCRR5P ; IHS/PHXAO/TMJ - PRNT BILL VSTS ; [ 08/15/2006 11:54 AM ]
;;4.0;REFERRED CARE INFO SYSTEM;**2,9**;JAN 09, 2006;Build 101
;IHS/ITSC/FCJ FIX PRINT 1 PAT PER PAGE ; ADDED OPTION TO ALPHA PRINT
; PRINT ALL COMMENTS FROM RCIS COMMENT FILE
;IHS/ITSC/FCJ ADDED PRINTING OF SECONDARY REF
;BMC 4.0*2 8/15/06 IHS/OIT/FCJ Mv Discharge Com after Case Com
; Added Disharge Date after Discharge Com
;4.0*9 11.11.2012 IHS.OIT.FCJ ADDED ICD-10 CHANGE
;
S BMC80E="==============================================================================="
S BMC80D="-------------------------------------------------------------------------------"
S BMC15S=" "
S BMCPG=0 I '$D(^XTMP("BMCRR5",BMCJOB,BMCBT)) D @("HEAD"_(2-($E(IOST,1,2)="C-"))) W !,"No referrals to report",! G XIT
S BMCSORT=0 K BMCQUIT D @("HEAD"_(2-($E(IOST,1,2)="C-")))
F S BMCSORT=$O(^XTMP("BMCRR5",BMCJOB,BMCBT,"DATA HITS",BMCSORT)) Q:BMCSORT=""!($D(BMCQUIT)) D PRINT
XIT ;
K ^XTMP("BMCRR5",BMCJOB,BMCBT)
K BMCSTST,BMCSTYPA,BMCSORTA,BMCCTYP
K BMCRREC,BMCREF,BMC2,BMCI,BMCG,BMCX,BMCSTR,BMCCTR,BMCFILE,BMCNODE,BMCAR,BMC1,BMCBT,BMCH,BMCPG,BMCV,BMCVDFN,BMCVDG,BMCVFLE,BMCVI,BMCVIGR,BMCVL,BMCVNM,BMCX,BMCY
D KILL^AUPNPAT
K DFN
Q
PRINT ;print one referral
I $G(BMCSPAGE),BMCPG'=1 D HEAD Q:$D(BMCQUIT)
I $Y>(IOSL-10) D HEAD Q:$D(BMCQUIT)
I BMCSTYPE'="P" W !!,$S(BMCSTYPE="F":"FACILITY REFERRED TO: ",BMCSTYPE="C":"CASE MANAGER: ",BMCSTYPE="P":"PATIENT NAME: ",1:"???: "),BMCSORT,!
I BMCSTYPE'="P",$G(BMCSTYPA)=1 D Q
.S BMCSORTA="" F S BMCSORTA=$O(^XTMP("BMCRR5",BMCJOB,BMCBT,"DATA HITS",BMCSORT,BMCSORTA)) Q:BMCSORTA="" D Q:$D(BMCQUIT)
..S BMCREF="" F S BMCREF=$O(^XTMP("BMCRR5",BMCJOB,BMCBT,"DATA HITS",BMCSORT,BMCSORTA,BMCREF)) Q:BMCREF'=+BMCREF D PRINT1 Q:$D(BMCQUIT) S BMCTST=0
S BMCREF="" F S BMCREF=$O(^XTMP("BMCRR5",BMCJOB,BMCBT,"DATA HITS",BMCSORT,BMCREF)) Q:BMCREF'=+BMCREF D PRINT1 Q:$D(BMCQUIT) S BMCTST=0
Q
PRINT1 ;
S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3)
I $G(BMCSPAGE),BMCTST=0 D HEAD Q:$D(BMCQUIT)
;BMC*4.1 4/19/06 IHS.OIT.FCJ CHANGED BMCTYPR TO TEST FOR 1
I $P($G(^BMCREF(BMCREF,1)),U)'="",BMCTYPR'=1 Q
D BUILD
Q
BUILD ; build array
K BMCAR
S BMCRREC=^BMCREF(BMCREF,0)
W !!
S Y=$P(BMCRREC,U,3) D ^AUPNPAT
S BMCSTR="",BMCCTR=0
S BMCSTR=$E($P(^DPT($P(BMCRREC,U,3),0),U)_BMC15S,1,24)
S BMCSTR="Name: "_BMCSTR_" "_$$FMTE^XLFDT(AUPNDOB,"5D")_" "_$$VAL^XBDIQ1(9000001,DFN,1102.98)_" "_$$SSN^AUPNPAT(DFN) D SET Q:$D(BMCQUIT)
S X=$$VAL^XBDIQ1(90001,BMCREF,.02) W ?59,"Ref #:"_X_$P($G(^BMCREF(BMCREF,1)),U)
K BMCAR D ENPM^XBDIQ1(2.01,DFN_",0",".01","BMCAR(")
S I=0 F S I=$O(BMCAR(I)) Q:I'=+I S BMCSTR=BMCAR(I,.01)_" "
I BMCSTR]"" S BMCSTR="AKA'S: "_BMCSTR D SET Q:$D(BMCQUIT)
S BMCSTR="Tribe: "_$E($$VAL^XBDIQ1(9000001,DFN,1108),1,20)_" Tribal #: "_$S($$VAL^XBDIQ1(9000001,DFN,.07)]"":$$VAL^XBDIQ1(9000001,DFN,.07),1:"< ? >")
S BMCSTR=BMCSTR_" "_$$VAL^XBDIQ1(9000001,DFN,1118) D SET Q:$D(BMCQUIT)
CHARTS ;print duz(2) chart then first 4 in mult.
K BMCAR D ENPM^XBDIQ1(9000001.41,DFN_",0",".02","BMCAR(")
I $D(BMCAR(DUZ(2))) S BMCSTR=$P(^AUTTLOC(DUZ(2),0),U,7)_"#: "_BMCAR(DUZ(2),.02) S (I,F,C)=0 F S I=$O(BMCAR(I)) Q:I'=+I!(C>4) I I'=DUZ(2) S C=C+1,BMCSTR=BMCSTR_" "_$P(^AUTTLOC(I,0),U,7)_"#: "_BMCAR(I,.02)
D SET Q:$D(BMCQUIT)
REQ ;
S BMCSTR="Referred To:",Y=$$FACREF^BMCRLU(BMCREF),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,15,$L(Y)),Y="Attending:"
S BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,45,$L(Y)),Y=$E($$VAL^XBDIQ1(90001,BMCREF,.09),1,18),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,56,$L(Y)) D SET Q:$D(BMCQUIT)
S BMCRNUMB=$P(^BMCREF(BMCREF,0),U,2)
S BMCSTST=$P($G(^BMCREF(BMCREF,1)),U)
D SECREF2^BMCRUTL ;PRINT SEC REF INFO
S BMCSTR="Referred By: "_$$VAL^XBDIQ1(90001,BMCREF,.06) D SET Q:$D(BMCQUIT)
S BMCSTR="Beg DOS: "_$$AVDOS^BMCRLU(BMCREF)_" Est LOS: "_$$AVLOS^BMCRLU(BMCREF)_" LOS to Date: "_$$VAL^XBDIQ1(90001,BMCREF,.1499) D SET Q:$D(BMCQUIT)
S BMCSTR="Purpose: "_$$VAL^XBDIQ1(90001,BMCREF,1201) D SET Q:$D(BMCQUIT)
DRG ;
S BMCSTR="Primary Payor: "_$$VAL^XBDIQ1(90001,BMCREF,.11) D SET Q:$D(BMCQUIT)
D VFILES
2 ;BUSINESS OFFICE COMMENTS
I '$D(^BMCCOM("AD",BMCREF)) Q
S BMCCTYP="B",BMCSTR="Business Office Notes: " D COMMENTS Q:$D(BMCQUIT)
;BMC 4.0*2 8/15/06 IHS/OIT/FCJ Mv Discharge Com after Case Com
; and added Discharge Date
3 ;CASE MANAGEMENT COMMENTS
S BMCCTYP="C",BMCSTR="Case Review Comments: " D COMMENTS Q:$D(BMCQUIT)
4 ;DISCHARGE COMMENTS
S BMCCTYP="D",BMCSTR="Discharge Comments: " D COMMENTS Q:$D(BMCQUIT)
DCHDT ;DISCHARGE DATE
S BMCSTR="Date Discharge Consult Received: "_$$VAL^XBDIQ1(90001,BMCREF,.18) D SET Q:$D(BMCQUIT)
Q
S BMCI=0
F S BMCI=$O(^BMCCOM("AD",BMCREF,BMCI)) Q:BMCI'=+BMCI!($D(BMCQUIT)) D
.Q:$P(^BMCCOM(BMCI,0),U,5)'=BMCCTYP
.S Y=$P(^BMCCOM(BMCI,0),U)
.S BMCSTR=BMCSTR_$$FMTE^XLFDT(Y,"5D")_" By: "_$$VAL^XBDIQ1(90001.03,BMCI,.04)
.D SET Q:$D(BMCQUIT)
.S BMCG="^BMCCOM("_BMCI_",1,BMCX)" D WP
Q
;S BMCSTR="" D SET S BMCSTR="Additional Comments:" D SET ;IHS/ITSC/FCJ COMMENTED OUT FOR NOW...SHOULD BE TESTED IN WP
VFILES ;set up array of all v file entries
NEW DA,D0,DIC,DIQ,DR,DI
S BMCVFLE=90001 F BMCVL=0:0 S BMCVFLE=$O(^DIC(BMCVFLE)) Q:BMCVFLE>90001.02!(BMCVFLE'=+BMCVFLE)!($D(BMCQUIT)) D VF2
Q
;
VF2 ;
S BMCVNM=$P(^DIC(BMCVFLE,0),U),BMCVDG=^DIC(BMCVFLE,0,"GL"),BMCVIGR=BMCVDG_"""AD"",BMCREF,BMCVDFN)",BMCVDFN=""
F BMCVI=1:1 S BMCVDFN=$O(@BMCVIGR) Q:BMCVDFN="" D VF3
Q
;
VF3 ;
I BMCVI<2 S BMCSTR=$E(BMCVNM)_$$LOW^XLFSTR($E(BMCVNM,2,99)) D SET Q:$D(BMCQUIT)
K BMCAR D ENP^XBDIQ1(BMCVFLE,BMCVDFN,".01;.06","BMCAR(","E")
;4.0*9 11.11.2012 IHS.OIT.FCJ ADDED ICD-10 2 NEW LINE
S BMCDOS=$$AVDOS^BMCRLU(BMCREF,"N") ;BMC*4.0*9
I BMCVFLE="90001.01" D ENP^XBDIQ1(BMCVFLE,BMCVDFN,".01","BMCAR(","I") S BMCAR(.01)=$P($$ICDDX^ICDEX(BMCAR(.01,"I"),BMCDOS,,"I"),U,2)
S Y=BMCAR(.01)_" - "_BMCAR(.06),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,3,$L(Y)) D SET Q:$D(BMCQUIT)
Q
S ;
S (C,F)=0 F S F=$O(BMCAR(F)) Q:F'=+F I BMCAR(F)]"" D
.S C=C+1,Y=$E($S($G(^DD(90001,F,.1))]"":$P(^DD(90001,F,.1),U),1:$P(^DD(90001,F,0),U)),1,13)_": ",Y=$E(Y)_$$LOW^XLFSTR($E(Y,2,999)),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,$P(BMC1,",",C),$L(Y))
.S Y=$E(BMCAR(F),1,20),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,$P(BMC2,",",C),$L(Y))
D SET Q:$D(BMCQUIT)
Q
BUILD1 ;
S BMCSTR=$E(BMCH,1,25)_":",BMCSTR=$$SETSTR^VALM1(BMCV,BMCSTR,28,$L(BMCV))
D SET Q:$D(BMCQUIT)
Q
SET ;set array
I $Y>(IOSL-3),BMCOPT'="B" D HEAD Q:$D(BMCQUIT)
W !,BMCSTR
S BMCSTR=""
Q
;
WP ;EP - Entry point to print wp fields pass node in BMCNODE
;PASS FILE IN BMCFILE, ENTRY IN BMCREF
K ^UTILITY($J,"W")
S BMCX=0
I '$D(BMCG) S BMCG=^DIC(BMCFILE,0,"GL"),BMCG=BMCG_BMCREF_","_BMCNODE_",BMCX)"
S DIWL=1,DIWR=75,DIWF="C75" F S BMCX=$O(@BMCG) Q:BMCX'=+BMCX!($D(BMCQUIT)) D
.S Y=$P(BMCG,")")_",0)" S X=@Y D ^DIWP
WPS ;EP
S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z!($D(BMCQUIT)) S BMCSTR=$$SETSTR^VALM1(^UTILITY($J,"W",DIWL,Z,0),BMCSTR,5,$L(^UTILITY($J,"W",DIWL,Z,0))) D SET Q:$D(BMCQUIT)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),BMCNODE,BMCFILE,BMCG,BMCCOL
Q
HEAD ;
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BMCQUIT=1 Q
HEAD1 ;
W:$D(IOF) @IOF
HEAD2 ;
S BMCTST=1
S BMCPG=BMCPG+1
W !,"***** CONFIDENTIAL PATIENT INFORMATION ***** Referral Summary (TLOG) Page ",BMCPG
W !,"RCIS RUN SITE: "_$P($G(^DIC(4,BMCOLOC,0)),U)
W !,"Report Run Date: ",$$FMTE^XLFDT($$HTFM^XLFDT($H),"1P")
W !,BMC80D
Q
BMCRR5P ; IHS/PHXAO/TMJ - PRNT BILL VSTS ; [ 08/15/2006 11:54 AM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**2,9**;JAN 09, 2006;Build 101
+2 ;IHS/ITSC/FCJ FIX PRINT 1 PAT PER PAGE ; ADDED OPTION TO ALPHA PRINT
+3 ; PRINT ALL COMMENTS FROM RCIS COMMENT FILE
+4 ;IHS/ITSC/FCJ ADDED PRINTING OF SECONDARY REF
+5 ;BMC 4.0*2 8/15/06 IHS/OIT/FCJ Mv Discharge Com after Case Com
+6 ; Added Disharge Date after Discharge Com
+7 ;4.0*9 11.11.2012 IHS.OIT.FCJ ADDED ICD-10 CHANGE
+8 ;
+9 SET BMC80E="==============================================================================="
+10 SET BMC80D="-------------------------------------------------------------------------------"
+11 SET BMC15S=" "
+12 SET BMCPG=0
IF '$DATA(^XTMP("BMCRR5",BMCJOB,BMCBT))
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
WRITE !,"No referrals to report",!
GOTO XIT
+13 SET BMCSORT=0
KILL BMCQUIT
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
+14 FOR
SET BMCSORT=$ORDER(^XTMP("BMCRR5",BMCJOB,BMCBT,"DATA HITS",BMCSORT))
IF BMCSORT=""!($DATA(BMCQUIT))
QUIT
DO PRINT
XIT ;
+1 KILL ^XTMP("BMCRR5",BMCJOB,BMCBT)
+2 KILL BMCSTST,BMCSTYPA,BMCSORTA,BMCCTYP
+3 KILL BMCRREC,BMCREF,BMC2,BMCI,BMCG,BMCX,BMCSTR,BMCCTR,BMCFILE,BMCNODE,BMCAR,BMC1,BMCBT,BMCH,BMCPG,BMCV,BMCVDFN,BMCVDG,BMCVFLE,BMCVI,BMCVIGR,BMCVL,BMCVNM,BMCX,BMCY
+4 DO KILL^AUPNPAT
+5 KILL DFN
+6 QUIT
PRINT ;print one referral
+1 IF $GET(BMCSPAGE)
IF BMCPG'=1
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+2 IF $Y>(IOSL-10)
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+3 IF BMCSTYPE'="P"
WRITE !!,$SELECT(BMCSTYPE="F":"FACILITY REFERRED TO: ",BMCSTYPE="C":"CASE MANAGER: ",BMCSTYPE="P":"PATIENT NAME: ",1:"???: "),BMCSORT,!
+4 IF BMCSTYPE'="P"
IF $GET(BMCSTYPA)=1
Begin DoDot:1
+5 SET BMCSORTA=""
FOR
SET BMCSORTA=$ORDER(^XTMP("BMCRR5",BMCJOB,BMCBT,"DATA HITS",BMCSORT,BMCSORTA))
IF BMCSORTA=""
QUIT
Begin DoDot:2
+6 SET BMCREF=""
FOR
SET BMCREF=$ORDER(^XTMP("BMCRR5",BMCJOB,BMCBT,"DATA HITS",BMCSORT,BMCSORTA,BMCREF))
IF BMCREF'=+BMCREF
QUIT
DO PRINT1
IF $DATA(BMCQUIT)
QUIT
SET BMCTST=0
End DoDot:2
IF $DATA(BMCQUIT)
QUIT
End DoDot:1
QUIT
+7 SET BMCREF=""
FOR
SET BMCREF=$ORDER(^XTMP("BMCRR5",BMCJOB,BMCBT,"DATA HITS",BMCSORT,BMCREF))
IF BMCREF'=+BMCREF
QUIT
DO PRINT1
IF $DATA(BMCQUIT)
QUIT
SET BMCTST=0
+8 QUIT
PRINT1 ;
+1 SET BMCRREC=^BMCREF(BMCREF,0)
SET DFN=$PIECE(BMCRREC,U,3)
+2 IF $GET(BMCSPAGE)
IF BMCTST=0
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+3 ;BMC*4.1 4/19/06 IHS.OIT.FCJ CHANGED BMCTYPR TO TEST FOR 1
+4 IF $PIECE($GET(^BMCREF(BMCREF,1)),U)'=""
IF BMCTYPR'=1
QUIT
+5 DO BUILD
+6 QUIT
BUILD ; build array
+1 KILL BMCAR
+2 SET BMCRREC=^BMCREF(BMCREF,0)
+3 WRITE !!
+4 SET Y=$PIECE(BMCRREC,U,3)
DO ^AUPNPAT
+5 SET BMCSTR=""
SET BMCCTR=0
+6 SET BMCSTR=$EXTRACT($PIECE(^DPT($PIECE(BMCRREC,U,3),0),U)_BMC15S,1,24)
+7 SET BMCSTR="Name: "_BMCSTR_" "_$$FMTE^XLFDT(AUPNDOB,"5D")_" "_$$VAL^XBDIQ1(9000001,DFN,1102.98)_" "_$$SSN^AUPNPAT(DFN)
DO SET
IF $DATA(BMCQUIT)
QUIT
+8 SET X=$$VAL^XBDIQ1(90001,BMCREF,.02)
WRITE ?59,"Ref #:"_X_$PIECE($GET(^BMCREF(BMCREF,1)),U)
+9 KILL BMCAR
DO ENPM^XBDIQ1(2.01,DFN_",0",".01","BMCAR(")
+10 SET I=0
FOR
SET I=$ORDER(BMCAR(I))
IF I'=+I
QUIT
SET BMCSTR=BMCAR(I,.01)_" "
+11 IF BMCSTR]""
SET BMCSTR="AKA'S: "_BMCSTR
DO SET
IF $DATA(BMCQUIT)
QUIT
+12 SET BMCSTR="Tribe: "_$EXTRACT($$VAL^XBDIQ1(9000001,DFN,1108),1,20)_" Tribal #: "_$SELECT($$VAL^XBDIQ1(9000001,DFN,.07)]"":$$VAL^XBDIQ1(9000001,DFN,.07),1:"< ? >")
+13 SET BMCSTR=BMCSTR_" "_$$VAL^XBDIQ1(9000001,DFN,1118)
DO SET
IF $DATA(BMCQUIT)
QUIT
CHARTS ;print duz(2) chart then first 4 in mult.
+1 KILL BMCAR
DO ENPM^XBDIQ1(9000001.41,DFN_",0",".02","BMCAR(")
+2 IF $DATA(BMCAR(DUZ(2)))
SET BMCSTR=$PIECE(^AUTTLOC(DUZ(2),0),U,7)_"#: "_BMCAR(DUZ(2),.02)
SET (I,F,C)=0
FOR
SET I=$ORDER(BMCAR(I))
IF I'=+I!(C>4)
QUIT
IF I'=DUZ(2)
SET C=C+1
SET BMCSTR=BMCSTR_" "_$PIECE(^AUTTLOC(I,0),U,7)_"#: "_BMCAR(I,.02)
+3 DO SET
IF $DATA(BMCQUIT)
QUIT
REQ ;
+1 SET BMCSTR="Referred To:"
SET Y=$$FACREF^BMCRLU(BMCREF)
SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,15,$LENGTH(Y))
SET Y="Attending:"
+2 SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,45,$LENGTH(Y))
SET Y=$EXTRACT($$VAL^XBDIQ1(90001,BMCREF,.09),1,18)
SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,56,$LENGTH(Y))
DO SET
IF $DATA(BMCQUIT)
QUIT
+3 SET BMCRNUMB=$PIECE(^BMCREF(BMCREF,0),U,2)
+4 SET BMCSTST=$PIECE($GET(^BMCREF(BMCREF,1)),U)
+5 ;PRINT SEC REF INFO
DO SECREF2^BMCRUTL
+6 SET BMCSTR="Referred By: "_$$VAL^XBDIQ1(90001,BMCREF,.06)
DO SET
IF $DATA(BMCQUIT)
QUIT
+7 SET BMCSTR="Beg DOS: "_$$AVDOS^BMCRLU(BMCREF)_" Est LOS: "_$$AVLOS^BMCRLU(BMCREF)_" LOS to Date: "_$$VAL^XBDIQ1(90001,BMCREF,.1499)
DO SET
IF $DATA(BMCQUIT)
QUIT
+8 SET BMCSTR="Purpose: "_$$VAL^XBDIQ1(90001,BMCREF,1201)
DO SET
IF $DATA(BMCQUIT)
QUIT
DRG ;
+1 SET BMCSTR="Primary Payor: "_$$VAL^XBDIQ1(90001,BMCREF,.11)
DO SET
IF $DATA(BMCQUIT)
QUIT
+2 DO VFILES
2 ;BUSINESS OFFICE COMMENTS
+1 IF '$DATA(^BMCCOM("AD",BMCREF))
QUIT
+2 SET BMCCTYP="B"
SET BMCSTR="Business Office Notes: "
DO COMMENTS
IF $DATA(BMCQUIT)
QUIT
+3 ;BMC 4.0*2 8/15/06 IHS/OIT/FCJ Mv Discharge Com after Case Com
+4 ; and added Discharge Date
3 ;CASE MANAGEMENT COMMENTS
+1 SET BMCCTYP="C"
SET BMCSTR="Case Review Comments: "
DO COMMENTS
IF $DATA(BMCQUIT)
QUIT
4 ;DISCHARGE COMMENTS
+1 SET BMCCTYP="D"
SET BMCSTR="Discharge Comments: "
DO COMMENTS
IF $DATA(BMCQUIT)
QUIT
DCHDT ;DISCHARGE DATE
+1 SET BMCSTR="Date Discharge Consult Received: "_$$VAL^XBDIQ1(90001,BMCREF,.18)
DO SET
IF $DATA(BMCQUIT)
QUIT
+2 QUIT
+1 SET BMCI=0
+2 FOR
SET BMCI=$ORDER(^BMCCOM("AD",BMCREF,BMCI))
IF BMCI'=+BMCI!($DATA(BMCQUIT))
QUIT
Begin DoDot:1
+3 IF $PIECE(^BMCCOM(BMCI,0),U,5)'=BMCCTYP
QUIT
+4 SET Y=$PIECE(^BMCCOM(BMCI,0),U)
+5 SET BMCSTR=BMCSTR_$$FMTE^XLFDT(Y,"5D")_" By: "_$$VAL^XBDIQ1(90001.03,BMCI,.04)
+6 DO SET
IF $DATA(BMCQUIT)
QUIT
+7 SET BMCG="^BMCCOM("_BMCI_",1,BMCX)"
DO WP
End DoDot:1
+8 QUIT
+9 ;S BMCSTR="" D SET S BMCSTR="Additional Comments:" D SET ;IHS/ITSC/FCJ COMMENTED OUT FOR NOW...SHOULD BE TESTED IN WP
VFILES ;set up array of all v file entries
+1 NEW DA,D0,DIC,DIQ,DR,DI
+2 SET BMCVFLE=90001
FOR BMCVL=0:0
SET BMCVFLE=$ORDER(^DIC(BMCVFLE))
IF BMCVFLE>90001.02!(BMCVFLE'=+BMCVFLE)!($DATA(BMCQUIT))
QUIT
DO VF2
+3 QUIT
+4 ;
VF2 ;
+1 SET BMCVNM=$PIECE(^DIC(BMCVFLE,0),U)
SET BMCVDG=^DIC(BMCVFLE,0,"GL")
SET BMCVIGR=BMCVDG_"""AD"",BMCREF,BMCVDFN)"
SET BMCVDFN=""
+2 FOR BMCVI=1:1
SET BMCVDFN=$ORDER(@BMCVIGR)
IF BMCVDFN=""
QUIT
DO VF3
+3 QUIT
+4 ;
VF3 ;
+1 IF BMCVI<2
SET BMCSTR=$EXTRACT(BMCVNM)_$$LOW^XLFSTR($EXTRACT(BMCVNM,2,99))
DO SET
IF $DATA(BMCQUIT)
QUIT
+2 KILL BMCAR
DO ENP^XBDIQ1(BMCVFLE,BMCVDFN,".01;.06","BMCAR(","E")
+3 ;4.0*9 11.11.2012 IHS.OIT.FCJ ADDED ICD-10 2 NEW LINE
+4 ;BMC*4.0*9
SET BMCDOS=$$AVDOS^BMCRLU(BMCREF,"N")
+5 IF BMCVFLE="90001.01"
DO ENP^XBDIQ1(BMCVFLE,BMCVDFN,".01","BMCAR(","I")
SET BMCAR(.01)=$PIECE($$ICDDX^ICDEX(BMCAR(.01,"I"),BMCDOS,,"I"),U,2)
+6 SET Y=BMCAR(.01)_" - "_BMCAR(.06)
SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,3,$LENGTH(Y))
DO SET
IF $DATA(BMCQUIT)
QUIT
+7 QUIT
S ;
+1 SET (C,F)=0
FOR
SET F=$ORDER(BMCAR(F))
IF F'=+F
QUIT
IF BMCAR(F)]""
Begin DoDot:1
+2 SET C=C+1
SET Y=$EXTRACT($SELECT($GET(^DD(90001,F,.1))]"":$PIECE(^DD(90001,F,.1),U),1:$PIECE(^DD(90001,F,0),U)),1,13)_": "
SET Y=$EXTRACT(Y)_$$LOW^XLFSTR($EXTRACT(Y,2,999))
SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,$PIECE(BMC1,",",C),$LENGTH(Y))
+3 SET Y=$EXTRACT(BMCAR(F),1,20)
SET BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,$PIECE(BMC2,",",C),$LENGTH(Y))
End DoDot:1
+4 DO SET
IF $DATA(BMCQUIT)
QUIT
+5 QUIT
BUILD1 ;
+1 SET BMCSTR=$EXTRACT(BMCH,1,25)_":"
SET BMCSTR=$$SETSTR^VALM1(BMCV,BMCSTR,28,$LENGTH(BMCV))
+2 DO SET
IF $DATA(BMCQUIT)
QUIT
+3 QUIT
SET ;set array
+1 IF $Y>(IOSL-3)
IF BMCOPT'="B"
DO HEAD
IF $DATA(BMCQUIT)
QUIT
+2 WRITE !,BMCSTR
+3 SET BMCSTR=""
+4 QUIT
+5 ;
WP ;EP - Entry point to print wp fields pass node in BMCNODE
+1 ;PASS FILE IN BMCFILE, ENTRY IN BMCREF
+2 KILL ^UTILITY($JOB,"W")
+3 SET BMCX=0
+4 IF '$DATA(BMCG)
SET BMCG=^DIC(BMCFILE,0,"GL")
SET BMCG=BMCG_BMCREF_","_BMCNODE_",BMCX)"
+5 SET DIWL=1
SET DIWR=75
SET DIWF="C75"
FOR
SET BMCX=$ORDER(@BMCG)
IF BMCX'=+BMCX!($DATA(BMCQUIT))
QUIT
Begin DoDot:1
+6 SET Y=$PIECE(BMCG,")")_",0)"
SET X=@Y
DO ^DIWP
End DoDot:1
WPS ;EP
+1 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z!($DATA(BMCQUIT))
QUIT
SET BMCSTR=$$SETSTR^VALM1(^UTILITY($JOB,"W",DIWL,Z,0),BMCSTR,5,$LENGTH(^UTILITY($JOB,"W",DIWL,Z,0)))
DO SET
IF $DATA(BMCQUIT)
QUIT
+2 KILL DIWL,DIWR,DIWF,Z
+3 KILL ^UTILITY($JOB,"W"),BMCNODE,BMCFILE,BMCG,BMCCOL
+4 QUIT
HEAD ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BMCQUIT=1
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
HEAD2 ;
+1 SET BMCTST=1
+2 SET BMCPG=BMCPG+1
+3 WRITE !,"***** CONFIDENTIAL PATIENT INFORMATION ***** Referral Summary (TLOG) Page ",BMCPG
+4 WRITE !,"RCIS RUN SITE: "_$PIECE($GET(^DIC(4,BMCOLOC,0)),U)
+5 WRITE !,"Report Run Date: ",$$FMTE^XLFDT($$HTFM^XLFDT($HOROLOG),"1P")
+6 WRITE !,BMC80D
+7 QUIT
