Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BMCRR5P

BMCRR5P.m

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