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

PRCAGU.m

Go to the documentation of this file.
  1. PRCAGU ;WASH-ISC@ALTOONA,PA/CMS-Patient Statement Utility ;8/23/94 8:06 AM
  1. V ;;4.5;Accounts Receivable;**181,219,301,348**;Mar 20, 1995;Build 20
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;PRCA*4.5*348 Ensure veterans get a bill even though they
  1. ; have no last statement (2) event in file 341
  1. ;
  1. Q ;This routine should not be called from the top
  1. SITE ;Set statement variables from Site Parameter File
  1. NEW SP0,SP2
  1. S SP0=$G(^RC(342,1,0)) I SP0="" G SITEQ
  1. S SP2=$G(^RC(342,1,2))
  1. S SITE("SUP")=+$P(SP0,U,2) ;suppres right&oblig
  1. S SITE("DETL")=+$P(SP0,U,5) ;Copay info 1-brief or 2-expanded
  1. S SITE("COM1")=$P($G(SP2),U,1) ;statement comment 1
  1. S SITE("COM2")="" ; statement comment 2 disabled with GMT patch ;($P($G(SP2),U,2))
  1. S SITE("SCAN")=$G(^RC(342,1,5)) ;mark for auto stuffer
  1. S SITE("ZERO")=$P($G(SP0),U,9) ;suppress zero balance
  1. SITEQ Q
  1. PBAL(DEB,DAT,PBAL,PRCASTMT) ;get previous balance and date of last transaction
  1. N EVN,I,Y G:'DEB PBALQ
  1. S EVN=$O(^RC(341,"AD",DEB,+$O(^RC(341.1,"AC",2,0)),DAT,0))
  1. I '$G(EVN) S:$G(PRCASTMT) DAT=PDAT G PBALQ ;PRCA*4.5*348
  1. S Y=$G(^RC(341,EVN,1)) F I=1:1:5 S PBAL=PBAL+$P(Y,U,I)
  1. S DAT=$P($G(^RC(341,EVN,0)),U,6)
  1. PBALQ Q
  1. BBAL(DEB,BBAL) ;get bills balances return array
  1. NEW ADM,AC,BAL,CT,I,INT,MF,OP,PB,PRE,STAT,CS,CSFLAG
  1. S (BBAL,PB,INT,ADM,MF,CT)=0,LET3="",CSFLAG=$D(CSBB)
  1. G:'DEB BBALQ
  1. S AC=+$O(^PRCA(430.3,"AC",102,0)),OP=+$O(^PRCA(430.3,"AC",112,0)),PRE=+$O(^PRCA(430.2,"AC",33,0))
  1. F STAT=AC,OP F BN=0:0 S BN=$O(^PRCA(430,"AS",DEB,STAT,BN)) Q:'BN D
  1. .S BAL=$G(^PRCA(430,BN,7)),CS=$D(^PRCA(430,"TCSP",BN)) ; set flag for CS bills
  1. .I $D(^PRCA(430,BN,6)) S LET3=$P(^(6),U,3) I LET3="" S ^XTMP("PRCAGU",$J,DEB,BN)=""
  1. .I $P(^PRCA(430,BN,0),U,2)=PRE S PB=PB-BAL Q
  1. .S PB=PB+$P(BAL,U,1),INT=INT+$P(BAL,U,2),ADM=ADM+$P(BAL,U,3),MF=MF+$P(BAL,U,4),CT=CT+$P(BAL,U,5)
  1. .; for CS bills, update the CS bill balance
  1. .I CS S CSBB=$G(CSBB)+$P(BAL,U,1)+$P(BAL,U,2)+$P(BAL,U,3)+$P(BAL,U,4)+$P(BAL,U,5)
  1. S BBAL=PB+INT+ADM+MF+CT
  1. F X="PB","INT","ADM","MF","CT" S BBAL(X)=@X
  1. BBALQ I 'CSFLAG K CSBB
  1. Q
  1. UPDAT(DEB,DAT) ;update bill file 430 letter fields
  1. NEW BN,DA,DIE,DR,II,LET,NOT,X,Y
  1. G:'DEB UPDATQ
  1. S:$G(DAT)="" DAT=DT S DIE="^PRCA(430,",NOT=0,BN=0
  1. F S BN=$O(^PRCA(430,"AS",DEB,16,BN)) Q:'BN S DA=BN D
  1. .S LET=$G(^PRCA(430,BN,6))
  1. .F II=1:1:4 Q:$P(LET,U,II)=DAT I $P(LET,U,II)="" S NOT=II,DR=$S(II=1:61,II=2:62,II=3:63,1:68)_"////^S X="_DAT_";68.1////^S X="_DAT D ^DIE Q
  1. UPDATQ Q
  1. BEVN(DEB,DAT) ;set event for non patient letters
  1. NEW BAL,BN,DA,DIE,DR,EVN,I,NOT,X,Y
  1. G:'DEB BEVNQ
  1. S:$G(DAT)="" DAT=DT S DIE="^RC(341,",NOT=0,BN=0
  1. F S BN=$O(^PRCA(430,"AS",DEB,16,BN)) Q:'BN D
  1. .F I=1:1:3 I $P($G(^PRCA(430,BN,6)),U,I)=DAT S NOT=I Q
  1. .S:'NOT NOT=4 S BAL=$G(^PRCA(430,BN,7)),ERR="",EVN=""
  1. .D OPEN^RCEVDRV1(10,$P(^RCD(340,DEB,0),U),DAT,DUZ,$$SITE^RCMSITE,.ERR,.EVN,+BAL_U_$P(BAL,U,2)_U_$P(BAL,U,3)_U_$P(BAL,U,4)_U_$P(BAL,U,5))
  1. .I EVN S DA=EVN,DR="5.01////^S X="_BN_";5.02////^S X="_NOT D ^DIE D CLOSE^RCEVDRV1(EVN)
  1. BEVNQ Q
  1. PRE(DEB) ;check for prepay bills in Refund review or Pending Calm
  1. NEW BAL,BN,PEN,PRE,RR,STAT,Y
  1. S (BAL,Y)=0 G:'DEB PREQ
  1. S RR=+$O(^PRCA(430.3,"AC",113,0)),PEN=+$O(^PRCA(430.3,"AC",107,0)),PRE=+$O(^PRCA(430.2,"AC",33,0))
  1. F STAT=RR,PEN F BN=0:0 S BN=$O(^PRCA(430,"AS",DEB,STAT,BN)) Q:'BN D
  1. .I $P($G(^PRCA(430,BN,0)),U,2)=PRE S Y=BN,BAL=BAL+$G(^PRCA(430,BN,7))
  1. PREQ Q Y_U_BAL
  1. LST(DEB,EVN,BDT) ;get last statement date before the statement date sent
  1. NEW BEG,DAT,Y
  1. S BDT=0 I 'DEB G LSTQ
  1. S Y=+$O(^RC(341.1,"AC",2,0)),BEG=$P($G(^RC(341,EVN,0)),U,7) I 'BEG G LSTQ
  1. S BEG=9999999.999999-BEG
  1. F DAT=BEG:0 S DAT=$O(^RC(341,"AD",DEB,Y,DAT)) Q:'DAT S BDT=DAT Q
  1. ;return BDT in inverse date
  1. LSTQ Q