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

BMCRR18P.m

Go to the documentation of this file. 
  1. BMCRR18P ; IHS/PHXAO/TMJ - PRNT BILL VSTS ;       [ 09/27/2006  2:05 PM ]
  1.  ;;4.0;REFERRED CARE INFO SYSTEM;**1**;JAN 09, 2006;Build 101
  1.  ;;IHS/ITSC/FCJ PRT DISCHARGE COMMENTS FR RCIS COMMENTS FILE AND SEC SUF
  1.  ;4.0*1 3.8.06 IHS/OIT/FCJ ADDED BEG AND END DT TO REPORT HEADER
  1.  ;
  1.  ;Go to SUMPRINT Line Tag if User Selects Summary Print
  1.  ;I BMCOUTP="S" D SUMPRINT Q
  1.  ;
  1.  ;
  1.  S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) I '$D(^XTMP("BMCRR18",BMCJOB,BMCBT)) W !,"No referrals to report",! G XIT
  1.  S BMCPN=0,BMCQUIT=0
  1.  S BMCDATE="" F  S BMCDATE=$O(^XTMP("BMCRR18",BMCJOB,BMCBT,"DATA HITS",BMCDATE)) Q:BMCDATE=""!(BMCQUIT)  D P
  1. XIT ;
  1.  K ^XTMP("BMCRR18",BMCJOB,BMCBT)
  1.  D DONE^BMCRLP2
  1.  D KILL^AUPNPAT
  1.  K BMCDATE,BMCI
  1.  Q
  1. P ;
  1.  S BMCPN="" F  S BMCPN=$O(^XTMP("BMCRR18",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN)) Q:BMCPN=""!(BMCQUIT)  D PRINT
  1.  Q
  1. PRINT ;print one referral
  1.  I $Y>(IOSL-10) D HEAD Q:BMCQUIT
  1.  S BMCREF=0 F  S BMCREF=$O(^XTMP("BMCRR18",BMCJOB,BMCBT,"DATA HITS",BMCDATE,BMCPN,BMCREF)) Q:BMCREF'=+BMCREF!(BMCQUIT)  S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3) D
  1.  .D:BMCOUTP="D" PRINT1,HEAD
  1.  .D:BMCOUTP="S" SUMPRINT
  1.  Q
  1. PRINT1 ;
  1.  I $Y>(IOSL-3) D HEAD Q:BMCQUIT
  1.  S BMCHRN="????" I $D(^AUPNPAT(DFN,41,DUZ(2))) S BMCHRN=$P(^AUTTLOC(DUZ(2),0),U,7)_$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
  1.  W !!,$E($P(^DPT(DFN,0),U),1,20),?22,BMCHRN,?28,$$AGE^AUPNPAT(DFN,DT,"R")
  1.  S BMCRNUMB=$P($G(^BMCREF(BMCREF,0)),U,2)
  1.  W ?35,BMCRNUMB,$P($G(^BMCREF(BMCREF,1)),U)
  1.  W ?53,$E($$COMMRES^AUPNPAT(DFN,"E"),1,10)
  1.  W ?65,$E($$FACREF^BMCRLU(BMCREF),1,15)
  1.  W !,$E($P($G(^BMCREF(BMCREF,12)),U,1),1,19)
  1.  W ?27,"Admit Dt:  ",$$AVDOS^BMCRLU(BMCREF,"C"),"-","Disch Dt: ",$$AVEOS^BMCRLU(BMCREF,"S")," LOS: ",$$AVLOS^BMCRLU(BMCREF,"C")
  1.  ;
  1. CASECOM ;
  1.  W !
  1.  Q:'$D(^BMCCOM("AD",BMCREF))
  1.  S BMCI=0 F  S BMCI=$O(^BMCCOM("AD",BMCREF,BMCI)) Q:BMCI'=+BMCI!(BMCQUIT)  D
  1.  .Q:$P(^BMCCOM(BMCI,0),U,5)'="C"
  1.  .W !,"Case Review Comments: "_$$FMTE^XLFDT($P(^BMCCOM(BMCI,0),U),"5D")
  1.  .W ?32,"By: ",$$VAL^XBDIQ1(90001.03,BMCI,.04),!
  1.  .D COMMENTS
  1. DISCOM ;
  1.  I '$D(^BMCCOM("AD",BMCREF)) Q
  1.  S BMCI=0
  1.  F  S BMCI=$O(^BMCCOM("AD",BMCREF,BMCI)) Q:BMCI'=+BMCI!(BMCQUIT)  D
  1.  .Q:$P(^BMCCOM(BMCI,0),U,5)'="D"
  1.  .W !,"Discharge Comments: "_$$FMTE^XLFDT($P(^BMCCOM(BMCI,0),U),"5D")
  1.  .W ?32,"By: ",$$VAL^XBDIQ1(90001.03,BMCI,.04),!
  1.  .D COMMENTS
  1.  Q
  1. COMMENTS ;
  1.  S BMCNODE=1,BMCIOM=70,BMCFILE=90001.03,BMCDA=BMCI D WP^BMCFDR K BMCIOM
  1.  S Y=0 F  S Y=$O(BMCWP(Y)) Q:Y'=+Y!(BMCQUIT)  D
  1.  .I $Y>(IOSL-3) D HEAD Q:BMCQUIT
  1.  .W ?10,BMCWP(Y),!
  1.  Q
  1.  NEW X,Y,Z,C
  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 !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
  1.  W !?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),?72,"Page ",BMCPG,!
  1.  W ?21,"**AREA HOSPITAL DISCHARGES BY DATE**"
  1.  ;4.0*1 3.8.06 IHS/OIT/FCJ ADDED NXT 2 LINES TO PRT BEG AND END DT
  1.  S Y=BMCBD D DD^%DT W !,?28,"BEG DATE: "_Y
  1.  S Y=BMCED D DD^%DT W !,?28,"END DATE: "_Y,!
  1.  ;
  1.  I BMCOUTP="D" W !!,"Pt Name/Purpose",?22,"Rec #",?29,"Age",?36,"Referral #",?52,"Community",?65,"Fac. Ref To"
  1.  ;
  1.  I BMCOUTP="S" W !!,"Pt Name/Purpose",?22,"Rec #",?32,"Age",?39,"Referral #",?52,"Community",?65,"Fac. Ref To",?82,"Purpose of Referral",?104,"Beginning ",?116,"Ending ",?126,"Los"
  1.  I BMCOUTP="D" W !,$TR($J(" ",80)," ","-")
  1.  I BMCOUTP="S" W !,$TR($J(" ",132)," ","-")
  1.  Q
  1.  ;
  1. SUMPRINT ;Entry Point Down to Print Report Summary Selection
  1.  ;
  1.  ;
  1.  I $Y>(IOSL-3) D HEAD Q:BMCQUIT
  1.  S BMCHRN="????" I $D(^AUPNPAT(DFN,41,DUZ(2))) S BMCHRN=$P(^AUTTLOC(DUZ(2),0),U,7)_$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
  1.  W !,$E($P(^DPT(DFN,0),U),1,20),?22,BMCHRN,?31,$$AGE^AUPNPAT(DFN,DT,"R")
  1.  W ?38,$P($G(^BMCREF(BMCREF,0)),U,2)
  1.  W ?53,$E($$COMMRES^AUPNPAT(DFN,"E"),1,10)
  1.  W ?65,$E($$FACREF^BMCRLU(BMCREF),1,15)
  1.  W ?82,$E($P($G(^BMCREF(BMCREF,12)),U,1),1,20)
  1.  W ?104,$$AVDOS^BMCRLU(BMCREF,"C"),?117,$$AVEOS^BMCRLU(BMCREF,"S"),?126,$$AVLOS^BMCRLU(BMCREF,"C")
  1.  Q
  1.  ;