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

BMCRR23P.m

Go to the documentation of this file. 
  1. BMCRR23P ; IHS/OIT/FCJ - REPORT FOR CALL IN REFERRALS (2/2)  
  1.  ;;4.0;REFERRED CARE INFO SYSTEM;**12**;JAN 09, 2006;Build 101
  1.  ;4.0*12;IHS/ITSC/FCJ NEW ROUTINE
  1.  ;
  1. START ;
  1.  S BMC80E="==============================================================================="
  1.  S BMC80D="-------------------------------------------------------------------------------"
  1.  S BMCSRTH=""
  1.  S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-"))) I '$D(^XTMP(BMCJOB,"BMCRR23",BMCBT)) W:BMCRTYP="S" !,BMC80D W !,"No referrals to report",! G DONE
  1. SORT ;
  1.  S BMCSORT="",BMCQUIT=""
  1.  S (BMCRCTOT,BMCRRTOT,BMCRTOT,BMCCPO,BMCRPO,BMCRCDAY,BMCRRDAY,BMCTAVG)=0
  1.  F  S BMCSORT=$O(^XTMP(BMCJOB,"BMCRR23",BMCBT,"DATA HITS",DUZ(2),BMCSORT)) Q:BMCSORT=""!BMCQUIT  D PRINT
  1.  G:BMCQUIT DONE
  1.  I BMCRTYP="S" D SUM K ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","R"),^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","C")
  1.  I BMCRTYP="D" D DETAIL S BMCRTYP="S" D HEAD1,SUM
  1.  D:$Y>(IOSL-6) HEAD D DONE
  1.  Q
  1. DONE ;
  1.  D DONE^BMCRLP1
  1.  Q
  1. PRINT ;
  1.  S BMCCFC="" D CHSFAC
  1.  S BMCREF=0
  1.  F  S BMCREF=$O(^XTMP(BMCJOB,"BMCRR23",BMCBT,"DATA HITS",DUZ(2),BMCSORT,BMCREF)) Q:BMCREF'=+BMCREF!BMCQUIT  D
  1.  .S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3)
  1.  .S:BMCSORT="C" BMCRCTOT=BMCRCTOT+1
  1.  .S:BMCSORT="R" BMCRRTOT=BMCRRTOT+1
  1.  .S BMCRTOT=BMCRTOT+1 D PRINT1
  1.  Q
  1. PRINT1 ;
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,0)=$P($G(^BMCREF(BMCREF,0)),U,2)_$P($G(^BMCREF(BMCREF,1)),U) ;Ref number
  1.  S Y=$P($G(^BMCREF(BMCREF,1)),U,3) I Y?1N.N D DT^BMCRUTL   ;call-in date
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,0)=^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,0)_"^"_Y
  1.  S Y=$P($G(^BMCREF(BMCREF,0)),U) I Y?1N.N D DT^BMCRUTL     ;Ref initiated
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,0)=^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,0)_"^"_Y
  1.  S Y=$P($G(^BMCREF(BMCREF,11)),U,13) I Y?1N.N D DT^BMCRUTL  ;CHS APPROVAL DATE
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,0)=^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,0)_"^"_Y
  1.  ;MAYBE MORE THEN ONE PO, but only using the first PO, as it should be the primary visit.
  1.  S BMCPOC=0,L=0
  1.  S L=$O(^BMCREF(BMCREF,41,L)) Q:L'?1N.N  D
  1.  .S BMCCHS=$P(^BMCREF(BMCREF,41,L,0),U)
  1.  .Q:$P($G(^ACHSF(DUZ(2),"D",BMCCHS,"PA")),U,4)'="F"
  1.  .Q:$P($G(^ACHSF(DUZ(2),"D",BMCCHS,"PA")),U,5)>0
  1.  .;PO ISSUED-BMCPOIS;PO PAID-BMCPOPD;PO NUMBER-BMCPO;DAYS TO PAY
  1.  .S BMCCHS0=^ACHSF(DUZ(2),"D",BMCCHS,0)
  1.  .S Y=$P(BMCCHS0,U,2) D DT^BMCRUTL         ;PO ISSUED
  1.  .I BMCPOC>0 S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,BMCPOC)="^^^"
  1.  .S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,BMCPOC)=^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,BMCPOC)_"^"_Y
  1.  .S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,BMCPOC)=^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,BMCPOC)_"^"_$E($P(BMCCHS0,U,27),3,4)_"-"_BMCCFC_"-"_$P(BMCCHS0,U)         ;PO NUMBER
  1.  .S (X1,Y)=$P(^ACHSF(DUZ(2),"D",BMCCHS,"PA"),U,3) D DT^BMCRUTL    ;DATE PAID
  1.  .S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,BMCPOC)=^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,BMCPOC)_"^"_Y
  1.  .;S X2=$S(BMCSORT="C":$P($G(^BMCREF(BMCREF,11)),U,13),1:$P(BMCCHS0,U,2)) D ^%DTC  ;NO LONGER USING DATE APPROVED
  1.  .S X2=$P(BMCCHS0,U,2) D ^%DTC
  1.  .S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,BMCPOC)=^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCRTOT,BMCPOC)_"^"_X
  1.  .S:BMCSORT="C" BMCRCDAY=BMCRCDAY+X S:BMCSORT="R" BMCRRDAY=BMCRRDAY+X
  1.  .S BMCPOC=BMCPOC+1 S:BMCSORT="C" BMCCPO=BMCCPO+1 S:BMCSORT="R" BMCRPO=BMCRPO+1
  1.  I (BMCCPO+BMCRPO)>0 S BMCTAVG=(BMCRCDAY+BMCRRDAY)/(BMCCPO+BMCRPO)
  1.  Q
  1. DETAIL ;
  1.  S BMCTST=""
  1.  F BMCSORT="C","R" D:$D(^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT))  Q:BMCQUIT
  1.  .S BMCSRTH=$S(BMCSORT="C":"CHS CALL-IN REFERRAL",1:"CHS NON-CALL-IN REFERRAL")
  1.  .W:BMCTST'=BMCSORT !,BMCSRTH S BMCTST=BMCSORT
  1.  .S BMCR="" F  S BMCR=$O(^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCR)) Q:BMCR'?1N.N  D  Q:BMCQUIT
  1.  ..S BMCREC=^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCR,0)
  1.  ..W !,$P(BMCREC,U),?16,$E($P(BMCREC,U,2),1,6)_$E($P(BMCREC,U,2),9,10),?25,$E($P(BMCREC,U,3),1,6)_$E($P(BMCREC,U,3),9,10),?34,$E($P(BMCREC,U,4),1,6)_$E($P(BMCREC,U,4),9,10)
  1.  ..W ?43,$E($P(BMCREC,U,5),1,6)_$E($P(BMCREC,U,5),9,10),?52,$P(BMCREC,U,6),?65,$E($P(BMCREC,U,7),1,6)_$E($P(BMCREC,U,7),9,10),?74,$P(BMCREC,U,8)
  1.  ..I $Y>(IOSL-5) D HEAD Q:BMCQUIT
  1.  ..S BMCPOC=0 F  S BMCPOC=$O(^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCR,BMCPOC)) Q:BMCPOC'?1N.N  D  Q:BMCQUIT
  1.  ...S BMCREC=^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",BMCSORT,BMCR,BMCPOC)
  1.  ...W !?43,$E($P(BMCREC,U,5),1,6)_$E($P(BMCREC,U,5),9,10),?52,$P(BMCREC,U,6),?65,$E($P(BMCREC,U,7),1,6)_$E($P(BMCREC,U,7),9,10),?74,$P(BMCREC,U,8)
  1.  ...I $Y>(IOSL-5) D HEAD Q:BMCQUIT
  1.  .I $E(IOST)="C",IO=IO(0),'BMCQUIT W ! S DIR(0)="EO" D ^DIR K DIR W ! I Y=0!(Y="^")!($D(DTOUT)) S BMCQUIT=1
  1.  Q
  1. CHSFAC ;
  1.  S BMCCFC=$P($G(^AUTTAREA($P($G(^AUTTLOC(DUZ(2),0)),U,4),0)),U,3)_$E($P($G(^AUTTLOC(DUZ(2),0)),U,17),2,3)
  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 !?12,"*********** 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 !?14,"CHS TYPE REFERRAL REPORT SORTED BY CALL-IN REFERRALS"
  1.  S Y=BMCBD D DD^%DT W !?17,"BEG DATE: "_Y
  1.  S Y=BMCED D DD^%DT W ?40,"END DATE: "_Y
  1.  I BMCRTYP="S" W !,BMC80D Q
  1. HEAD3 ;
  1.  W !!,?3,"REFERRAL",?16,"CALL-IN",?25,"REFERRAL",?36,"CHS",?46,"PO",?74,"DAYS"
  1.  W !,?4,"NUMBER",?18,"DATE",?24,"INITIATED",?34,"APPROVAL",?44,"ISSUED",?53,"PO NUMBER",?65,"PO PAID",?73,"TO PAY"
  1.  W !,BMC80D
  1.  W !,BMCSRTH
  1.  Q
  1. SUM ;
  1.  G:BMCRPT="C" SUMC
  1.  G:BMCRPT="N" SUMN
  1.  W !,"TOTAL CHS Referrals: ",BMCRTOT
  1.  W !,"TOTAL PO'S: ",BMCCPO+BMCRPO
  1.  W !,"TOTAL Days to Pay: ",BMCRCDAY+BMCRRDAY
  1.  W !,"Average Days to Pay: ",$FN(BMCTAVG,"",2)   ;total days/total PO's
  1. SUMC ;
  1.  W !!,"CHS Call-In Referrals from PO issue date to paid date"
  1.  W !,"TOTAL CHS Call-In Referrals: ",BMCRCTOT
  1.  W !,"TOTAL CHS Call-In Referral Days: ",BMCRCDAY
  1.  W !,"TOTAL CHS Call-In Referral Average Days: " W $S(BMCCPO>0:$FN((BMCRCDAY/BMCCPO),"",2),1:0)
  1.  Q:BMCRPT="C"
  1. SUMN ;
  1.  W !!,"CHS Non-Call-In Referrals from PO issue date to paid date"
  1.  W !,"TOTAL CHS Non-Call-In Referrals: ",BMCRRTOT
  1.  W !,"TOTAL CHS Non-Call-In Referral Days: ",BMCRRDAY
  1.  W !,"TOTAL CHS Non-Call-In Referral Average Days: " W $S(BMCRPO>0:$FN((BMCRRDAY/BMCRPO),"",2),1:0)
  1.  Q
  1. FILHDR ;
  1.  I BMCFIL="Y" D
  1.  .S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",1,"HDR1")="********** CONFIDENTIAL PATIENT INFORMATION **********"
  1.  .S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",1,"HDR2")=$P(^DIC(4,DUZ(2),0),U)
  1.  .S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",1,"HDR3")="CHS TYPE REFERRAL REPORT SORTED BY CALL-IN REFERRALS"
  1.  .S Y=BMCBD D DD^%DT S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",1,"HDR4")="BEG DATE: "_Y
  1.  .S Y=BMCED D DD^%DT S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",1,"HDR4")=^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",1,"HDR4")_"  END DATE: "_Y
  1.  .I $D(^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","R")) S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","R",0)="CHS NON-CALL-IN REFERRAL"
  1.  .I $D(^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","C")) S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","C",0)="CHS CALL-IN REFERRAL"
  1.  .I ($D(^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","R")))!($D(^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","C"))) D
  1.  ..S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL",1,"HDR5")="REFERRAL NUMBER^CALL-IN DATE^REFERRAL INITIATED^CHS APPROVAL^PO ISSUED^PO NUMBER^PO PAID^DAYS TO PAY"
  1.  Q
  1. FILSUM ;
  1.  G:BMCRPT="C" FILSUMC
  1.  G:BMCRPT="N" FILSUMN
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","S",1)="TOTAL CHS Referrals: "_BMCRTOT
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","S",2)="TOTAL PO'S: "_(BMCCPO+BMCRPO)
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","S",3)="TOTAL Days to Pay: "_(BMCRCDAY+BMCRRDAY)
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","S",4)="Average Days to Pay: "_$FN(BMCTAVG,"",2)   ;total days/total PO's
  1. FILSUMC ;
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","S",5)="CHS Call-In Referrals from PO issue date to paid date"
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","S",6)="TOTAL CHS Call-In Referrals: "_BMCRCTOT
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","S",7)="TOTAL CHS Call-In Referral Days: "_BMCRCDAY
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","S",8)="TOTAL CHS Call-In Referral Average Days: "_$S(BMCCPO>0:$FN((BMCRCDAY/BMCCPO),"",2),1:0)
  1.  Q:BMCRPT="C"
  1. FILSUMN ;
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","S",9)="CHS Non-Call-In Referrals from PO issue date to paid date"
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","S",10)="TOTAL CHS Non-Call-In Referrals: "_BMCRRTOT
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","S",11)="TOTAL CHS Non-Call-In Referral Days: "_BMCRRDAY
  1.  S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"FIL","S",12)="TOTAL CHS Non-Call-In Referral Average Days: "_$S(BMCRPO>0:$FN((BMCRRDAY/BMCRPO),"",2),1:0)
  1.  Q
  1. FILSAV ;SAVE FILE
  1.  ;
  1.  K ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"DATA HITS")
  1.  N XBFN,XBE,XBJ,XBUF,XBQ,XBMED,XBFLT,XBS1,XBIO,XBF,XBGL
  1.  S X=$E(DT,4,7)_$E(DT,2,3)
  1.  D NOW^%DTC S X=(%I(3)+1700)_$E(%,4,7)_"_"_$P(%,".",2)
  1.  S:$L(X)'=15 X=X_0
  1.  S X1=$P(^AUTTLOC(DUZ(2),0),U,10),XBE=$J
  1.  S XBFN="REFERRAL-REPORT-"_X1_"."_X
  1.  S XBMED="F",XBFLT=1
  1.  S XBQ="N"
  1.  S XBUF=$P(^BMCPARM(DUZ(2),4100),U,13)
  1.  I XBUF="" S XBUF=$P(^AUTTSITE(1,1),U,2)
  1.  S XBS1="BMC RCIS REPORTS"
  1.  S XBIO=51,XBF=$J,XBGL="^XTMP(" D ^ZIBGSVEM
  1.  ;S XBGL="TMP("_$J_",""ACHSVUR2"","D ^XBGSAVE
  1.  Q