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

BARBL.m

Go to the documentation of this file. 
  1. BARBL ; IHS/SD/LSL - AGE DAY LETTER AND LIST ; 07/30/2008
  1.  ;;1.8;IHS ACCOUNTS RECEIVABLE;**3,4,6,23**;OCT 26, 2005
  1.  ; NOV 2012 P.OTTIS HEAT #75153 ADDED PAT DOB
  1.  ;                       SPLIT LONG BILL #
  1.  ; JAN 2013 ADDED PAT SSN
  1.  ; MAY 2013 HEAT 117349 UNDEF BARA(.01) 
  1.  ; AUG 2013 FIXED UNDEF ENTRY IN ^BARBL (YAKAMA) ONEAC+3
  1.  ; OCT 2013 REFORMATING DOB & LONG NAMES BETA P23 10/24/2013
  1.  ;*************************************************************
  1.  W !!,"Enter the minimum age (in days) of bills to be itemized."
  1.  K DIR
  1.  S DIR(0)="N0^0:9000"
  1.  D ^DIR
  1.  K DIR
  1.  Q:Y'>0
  1.  S BARAGE=Y
  1.  D SELACC
  1.  Q:$G(BARQUIT)
  1.  S DIR("A")="Summary Only"
  1.  S DIR("B")="NO"
  1.  S DIR(0)="Y"
  1.  D ^DIR
  1.  K DIR
  1.  S BARSUM=Y
  1.  S BARSBY=1
  1.  I '$G(BARSUM) D
  1.  .S DIR(0)="S^1:POLICY HOLDER;2:POLICY NUMBER;3:PATIENT;4:DATE OF SERVICE"
  1.  .S DIR("A")="Within Account Sort By"
  1.  .S DIR("B")=1
  1.  .D ^DIR
  1.  .K DIR
  1.  .S BARSBY=Y
  1.  S %ZIS="NQ"
  1.  S %ZIS("A")="Print to Device: "
  1.  D ^%ZIS
  1.  Q:POP
  1.  I IO'=IO(0) D QUE,EXIT,HOME^%ZIS Q
  1.  I $D(IO("S")) D
  1.  . S IOP=ION
  1.  . D ^%ZIS
  1.  ;
  1. AGE ; *
  1.  ; * dequeing compute point
  1.  K ^TMP("BAR",$J,"BLAGE")
  1.  S BARSVC=$$GET1^DIQ(200,DUZ,29)
  1.  I '$D(BARSAC) D
  1.  .S BARACDA=0
  1.  .F  S BARACDA=$O(^BARBL(DUZ(2),"ABAL",BARACDA)) Q:'BARACDA  D ONEAC
  1.  I $D(BARSAC) D
  1.  .S BARACDA=0
  1.  .F  S BARACDA=$O(BARSAC(BARACDA)) Q:'BARACDA  D ONEAC
  1.  D PRINT
  1.  I $D(IO("S")) D ^%ZISC
  1.  D EXIT
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. ONEAC ;ONE A/R ACCOUNT
  1.  S DA=0
  1.  F  S DA=$O(^BARBL(DUZ(2),"ABAL",BARACDA,DA)) Q:'DA  D
  1.  .I '$D(^BARBL(DUZ(2),DA)) Q  ;P.OTT
  1.  .K BART
  1.  .D ENP^XBDIQ1(90050.01,DA,"3;7.2;10;15","BART(","I")
  1.  .I BART(7.2)<BARAGE Q  ;age
  1.  .I BART(10)'=BARSVC Q  ;SVC
  1.  .S BARSVAL=$G(^BARBL(DUZ(2),DA,7))
  1.  .Q:BARSVAL=""                          ;MRS:BAR*1.8*6 IM29966
  1.  .S $P(BARSVAL,"^",3)=$P(^BARBL(DUZ(2),DA,1),"^",16)
  1.  .S $P(BARSVAL,"^",4)=$P(^BARBL(DUZ(2),DA,1),"^",2)
  1.  .S BARSVAL=$P(BARSVAL,"^",BARSBY)
  1.  .S:BARSVAL="" BARSVAL="UNKNOWN"
  1.  .S ^TMP("BAR",$J,"BLAGE",BARACDA,BARSVAL,DA)=BART(15)
  1.  .S ^TMP("BAR",$J,"BLAGE",BARACDA)=$G(^TMP("BAR",$J,"BLAGE",BARACDA))+BART(15)
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. PRINT ;
  1.  ;** deque for print
  1.  D SUMMARY
  1.  Q:$G(BARQUIT)
  1.  Q:$G(BARSUM)
  1.  S BARACDA=0
  1.  F  S BARACDA=$O(^TMP("BAR",$J,"BLAGE",BARACDA)) Q:BARACDA'>0  S BARTOT=^(BARACDA) Q:$G(BARQUIT)  D
  1.  .K BARA
  1.  .D ENP^XBDIQ1(90050.02,BARACDA,".01;1:1.99","BARA(","N")
  1.  .D LETTER
  1.  .Q:$G(BARQUIT)
  1.  .D LIST
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. LETTER ;
  1.  ; ** print letter
  1.  W $$EN^BARVDF("IOF")
  1.  D ENP^XBDIQ1(90052.03,2,".01;100","BARLT(")
  1.  S BARL=0
  1.  ;** header
  1.  F BARL=BARL+1:1 Q:'$D(BARLT(100,BARL))  Q:$E(BARLT(100,BARL))="~"  W !,BARLT(100,BARL)
  1.  ;** address
  1.  W !,"DATE:",?10,$$MDT2^BARDUTL(DT)
  1.  ;W !!,"TO:",?10,BARA(.01)
  1.  W !!,"TO:",?10,$G(BARA(.01))  ;BAR*1.8*4 IM????? OCCURRED DURING BETA TESTING
  1.  S DR=1.01
  1.  ;W !,?10,BARA(1.01)
  1.  W !,?10,$G(BARA(1.01))  ;IHS/SD/TPF BAR*1.8*3 IM25704
  1.  F  S DR=$O(BARA(DR)) Q:DR'>0  W !,?10,BARA(DR)
  1.  ;** from
  1.  S BARFDA=$$GET1^DIQ(9002274.5,1,.23,"I")
  1.  G:BARFDA'>0 CNT
  1.  K BARF
  1.  D ENP^XBDIQ1(9999999.06,BARFDA,".14:.17","BARF(")
  1.  W !!,"FROM: ",$G(BARUSR(29)),"  address for payments"
  1.  W !,?5,BARF(.14)
  1.  W !,?5,BARF(.15)
  1.  W !,?5,BARF(.16)
  1.  W !,?5,BARF(.17)
  1.  K BARF
  1. CNT F BARL=BARL+1:1 Q:'$D(BARLT(100,BARL))  Q:$E(BARLT(100,BARL))="~"  W !,BARLT(100,BARL)
  1.  ;** regarding
  1.  W !,"Regarding Past due bills over  ",BARAGE," days totaling  $ ",$FN(BARTOT,",",2)
  1.  ;** body
  1.  F BARL=BARL+1:1 Q:'$D(BARLT(100,BARL))  Q:$E(BARLT(100,BARL))="~"  W !,BARLT(100,BARL)
  1.  F BARL=BARL+1:1 Q:'$D(BARLT(100,BARL))  Q:$E(BARLT(100,BARL))="~"  W !,BARLT(100,BARL)
  1.  D EOP
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. LIST ;** list bills
  1.  NEW BARTMP1,BARTMP2,BARSSN
  1.  S BARBLDA=0,BARSVAL=0
  1.  S BARPG("HDR")=$G(BARA(.01),"UNKNOWN")_"   over  "_BARAGE_"  days" ;P.OTT MAY 2013
  1.  D BARHDR
  1.  F  S BARSVAL=$O(^TMP("BAR",$J,"BLAGE",BARACDA,BARSVAL)) Q:BARSVAL=""  D
  1.  .F  S BARBLDA=$O(^TMP("BAR",$J,"BLAGE",BARACDA,BARSVAL,BARBLDA)) Q:BARBLDA'>0  Q:$G(BARQUIT)  D  Q:($G(DIROUT)!$G(DUOUT)!$G(DTOUT)!$G(DROUT))
  1.  ..K BARB
  1.  ..D ENP^XBDIQ1(90050.01,BARBLDA,".01;101;102;13;15;7.2;701;702","BARB(","I")
  1.  .. S BARPIEN=$P(^BARBL(DUZ(2),BARBLDA,1),U)
  1.  .. S BARDOB=$$GET1^DIQ(2,BARPIEN,".03","E")
  1.  .. S BARSSN=$P($G(^DPT(BARPIEN,0)),U,9) ;S BARSSN=$P($G(^DPT(BARPTDA,0)),U,9)
  1.  ..W !,$E(BARB(701),1,22)
  1.  ..W ?25,$E(BARB(702),1,12)
  1.  ..S BARTMP2=BARB(.01),BARTMP1=$P(BARTMP2,"-"),BARTMP2=$P(BARTMP2,"-",2,99)
  1.  ..W ?39,BARTMP1
  1.  ..W ?49,$$FMDT(BARB(102,"I"))
  1.  ..W ?58,$J(BARB(13),10,2)
  1.  ..W ?69,$J(BARB(15),10,2)
  1.  ..W !,"Pat: ",BARB(101)
  1.  ..I BARTMP2]"" W ?39,BARTMP2
  1.  ..W ?49,BARDOB
  1.  ..W !,BARSSN
  1.  ..;;;;W !,"Pat DOB: "
  1.  ..W "   Comment:"
  1.  ..F  W "_" Q:$X+3>IOM
  1.  .. ;-----------------------------------
  1.  ..W !
  1.  ..I $Y+4>IOSL D
  1.  ...D EOP
  1.  ...D PG
  1.  W !!,"TOTAL: ",?67,$J("$"_$FN(BARTOT,",",2),12)
  1.  D EOP
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. SUMMARY ;
  1.  S BARPG("HDR")="Summary of bills/accounts over "_BARAGE_" days"
  1.  D BARHDR
  1.  S (BARAC,BARTOT,BARCNT)=0
  1.  F  S BARAC=$O(^TMP("BAR",$J,"BLAGE",BARAC)) Q:BARAC'>0  Q:$G(BARQUIT)  S X=^(BARAC) S BARTOT=BARTOT+X D  Q:$G(BARQUIT)
  1.  .W !,$$GET1^DIQ(90050.02,BARAC,.01),?50,$J($FN(X,",",2),12)
  1.  .Q:$Y+6'>IOSL
  1.  .D EOP
  1.  .D PG
  1.  Q:$G(BARQUIT)
  1.  W !!,"TOTAL ALL ACCOUNTS:",?50,$J($FN(BARTOT,",",2),12),!!
  1.  W !!,?15,"E N D   O F   R E P O R T",!!
  1.  D EOP
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. SELACC ;
  1.  ; ** select accounts to print
  1.  K BARSAC
  1.  W !,"Select individual A/R accounts or hit RETURN for ALL accounts."
  1.  S DIC=$$DIC^XBDIQ1(90050.02)
  1.  S DIC(0)="AEQMZ"
  1.  S DIC("S")="I $P(^(0),U,10)=$$VALI^XBDIQ1(200,DUZ,29)"
  1.  F  D ^DIC Q:Y'>0  S BARSAC(+Y)=Y(0,0)
  1.  Q:'$D(BARSAC)
  1.  S DA=0
  1.  W !
  1.  F  S DA=$O(BARSAC(DA)) Q:'DA  W !,BARSAC(DA)
  1.  W !
  1.  K DIR
  1.  S DIR(0)="Y"
  1.  S DIR("B")="YES"
  1.  S DIR("A")="Selected Account(s) Correct"
  1.  D ^DIR
  1.  I Y Q
  1.  K BARSAC
  1.  G SELACC
  1.  ; *********************************************************************
  1.  ;
  1. FMDT(X) ;
  1.  ; cvt fmdt to mm/dd/yyyy
  1.  S X=$$SDT^BARDUTL(X)
  1.  Q X
  1.  ; *********************************************************************
  1.  ;
  1. PG ;
  1. BARPG ;EP PAGE CONTROLLER
  1.  ; this utility uses variables BARPG("HDR"),BARPG("DT"),BARPG("LINE"),BARPG("PG")
  1.  ; kill variables by D EBARPG
  1.  ;
  1.  S BARPG("PG")=+$G(BARPG("PG"))+1
  1.  ;
  1. BARHDR ;EP
  1.  ; write page header
  1.  W $$EN^BARVDF("IOF")
  1.  W !
  1.  Q:'$D(BARPG("HDR"))
  1.  S:'$D(BARPG("LINE")) $P(BARPG("LINE"),"=",IOM)=""
  1.  S:'$D(BARDASH) $P(BARDASH,"-",IOM)=""
  1.  S:'$D(BARPG("PG")) BARPG("PG")=1
  1.  W ?(IOM-40-$L(BARPG("HDR"))/2),BARPG("HDR")
  1.  W ?(IOM-24),$$SDT^BARDUTL(DT)
  1.  W ?(IOM-10),"PAGE: ",BARPG("PG")
  1.  W !,BARPG("LINE")
  1.  ;
  1. BARHD ;EP
  1.  ; Write column header / message
  1.  W !
  1.  I BARPG("HDR")'["mmary" D
  1.  . W "Policy Holder",?25,"Policy #",?39,"Claim #",?49,"DOS",?58,$J("Amt Bld",10),?69,$J("Balance",10)
  1.  . W !,"PT. SS #",?49,"DOB"
  1.  W !,BARDASH,!
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. EBARPG ;
  1.  K BARPG("LINE"),BARPG("PG"),BARPG("HDR"),BARPG("DT")
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. QUE ;QUE
  1.  N I
  1.  F I="BARSAC*","BARSBY","BARAGE","BARSUM" S ZTSAVE(I)=""
  1.  S ZTRTN="AGE^BARBL"
  1.  S ZTDESC="AGED DAY LETTER"
  1.  K ZTSK
  1.  D ^%ZTLOAD
  1.  W:$G(ZTSK) !,"Task # ",ZTSK," queued.",!
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. EXIT ;clean up and quit
  1.  K DIC,BARSAC,BARSBY,BARA,BARB,BARPG,BARAC,BARACDA,BARAGE,BARBLDS
  1.  K BARCNT,BARFDA,BARJOB,BARL,BARLT,BARQUIT,BARSVAL,BARSVC,BART,BARTOT
  1.  W $$EN^BARVDF("IOF")
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. EOP ;end of page
  1.  I IO=IO(0),'$D(IO("S")),'$G(ZTQUEUED) D
  1.  .F  W ! Q:$Y+4>IOSL
  1.  .D EOP^BARUTL(0)
  1.  .S:'Y BARQUIT=1
  1.  Q