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

BMCRR7P2.m

Go to the documentation of this file.
  1. BMCRR7P2 ; IHS/PHXAO/TMJ - DETAILED OLOG REPORT ;
  1. ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
  1. S BMC80E="==============================================================================="
  1. S BMC80D="-------------------------------------------------------------------------------"
  1. S BMCPG=0 I '$D(^XTMP("BMCRR7",BMCJOB,BMCBT)) D @("HEAD"_(2-($E(IOST,1,2)="C-"))) W !,"No referrals to report",! G XIT
  1. S BMCPN=0 K BMCQUIT D @("HEAD"_(2-($E(IOST,1,2)="C-")))
  1. F S BMCPN=$O(^XTMP("BMCRR7",BMCJOB,BMCBT,"DATA HITS",BMCPN)) Q:BMCPN=""!($D(BMCQUIT)) D DFN
  1. XIT ;
  1. K ^XTMP("BMCRR7",BMCJOB,BMCBT)
  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. DFN ;
  1. S DFN="" F S DFN=$O(^XTMP("BMCRR7",BMCJOB,BMCBT,"DATA HITS",BMCPN,DFN)) Q:DFN=""!($D(BMCQUIT)) D PRINT
  1. Q
  1. PRINT ;print one referral
  1. S BMC2="15,61",BMC1="1,45"
  1. S BMCREF=0 F S BMCREF=$O(^XTMP("BMCRR7",BMCJOB,BMCBT,"DATA HITS",BMCPN,DFN,BMCREF)) Q:BMCREF'=+BMCREF!($D(BMCQUIT)) S BMCRREC=^BMCREF(BMCREF,0) D BUILD
  1. Q
  1. BUILD ; build array
  1. K BMCAR
  1. ;D TERM^VALM0
  1. S BMCRREC=^BMCREF(BMCREF,0)
  1. ;I BMCOPT'="B" D HEAD Q:$D(BMCQUIT)
  1. W !!
  1. S Y=$P(BMCRREC,U,3) D ^AUPNPAT
  1. S BMCSTR="",BMCCTR=0
  1. S BMCSTR="Name: "_$E($P(^DPT($P(BMCRREC,U,3),0),U),1,25)_" "_" "_$$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 ?57,"Ref #: "_X
  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 BMCSTR="Referred By: "_$$VAL^XBDIQ1(90001,BMCREF,.06) D SET Q:$D(BMCQUIT)
  1. ;K BMCAR D ENP^XBDIQ1(90001,BMCREF,".19;.31","BMCAR(","E") D S
  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="Est LOS:",Y=$$AVLOS^BMCRLU(BMCREF),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,15,$L(Y)),Y="LOS to Date: ",BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,45,$L(Y)),Y=$$VAL^XBDIQ1(90001,BMCREF,.1499),BMCSTR=$$SETSTR^VALM1(Y,BMCSTR,61,$L(Y)) 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 ;
  1. G:'$D(^BMCREF(BMCREF,2)) 3
  1. S BMCSTR="Business Office Notes: " D SET Q:$D(BMCQUIT)
  1. K BMCG S BMCFILE=90001,BMCREF=BMCREF,BMCNODE=2 D WP
  1. S BMCSTR="" D SET Q:$D(BMCQUIT)
  1. 3 ;
  1. G:'$D(^BMCREF(BMCREF,3)) COMMENTS
  1. S BMCSTR="Discharge Comments:" D SET Q:$D(BMCQUIT)
  1. K BMCG S BMCFILE=90001,BMCREF=BMCREF,BMCNODE=3 D WP
  1. S BMCSTR="" D SET Q:$D(BMCQUIT)
  1. COMMENTS ;
  1. I '$D(^BMCCOM("AD",BMCREF)) Q
  1. S BMCI=0 F S BMCI=$O(^BMCCOM("AD",BMCREF,BMCI)) Q:BMCI'=+BMCI!($D(BMCQUIT)) D
  1. .S Y=$P(^BMCCOM(BMCI,0),U),BMCSTR="Comments Made on "_$$FMTE^XLFDT(Y,"5D") D SET Q:$D(BMCQUIT)
  1. .S BMCG="^BMCCOM("_BMCI_",1,BMCX)" D WP
  1. Q:BMCOPT="B"
  1. S BMCSTR="" D SET S BMCSTR="Additional Comments:" D SET
  1. Q
  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. 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. .Q
  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 BMCPG=BMCPG+1
  1. W !,"***** CONFIDENTIAL PATIENT INFORMATION ***** Referral Summary (TLOG) Page ",BMCPG
  1. W !,"Report Run Date: ",$$FMTE^XLFDT($$HTFM^XLFDT($H),"1P")
  1. W !,BMC80D
  1. Q