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