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

BARPST.m

Go to the documentation of this file. 
  1. BARPST ; IHS/SD/LSL - PAYMENT BATCH POSTING JAN 15,1997 ; 07/14/2010
  1.  ;;1.8;IHS ACCOUNTS RECEIVABLE;**6,7,13,15,19,21,22,23**;OCT 26, 2005;Build 38
  1.  ;;
  1.  ; IHS/SD/LSL - 07/31/2002 - V1.7 - NOIS HQW-0302-100213
  1.  ;     Modified BATW to also display batch name.
  1.  ; 
  1.  ; IHS/SD/SDR 6/4/09 HEAT5219 BAR*1.8*13
  1.  ;     Restrict sites from posting batches prior to 01/01/09, 
  1.  ;     (effective at sites 07/01/09)
  1.  ;
  1.  ; IHS/SD/TMM 12/21/09 M3  HEAT9506 BAR*1.8*15
  1.  ;                         Restrict sites from posting batches prior to 2 quarters 
  1.  ;                         ago.  (effective 1/1/10) 
  1.  ;
  1.  ; IHS/SD/TMM 12/21/09 M4  BAR*1.8*19
  1.  ;                         Lockdown date not working correctly for batches in 12/2009.
  1.  ; P.OTT SEP 2012 HEAT#83479 FIXING BUG IF DATA IS MISSING IN I $D(^BAREDI("I",DUZ(2),BAR,0))
  1.  ; *********************************************************************
  1.  ;
  1. EN ;EP -  lookup collection id
  1.  D ^BARVKL0
  1.  S BARESIG=""
  1.  D SIG^XUSESIG
  1.  Q:X1=""  ;elec signature test
  1.  S BARESIG=1
  1.  D RAYGO
  1.  ; -------------------------------
  1.  ;
  1. ENTRY ;
  1.  ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
  1.  I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) G FINISH  ;IS SESSION STILL OPEN
  1.  I '$D(BARUSR) D INIT^BARUTL
  1.  W !!
  1.  K DIC,BARCOL
  1.  S DIC="^BARCOL(DUZ(2),"
  1.  S DIC(0)="SAEZQM"
  1.  S DIC("A")="Select Batch: "
  1.  S DIC("S")="I $P(^(0),U,3)=""P""&($G(BARUSR(29,""I""))=$P(^(0),U,10))"
  1.  S DIC("W")="D BATW^BARPST"
  1.  K DD,DO
  1.  D ^DIC
  1.  K DIC
  1.  I Y'>0 G FINISH
  1.  I '$$CKDATE^BARPST(+Y,1,"SELECT A/R COLLECTION BATCH") G ENTRY  ;DISALLOW POSTING TO OLD BATCHES;MRS;BAR*1.8*6 DD 4.2.4
  1.  S BARCOL=+Y
  1.  S BARCOL(0)=Y(0)
  1.  D BBAL(BARCOL)
  1.  ; -------------------------------
  1.  ;
  1. ITEM ;
  1.  ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
  1.  I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) G FINISH  ;IS SESSION STILL OPEN
  1.  W !!
  1.  K BARITM
  1.  S DA(1)=BARCOL
  1.  S DIC="^BARCOL(DUZ(2),"_DA(1)_",1,"
  1.  S DIC(0)="AEMQZ"
  1.  S DIC("W")="D DICW^BARPST"
  1.  S DIC("A")="Select Batch Item: "
  1.  S DIC("S")="I $P(^(0),U,17)'=""C""&($P(^(0),U,17)'=""R"")"
  1.  K DD,DO
  1.  D ^DIC
  1.  K DIC
  1.  I +Y<1 G ENTRY
  1.  S BARITM=+Y
  1.  S BARITM(0)=Y(0)
  1.  D IBAL(BARITM)
  1.  ; -------------------------------
  1.  ;
  1. GETSUB ;
  1.  K BAREOB
  1.  I $P(BARITM(0),U,17)'="E" G GETPAT
  1.  I '+$P(^BAR(90052.06,DUZ(2),DUZ(2),0),U,2) G GETPAT
  1.  W !!
  1.  S DA(2)=+BARCOL
  1.  S DA(1)=+BARITM
  1.  D ^XBSFGBL(90051.1101601,.BARGL)
  1.  S DIC=$P(BARGL,"DA,",1)
  1.  S DIC(0)="AEMQZ"
  1.  S DIC("W")="W ?20,$J($P(^(0),U,2),8,2)"
  1.  S DIC("A")="Select Visit Location: "
  1.  K DD,DO
  1.  D ^DIC
  1.  K DIC
  1.  I +Y<1 D  G ITEM
  1.  .W !!!
  1.  .W "Select Batch: "_$P(BARCOL(0),U,1)
  1.  .S Y=BARCOL
  1.  .D BATW1,BBAL(BARCOL)
  1.  .Q
  1.  S BAREOB=+Y
  1.  S BAREOB(0)=Y(0)
  1.  D EBAL(BAREOB)
  1.  ; -------------------------------
  1.  ;
  1. GETPAT ;
  1.  ; ** get patient and dos range
  1.  ;IHS/SD/TPF BAR*1.8*21 8/3/2011 HEAT20490
  1.  I $$NOTOPEN^BARUFUT(.DUZ,$G(UFMSESID)) G FINISH  ;IS SESSION STILL OPEN
  1.  S BARPASS=$$EN^BARPST1()
  1.  I +BARPASS=0 D  G ITEM
  1.  .I +$G(^BARVSIT(4))>0!(+$G(BARCLIT(19))>0) D
  1.  ..K DIR
  1.  ..S DIR(0)="Y"
  1.  ..S DIR("A")="Do you want to POST any of the unposted balance to UNALLOCATED CASH"
  1.  ..S DIR("B")="NO"
  1.  ..D ^DIR
  1.  ..K DIR
  1.  ..I Y'=1 Q
  1.  ..D UNALC^BARPST7(+BARCL("ID"),+BARCLIT("ID"),+$G(BARVSIT("ID")))
  1.  .W !!!,"Select Batch: "_$P(BARCOL(0),U,1)
  1.  .S Y=BARCOL
  1.  .D BATW1,BBAL(BARCOL)
  1.  .Q
  1.  S BARCNT=$$EN^BARPST2(BARPASS)
  1.  I 'BARCNT D  G GETPAT
  1.  .W *7
  1.  .W "No bills found in this date range!"
  1.  .D EOP^BARUTL(1)
  1.  .D TOP^BARPST1(0)
  1.  D EN^BARPST3
  1.  D TOP^BARPST1(0)
  1.  G GETPAT
  1.  ; *********************************************************************
  1.  ;
  1. BATW ;EP - dic DIC("W")
  1.  ;
  1. BATW1 ;
  1.  N X,DA,DIC,DIQ,XB,DR
  1.  K BARCL
  1.  S DA=+Y
  1.  S DR=".01;4;8;15;16;17"
  1.  S DIQ="BARCL("
  1.  S DIC="^BARCOL(DUZ(2),"
  1.  D EN^XBDIQ1
  1.  W ?20,$E(BARCL(.01),1,35),?58,$E(BARCL(8),1,20)
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. BBAL(BARCOL) ;EP
  1.  ; ** display batch posting balance and total
  1.  N DA,DIC,DIQ,XB,DR
  1.  K BARCL
  1.  S DA=BARCOL
  1.  S DR="15:17"
  1.  S DIQ="BARCL("
  1.  S DIC="^BARCOL(DUZ(2),"
  1.  D EN^XBDIQ1
  1.  W !?5,"===> Total Posted: $ "_$J(BARCL(16),0,2)
  1.  W ?37,"===> Remaining Balance: $ "_$J(BARCL(17),0,2)
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. DICW ;EP -  help display on item lookup
  1.  Q:$G(DZ)'["?"
  1.  D ^XBNEW("DICW1^BARPST:Y;BARCOL*")
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. DICW1 ;EP
  1.  K BARCLIT
  1.  N DIC,DA,DR,DIQ
  1.  Q:'+Y
  1.  S (DA,BARITDA)=+Y
  1.  S DIQ="BARCLIT("
  1.  S DIQ(0)="I"
  1.  S DIC=90051.1101
  1.  S DA(1)=+BARCOL
  1.  S DR="2;2.5;7;11;101"
  1.  D EN^XBDIQ1
  1.  W ?7,$J($E(BARCLIT(11),1,9),10)
  1.  W:$L(BARCLIT(11))>9 "*"
  1.  W ?18,$J(BARCLIT(101),8,2),?28,BARCLIT(7),?58,$E($G(BARCLIT(2.5)),1,2)
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. IBAL(BARITM) ;EP
  1.  ; ** display item balance and posting total
  1.  K BARCLIT
  1.  N DIC,DA,DR,DIQ
  1.  Q:'+BARITM
  1.  S (DA,BARITDA)=+BARITM
  1.  S DA(1)=+BARCOL
  1.  S DIC=90051.1101
  1.  S DIQ="BARCLIT("
  1.  S DR="18;19;101"
  1.  D EN^XBDIQ1
  1.  W !?3,"===> Item Total Posted: $ "_$J(BARCLIT(18),0,2)
  1.  W ?42,"===> Item Remaining Balance: $ "_$J(BARCLIT(19),0,2)
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. EBAL(BAREOB) ;EP
  1.  ; ** display item balance and posting total
  1.  N DA,DIQ,DIC,DR
  1.  K BARVSIT
  1.  S DA=BAREOB
  1.  S DA(1)=+BARITM
  1.  S DA(2)=+BARCOL
  1.  S DIC=90051.1101601
  1.  S DIQ="BARVSIT("
  1.  S DR="2;3;4"
  1.  D EN^XBDIQ1
  1.  W !?0,"===> Sub-Item Total Posted: $ "_$J(BARVSIT(3),0,2)
  1.  W ?39,"===> Sub-Item Remaining Balance: $ "_$J(BARVSIT(4),0,2)
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. FINISH ;
  1.  D ^BARVKL0
  1.  Q
  1.  ; *********************************************************************
  1.  ;
  1. RAYGO ;EP
  1.  ; set roll-over flag
  1.  K BARRAYGO,DIR
  1.  S BARRAYGO=$P($G(^BAR(90052.06,DUZ(2),DUZ(2),0)),"^",13)
  1.  I BARRAYGO="Y" S BARRAYGO=1 Q
  1.  I BARRAYGO="N" S BARRAYGO=0 Q
  1.  S DIR("A")="Roll-over as you post"
  1.  S DIR("B")="NO"
  1.  S DIR(0)="Y"
  1.  S DIR("?")="Enter 'YES' to roll A/R bills back to 3P during posting."
  1.  W !
  1.  D ^DIR
  1.  K DIR
  1.  S BARRAYGO=Y
  1.  Q
  1.  ;
  1. CKDATE(Z,Q,P) ;EP; NEW; CHECK COLLECTION BATCH DATE ;MRS;BAR*1.8*6 DD 4.2.4
  1.  ;ENTERS WITH: Z = COLLECTION BATCH IEN
  1.  ;             Q = 0=SILENT OR 1=VERBOSE
  1.  ;             P = TYPE (ERA or COLLECTION BATCH CHECK) ALSO CALLED BY BAREDP00
  1.  ;I DUZ=902 Q 1
  1.  N X,Y,BAR
  1.  I '$$IHS^BARUFUT(DUZ(2)) Q 1  ;
  1.  ;;;I '$$IHSERA^BARUFUT(DUZ(2)) Q 1  ;P.OTT
  1.  I Z="",P["COLLECTION" D  Q 0          ;MRS;BAR*1.8*7 IM30386
  1.  .N BARBIL
  1.  .S BARBIL=$$GET1^DIQ(90050.03,BARTX_",",4,"E")
  1.  .W !,"SESSION ID "_UFMSESID_" HAS TRANSACTION "_BARTX
  1.  .W:BARBIL]"" !,"FOR A/R BILL # "_BARBIL
  1.  .W !,"WITH MISSING COLLECTION BATCH, NOTIFY OIT SUPPORT"
  1.  .D EOP^BARUTL(1)
  1.  ;***BEGIN ADD***     ;M3*TMM*12/21/09*ADD
  1.  ;N BARYYY,BARYYY2,BARYYY3,BARMM,BARTMP,BARQTR,BARL1,BARL2,BARL3,BARL4,BARL5,BARL6
  1.  S BARYYY=$E(DT,1,3)
  1.  S BARMM=$E(DT,4,5)
  1.  S BARTMP=+BARMM
  1.  S BARQTR=$P($T(LOCKDOWN+BARTMP),";;",2)     ; quarter dates
  1.  S BARL1=$P(BARQTR,"^",1)                    ;*current month (for current month, use this line of data)
  1.  S BARL2=$P(BARQTR,"^",2)                    ;*last day of month/lock down period
  1.  S BARL3=$P(BARQTR,"^",3)                    ; first day of month after the lock down/cut off date
  1.  S BARL4=$P(BARQTR,"^",4)                    ;*month/quarter lockdown begins (lock down based on quarter, not month)
  1.  S BARL5=$P(BARQTR,"^",5)                    ;*use current(0) or prior year(1)
  1.  S BARL6=$P(BARQTR,"^",6)                    ;*use current(0) or prior year(1)
  1.  S BARYYY2=BARYYY-BARL5
  1.  S BARYYY3=BARYYY-BARL6
  1.  S BARL2=BARYYY2_BARL2                       ;last date of lock down period
  1.  S BARL3=BARYYY3_BARL3                       ;first available date after lock down period
  1.  ;W !,"BARL2=",BARL2
  1.  ;S X=DT>BARL2
  1.  ;W !,"DT>BARL2=",X
  1.  ;W !,"DT=",DT
  1.  ;M4*DEL*TMM*20100714  I DT>BARL2 S BARCDT=BARYYY2_BARL4_"00"
  1.  I DT>BARL2 S BARCDT=$E(BARL3,1,5)_"00"        ;M4*ADD*TMM*20100714
  1.  I DT<BARL3 S BARCDT=3051000                 ;oldest collection date allowed (lockdown date)
  1.  ;W !,"BARCDT=",BARCDT
  1.  S BARL3MM=$E(BARL3,4,5)
  1.  S BARL3DD=$E(BARL3,6,7)
  1.  S BARL3YY=$E(BARL3,1,3)+1700
  1.  S BARL3FMT=BARL3MM_"/"_BARL3DD_"/"_BARL3YY
  1.  ;
  1.  I P["COLLECTION",($P(^BARCOL(DUZ(2),+Z,0),U,4)>BARCDT) Q 1
  1.  ;-------------------------------------REWRITE P.OTT
  1.  I P["ERA" D  I $G(Y)>BARCDT Q 1
  1.  . S Y=0,BAR=$$GETONE(Z) ;W !,"RETURNED BAR=",BAR
  1.  . I 'BAR W !!,"Cannot find filename in A/R EDI IMPORT File" Q
  1.  . S X=$P($P($G(^BAREDI("I",DUZ(2),BAR,0)),U,2),"@",1)  ;RETURN DATE 
  1.  . S %DT="" D ^%DT ;RETURN Y (DATE)
  1.  . QUIT
  1.  ;--------------------------------------
  1.  I P["ERA" D  I $G(Y)>BARCDT Q 1
  1.  .;some files have 30 characters; some have full name; check for both
  1.  .S BAR=$O(^BAREDI("I",DUZ(2),"C",Z,""))
  1.  .S:BAR="" BAR=$O(^BAREDI("I",DUZ(2),"C",$E(Z,1,30),""))
  1.  .I BAR="" W !!,"Cannot find filename in A/R EDI IMPORT File"
  1.  .;end new code HEAT56444
  1.  .Q:BAR=""                                  ;MRS:BAR*1.8*7 IM30386
  1.  .S X=$P($P($G(^BAREDI("I",DUZ(2),BAR,0)),U,2),"@",1)
  1.  .S %DT=""
  1.  .D ^%DT
  1.  I P["ERA",(BAR="") Q  ;bar*1.8*22 SDR HEAT56444
  1.  I Q D
  1.  .W !!,"CANNOT "_P_" OLDER THAN "_$S(DT>BARL2:BARL3FMT,1:"10/01/2005")  ;M3*TMM*12/21/09*ADD
  1.  .D EOP^BARUTL(1)
  1.  Q 0
  1.  ;
  1. GETONE(BARZNAM) ;P.OTT
  1.  NEW BARFN1,BARFN2
  1.  SET BARFN1=BARZNAM,BARFN2=$E(BARZNAM,1,30),CNT=0
  1.  S BAR="" F  S BAR=$O(^BAREDI("I",DUZ(2),"C",BARFN1,BAR)) Q:BAR=""  I $D(^BAREDI("I",DUZ(2),BAR,0)) Q
  1.  I BAR Q BAR
  1.  ;some files have 30 characters; some have full name; check for both
  1.  S BAR="" F  S BAR=$O(^BAREDI("I",DUZ(2),"C",BARFN2,BAR)) Q:BAR=""  I $D(^BAREDI("I",DUZ(2),BAR,0)) Q
  1.  I BAR Q BAR
  1.  Q 0  ;NO DATA FOUND: RETURN ZERO
  1.  ;
  1. LOCKDOWN ;;$T quarter lockdown for posting   ;M3*TMM*12/21/09*ADD TAG
  1.  ;;01^0630^0701^07^1^1
  1.  ;;02^0630^0701^07^1^1
  1.  ;;03^0630^0701^07^1^1
  1.  ;;04^0930^1001^10^1^1
  1.  ;;05^0930^1001^10^1^1
  1.  ;;06^0930^1001^10^1^1
  1.  ;;07^1231^0101^01^1^0
  1.  ;;08^1231^0101^01^1^0
  1.  ;;09^1231^0101^01^1^0
  1.  ;;10^0331^0401^04^0^0
  1.  ;;11^0331^0401^04^0^0
  1.  ;;12^0331^0401^04^0^0
  1.  ;;end of list
  1.  Q