Changeset 623 for WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (15 years ago)
- Location:
- WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC
- Files:
-
- 19 edited
-
PRCACM.m (modified) (1 diff)
-
PRCAGST.m (modified) (1 diff)
-
PRCAGST1.m (modified) (1 diff)
-
PRCASVC.m (modified) (1 diff)
-
RCDMC90.m (modified) (1 diff)
-
RCDPEM.m (modified) (1 diff)
-
RCDPESR2.m (modified) (1 diff)
-
RCDPESR3.m (modified) (1 diff)
-
RCDPESR6.m (modified) (1 diff)
-
RCDPESR9.m (modified) (1 diff)
-
RCDPEWL0.m (modified) (1 diff)
-
RCDPEX32.m (modified) (1 diff)
-
RCDPUDEP.m (modified) (1 diff)
-
RCFMOBR.m (modified) (1 diff)
-
RCMSITE.m (modified) (1 diff)
-
RCRCXM1.m (modified) (1 diff)
-
RCXVDC.m (modified) (1 diff)
-
RCXVDC4.m (modified) (1 diff)
-
RCXVFTP.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCACM.m
r613 r623 1 PRCACM ;WASH-ISC@ALTOONA,PA/RGY-COMMENT ADJUSTMENT TRANSACTION ;6/2/95 2:41 PM 2 ;;4.5;Accounts Receivable;**8,67,125,169,254**;Mar 20, 1995;Build 2 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; DBIA 3820-A used for direct global read into file 399. 5 ; 6 ;This is a routine for adjustment transaction. 7 NEW PRCABN,PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,DIROUT,DIRUT,DIR,DUOUT,PRCA,PRCATY 8 ADJUST D BEGIN G:('$D(PRCABN))!('$D(PRCAEN)) Q 9 S PRCAA1=$S($D(^PRCA(433,PRCAEN,4,0)):+$P(^(0),U,4),1:0) G Q:PRCAA1'>0 S PRCAA2=$P(^(0),U,3) W ! 10 DIE S DR="[PRCA COMMENT]",DIE="^PRCA(433,",DA=PRCAEN D ^DIE K DIE,DR,DA 11 I $P($G(^PRCA(433,PRCAEN,5)),"^",2)=""!'$P(^PRCA(433,PRCAEN,1),"^") S PRCACOMM="TRANSACTION INCOMPLETE" D DELETE^PRCAWO1 K PRCACOMM G:$D(DTOUT) Q G ADJUST 12 W ! W:$D(IOF) @IOF S D0=PRCAEN K DXS D ^PRCATO4 K DXS 13 I $P($G(^PRCA(433,PRCAEN,1)),"^")>$P($G(^(5)),"^",3),$P($G(^(5)),"^",3) W !!,*7,"You entered a date of follow-up before the date of contact!" S PRCACOMM="INVALID FOLLOW-UP DATE" D DELETE^PRCAWO1 K PRCACOMM G ADJUST 14 ASK S %=2 W !!,"Is this correct" D YN^DICN I %=0 W !,"Answer 'Y' or 'YES' if this data is correct, answer 'N' or 'NO' if not",! G ASK 15 I (%<0)!(%=2) S PRCACOMM="USER CANCELED" D DELETE^PRCAWO1 K PRCACOMM G ADJUST 16 DONE I '$D(PRCAD("DELETE")) S RCASK=1 D TRANUP^PRCAUTL,UPPRIN^PRCADJ 17 I $P($G(^RCD(340,+$P(^PRCA(430,PRCABN,0),"^",9),0)),"^")[";DPT(" D 18 .S $P(^PRCA(433,PRCAEN,0),"^",10)=1 19 .S DIR(0)="Y",DIR("A")="Should the BRIEF COMMENT print on the patient statement",DIR("B")="NO" D ^DIR K DIR 20 .I Y=1 S DIR(0)="Y",DIR("A")="Are you SURE this BRIEF COMMENT should appear on the patient statement",DIR("B")="NO" D ^DIR K DIR I Y=1 D 21 ..W !!,*7,"*** OK, This comment will appear on the patient's statement! ***",!,"(If you change your mind, use the option Remove/Add Comment From Patient Statement)",! 22 ..S $P(^PRCA(433,PRCAEN,0),"^",10)="" 23 ..Q 24 .Q 25 G ADJUST 26 Q Q 27 EN1 Q:'$D(PRCABN) 28 NEW X 29 F X=0:0 S X=$O(^PRCA(433,"C",PRCABN,X)) Q:'X I $P($G(^PRCA(433,X,1)),"^",4) I $P(^(1),"^",2)=1!($P(^(1),"^",2)=35) S PRCAQNM=$P(^(1),"^",4)+1 30 Q 31 ASK1 ;ASK FOR STATUS 32 NEW DTOUT,DUOUT,DIRUT,DIR,DIROUT 33 S DIR("A")="Change 'BILL' status to?",DIR("B")="CANCELLED",DIR(0)="SB^1:CANCELLED;2:COLLECTED/CLOSED;" D ^DIR K DIR 34 I Y=2 S PRCA("STATUS")=$O(^PRCA(430.3,"AC",108,0)) 35 Q 36 RPT ; 37 NEW %DT,BEG,END,DIC,L,FR,TO,FLDS,PRCACM,POP,PRCADEV 38 ST W !! S %DT="AEX",%DT("A")="Follow-up Date(s) From: " D ^%DT G:Y<0 REPQ S BEG=Y 39 S %DT="AEX",%DT("A")="Follow-up Date(s) To: " D ^%DT G:Y<0 REPQ S END=Y 40 I BEG>END W !!,*7," (Ending date must be greater than Start date.)" G ST 41 S %ZIS="MQ" D ^%ZIS G:POP REPQ S PRCADEV=ION_";"_IOST_";"_IOM_";"_IOSL_";"_$G(IO("DOC")) 42 I $D(IO("Q")) S Y=$$TI() G:Y<0 REPQ F PRCACM=1,2 S ZTDTH=$H,ZTRTN="DQ"_PRCACM_"^PRCACM",ZTSAVE("BEG")="",ZTSAVE("PRCADEV")="",ZTSAVE("END")="",ZTDESC="Comment Follow-up List" D ^%ZTLOAD G REPQ:PRCACM=2 43 D DQ1,DQ2:'$D(DTOUT) 44 REPQ Q 45 DQ1 ; 46 S IOP=PRCADEV,DIC="^PRCA(433,",L=0,BY="[PRCA FOLLOW-UP]",FLDS="[PRCA FOLLOW-UP]",FR=BEG,TO=END D EN1^DIP 47 D ^%ZISC K IOP 48 I $E(IOST)="C" W !,*7,"OK, first part of report complete...",!,"press return to continue: " R X:DTIME W @IOF S:X["^"!'$T DTOUT=1 49 Q 50 DQ2 ; 51 S IOP=PRCADEV D ^%ZIS 52 I 'POP S IOP=PRCADEV,DIC="^RC(341,",L=0,BY="[RCAM COMMENT]",FLDS="[RCAM COMMENT]",FR=BEG,TO=END D EN1^DIP 53 D ^%ZISC K IOP 54 Q 55 TI() ; 56 N %DT D NOW^%DTC S %DT("A")="Request Time to Queue? ",%DT("B")="NOW" 57 S %DT="AERX",%DT(0)=% D ^%DT 58 Q Y 59 BEGIN K PRCATERM,PRCABN,PRCAEN,PRCA("CKSITE"),PRCAIBS D BILL^PRCAUTL Q:('$D(PRCABN)) 60 S PRCAIBS=$P($G(^DGCR(399,PRCABN,0)),U,13) ; IB claim status - DBIA3820-A 61 I PRCAIBS=1 W !!,"** You cannot add AR Comments to an Entered/Not Reviewed claim. **",!,*7 G BEGIN 62 I PRCAIBS=2 W !!,"** You cannot add AR Comments to an MRA Request claim. **",!,*7 G BEGIN 63 I '$D(^PRCA(430,PRCABN,2,0)),PRCAIBS=7 W !!,"** You cannot add AR Comments to a claim Cancelled/not passed to AR. **",!,*7 G BEGIN 64 I $P($G(^PRCA(430,PRCABN,0)),"^",8)=49 W !!,"** Comments CANNOT be entered on an ARCHIVED bill. **",!,*7 G BEGIN 65 D SETTR^PRCAUTL,PATTR^PRCAUTL S DIC="^PRCA(433," K PRCAMT,PRCAD("DELETE") Q 1 PRCACM ;WASH-ISC@ALTOONA,PA/RGY-COMMENT ADJUSTMENT TRANSACTION ;6/2/95 2:41 PM 2 V ;;4.5;Accounts Receivable;**8,67,125,169**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ;This is a routine for adjustment transaction. 5 NEW PRCABN,PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,DIROUT,DIRUT,DIR,DUOUT,PRCA,PRCATY 6 ADJUST D BEGIN G:('$D(PRCABN))!('$D(PRCAEN)) Q 7 S PRCAA1=$S($D(^PRCA(433,PRCAEN,4,0)):+$P(^(0),U,4),1:0) G Q:PRCAA1'>0 S PRCAA2=$P(^(0),U,3) W ! 8 DIE S DR="[PRCA COMMENT]",DIE="^PRCA(433,",DA=PRCAEN D ^DIE K DIE,DR,DA 9 I $P($G(^PRCA(433,PRCAEN,5)),"^",2)=""!'$P(^PRCA(433,PRCAEN,1),"^") S PRCACOMM="TRANSACTION INCOMPLETE" D DELETE^PRCAWO1 K PRCACOMM G:$D(DTOUT) Q G ADJUST 10 W ! W:$D(IOF) @IOF S D0=PRCAEN K DXS D ^PRCATO4 K DXS 11 I $P($G(^PRCA(433,PRCAEN,1)),"^")>$P($G(^(5)),"^",3),$P($G(^(5)),"^",3) W !!,*7,"You entered a date of follow-up before the date of contact!" S PRCACOMM="INVALID FOLLOW-UP DATE" D DELETE^PRCAWO1 K PRCACOMM G ADJUST 12 ASK S %=2 W !!,"Is this correct" D YN^DICN I %=0 W !,"Answer 'Y' or 'YES' if this data is correct, answer 'N' or 'NO' if not",! G ASK 13 I (%<0)!(%=2) S PRCACOMM="USER CANCELED" D DELETE^PRCAWO1 K PRCACOMM G ADJUST 14 DONE I '$D(PRCAD("DELETE")) S RCASK=1 D TRANUP^PRCAUTL,UPPRIN^PRCADJ 15 I $P($G(^RCD(340,+$P(^PRCA(430,PRCABN,0),"^",9),0)),"^")[";DPT(" D 16 .S $P(^PRCA(433,PRCAEN,0),"^",10)=1 17 .S DIR(0)="Y",DIR("A")="Should the BRIEF COMMENT print on the patient statement",DIR("B")="NO" D ^DIR K DIR 18 .I Y=1 S DIR(0)="Y",DIR("A")="Are you SURE this BRIEF COMMENT should appear on the patient statement",DIR("B")="NO" D ^DIR K DIR I Y=1 D 19 ..W !!,*7,"*** OK, This comment will appear on the patient's statement! ***",!,"(If you change your mind, use the option Remove/Add Comment From Patient Statement)",! 20 ..S $P(^PRCA(433,PRCAEN,0),"^",10)="" 21 ..Q 22 .Q 23 G ADJUST 24 Q Q 25 EN1 Q:'$D(PRCABN) 26 NEW X 27 F X=0:0 S X=$O(^PRCA(433,"C",PRCABN,X)) Q:'X I $P($G(^PRCA(433,X,1)),"^",4) I $P(^(1),"^",2)=1!($P(^(1),"^",2)=35) S PRCAQNM=$P(^(1),"^",4)+1 28 Q 29 ASK1 ;ASK FOR STATUS 30 NEW DTOUT,DUOUT,DIRUT,DIR,DIROUT 31 S DIR("A")="Change 'BILL' status to?",DIR("B")="CANCELLED",DIR(0)="SB^1:CANCELLED;2:COLLECTED/CLOSED;" D ^DIR K DIR 32 I Y=2 S PRCA("STATUS")=$O(^PRCA(430.3,"AC",108,0)) 33 Q 34 RPT ; 35 NEW %DT,BEG,END,DIC,L,FR,TO,FLDS,PRCACM,POP,PRCADEV 36 ST W !! S %DT="AEX",%DT("A")="Follow-up Date(s) From: " D ^%DT G:Y<0 REPQ S BEG=Y 37 S %DT="AEX",%DT("A")="Follow-up Date(s) To: " D ^%DT G:Y<0 REPQ S END=Y 38 I BEG>END W !!,*7," (Ending date must be greater than Start date.)" G ST 39 S %ZIS="MQ" D ^%ZIS G:POP REPQ S PRCADEV=ION_";"_IOST_";"_IOM_";"_IOSL_";"_$G(IO("DOC")) 40 I $D(IO("Q")) S Y=$$TI() G:Y<0 REPQ F PRCACM=1,2 S ZTDTH=$H,ZTRTN="DQ"_PRCACM_"^PRCACM",ZTSAVE("BEG")="",ZTSAVE("PRCADEV")="",ZTSAVE("END")="",ZTDESC="Comment Follow-up List" D ^%ZTLOAD G REPQ:PRCACM=2 41 D DQ1,DQ2:'$D(DTOUT) 42 REPQ Q 43 DQ1 ; 44 S IOP=PRCADEV,DIC="^PRCA(433,",L=0,BY="[PRCA FOLLOW-UP]",FLDS="[PRCA FOLLOW-UP]",FR=BEG,TO=END D EN1^DIP 45 D ^%ZISC K IOP 46 I $E(IOST)="C" W !,*7,"OK, first part of report complete...",!,"press return to continue: " R X:DTIME W @IOF S:X["^"!'$T DTOUT=1 47 Q 48 DQ2 ; 49 S IOP=PRCADEV D ^%ZIS 50 I 'POP S IOP=PRCADEV,DIC="^RC(341,",L=0,BY="[RCAM COMMENT]",FLDS="[RCAM COMMENT]",FR=BEG,TO=END D EN1^DIP 51 D ^%ZISC K IOP 52 Q 53 TI() ; 54 N %DT D NOW^%DTC S %DT("A")="Request Time to Queue? ",%DT("B")="NOW" 55 S %DT="AERX",%DT(0)=% D ^%DT 56 Q Y 57 BEGIN K PRCATERM,PRCABN,PRCAEN,PRCA("CKSITE") D BILL^PRCAUTL Q:('$D(PRCABN)) 58 I '$D(^PRCA(430,PRCABN,2,0)) W !!,"** This bill was cancelled in IB before it was passed to AR. **",!,*7 G BEGIN 59 I $P($G(^PRCA(430,PRCABN,0)),"^",8)=49 W !!,"** Comments CANNOT be entered on an ARCHIVED bill. **",!,*7 G BEGIN 60 D SETTR^PRCAUTL,PATTR^PRCAUTL S DIC="^PRCA(433," K PRCAMT,PRCAD("DELETE") Q -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST.m
r613 r623 1 PRCAGST 2 V ;;4.5;Accounts Receivable;**34,181,190,249**;Mar 20, 1995;Build 23 4 5 EN(DEB,TBAL,PDAT,PBAL,LDT) 6 7 8 9 10 11 12 13 14 W !!,"Department of Veterans Affairs",?50,"Acct No.: ",$P($$SITE^VASITE(),U,3)_"/"_$E(SSN,6,9) 15 16 17 18 19 20 21 22 23 24 25 LB 26 27 28 29 30 31 32 33 34 35 36 37 38 39 MES 40 41 42 43 44 45 46 47 48 49 GMT(PRDEB) 50 51 52 53 54 1 PRCAGST ;WASH-ISC@ALTOONA,PA/CMS-Print Patient Statement ;12/12/96 9:39 AM 2 V ;;4.5;Accounts Receivable;**34,181,190**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ;ENTRY WITH DEBTOR PRINT STATEMENT 5 EN(DEB,TBAL,PDAT,PBAL,LDT) ; 6 NEW ADD,DA,LN,NAM,PAGE,SSN,X,X1,X2,Y 7 I '$D(SITE) D SITE^PRCAGU 8 S SSN=$$SSN^RCFN01(DEB),SSN=$S(SSN=-1:"XXXXXXXXX",1:SSN) 9 S ADD=$$SADD^RCFN01(8) I ADD="" S ADD=$$SADD^RCFN01(1) 10 S X=0 F Y=1:1:3 I $P(ADD,U,Y)]"" S X=X+1 S ADD(X)=$P(ADD,U,Y) 11 S X=X+1,ADD(X)=$P(ADD,U,4)_", "_$P(ADD,U,5)_" "_$P(ADD,U,6) 12 S X=X+1,ADD(X)=$P(ADD,U,7) 13 W @IOF 14 W !!,"Department of Veterans Affairs",?50,"Acct No.: ",SSN 15 W !,$G(ADD(1)) 16 S Y=$$FPS^RCAMFN01($S($G(LDT)>0:$E(LDT,1,5),1:$E(DT,1,5))_$TR($J($$PST^RCAMFN01(DEB),2)," ",0),$S(+$E($G(LDT),6,7)>$$STD^RCCPCFN:2,1:1)) D DD^%DT 17 W !,$G(ADD(2)),?50 I TBAL>0 W "Due: UPON RECEIPT" 18 W !,$G(ADD(3)),?50,$S(TBAL>0:"Amount Due: $"_$J(TBAL,0,2),1:"NO AMOUNT DUE") 19 W !,$G(ADD(4)),?50,$S(TBAL'>0:"*THIS IS NOT A BILL*",1:"Amount Paid: _____________") 20 W !,$G(ADD(5)),?50,"Today's Date: " S Y=DT D DD^%DT W Y 21 I TBAL'>0 D MES G LB 22 W !!,?2,"Please Make your Check or Money Order payable to the ""Department of Veterans" 23 W !,?2,"Affairs"" and send payment to the above address. If you have any questions" 24 W !,?2,"regarding this statement, please call the number listed above.",!!! 25 LB K ADD S NAM=$$NAM^RCFN01(DEB) 26 W !,?7,NAM 27 S ADD=$$DADD^RCAMADD(DEB,1) ; Get debtor address, confidential if applicable 28 S X=0 F Y=1:1:3 I $P(ADD,U,Y)]"" S X=X+1 S ADD(X)=$P(ADD,U,Y) 29 S X=X+1,ADD(X)=$P(ADD,U,4)_", "_$P(ADD,U,5)_" "_$P(ADD,U,6) 30 F X=0:0 S X=$O(ADD(X)) Q:'X W !,?7,$E(ADD(X),1,40) I X=1 W ?50 X $G(SITE("SCAN")) 31 W ! 32 I $G(SITE("COM1"))'="" W !,?2,SITE("COM1") 33 I $$GMT(DEB) W !,?2,"REDUCTION OF INPATIENT COPAYMENT DUE TO GEOGRAPHIC MEANS TEST STATUS" 34 W !! I TBAL>0 W !,?10,"Please Detach and Return Top Portion with Payment" 35 S Y="",$P(Y,"=",80)="" W !,Y 36 W !,"IMPORTANT: Please read the Notice of Rights accompanying this statement!",! 37 D ^PRCAGST1 38 Q 39 MES ;text for no amount due 40 W !!,?2,"This statement is being sent to you to provide you with information" 41 W !,?2,"concerning transactions affecting your account. If a prepayment offset" 42 W !,?2,"a bill or you have made one or more payments or charges were removed," 43 W !,?2,"from your account, you are being sent this statement to confirm these actions.",!! 44 Q 45 ; 46 ; Detect GMT-related status for the statement (fetch all patient's bills) 47 ; Input: Temporary global ^TMP("PRCAGT",$J,PRDEB) 48 ; Output: 1 - 'Yes', 0 - 'No' 49 GMT(PRDEB) N PRDAT,PRBN,PRGMT 50 S PRGMT=0 ; Default 51 I $G(PRDEB)'="" S PRDAT=0 F S PRDAT=$O(^TMP("PRCAGT",$J,PRDEB,PRDAT)) Q:'PRDAT D Q:PRGMT 52 . S PRBN=0 F S PRBN=$O(^TMP("PRCAGT",$J,PRDEB,PRDAT,PRBN)) Q:'PRBN D Q:PRGMT 53 .. I $$ISGMTBIL^IBAGMT($P($G(^PRCA(430,PRBN,0)),U,1)) S PRGMT=1 54 Q PRGMT -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST1.m
r613 r623 1 PRCAGST1 2 V ;;4.5;Accounts Receivable;**2,48,104,176,249**;Mar 20, 1995;Build 23 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 WRL(DAT,DESC,AMT,REF) 24 25 26 27 28 29 30 31 32 33 TRANDESC(PRTRAN,RCDESC) 34 35 36 37 38 39 AMOUNT(BN,TTY,AMT,THNK) 40 41 42 43 44 45 46 47 48 49 50 51 BILLDESC(PRBILL,RCDESC) 52 53 54 DAT(DAT) 55 56 57 HDR 58 59 60 61 W !,"Department of Veterans Affairs",?50,"Acct No.:",$P($$SITE^VASITE(),U,3)_"/"_$E(SSN,6,9) 62 63 64 65 66 1 PRCAGST1 ;WASH-ISC@ALTOONA,PA/CMS-Print Patient Statement Bottom ;10/16/96 11:13 AM 2 V ;;4.5;Accounts Receivable;**2,48,104,176**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ;ENTRY FROM PRCAGST PAGE 1 5 NEW AMT,BN,DAT,DESC,I,REF,THNK,TN,TTY,X,Y,RCTOTAL 6 D HDR 7 S DESC(1)="Previous Balance",REF="" D WRL(PDAT,.DESC,PBAL,REF) 8 S DAT=0 9 F S DAT=$O(^TMP("PRCAGT",$J,DEB,DAT)) Q:'DAT S BN=0 F S BN=$O(^TMP("PRCAGT",$J,DEB,DAT,BN)) Q:'BN D 10 . S REF=$P($G(^PRCA(430,BN,0)),"^") ; Get Bill Name 11 . I $D(^TMP("PRCAGT",$J,DEB,DAT,BN,0)) S AMT=+^(0) I AMT D Q 12 .. D BILLDESC(BN,.DESC) ; Compile bill description 13 .. D WRL(DAT,.DESC,AMT,REF) ; Print the item 14 . S TN=0 F S TN=$O(^TMP("PRCAGT",$J,DEB,DAT,BN,TN)) Q:'TN S AMT=^(TN) D 15 .. S TTY=$P(AMT,U,2) S AMT=+AMT 16 .. D AMOUNT(TN,TTY,.AMT,.THNK) ; Adjust Amount sign (+/-) and "Thank You" flag 17 .. D TRANDESC(TN,.DESC) ; Compile description 18 .. D WRL(DAT,.DESC,AMT,REF) ; Print the item 19 I ($Y+9)>(IOSL-2) D D HDR 20 . W !,"|" F I=12,46,9,12 S Y="",$P(Y,"_",I)="" W Y,"|" 21 D SUM^PRCAGST2 22 Q 23 WRL(DAT,DESC,AMT,REF) ;Write transaction 24 NEW LN,I,X,Y 25 S LN=1,X=0 F S X=$O(DESC(X)) Q:'X S LN=$G(LN)+1 26 I ($Y+LN)>(IOSL-2) D D HDR 27 . W !,"|" F I=12,46,9,12 S Y="",$P(Y,"_",I)="" W Y,"|" 28 W !,"|",$S($G(DAT):$$DAT(DAT),1:""),?12,"|",DESC(1),?58,"|",$J(AMT,8,2),?67,"|",?68,$G(REF),?79,"|" 29 F X=1:0 S X=$O(DESC(X)) Q:'X W !,"|",?12,"|",DESC(X),?58,"|",?67,"|",?79,"|" 30 Q 31 ; 32 ; Get transaction description array 33 TRANDESC(PRTRAN,RCDESC) N RCTOTAL 34 ; RCTOTAL not used in reprinted statements. 35 K RCDESC 36 D TRANDESC^RCCPCPS1(PRTRAN,45) ; returns RCDESC() array (max. length 45 characters) 37 Q 38 ; 39 AMOUNT(BN,TTY,AMT,THNK) ;Adjust (+/-) amount depending on Transaction Type 40 N BN0,CAT,TS 41 S BN0=$G(^PRCA(430,BN,0)),CAT=$$CATN^PRCAFN(+$P(BN0,U,2)) 42 I ",2,8,9,10,11,14,19,47,34,35,29,"[(","_TTY_",") I AMT'<0 S AMT=-AMT 43 I ",2,8,9,10,11,12,14,19,47,34,35,29,"'[(","_TTY_",") I AMT<0 S AMT=-AMT 44 I +CAT=33,TTY=1 I AMT<0 S AMT=-AMT 45 I +CAT=33,TTY=35 I AMT>0 S AMT=-AMT 46 S TS=$P($G(^PRCA(430.3,TTY,0)),U,3) I '$D(THNK),(TS=2!(TS=20)) S THNK=1 47 Q 48 ; Description for bills 49 ; Input: PRBILL - Bill IEN 50 ; Output: RCDESC(1..n) - Description Array 51 BILLDESC(PRBILL,RCDESC) K RCDESC 52 D BILLDESC^RCCPCPS1(PRBILL,45) ; returns RCDESC() array (max. length 45 characters) 53 Q 54 DAT(DAT) ;slash date 55 I 'DAT Q "" 56 Q $$SLH^RCFN01(DAT,"/") 57 HDR ;statement transaction header 58 NEW I,Y 59 S PAGE=$G(PAGE)+1 60 I PAGE>1 W @IOF I $G(^RC(342,1,5))]"" F I=1:1:18 W ! 61 W !,"Department of Veterans Affairs",?50,"Acct No.: ",SSN 62 W !,NAM,?50,"Page ",PAGE 63 S Y="",$P(Y,"_",80)="" W !,Y 64 W !,"|Date Posted|",?13," Description",?58,"| Amount ",?67,"| Reference |" 65 W !,"|" F I=12,46,9,12 S Y="",$P(Y,"_",I)="" W Y,"|" 66 Q -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCASVC.m
r613 r623 1 PRCASVC 2 V ;;4.5;Accounts Receivable;**1,21,48,90,136,138,249**;Mar 20, 1995;Build 23 4 REL 5 6 7 8 9 Q3 10 11 S:'$G(DA) DA=PRCASV("ARREC")S %=$$GETFUNDB^RCXFMSUF(DA)12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 FY 29 30 EXITFY 31 FY1 32 33 34 35 MEDICARE 36 37 38 39 40 41 1 PRCASVC ;SF-ISC/YJK-ACCEPT, AMMEND AND CANCEL AR BILL ;9/6/95 2:09 PM 2 V ;;4.5;Accounts Receivable;**1,21,48,90,136,138**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 REL ;Accept bill into AR 5 N X,Y 6 D ^PRCASVC6 G:$D(PRCAERR) Q3 S PRCADEBT=$O(^RCD(340,"B",PRCASV("DEBTOR"),0)) I 'PRCADEBT K DD,DO S DIC="^RCD(340,",DIC(0)="QL",X=PRCASV("DEBTOR"),DLAYGO=340 D FILE^DICN K DIC,DLAYGO,DO Q:Y<0 S PRCADEBT=+Y 7 D FY S PRCAT=$P(^PRCA(430.2,PRCASV("CAT"),0),"^",6) F Y="IDNO^4","GPNO^6","GPNM^5","INPA^1" S:$D(PRCASV($P(Y,"^"))) $P(^PRCA(430,PRCASV("ARREC"),202),"^",$P(Y,"^",2))=PRCASV($P(Y,"^")) 8 S DIE="^PRCA(430,",DR="[PRCASV REL]",DA=PRCASV("ARREC") D ^DIE 9 Q3 K PRCAT,PRCAORA,PRCADEBT,DIE,DR,% 10 ; set the fund for the bill (set in routine rcxfmsuf) 11 S %=$$GETFUNDB^RCXFMSUF(DA) 12 I "^27^28^"[("^"_PRCASV("CAT")_"^") D 13 .N P 14 .F P=6,8,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=6:1000,P=8:$G(PRCASV("SITE")),P=10:9,1:$P($G(PRCASV("FY")),"^")) 15 .S $P(^PRCA(430,DA,11),"^",18,999)="" 16 I PRCASV("CAT")=27 S $P(^PRCA(430,+PRCASV("ARREC"),0),"^",5)=$O(^PRCA(430.6,"B","CHMPV",0)) 17 I PRCASV("CAT")=29 S $P(^PRCA(430,DA,11),"^",18,999)="" 18 I "^30^31^32^"[("^"_PRCASV("CAT")_"^") D 19 .N RCCARE,P 20 .F P=8,9,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=8:$P(^PRCA(430,DA,0),"^",12),P=9:1,P=10:"02",1:$P($G(PRCASV("FY")),"^")) 21 .S $P(^PRCA(430,DA,11),"^",18)="" 22 .S RCCARE=$$TYP^IBRFN(DA),RCCARE(1)=$S(RCCARE="I":8028,RCCARE="O":8029,1:8030),$P(^PRCA(430,DA,11),"^",6)=RCCARE(1) 23 I $G(PRCASV("MEDCA"))!$G(PRCASV("MEDURE")) D MEDICARE 24 K DA 25 Q 26 ; 27 ; 28 FY K:$D(^PRCA(430,PRCASV("ARREC"),2)) ^(2) S PRCAK1=1,PRCAORA=0,^PRCA(430,PRCASV("ARREC"),2,0)="^430.01IA^^" 29 F J=1:1 S X=$P(PRCASV("FY"),U,PRCAK1),PRCAMT=+$P(PRCASV("FY"),U,PRCAK1+1) D FY1 S PRCAK1=PRCAK1+2 Q:$P(PRCASV("FY"),U,PRCAK1)="" 30 EXITFY K PRCAK1,J,PRCAMT Q 31 FY1 S DA(1)=PRCASV("ARREC"),DIC="^PRCA(430,"_DA(1)_",2,",DIC(0)="QL",DLAYGO=430 D ^DIC K DIC,DLAYGO Q:Y<0 S DA=+Y 32 S PRCAORA=PRCAORA+PRCAMT,$P(^PRCA(430,PRCASV("ARREC"),0),"^",3)=PRCAORA,$P(^(7),"^")=PRCAORA,$P(^(2,DA,0),U,2)=PRCAMT,$P(^(0),"^",8)=PRCAMT 33 K DA Q 34 ; 35 MEDICARE ;Setup Medicare Supplemental amounts 36 N DR,DIE 37 I $G(PRCASV("MEDCA")) S DIE="^PRCA(430,",DR="131////"_PRCASV("MEDCA") D ^DIE 38 I $G(PRCASV("MEDURE")) S DIE="^PRCA(430,",DR="132////"_PRCASV("MEDURE") D ^DIE 39 K PRCASV("MEDCA"),PRCASV("MEDURE") 40 Q ;MEDICARE 41 ; -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDMC90.m
r613 r623 1 RCDMC90 ;WASH IRMFO@ALTOONA,PA/TJK-DMC 90 DAY ;7/17/97 8:13 AM 2 V ;;4.5;Accounts Receivable;**45,108,133,121,163,190,192,236,237,229,253**;Mar 20, 1995;Build 9 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ENTER ;Entry point from nightly process 5 Q:'$D(RCDOC) 6 ;run the interest and admin for newly flagged Katrina Patients. 7 I DT'<$P($G(^RC(342,1,30)),"^",1)&(DT'>$P($G(^RC(342,1,30)),"^",2)) D ^RCEXINAD 8 N DEBTOR,BILL,DEBTOR0,B0,B6,B7,LTRDT3,P30DT,PRIN,INT,ADMIN,B4,B12 9 N TPRIN,TINT,TADMIN,ESTDT,CATYP,DFN,CNTR,SITE,LN,FN,MN,STNM,DOB,SITE 10 N PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,XN,P91DT,OFFAMT,RCNT,TLINE,REPAY,X1,X2 11 N LKUP,ADDR,ADDRPHO,CHKPHONE,PSSN 12 K ^XTMP("RCDMC90",$J),^TMP($J,"RCDMC90") S ^XTMP("RCDMC90",0)=DT 13 S SITE=$$SITE^RCMSITE(),TLINE="0^0^0" 14 S X1=DT,X2=-91 D C^%DTC S P91DT=X 15 S X1=DT,X2=-30 D C^%DTC S P30DT=X 16 S (CNTR,DEBTOR)=0,RCNT=2 G UPDATE:$G(RCDOC)="W" 17 ;MASTER SHEET COMPILATION 18 F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D 19 .N X,RCDFN 20 .S RCDFN=$P($G(^RCD(340,DEBTOR,0)),"^",1) I $P(RCDFN,";",2)'["DPT" Q 21 .S X=$$EMERES^PRCAUTL(+RCDFN) I X]""&('$D(^RCD(340,"DMC",1,DEBTOR))) Q ;stop the master sheet compilation for hurricane Katrina sites 22 .K ^TMP($J,"RCDMC90","BILL") 23 .S QUIT=1,OFFAMT=+$P($G(^RCD(340,DEBTOR,3)),U,9) 24 .D PROC(DEBTOR,.QUIT) Q:QUIT 25 .;COMPILES FIELDS UNIQUE TO MASTER CODE SHEETS 26 .S FULLNM=$$NM(DFN),FN=$P(FULLNM,U,3),MN=$P(FULLNM,U,4) 27 .S LN=$P(FULLNM,U,1),XN=$P(FULLNM,U,2) 28 .S FULLNM=FN_" "_$S(MN'="":$P(MN,".")_" ",1:"")_LN_$S(XN'="":" "_$P(XN,"."),1:"") 29 .S STNM=$$LJ^XLFSTR($E(FN)_$S(MN'="":$E(MN),1:" ")_$E(LN,1,5),7," ") 30 .S DOB=$$DATE8(+VADM(3)) 31 .;SET HOLDING GLOBAL FOR MASTER SHEETS 32 .S CNTR=CNTR+1 33 .S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_STNM_SITE_DOB_PHONE_$$LJ^XLFSTR(FULLNM,40)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,2),2) 34 .S CNTR=CNTR+1 35 .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,1),3,40),38)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,3)),1) 36 .S CNTR=CNTR+1 37 .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,3),2,40),39)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,40),40) 38 .S CNTR=CNTR+1 39 .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_$$DATE8(ESTDT)_$$AMT(TPRIN)_$$AMT(TINT)_$E($$AMT(TADMIN),1,4) 40 .S CNTR=CNTR+1 41 .S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TADMIN),5,9)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_$E("0000000000",1,10-$L(DEBTOR))_DEBTOR_"$" 42 .S $P(^RCD(340,DEBTOR,3),U)=1,$P(^(3),U,2)=DT,$P(^(3),U,3)=ESTDT,$P(^(3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN,^RCD(340,"DMC",1,DEBTOR)="" 43 .S X=0 F S X=$O(^TMP($J,"RCDMC90","BILL",X)) Q:'X S ^PRCA(430,X,12)=^(X) 44 .D SETREC 45 .Q 46 D COMPILE^RCDMC90U(375,CNTR,5,TLINE),KVAR 47 Q 48 UPDATE ;WEEKLY UPDATE COMPILATION 49 F S DEBTOR=$O(^RCD(340,"DMC",1,DEBTOR)) Q:DEBTOR'?1N.N D 50 .I '$G(^RCD(340,DEBTOR,3)) K ^RCD(340,"DMC",1,DEBTOR) Q 51 .S QUIT=1,OFFAMT=+$P(^RCD(340,DEBTOR,3),U,9) 52 .D PROC(DEBTOR,.QUIT) Q:QUIT 53 .;SET HOLDING GLOBAL FOR WEEKLY UPDATES 54 .S CNTR=CNTR+1 55 .S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,30),30) 56 .S CNTR=CNTR+1 57 .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,2),31,40),10)_$$LJ^XLFSTR($E($P(ADDR,U,3),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,29),29) 58 .S CNTR=CNTR+1 59 .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,4),30,40),11)_$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_SITE_PHONE_$E($$AMT(TPRIN),1,6) 60 .S CNTR=CNTR+1 61 .S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TPRIN),7,9)_$$AMT(TINT)_$$AMT(TADMIN)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_"$" 62 .S:TOTAL $P(^RCD(340,DEBTOR,3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN 63 .D SETREC 64 .Q 65 D COMPILE^RCDMC90U(300,CNTR,4,TLINE),KVAR 66 Q 67 KVAR D KVAR^VADPT 68 K RCDOC,^XTMP("RCDMC90",$J),VA("BID"),XMDUZ 69 Q 70 PROC(DEBTOR,QUIT) ;PROCESS BILLS FOR A SPECIFIC DEBTOR 71 ;SETS DATA COMMON TO BOTH WEEKLY & MASTER CODESHEETS 72 S DEBTOR0=$G(^RCD(340,DEBTOR,0)) 73 Q:$P(DEBTOR0,U)'["DPT" 74 S DFN=+DEBTOR0 D DEM^VADPT Q:$E(VADM(2),1,5)="00000" 75 F X=1:1:6 S CATYP(X)="" 76 S (BILL,TOTAL,TPRIN,TINT,TADMIN,REPAY)=0,ESTDT=P91DT 77 I RCDOC="W",$P(^RCD(340,DEBTOR,3),U,10) G TOTAL 78 F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D K:PRIN=0 ^PRCA(430,BILL,12) Q:REPAY 79 .S (PRIN,INT,ADMIN)=0 80 .I +VADM(6) Q 81 .S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B12=$G(^(12)) 82 .Q:$P(B0,U,8)'=16 83 .I B4 D Q 84 ..S (TOTAL,TPRIN,TINT,TADMIN)=0 85 ..S X=0 F S X=$O(^PRCA(430,"C",DEBTOR,X)) Q:X'?1N.N K ^PRCA(430,X,12) 86 ..S REPAY=1 87 ..Q 88 .I RCDOC="W",'$P(B12,U) Q 89 .S PRIN=$P(B7,U),INT=$P(B7,U,2),ADMIN=$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5) 90 .I PRIN'>0,INT+ADMIN>0 D Q 91 ..N XMSUB,XMY,XMTEXT,MSG 92 ..S XMSUB="Notice Of Active Bill Without Principal Balance" 93 ..S XMY("G.DMR")="" 94 ..S XMDUZ="AR PACKAGE" 95 ..S XMTEXT="MSG(" 96 ..S MSG(1)="The following bill has a 0 principal balance," 97 ..S MSG(2)="but has interest/admin charges remaining." 98 ..S MSG(3)="These charges should be exempted" 99 ..S MSG(4)=" " 100 ..S MSG(5)="BILL #: "_$P(B0,U) 101 ..D ^XMD 102 ..Q 103 .Q:$P(B4,U) 104 .S LTRDT3=$P(B6,U,3) Q:'LTRDT3 Q:LTRDT3>P30DT 105 .;CHECK FOR DC REFERRAL HERE 106 .I $P(B6,U,4),($P(B6,U,5)="DC")!($P(B6,U,5)="RC") Q 107 .;Q:$$INSURED^IBCNS1(DFN,$P(B0,U,10)) ;Commented out w/patch *121 108 .S X=$P(B0,U,2),X=$S(X=22:1,X=23:1,(X>2)&(X<6):2,X=18:2,X=24:2,X=25:2,X=1:3,X=2:4,(X>26)&(X<30):5,X>29:6,1:"") 109 .Q:X="" K CATYP(X) 110 .;Check if bill should be deferred from being sent to DMC if Veteran is 111 .;SC 50% to 100% or Receiving VA Pension (Hold Debt to DMC project, sbw) 112 .Q:+$$HOLDCHK^RCDMCUT1(BILL,DFN)>0 113 .I $P(B6,U,21),$P(B6,U,21)<ESTDT S ESTDT=$P($P(B6,U,21),".") 114 .I $P(B12,U,2),PRIN>$P(B12,U,2) S PRIN=$P(B12,U,2) 115 .S ^TMP($J,"RCDMC90","BILL",BILL)=$S($P(B12,U):$P(B12,U),1:DT)_U_PRIN_U_INT_U_ADMIN 116 .S TPRIN=TPRIN+PRIN,TINT=TINT+INT,TADMIN=TADMIN+ADMIN 117 .Q 118 TOTAL S TOTAL=TPRIN+TINT+TADMIN 119 I RCDOC="M" Q:TPRIN'>0 ;PRCA*4.5*229 120 I RCDOC="M",'+$$SWSTAT^IBBAPI() Q:TOTAL<25 ;PRCA*4.5*229 121 ; 122 I RCDOC="M",$P(VADM(2),U)["P" S PSSN=$P(VADM(2),U) D PSEUDO^RCDMC90U(DFN,PSSN) Q 123 I RCDOC="W" Q:(TOTAL_U_TPRIN_U_TINT_U_TADMIN)=$P(^RCD(340,DEBTOR,3),U,5,8) 124 S DFN=+DEBTOR0 125 ;SETS CATEGORY CODE 1=MEANS TEST,2=PHARMACY,3=INEL.,4=EMER./HUM. 126 ;5=CHAMPVA,6=TRICARE OR ANY COMBINATION THEREOF 127 S CATYP="" F X=1:1:6 S:'$D(CATYP(X)) CATYP=CATYP_X 128 S CATYP=$$LJ^XLFSTR(CATYP,6) 129 ; 130 ;Send Master/Weekly error msg if Unknown or Invalid address 131 ;If Master update, quit and don't refer to DMC 132 ;If Weekly update, send a zero balance 133 S LKUP=$$CHKADD(DEBTOR) 134 I LKUP D ERROR^RCDMC90U(RCDOC,LKUP,DFN) Q:RCDOC="M" S (TOTAL,TPRIN,TINT,TADMIN)=0 135 ; 136 S ZIPCODE=$TR($P(ADDR,U,6),"-") 137 ; 138 ;Retrieve and format patient phone number 139 S ADDRPHO=$P(ADDR,U,7),PHONE="" 140 F I=1:1:$L(ADDRPHO) S CHKPHONE=$E(ADDRPHO,I) I CHKPHONE?1N S PHONE=PHONE_CHKPHONE 141 S PHONE=$S(PHONE?10N:PHONE,PHONE?7N:" "_PHONE,1:" ") 142 ; 143 I RCDOC="W",TOTAL=0 D 144 .K ^RCD(340,"DMC",1,DEBTOR),^RCD(340,DEBTOR,3) 145 .N NM,XMSUB,XMY,XMTEXT,MSG 146 .S XMSUB="Deletion of Debtor from DMC" 147 .S XMY("G.DMX")="" 148 .S XMDUZ="AR PACKAGE" 149 .S XMTEXT="MSG(" 150 .S MSG(1)="The following patient has a DMC balance of '0'" 151 .S MSG(2)="and will be deleted from the DMC system:" 152 .S MSG(3)=" " 153 .S MSG(4)=$P(^DPT(DFN,0),U)_" SSN: "_$P(^(0),U,9) 154 .D ^XMD 155 .Q 156 S QUIT=0 157 PROCQ Q 158 DATE8(X) ;CHANGES FILEMAN DATE INTO 8 DIGIT DATE IN FORMAT MMDDYYYY 159 S X=$E(X,4,7)_($E(X,1,3)+1700) 160 Q X 161 AMT(X) ;CHANGES AMOUNT TO ZERO FILLED, RIGHT JUSTIFIED 162 S X=$TR($J(X,0,2),".") 163 S X=$E("000000000",1,9-$L(X))_X 164 Q X 165 NM(DFN) ;Returns first, middle, and last name in 3 different variables 166 N FN,LN,MN,NM,XN 167 S NM=$P($G(^DPT(DFN,0)),"^") 168 S LN=$TR($P(NM,",")," .'-"),MN=$P($P(NM,",",2)," ",2) 169 I ($E(MN,1,2)="SR")!($E(MN,1,2)="JR")!(MN?2.3"I")!(MN?0.1"I"1"V"1.3"I") S XN=MN,MN="" 170 I $G(XN)="" S XN=$P($P($G(NM),",",2)," ",3) 171 S FN=$P($P(NM,",",2)," ") 172 QNM Q LN_"^"_XN_"^"_FN_"^"_MN 173 BAL(DEBTOR) ;COMPUTES TOTAL OF ACTIVE BILLS THAT COULD BE SENT TO DMC 174 N BILL,BAL 175 S (BILL,BAL)=0 176 F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D 177 .S B0=$G(^PRCA(430,BILL,0)),B7=$G(^(7)) 178 .Q:$P(B0,U,8)'=16 179 .S X=$P(B0,U,2),X=$S((X>0)&(X<6):1,X=18:1,(X>21)&(X<26):1,(X>26)&(X<33):1,1:"") 180 .Q:X="" 181 .S BAL=BAL+$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5) 182 .Q 183 BALQ Q BAL 184 SETREC ;SETS TEMPORARY GLOBAL FOR MAIL MESSAGE TO USERS 185 S RCNT=RCNT+1 D PID^VADPT S:$L(VA("BID"))=4 VA("BID")=" "_VA("BID") 186 S TLINE=($P(TLINE,U)+TPRIN)_U_($P(TLINE,U,2)+TINT)_U_($P(TLINE,U,3)+TADMIN) 187 S ^XTMP("RCDMC90",$J,"REC",$P(^DPT(DFN,0),U)_";"_DFN)=$$LJ^XLFSTR($E($P(^DPT(DFN,0),U),1,28),29)_" "_VA("BID")_" "_$J(TPRIN,10,2)_$J(TINT,10,2)_$J(TADMIN,10,2)_$J(TOTAL,10,2) 188 Q 189 ; 190 CHKADD(DEBTOR) ; Checks for invalid and unknown addresses 191 N CHK S CHK=0,ADDR="" 192 I $P($G(^RCD(340,+DEBTOR,1)),"^",9)=1 S CHK=1 G CHKADDQ 193 S ADDR=$$DADD^RCAMADD(+DEBTOR,1) ;get address (confidential if possible) 194 I ADDR'?.ANP!(ADDR["$")!(ADDR["**")!(ADDR["///")!(ADDR["ZZZ") S CHK=2 195 CHKADDQ Q CHK 196 ; 1 RCDMC90 ;WASH IRMFO@ALTOONA,PA/TJK-DMC 90 DAY ;7/17/97 8:13 AM 2 V ;;4.5;Accounts Receivable;**45,108,133,121,163,190,192,236,237,229**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ENTER ;Entry point from nightly process 5 Q:'$D(RCDOC) 6 ;run the interest and admin for newly flagged Katrina Patients. 7 I DT'<$P($G(^RC(342,1,30)),"^",1)&(DT'>$P($G(^RC(342,1,30)),"^",2)) D ^RCEXINAD 8 N DEBTOR,BILL,DEBTOR0,B0,B6,B7,LTRDT3,P30DT,PRIN,INT,ADMIN,B4,B12 9 N TPRIN,TINT,TADMIN,ESTDT,CATYP,DFN,CNTR,SITE,LN,FN,MN,STNM,DOB,SITE 10 N PHONE,QUIT,TOTAL,ZIPCODE,FULLNM,XN,P91DT,OFFAMT,RCNT,TLINE,REPAY,X1,X2 11 N LKUP,ADDR,ADDRPHO,CHKPHONE,PSSN 12 K ^XTMP("RCDMC90",$J),^TMP($J,"RCDMC90") S ^XTMP("RCDMC90",0)=DT 13 S SITE=$$SITE^RCMSITE(),TLINE="0^0^0" 14 S X1=DT,X2=-91 D C^%DTC S P91DT=X 15 S X1=DT,X2=-30 D C^%DTC S P30DT=X 16 S (CNTR,DEBTOR)=0,RCNT=2 G UPDATE:$G(RCDOC)="W" 17 ;MASTER SHEET COMPILATION 18 F S DEBTOR=$O(^PRCA(430,"C",DEBTOR)) Q:DEBTOR'?1N.N D 19 .N X,RCDFN 20 .S RCDFN=$P($G(^RCD(340,DEBTOR,0)),"^",1) I $P(RCDFN,";",2)'["DPT" Q 21 .S X=$$EMERES^PRCAUTL(+RCDFN) I X]""&('$D(^RCD(340,"DMC",1,DEBTOR))) Q ;stop the master sheet compilation for hurricane Katrina sites 22 .K ^TMP($J,"RCDMC90","BILL") 23 .S QUIT=1,OFFAMT=+$P($G(^RCD(340,DEBTOR,3)),U,9) 24 .D PROC(DEBTOR,.QUIT) Q:QUIT 25 .;COMPILES FIELDS UNIQUE TO MASTER CODE SHEETS 26 .S FULLNM=$$NM(DFN),FN=$P(FULLNM,U,3),MN=$P(FULLNM,U,4) 27 .S LN=$P(FULLNM,U,1),XN=$P(FULLNM,U,2) 28 .S FULLNM=FN_" "_$S(MN'="":$P(MN,".")_" ",1:"")_LN_$S(XN'="":" "_$P(XN,"."),1:"") 29 .S STNM=$$LJ^XLFSTR($E(FN)_$S(MN'="":$E(MN),1:" ")_$E(LN,1,5),7," ") 30 .S DOB=$$DATE8(+VADM(3)) 31 .;SET HOLDING GLOBAL FOR MASTER SHEETS 32 .S CNTR=CNTR+1 33 .S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_STNM_SITE_DOB_PHONE_$$LJ^XLFSTR(FULLNM,40)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,2),2) 34 .S CNTR=CNTR+1 35 .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,1),3,40),38)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,3)),1) 36 .S CNTR=CNTR+1 37 .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,3),2,40),39)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,40),40) 38 .S CNTR=CNTR+1 39 .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_$$DATE8(ESTDT)_$$AMT(TPRIN)_$$AMT(TINT)_$E($$AMT(TADMIN),1,4) 40 .S CNTR=CNTR+1 41 .S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TADMIN),5,9)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_$E("0000000000",1,10-$L(DEBTOR))_DEBTOR_"$" 42 .S $P(^RCD(340,DEBTOR,3),U)=1,$P(^(3),U,2)=DT,$P(^(3),U,3)=ESTDT,$P(^(3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN,^RCD(340,"DMC",1,DEBTOR)="" 43 .S X=0 F S X=$O(^TMP($J,"RCDMC90","BILL",X)) Q:'X S ^PRCA(430,X,12)=^(X) 44 .D SETREC 45 .Q 46 D COMPILE^RCDMC90U(375,CNTR,5,TLINE),KVAR 47 Q 48 UPDATE ;WEEKLY UPDATE COMPILATION 49 F S DEBTOR=$O(^RCD(340,"DMC",1,DEBTOR)) Q:DEBTOR'?1N.N D 50 .I '$G(^RCD(340,DEBTOR,3)) K ^RCD(340,"DMC",1,DEBTOR) Q 51 .S QUIT=1,OFFAMT=+$P(^RCD(340,DEBTOR,3),U,9) 52 .D PROC(DEBTOR,.QUIT) Q:QUIT 53 .;SET HOLDING GLOBAL FOR WEEKLY UPDATES 54 .S CNTR=CNTR+1 55 .S ^XTMP("RCDMC90",$J,CNTR)=$E($$LJ^XLFSTR($P(VADM(2),U),9),1,9)_$$LJ^XLFSTR($E($P(ADDR,U,1),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,2),1,30),30) 56 .S CNTR=CNTR+1 57 .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,2),31,40),10)_$$LJ^XLFSTR($E($P(ADDR,U,3),1,40),40)_$$LJ^XLFSTR($E($P(ADDR,U,4),1,29),29) 58 .S CNTR=CNTR+1 59 .S ^XTMP("RCDMC90",$J,CNTR)=$$LJ^XLFSTR($E($P(ADDR,U,4),30,40),11)_$$LJ^XLFSTR($E($P(ADDR,U,5),1,40),40)_$$LJ^XLFSTR(ZIPCODE,9)_SITE_PHONE_$E($$AMT(TPRIN),1,6) 60 .S CNTR=CNTR+1 61 .S ^XTMP("RCDMC90",$J,CNTR)=$E($$AMT(TPRIN),7,9)_$$AMT(TINT)_$$AMT(TADMIN)_$$DATE8(DT)_CATYP_$$AMT(OFFAMT)_$$AMT($$BAL(DEBTOR))_"$" 62 .S:TOTAL $P(^RCD(340,DEBTOR,3),U,5)=TOTAL,$P(^(3),U,6)=TPRIN,$P(^(3),U,7)=TINT,$P(^(3),U,8)=TADMIN 63 .D SETREC 64 .Q 65 D COMPILE^RCDMC90U(300,CNTR,4,TLINE),KVAR 66 Q 67 KVAR D KVAR^VADPT 68 K RCDOC,^XTMP("RCDMC90",$J),VA("BID"),XMDUZ 69 Q 70 PROC(DEBTOR,QUIT) ;PROCESS BILLS FOR A SPECIFIC DEBTOR 71 ;SETS DATA COMMON TO BOTH WEEKLY & MASTER CODESHEETS 72 S DEBTOR0=$G(^RCD(340,DEBTOR,0)) 73 Q:$P(DEBTOR0,U)'["DPT" 74 S DFN=+DEBTOR0 D DEM^VADPT Q:$E(VADM(2),1,5)="00000" 75 F X=1:1:6 S CATYP(X)="" 76 S (BILL,TOTAL,TPRIN,TINT,TADMIN,REPAY)=0,ESTDT=P91DT 77 I RCDOC="W",$P(^RCD(340,DEBTOR,3),U,10) G TOTAL 78 F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D K:PRIN=0 ^PRCA(430,BILL,12) Q:REPAY 79 .S (PRIN,INT,ADMIN)=0 80 .I +VADM(6) Q 81 .S B0=$G(^PRCA(430,BILL,0)),B4=$G(^(4)),B6=$G(^(6)),B7=$G(^(7)),B12=$G(^(12)) 82 .Q:$P(B0,U,8)'=16 83 .I B4 D Q 84 ..S (TOTAL,TPRIN,TINT,TADMIN)=0 85 ..S X=0 F S X=$O(^PRCA(430,"C",DEBTOR,X)) Q:X'?1N.N K ^PRCA(430,X,12) 86 ..S REPAY=1 87 ..Q 88 .I RCDOC="W",'$P(B12,U) Q 89 .S PRIN=$P(B7,U),INT=$P(B7,U,2),ADMIN=$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5) 90 .I PRIN'>0,INT+ADMIN>0 D Q 91 ..N XMSUB,XMY,XMTEXT,MSG 92 ..S XMSUB="Notice Of Active Bill Without Principal Balance" 93 ..S XMY("G.DMR")="" 94 ..S XMDUZ="AR PACKAGE" 95 ..S XMTEXT="MSG(" 96 ..S MSG(1)="The following bill has a 0 principal balance," 97 ..S MSG(2)="but has interest/admin charges remaining." 98 ..S MSG(3)="These charges should be exempted" 99 ..S MSG(4)=" " 100 ..S MSG(5)="BILL #: "_$P(B0,U) 101 ..D ^XMD 102 ..Q 103 .Q:$P(B4,U) 104 .S LTRDT3=$P(B6,U,3) Q:'LTRDT3 Q:LTRDT3>P30DT 105 .;CHECK FOR DC REFERRAL HERE 106 .I $P(B6,U,4),($P(B6,U,5)="DC")!($P(B6,U,5)="RC") Q 107 .;Q:$$INSURED^IBCNS1(DFN,$P(B0,U,10)) ;Commented out w/patch *121 108 .S X=$P(B0,U,2),X=$S(X=22:1,X=23:1,(X>2)&(X<6):2,X=18:2,X=24:2,X=25:2,X=1:3,X=2:4,(X>26)&(X<30):5,X>29:6,1:"") 109 .Q:X="" K CATYP(X) 110 .I $P(B6,U,21),$P(B6,U,21)<ESTDT S ESTDT=$P($P(B6,U,21),".") 111 .I $P(B12,U,2),PRIN>$P(B12,U,2) S PRIN=$P(B12,U,2) 112 .S ^TMP($J,"RCDMC90","BILL",BILL)=$S($P(B12,U):$P(B12,U),1:DT)_U_PRIN_U_INT_U_ADMIN 113 .S TPRIN=TPRIN+PRIN,TINT=TINT+INT,TADMIN=TADMIN+ADMIN 114 .Q 115 TOTAL S TOTAL=TPRIN+TINT+TADMIN 116 I RCDOC="M" Q:TPRIN'>0 ;PRCA*4.5*229 117 I RCDOC="M",'+$$SWSTAT^IBBAPI() Q:TOTAL<25 ;PRCA*4.5*229 118 ; 119 I RCDOC="M",$P(VADM(2),U)["P" S PSSN=$P(VADM(2),U) D PSEUDO^RCDMC90U(DFN,PSSN) Q 120 I RCDOC="W" Q:(TOTAL_U_TPRIN_U_TINT_U_TADMIN)=$P(^RCD(340,DEBTOR,3),U,5,8) 121 S DFN=+DEBTOR0 122 ;SETS CATEGORY CODE 1=MEANS TEST,2=PHARMACY,3=INEL.,4=EMER./HUM. 123 ;5=CHAMPVA,6=TRICARE OR ANY COMBINATION THEREOF 124 S CATYP="" F X=1:1:6 S:'$D(CATYP(X)) CATYP=CATYP_X 125 S CATYP=$$LJ^XLFSTR(CATYP,6) 126 ; 127 ;Send Master/Weekly error msg if Unknown or Invalid address 128 ;If Master update, quit and don't refer to DMC 129 ;If Weekly update, send a zero balance 130 S LKUP=$$CHKADD(DEBTOR) 131 I LKUP D ERROR^RCDMC90U(RCDOC,LKUP,DFN) Q:RCDOC="M" S (TOTAL,TPRIN,TINT,TADMIN)=0 132 ; 133 S ZIPCODE=$TR($P(ADDR,U,6),"-") 134 ; 135 ;Retrieve and format patient phone number 136 S ADDRPHO=$P(ADDR,U,7),PHONE="" 137 F I=1:1:$L(ADDRPHO) S CHKPHONE=$E(ADDRPHO,I) I CHKPHONE?1N S PHONE=PHONE_CHKPHONE 138 S PHONE=$S(PHONE?10N:PHONE,PHONE?7N:" "_PHONE,1:" ") 139 ; 140 I RCDOC="W",TOTAL=0 D 141 .K ^RCD(340,"DMC",1,DEBTOR),^RCD(340,DEBTOR,3) 142 .N NM,XMSUB,XMY,XMTEXT,MSG 143 .S XMSUB="Deletion of Debtor from DMC" 144 .S XMY("G.DMX")="" 145 .S XMDUZ="AR PACKAGE" 146 .S XMTEXT="MSG(" 147 .S MSG(1)="The following patient has a DMC balance of '0'" 148 .S MSG(2)="and will be deleted from the DMC system:" 149 .S MSG(3)=" " 150 .S MSG(4)=$P(^DPT(DFN,0),U)_" SSN: "_$P(^(0),U,9) 151 .D ^XMD 152 .Q 153 S QUIT=0 154 PROCQ Q 155 DATE8(X) ;CHANGES FILEMAN DATE INTO 8 DIGIT DATE IN FORMAT MMDDYYYY 156 S X=$E(X,4,7)_($E(X,1,3)+1700) 157 Q X 158 AMT(X) ;CHANGES AMOUNT TO ZERO FILLED, RIGHT JUSTIFIED 159 S X=$TR($J(X,0,2),".") 160 S X=$E("000000000",1,9-$L(X))_X 161 Q X 162 NM(DFN) ;Returns first, middle, and last name in 3 different variables 163 N FN,LN,MN,NM,XN 164 S NM=$P($G(^DPT(DFN,0)),"^") 165 S LN=$TR($P(NM,",")," .'-"),MN=$P($P(NM,",",2)," ",2) 166 I ($E(MN,1,2)="SR")!($E(MN,1,2)="JR")!(MN?2.3"I")!(MN?0.1"I"1"V"1.3"I") S XN=MN,MN="" 167 I $G(XN)="" S XN=$P($P($G(NM),",",2)," ",3) 168 S FN=$P($P(NM,",",2)," ") 169 QNM Q LN_"^"_XN_"^"_FN_"^"_MN 170 BAL(DEBTOR) ;COMPUTES TOTAL OF ACTIVE BILLS THAT COULD BE SENT TO DMC 171 N BILL,BAL 172 S (BILL,BAL)=0 173 F S BILL=$O(^PRCA(430,"C",DEBTOR,BILL)) Q:BILL'?1N.N D 174 .S B0=$G(^PRCA(430,BILL,0)),B7=$G(^(7)) 175 .Q:$P(B0,U,8)'=16 176 .S X=$P(B0,U,2),X=$S((X>0)&(X<6):1,X=18:1,(X>21)&(X<26):1,(X>26)&(X<33):1,1:"") 177 .Q:X="" 178 .S BAL=BAL+$P(B7,U)+$P(B7,U,2)+$P(B7,U,3)+$P(B7,U,4)+$P(B7,U,5) 179 .Q 180 BALQ Q BAL 181 SETREC ;SETS TEMPORARY GLOBAL FOR MAIL MESSAGE TO USERS 182 S RCNT=RCNT+1 D PID^VADPT S:$L(VA("BID"))=4 VA("BID")=" "_VA("BID") 183 S TLINE=($P(TLINE,U)+TPRIN)_U_($P(TLINE,U,2)+TINT)_U_($P(TLINE,U,3)+TADMIN) 184 S ^XTMP("RCDMC90",$J,"REC",$P(^DPT(DFN,0),U)_";"_DFN)=$$LJ^XLFSTR($E($P(^DPT(DFN,0),U),1,28),29)_" "_VA("BID")_" "_$J(TPRIN,10,2)_$J(TINT,10,2)_$J(TADMIN,10,2)_$J(TOTAL,10,2) 185 Q 186 ; 187 CHKADD(DEBTOR) ; Checks for invalid and unknown addresses 188 N CHK S CHK=0,ADDR="" 189 I $P($G(^RCD(340,+DEBTOR,1)),"^",9)=1 S CHK=1 G CHKADDQ 190 S ADDR=$$DADD^RCAMADD(+DEBTOR,1) ;get address (confidential if possible) 191 I ADDR'?.ANP!(ADDR["$")!(ADDR["**")!(ADDR["///")!(ADDR["ZZZ") S CHK=2 192 CHKADDQ Q CHK 193 ; -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEM.m
r613 r623 1 RCDPEM 2 ;;4.5;Accounts Receivable;**173,255**;Mar 20, 1995;Build 1 3 4 5 6 7 EN 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 S RCZ=0 F S RCZ=$O(^RCY(344.3,"APOST",0,RCZ)) Q:'RCZ S RC0=$G(^RCY(344.3,RCZ,0)) I RC0'="",$P(RC0,U,8),($E($P(RC0,U,6),1,3)="469")!($E($P(RC0,U,6),1,3)="569") D28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 ENQ 70 71 72 MATCH(RCMAN,RCPROC) 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 MATCHQ 101 102 103 LOCKDEP(RCDEP,LOCK) 104 105 106 107 108 109 110 111 112 RCPTDET(RCRZ,RECTDA1,RCER) 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 DET(RCZ,RCR,RECTDA1,RCTRANDA) 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 1 RCDPEM ;ALB/TMK - POST EFT, ERA MATCHING TO EFT ;05-NOV-02 2 ;;4.5;Accounts Receivable;**173**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; IA 4050 covers call to SPL1^IBCEOBAR 5 Q 6 ; Note - keep processing in line with RCDPXPAP 7 EN ; Post EFT deposits, auto-match EFT's and ERA's 8 ; 9 K ^TMP($J,"RCDPETOT") 10 ; ^TMP($J,"RCDPETOT",344.3 or 344.31,file ien)= 11 ; (1) match (0/1/-1) (2) total $ (3) posted (0/1) (4) error ref 12 ; (5) EFT deposit ien 344.1 if added for EFT 13 ; 14 N RCZ,RCSUM,RCDEP,RECTDA,RC0,RCER,RCDUZ,Z,Z0,Z1,DA,X,Y,DIE,DR 15 M RCDUZ=DUZ 16 N DUZ S DUZ=+$O(^VA(200,"B","EDILOCKBOX,AUTOMATIC",0)),DUZ(0)="" S:'DUZ DUZ=.5 17 K ^TMP($J,"RCXM"),^TMP($J,"RCTOT") 18 S ZTREQ="@" 19 L +^RCY(344.3,"ALOCK"):5 I '$T D G ENQ ; Lock record 20 . ; Send bulletin that job could not be run 21 . S ^TMP($J,"RCXM",1)="The nightly job to post EFT deposits and match EFTs to ERAs could not be run",^TMP($J,"RCXM",2)="Another match process was already running (lock on ^RCY(344.3,""ALOCK"") )" 22 . D SENDBULL^RCDPEM1 23 ; 24 ; Post deposits for any unposted EFTs in file 344.3 25 ; 'Unposted' EFTs have a 0 in AMOUNT POSTED field 26 S ^TMP($J,"RCTOT","EFT_DEP")=0 27 S RCZ=0 F S RCZ=$O(^RCY(344.3,"APOST",0,RCZ)) Q:'RCZ S RC0=$G(^RCY(344.3,RCZ,0)) I RC0'="",$E($P(RC0,U,6),1,3)="469",$P(RC0,U,8) D 28 . S ^TMP($J,"RCTOT","EFT_DEP")=^TMP($J,"RCTOT","EFT_DEP")+1 29 . ; Verify check sums 30 . S RCSUM=$$CHKSUM^RCDPESR3(RCZ) 31 . I RCSUM'=$P(RC0,U,9) D Q 32 .. ; Bulletin that check sums do not match 33 .. ; Update record error list and checksum error field 34 .. S RCER(1)=$$SETERR^RCDPEM0(2) 35 .. S RCER(2)=" Checksum is invalid and the EFT deposit record is corrupted.",RCER(3)=" Stored Checksum = "_$P(RC0,U,9)_" Calculated Checksum: "_RCSUM,RCER(4)=" This EFT deposit cannot be sent to FMS. You must ask for it to be" 36 .. S RCER(5)=" retransmitted to your site." 37 .. D BULL^RCDPEM1(344.3,RC0,.RCER) 38 .. S $P(^TMP($J,"RCDPETOT",344.3,RCZ),U,4)=+$G(^TMP($J,"RCXM",0)) 39 .. D STORERR^RCDPEM0(RCZ,.RCER) 40 .. S DIE="^RCY(344.3,",DA=RCZ,DR=".1////1" D ^DIE 41 .. S ^TMP($J,"RCTOT","CSUM")=$G(^TMP($J,"RCTOT","CSUM"))+1 42 . ; 43 . S RCDEP=+$P(RC0,U,3),RECTDA=+$O(^RCY(344,"AD",RCDEP,0)) 44 . I RCDEP D LOCKDEP(RCDEP,1) 45 . I 'RCDEP!'RECTDA D ; Add deposit and/or receipt to files 344.1, 344 46 .. I 'RCDEP D ; Add dep record RCDEP, update field .03 with the pointer 47 ... S RCDEP=+$$ADDDEP^RCDPEM0($P(RC0,U,6),$P(RC0,U,7),RCZ) 48 ... S ^TMP($J,"RCTOT","DEPOSIT")=$G(^TMP($J,"RCTOT","DEPOSIT"))+1 49 .. ; 50 .. I 'RECTDA,RCDEP D ; Add receipt record, post to rev source cd 8NZZ 51 ... S RECTDA=+$$ADDREC^RCDPEM0(RCDEP,RCZ) 52 .. ; 53 . I RCDEP D LOCKDEP(RCDEP,0) 54 . ; 55 . I 'RCDEP!'RECTDA D Q ; Could not add entry to file 344.1 or 344 56 .. ; Send a bulletin, update error text 57 .. S RCER(1)=$$SETERR^RCDPEM0(2),RCER(2)=" "_$S('RCDEP:"Neither a deposit nor a receipt were able",1:"A receipt was not able")_" to be added - no match attempted" 58 .. I RCDEP,'RECTDA S RCER(3)=" Deposit Ticket # created: "_$P($G(^RCY(344.1,+$P(RC0,U,3),0)),U) 59 .. S RCER($O(RCER(""),-1)+1)="This EFT deposit can't be sent to FMS. You must ask Austin to retransmit" 60 .. D BULL^RCDPEM1(344.3,RC0,.RCER) 61 .. S $P(^TMP($J,"RCDPETOT",344.3,RCZ),U,4)=+$G(^TMP($J,"RCXM",0)) 62 .. D STORERR^RCDPEM0(RCZ,.RCER) 63 .. S ^TMP($J,"RCTOT","ERR")=$G(^TMP($J,"RCTOT","ERR"))+1 64 . ; 65 . S DIE="^RCY(344.31," S Z=0 F S Z=$O(^RCY(344.31,"B",RCZ,Z)) Q:'Z S DA=Z,DR=".11////1" D ^DIE 66 ; 67 D MATCH(0,1) 68 L -^RCY(344.3,"ALOCK") 69 ENQ K ^TMP($J,"RCDPETOT") 70 Q 71 ; 72 MATCH(RCMAN,RCPROC) ; Try to matched unmatched EFTs 73 ; RCMAN = 1 if job run manually, outside of nightly processing 74 ; RCPROC = 1 if called from EFT-EOB automatch, 0 if from manual match 75 ; 76 N RC0,RCER,RCZ,RCHAC 77 I '$O(^RCY(344.31,"AMATCH",0,0)) D G MATCHQ 78 . ; Send bulletin - no unmatched EFTs found 79 . N RCT 80 . S RCT=+$O(^TMP($J,"RCXM"," "),-1)+1 81 . S ^TMP($J,"RCXM",RCT)=$S('$G(RCMAN):"The nightly job",1:"The manual option")_" to match EFTs has found no EFTs are currently unmatched on your system" 82 . I $G(RCMAN) S ^TMP($J,"RCXM",RCT+1)="The action was initiated by "_$P($G(^VA(200,DUZ,0)),U) 83 . D SENDBULL^RCDPEM1 84 ; 85 S RCZ=0 F S RCZ=$O(^RCY(344.31,"AMATCH",0,RCZ)) Q:'RCZ D 86 . K RCER 87 . S RC0=$G(^RCY(344.31,RCZ,0)),RCHAC=($E($P($G(^RCY(344.3,+RC0,0)),U,6),1,3)="HAC") 88 . Q:RC0="" ; Bad xref 89 . Q:$S('RCHAC:'$P(RC0,U,11),1:0) ; EFT deposit must have been recorded 90 . S ^TMP($J,"RCTOT","EFT")=$G(^TMP($J,"RCTOT","EFT"))+1 91 . I RCHAC S ^TMP($J,"RCTOT","EFT_HAC")=$G(^TMP($J,"RCTOT","EFT_HAC"))+1 92 . S ^TMP($J,"RCDPETOT",344.31,RCZ)="" 93 . ; 94 . D MATCH^RCDPEM0(RCZ,RCPROC) 95 ; 96 I '$O(^TMP($J,"RCXM",0)) K RCER S RCER(1)="",RCER(2)="NO EXCEPTIONS WHILE MATCHING EFTs-ERAs OR IN RECORDING THE DEPOSITS TO FMS" D BULL^RCDPEM1("","",.RCER) K RCER 97 D EN2^RCDPEM1,BULL^RCDPEM1("","",.RCER) 98 D SENDBULL^RCDPEM1 99 ; 100 MATCHQ K ^TMP($J,"RCDPETOT"),^TMP($J,"RCTOT") 101 Q 102 ; 103 LOCKDEP(RCDEP,LOCK) ; Lock/confirm deposit ien RCDEP file 341.1 104 ; If LOCK = 1 lock deposit 105 ; If LOCK = 0 unlock deposit 106 I $G(LOCK) D 107 . L +^RCY(344.1,RCDEP,0) 108 . D CONFIRM^RCDPUDEP(RCDEP) ; confirm to prevent changes 109 I '$G(LOCK) L -^RCY(344.1,RCDEP,0) 110 Q 111 ; 112 RCPTDET(RCRZ,RECTDA1,RCER) ; Adds detail to a receipt based on file 344.49 113 ; RCRZ = ien of ERA entry in file 344.49 114 ; RECTDA1 = ien of receipt entry in file 344 115 ; RCER = error array returned if passed by reference 116 ; 117 N RCR,RCSPL,RCZ0,RCTRANDA,RCQ,DR,DA,DIE,X,Y,Q,Z0,Z1,Z 118 ; 119 S RCR=0 F S RCR=$O(^RCY(344.49,RCRZ,1,RCR)) Q:'RCR D 120 . S RCZ0=$G(^RCY(344.49,RCRZ,1,RCR,0)) 121 . I $P(RCZ0,U)'["." S RCSPL(+RCZ0)=$P(RCZ0,U,9) Q 122 . I $S(+$P(RCZ0,U,3)=0:$P($G(^RCY(344.49,RCRZ,0)),U,3),1:$P(RCZ0,U,3)<0) S RCSPL(RCZ0\1,+RCZ0)=RCZ0 Q 123 . S RCTRANDA=$$ADDTRAN^RCDPURET(RECTDA1) 124 . ; 125 . I 'RCTRANDA D Q ; Error adding receipt detail 126 .. S RCER(1)=$$SETERR^RCDPEM0() S RCER($O(RCER(""),-1)+1)=" NO DETAIL LINE ADDED TO RECEIPT "_$P($G(^RCY(344,RECTDA1,0)),U)_" FOR LINE #"_$P(RCZ0,U)_" IN EEOB WORKLIST SCRATCH PAD" 127 . ; 128 . ;Store receipt line detail 129 . D DET(RCRZ,RCR,RECTDA1,RCTRANDA) 130 . S RCSPL(RCZ0\1,+RCZ0)=RCZ0 131 S Z=0 F S Z=$O(RCSPL(Z)) Q:'Z S RCQ=+$G(RCSPL(Z)) I RCQ D 132 . S Z1=$O(RCSPL(Z,"")) Q:$O(RCSPL(Z,""),-1)=Z1 ; No split occurred 133 . S Z1=0 F S Z1=$O(RCSPL(Z,Z1)) Q:'Z1 S Z0=$G(RCSPL(Z,Z1)) D 134 .. S Q=+$P($G(^RCY(344.4,RCRZ,1,RCQ,0)),U,2) ; EOB detail rec 135 .. Q:'Q 136 .. I '$P(Z0,U,7)!($P(Z0,U,2)="") D ; Suspensed 137 ... D SPL1^IBCEOBAR(Q,$S($P(Z0,U,2)="":"NO BILL",1:$P(Z0,U,2)),"",$P(Z0,U,6)) ; IA 4050 138 .. E D 139 ... D SPL1^IBCEOBAR(Q,$P(Z0,U,2),$P(Z0,U,7),$P(Z0,U,6)) ; Add the split bill # ; IA 4050 140 ; 141 Q 142 ; 143 DET(RCZ,RCR,RECTDA1,RCTRANDA) ; Store receipt detail 144 ; RCZ = ien of entry file 344.49 145 ; RCR = ien of entry in file 344.491 146 ; RCPROC = Function calling this subroutine 147 ; = 1 EFT match to ERA = 0 manual add receipt 148 ; RECTDA1 = ien of entry in file 344 149 ; RCTRANDA = ien of entry in subfile 344.01 150 ; 151 N DIE,DA,DR,X,Y,Z,RCUP,RCCOM,RCZ0,RC0 152 S RC0=$G(^RCY(344.49,RCZ,0)) 153 S RCZ0=$G(^RCY(344.49,RCZ,1,RCR,0)) 154 S DR="",RCUP=+$O(^RCY(344.49,RCZ,1,"B",+RCZ0/1,0)),RCUP=$G(^RCY(344.49,RCZ,1,RCUP,0)) 155 I $P(RCZ0,U,7) S DR=".09////^S X="_+$P(RCZ0,U,7)_"_$C(59)_""PRCA(430,"";" 156 S DR=DR_".04////"_(+$P(RCZ0,U,3))_";"_$S($P(RC0,U,4)'="":".13////"_$P(RC0,U,4)_";",1:"")_".27////"_RCR_";" 157 I $P(RC0,U,5)'="" S DR=DR_".1////"_$P(RC0,U,5)_";" 158 I $P(RC0,U,6)'="" S DR=DR_".08////"_$P(RC0,U,6)_";" 159 S RCCOM=$P(RCZ0,U,10) 160 S Z=0 F S Z=$O(^RCY(344.49,RCZ,1,RCR,1,Z)) Q:'Z I $P($G(^(Z,0)),U,5)=1 S DR=DR_".28////1;" Q ; Update receipt line with dec adj flag 161 I $P(RCUP,U,2)["**ADJ" S DR=DR_"1.02////"_$E($S(RCCOM'="":RCCOM_"/",1:"")_$S($P($P(RCUP,U,2),"ADJ",2):"ERA adjustment - no bill referenced",1:"Total of EFT mismatched to ERA"),1,60)_";" 162 I $P($G(^RCY(344.49,RCZ,0)),U,4)'="" S DR=DR_".07////"_$P($G(^RCY(344.49,RCZ,0)),U,4)_";" 163 S DA(1)=RECTDA1,DA=RCTRANDA,DIE="^RCY(344,"_DA(1)_",1," 164 D ^DIE 165 Q 166 ; -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR2.m
r613 r623 1 RCDPESR2 ;ALB/TMK - Server auto-upd - EDI Lockbox ;06/03/02 2 ;;4.5;Accounts Receivable;**173,216,208,230,252**;Mar 20, 1995;Build 63 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; IA 4042 (IBCEOB) 5 ; 6 TASKERA(RCTDA) ; Task to upd ERA 7 ; RCTDA = ien 344.5 8 N ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN,ZTSK,DIE,DR,DA 9 S (ZTSAVE("DT"),ZTSAVE("U"),ZTSAVE("DUZ"))="",ZTSAVE("ZTREQ")="@",ZTRTN="NEWERA^RCDPESR2("_RCTDA_",0)",ZTDTH=$H,ZTIO="" 10 D ^%ZTLOAD 11 Q 12 ; 13 NEWERA(RCTDA,RCREFILE) ;Tasked 14 ; Add new EOB's to IB & ERA tot rec to AR 15 ; RCTDA = ien 344.5 16 ; RCREFILE = 1: re-filing rec via exc proc 17 N RCDUPERR,RCPAYER,RCRTOT,RCE,RCEC,RCERR,RCR1,RCADJ,DIE,DR,DA,Z,Q 18 S ZTREQ="@" 19 K ^TMP($J,"RCDPERA") 20 L +^RCY(344.5,RCTDA):5 21 I $D(ZTQUEUED) S DIE="^RCY(344.5,",DA=RCTDA,DR=".05////"_ZTSK_";.04////1" D ^DIE 22 I $P($G(^RCY(344.5,RCTDA,0)),U,5),'$G(RCREFILE) S DIE="^RCY(344.5,",DA=RCTDA,DR=".1////4;.08///1" D ^DIE 23 S RCR1=$P($G(^RCY(344.5,RCTDA,0)),U,7),RCPAYER=$P($G(^RCY(344.5,RCTDA,3)),U) 24 S RCRTOT=$S(RCR1:RCR1,1:$$ERATOT^RCDPESR6(RCTDA,.RCERR)) ; ERA rec 25 S RCDUPERR=$S($G(RCERR)="DUP"!($G(RCERR(1))=-2):$G(RCERR(1)),1:0) K RCERR(1) 26 I RCRTOT,'RCR1 S DIE="^RCY(344.5,",DR=".07////"_RCRTOT,DA=RCTDA D ^DIE 27 D:RCDUPERR'=-2 UPDEOB(RCTDA,5,$S('$G(RCREFILE):RCDUPERR,1:-1)) ; Add EOB det to IB 28 I RCRTOT D UPDCON^RCDPESR6(RCRTOT),UPDADJ^RCDPESR6(RCRTOT),UPD3444^RCDPESR6(.RCRTOT) ; Bills added 344.41 29 I RCRTOT,RCTDA S DIE="^RCY(344.5,",DR=".08////0;.1///@",DA=RCTDA D ^DIE 30 I 'RCRTOT D G QNEW 31 .I RCDUPERR Q:'RCTDA D S RCTDA="" Q 32 ..I RCDUPERR=-2 D BULLERA^RCDPESR0("D",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - DUPLICATE ERA NOT FILED "_$E(RCPAYER,1,20),.RCERR,0) 33 ..D TEMPDEL^RCDPESR1(RCTDA) 34 .S RCE(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" An error occurred while storing ERA data.",RCE(2)="No totals data was stored for this ERA record"_$S('$G(RCREFILE):" and an",1:" on this re-file attempt.") 35 .S RCE(3)=$S('$G(RCREFILE):"ERA transmission exception was created.",1:"") 36 .D WP^DIE(344.5,RCTDA_",",5,"A","RCE") 37 .S DIE="^RCY(344.5,",DA=RCTDA,DR=".07///@;.08////1;.1////1" D ^DIE 38 .K RCERR 39 .S RCERR(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" The ERA data could not be stored. The AR receipt",RCERR(2)=" for this data must be created/processed manually for the bills included" 40 .S RCERR(3)=" in this ERA."_$S('$G(RCREFILE):"",1:" This error occurred during a refile attempt."),RCERR(4)=" " 41 .D BULLERA^RCDPESR0("DF",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - TOTALS FILE EXCEPTION "_$E(RCPAYER,1,20),.RCERR,0) 42 .K RCERR 43 I $$ADJ^RCDPEU(RCRTOT,.RCADJ) D ;Bulletin adjs 44 .S RCEC=$$ADJERR^RCDPESR3(.RCERR) 45 .I RCADJ'=2 S RCEC=RCEC+1,RCERR(RCEC)=" THERE ARE ERA LEVEL ADJUSTMENT(S)",RCEC=RCEC+1,RCERR(RCEC)=" " 46 .I RCADJ'=1 S RCEC=RCEC+1,RCERR(RCEC)=" THE FOLLOWING BILL(S) HAVE RETRACTIONS:" D 47 ..S (Q,Z)=0 S Z=0 F S Z=$O(RCADJ(RCRTOT,Z)) Q:'Z S:'Q RCEC=RCEC+1,RCERR(RCEC)=" " S Q=Q+1,RCERR(RCEC)=RCERR(RCEC)_" "_RCADJ(RCRTOT,Z) S:Q=4 Q=0 48 ..S RCEC=RCEC+1,RCERR(RCEC)=" " 49 .D BULLERA^RCDPESR0("D",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - ERA HAS ADJ/TAKEBACKS "_$E(RCPAYER,1,20),.RCERR,0) 50 ; 51 QNEW I RCTDA,'$P($G(^RCY(344.5,RCTDA,0)),U,8) D TEMPDEL^RCDPESR1(RCTDA) S RCTDA="" 52 I RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U)'="" S DIE="^RCY(344.5,",DR=".04////0;.05///@"_$S('$G(RCR1)&$G(RCRTOT):";.07////"_RCRTOT,1:""),DA=RCTDA D ^DIE 53 K ^TMP($J,"RCDPERA") 54 I RCTDA L -^RCY(344.5,RCTDA) 55 Q 56 ; 57 UPDEOB(RCTDA,RCFILE,DUP) ;Upd 361.1 from ERA msg in 344.5 or .4 58 ;RCTDA = ien ERA msg in 344.5 or ;subfile in 344.4 59 ;RCFILE = 4 file 344.4, 5 if 344.5 60 ;DUP = msg # if dup msg, but not same # or -1 if same msg # 61 ;Returned for each bill in ERA: 62 ;^TMP($J,"RCDPEOB",n)=Bill ien^AR bill#^SrvDt 63 ;^TMP($J,"RCDPEOB",n,"EOB")=EOB ien^amt pd^ins co ptr^rev flg^EEOB pn^amtbld^^^^BPNPI^RNPI^ETQual^LN^FN 64 ;^TMP($J,"RCDPEOB","ADJ",x)=adj rec ('02') 65 ;Also: 66 ;^TMP($J,"RCDPEOB","HDR")=hdr rec from txmn 67 ;^TMP($J,"RCDPEOB","CONTACT")=ERA contact rec ('01') 68 ; 69 N RCGBL,RC,RC0,RCCT,RCCT1,RCEOB,RCBILL,RCDPBNPI,RCMNUM,RCIFN,RCIB,RCERR,RCSTAR,RCET,RCX,RCXMG,Z,Q,DA,DR,DIE,RCPAYER,RCFILED,RCEOBD,RCNOUPD,REFORM,RCSD,RCERR1,C5 70 K ^TMP($J,"RCDP-EOB"),^TMP("RCDPERR-EOB",$J) 71 ; 72 S RCPAYER="",RCFILED=1,RCNOUPD=0 73 I RCFILE=5 D 74 .S RCGBL=$NA(^RCY(344.5,RCTDA,2)) 75 .S RCMNUM=+$G(^RCY(344.5,RCTDA,0)),RCXMG=$P($G(^(0)),U,11) 76 .I $G(DUP) S RCNOUPD=$S(DUP>0:+DUP,1:RCXMG) 77 .S ^TMP($J,"RCDPEOB","HDR")=$G(^RCY(344.5,RCTDA,2,1,0)) 78 .I $P(^TMP($J,"RCDPEOB","HDR"),U)["XFR",'$P($G(^RCY(344.5,RCTDA,0)),U,14) D 79 ..D SENDACK^RCDPESR5(RCTDA,1) 80 ..S DR=".14////1",DIE="^RCY(344.5,",DA=RCTDA D ^DIE 81 ; 82 I RCFILE=4 D 83 .S RCGBL=$NA(^RCY(344.4,+RCTDA,1,+$P(RCTDA,";",2),1)) 84 .S RCMNUM=$P($G(^RCY(344.4,+RCTDA,0)),U,12),RCXMG=$P($G(^(0)),U,12) 85 .S ^TMP($J,"RCDPEOB","HDR")=$G(^RCY(344.4,+RCTDA,1,+$P(RCTDA,";",2),1,1,0)) 86 ; 87 S RCPAYER=$P($G(^TMP($J,"RCDPEOB","HDR")),U,6) 88 S RCDPBNPI=$P($G(^TMP($J,"RCDPEOB","HDR")),U,18) 89 ; 90 ;srv dates 91 S RCSD=$NA(^TMP($J,"RCSRVDT")) K @RCSD 92 S RC=1,C5=0 93 F S RC=$O(@RCGBL@(RC)) Q:'RC S RC0=$G(^(RC,0)) D 94 .I RC0<5 Q 95 .I +RC0=5 S C5=RC Q 96 .I +RC0=40,$P(RC0,U,2)?1.7N,C5,'$D(@RCSD@(C5)) S @RCSD@(C5)=$P(RC0,U,19) ;serv date 97 ; 98 S RC=1,(RCCT,RCCT1,RCX,REFORM)=0,RCBILL="" 99 S RCERR1=$NA(^TMP("RCERR1",$J)) K @RCERR1 100 F S RC=$O(@RCGBL@(RC)) Q:'RC S RC0=$G(^(RC,0)) D 101 .I RCFILE=5,+RC0=1 D Q 102 ..S ^TMP($J,"RCDPEOB","CONTACT")=RC0 103 .; 104 .I RCFILE=5,+RC0=2 D Q 105 ..S RCX=RCX+1,^TMP($J,"RCDPEOB","ADJ",RCX)=RC0 106 .; 107 .I +RC0=5 S RCCT=RCCT+1,RCCT1=0 D 108 ..S REFORM=0 109 ..S Z=$$BILL^RCDPESR1($P(RC0,U,2),$G(@RCSD@(RC)),.RCIB) 110 ..I Z S RCBILL=$P($G(^PRCA(430,Z,0)),U) I RCBILL'="",RCBILL'=$P(RC0,U,2) S REFORM=1,$P(RC0,U,2)=RCBILL 111 ..S RCBILL=$P(RC0,U,2) 112 ..S Z=$S(Z>0:$S($G(RCIB):Z,1:-1),1:-1) 113 ..S ^TMP($J,"RCDP-EOB",RCCT,0)=Z_U_RCBILL_U_$G(@RCSD@(RC)) 114 ..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,5)=$P(RC0,U,3)_","_$P(RC0,U,4)_" "_$P(RC0,U,5) ;Save pt nm 115 ..I Z>0 S Q=+$P($G(^PRCA(430,Z,0)),U,9) I $P($G(^RCD(340,Q,0)),U)["DIC(36," S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,3)=+^RCD(340,Q,0) ;Save ins co 116 .; 117 .I +RC0>5,REFORM S $P(RC0,U,2)=RCBILL ; 118 .I +RC0=10 D ;Save amt pd/billed, rev flg 119 ..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,2)=$S(+$P(RC0,U,11):$J($P(RC0,U,11)/100,"",2),1:0),$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,6)=$J($P(RC0,U,11),"",2) 120 ..I $P(RC0,U,6)="Y"!($P(RC0,U,7)=22) S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,4)=1 121 ..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,10,14)=RCDPBNPI_U_$P(RC0,U,16,19) 122 .I RCBILL=$P(RC0,U,2) S RCCT1=RCCT1+1,^TMP($J,"RCDP-EOB",RCCT,RCCT1,0)=RC0 123 ; 124 S RCSTAR=$TR($J("",15)," ","*"),RCET=RCSTAR_"ERROR/WARNING EEOB DETAIL SEQ #" 125 S RCCT=0 F S RCCT=$O(^TMP($J,"RCDP-EOB",RCCT)) Q:'RCCT S RCIFN=+$G(^(RCCT,0)),RCBILL=$P($G(^(0)),U,2),^TMP($J,"RCDPEOB",RCCT)=$G(^TMP($J,"RCDP-EOB",RCCT,0)) D 126 .S RCEOB=-1,RCEOBD="" 127 .I $S(RCIFN>0:$P(^PRCA(430.3,+$P($G(^PRCA(430,+RCIFN,0)),U,8),0),U,3)'=102,RCIFN'>0&($G(DUP)'>0):1,1:0) D 128 ..S @RCERR1@(RCCT)=" ",@RCERR1@(RCCT,1)=RCET_RCCT_RCSTAR 129 ..S @RCERR1@(RCCT,2)="Bill "_RCBILL_" is"_$S(RCIFN>0:" not in an ACTIVE status in your A/R",1:"n't valid/wasn't found so its detail wasn't stored in IB") 130 ..S:RCFILE=5 @RCERR1@(RCCT,"*")=@RCERR1@(RCCT,2) 131 ..S @RCERR1@(RCCT,3)=" The reported amount paid on this bill was: "_$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,2) 132 ..I RCIFN'>0 D 133 ...S @RCERR1@(RCCT,4)=" If the bill is not for your site, it must be transferred to the" 134 ...S @RCERR1@(RCCT,5)=" correct site and manually adjusted in your AR." 135 ...S @RCERR1@(RCCT,6)=" You can perform this transfer using EDI Lockbox ERA/EEOB exception process." 136 ...S @RCERR1@(RCCT,7)=" " 137 ..D DISP1^RCDPESR5(RCCT,1) 138 ..S Q=0 F S Q=$O(^TMP($J,"RCDP-EOB",RCCT,Q)) Q:'Q S ^TMP($J,"RCDPEOB",RCCT,Q)=$G(^TMP($J,"RCDP-EOB",RCCT,Q,0)) 139 ..S ^TMP($J,"RCDPEOB",RCCT)=^TMP($J,"RCDP-EOB",RCCT,0) M ^TMP($J,"RCDPEOB",RCCT,"ERR")=@RCERR1@(RCCT) 140 ..I RCFILE=5 D ;Store err if trans-in failed 141 ...N RCE,RC,DIE,X,Y,DA,DR 142 ...S RCE(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" "_$G(@RCERR1@(RCCT,"*")) 143 ...S RCE(2)=" ",RCFILED=0 144 ...D WP^DIE(344.5,RCTDA_",",5,"A","RCE") 145 .I RCIFN>0 D 146 ..N RCDUPEOB,RCALLDUP 147 ..;Chk rec exists 148 ..S RCDUPEOB=0 149 ..S RCEOB=$$DUP^RCDPESR3(RCMNUM,RCIFN,$P($G(^TMP($J,"RCDPEOB",RCCT,"EOB")),U,2),$P($G(^TMP($J,"RCDPEOB",RCCT,"EOB")),U,6)) ;Same msg for update? 150 ..I RCEOB,$P(RCEOB,U,2) S RCEOB=0 ;If chksum exists, let below check it 151 ..S ^TMP($J,"RCDP-EOB",RCCT,.5,0)="835ERA" ;Needed - checksum 152 ..S RCALLDUP=$$DUP^IBCEOB("^TMP("_$J_",""RCDP-EOB"","_RCCT_")",RCIFN) 153 ..I $S(RCALLDUP:1,RCEOB:$G(DUP)'>0,1:0) D 154 ...S RCDUPEOB=1 155 ...D DUPREC^RCDPESR6(RCET,RCCT,RCSTAR,RCFILE,RCALLDUP,RCEOB,RCBILL,.RCDUPEOB) 156 ...S:RCALLDUP RCEOBD=RCALLDUP 157 ..;Add stub to 361.1 158 ..I 'RCDUPEOB S RCEOB=+$$ADD3611^IBCEOB(RCMNUM,"","",RCIFN,1,"^TMP("_$J_",""RCDP-EOB"","_RCCT_")") ;IA 4042 159 ..K ^TMP($J,"RCDP-EOB",RCCT,.5,0) 160 ..I RCEOB<0 D:$G(DUP)'>0 Q 161 ...S @RCERR1@(RCCT)=" ",^(RCCT,1)=RCET_RCCT_RCSTAR,RCFILED=0 162 ...S @RCERR1@(RCCT,2)="Error - EEOB detail not added to IB for bill "_RCBILL,$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)="" 163 ...S:RCFILE=5 @RCERR1@(RCCT,"*")=@RCERR1@(RCCT,2) 164 ...D DISP1^RCDPESR5(RCCT,1) 165 ...S Q=0 F S Q=$O(^TMP($J,"RCDP-EOB",RCCT,Q)) Q:'Q S ^TMP($J,"RCDPEOB",RCCT,Q)=$G(^TMP($J,"RCDP-EOB",RCCT,Q,0)) 166 ...S ^TMP($J,"RCDPEOB",RCCT)=^TMP($J,"RCDP-EOB",RCCT,0) M ^TMP($J,"RCDPEOB",RCCT,"ERR")=@RCERR1@(RCCT) 167 ..;Upd 361.1, needs ^TMP($J,"RCDPEOB","HDR" and $J,"RCDP-EOB" 168 ..I RCDUPEOB'<0 S RCNOUPD=0 D UPD3611^IBCEOB(RCEOB,RCCT,1) 169 ..;errors in ^TMP("RCDPERR-EOB",$J 170 ..I $O(^TMP("RCDPERR-EOB",$J,0)) D ERRUPD^IBCEOB(RCEOB,"RCDPERR-EOB") 171 ..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)=$S('$G(RCEOBD):RCEOB,1:RCEOBD) 172 .K ^TMP("RCDPERR-EOB",$J) 173 ; 174 I RCNOUPD D DUPERA^RCDPESR3($G(DUP),RCNOUPD) 175 I $O(@RCERR1@("")) D BULLS^RCDPESR3(RCFILE,RCTDA,$S(RCNOUPD:RCNOUPD,1:$G(DUP)),$G(RCXMG)) 176 K ^TMP("RCDPERR-EOB",$J),^TMP($J,"RCDP-EOB"),@RCERR1,@RCSD 177 D CLEAN^DILF 178 Q 1 RCDPESR2 ;ALB/TMK - Server auto-upd - EDI Lockbox ;06/03/02 2 ;;4.5;Accounts Receivable;**173,216,208,230**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; IA 4042 (IBCEOB) 5 ; 6 TASKERA(RCTDA) ; Task to upd ERA 7 ; RCTDA = ien 344.5 8 N ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN,ZTSK,DIE,DR,DA 9 S (ZTSAVE("DT"),ZTSAVE("U"),ZTSAVE("DUZ"))="",ZTSAVE("ZTREQ")="@",ZTRTN="NEWERA^RCDPESR2("_RCTDA_",0)",ZTDTH=$H,ZTIO="" 10 D ^%ZTLOAD 11 Q 12 ; 13 NEWERA(RCTDA,RCREFILE) ;Tasked 14 ; Add new EOB's to IB & ERA tot rec to AR 15 ; RCTDA = ien 344.5 16 ; RCREFILE = 1: re-filing rec via exc proc 17 N RCDUPERR,RCPAYER,RCRTOT,RCE,RCEC,RCERR,RCR1,RCADJ,DIE,DR,DA,Z,Q 18 S ZTREQ="@" 19 K ^TMP($J,"RCDPERA") 20 L +^RCY(344.5,RCTDA):5 21 I $D(ZTQUEUED) S DIE="^RCY(344.5,",DA=RCTDA,DR=".05////"_ZTSK_";.04////1" D ^DIE 22 I $P($G(^RCY(344.5,RCTDA,0)),U,5),'$G(RCREFILE) S DIE="^RCY(344.5,",DA=RCTDA,DR=".1////4;.08///1" D ^DIE 23 S RCR1=$P($G(^RCY(344.5,RCTDA,0)),U,7),RCPAYER=$P($G(^RCY(344.5,RCTDA,3)),U) 24 S RCRTOT=$S(RCR1:RCR1,1:$$ERATOT^RCDPESR6(RCTDA,.RCERR)) ; ERA rec 25 S RCDUPERR=$S($G(RCERR)="DUP"!($G(RCERR(1))=-2):$G(RCERR(1)),1:0) K RCERR(1) 26 I RCRTOT,'RCR1 S DIE="^RCY(344.5,",DR=".07////"_RCRTOT,DA=RCTDA D ^DIE 27 D:RCDUPERR'=-2 UPDEOB(RCTDA,5,$S('$G(RCREFILE):RCDUPERR,1:-1)) ; Add EOB det to IB 28 I RCRTOT D UPDCON^RCDPESR6(RCRTOT),UPDADJ^RCDPESR6(RCRTOT),UPD3444^RCDPESR6(.RCRTOT) ; Bills added 344.41 29 I RCRTOT,RCTDA S DIE="^RCY(344.5,",DR=".08////0;.1///@",DA=RCTDA D ^DIE 30 I 'RCRTOT D G QNEW 31 .I RCDUPERR Q:'RCTDA D S RCTDA="" Q 32 ..I RCDUPERR=-2 D BULLERA^RCDPESR0("D",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - DUPLICATE ERA NOT FILED "_$E(RCPAYER,1,20),.RCERR,0) 33 ..D TEMPDEL^RCDPESR1(RCTDA) 34 .S RCE(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" An error occurred while storing ERA data.",RCE(2)="No totals data was stored for this ERA record"_$S('$G(RCREFILE):" and an",1:" on this re-file attempt.") 35 .S RCE(3)=$S('$G(RCREFILE):"ERA transmission exception was created.",1:"") 36 .D WP^DIE(344.5,RCTDA_",",5,"A","RCE") 37 .S DIE="^RCY(344.5,",DA=RCTDA,DR=".07///@;.08////1;.1////1" D ^DIE 38 .K RCERR 39 .S RCERR(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" The ERA data could not be stored. The AR receipt",RCERR(2)=" for this data must be created/processed manually for the bills included" 40 .S RCERR(3)=" in this ERA."_$S('$G(RCREFILE):"",1:" This error occurred during a refile attempt."),RCERR(4)=" " 41 .D BULLERA^RCDPESR0("DF",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - TOTALS FILE EXCEPTION "_$E(RCPAYER,1,20),.RCERR,0) 42 .K RCERR 43 I $$ADJ^RCDPEU(RCRTOT,.RCADJ) D ;Bulletin adjs 44 .S RCEC=$$ADJERR^RCDPESR3(.RCERR) 45 .I RCADJ'=2 S RCEC=RCEC+1,RCERR(RCEC)=" THERE ARE ERA LEVEL ADJUSTMENT(S)",RCEC=RCEC+1,RCERR(RCEC)=" " 46 .I RCADJ'=1 S RCEC=RCEC+1,RCERR(RCEC)=" THE FOLLOWING BILL(S) HAVE RETRACTIONS:" D 47 ..S (Q,Z)=0 S Z=0 F S Z=$O(RCADJ(RCRTOT,Z)) Q:'Z S:'Q RCEC=RCEC+1,RCERR(RCEC)=" " S Q=Q+1,RCERR(RCEC)=RCERR(RCEC)_" "_RCADJ(RCRTOT,Z) S:Q=4 Q=0 48 ..S RCEC=RCEC+1,RCERR(RCEC)=" " 49 .D BULLERA^RCDPESR0("D",RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U,11),"EDI LBOX - ERA HAS ADJ/TAKEBACKS "_$E(RCPAYER,1,20),.RCERR,0) 50 ; 51 QNEW I RCTDA,'$P($G(^RCY(344.5,RCTDA,0)),U,8) D TEMPDEL^RCDPESR1(RCTDA) S RCTDA="" 52 I RCTDA,$P($G(^RCY(344.5,RCTDA,0)),U)'="" S DIE="^RCY(344.5,",DR=".04////0;.05///@"_$S('$G(RCR1)&$G(RCRTOT):";.07////"_RCRTOT,1:""),DA=RCTDA D ^DIE 53 K ^TMP($J,"RCDPERA") 54 I RCTDA L -^RCY(344.5,RCTDA) 55 Q 56 ; 57 UPDEOB(RCTDA,RCFILE,DUP) ;Upd 361.1 from ERA msg in 344.5 or .4 58 ; RCTDA = ien ERA msg in 344.5 or ;subfile in 344.4 59 ; RCFILE = 4 file 344.4, 5 if 344.5 60 ; DUP = msg # if dup msg, but not same # or -1 if same msg # 61 ;Returned for each bill in ERA: 62 ; ^TMP($J,"RCDPEOB",n)=Bill ien^AR bill#^Service Date 63 ; ^TMP($J,"RCDPEOB",n,"EOB")=EOB ien^amt pd^ins co ptr^reversal flag^pt name on EEOB^amt billed 64 ; ^TMP($J,"RCDPEOB","ADJ",x)=adj rec ('02') 65 ;Also: 66 ; ^TMP($J,"RCDPEOB","HDR")=hdr rec from txmn 67 ; ^TMP($J,"RCDPEOB","CONTACT")=ERA contact rec ('01') 68 ; 69 N RCGBL,RC,RC0,RCCT,RCCT1,RCEOB,RCBILL,RCMNUM,RCIFN,RCIB,RCERR,RCSTAR,RCET,RCX,RCXMG,Z,Q,DA,DR,DIE,RCPAYER,RCFILED,RCEOBD,RCNOUPD,REFORM,RCSD,RCERR1,C5 70 K ^TMP($J,"RCDP-EOB"),^TMP("RCDPERR-EOB",$J) 71 ; 72 S RCPAYER="",RCFILED=1,RCNOUPD=0 73 I RCFILE=5 D 74 .S RCGBL=$NA(^RCY(344.5,RCTDA,2)) 75 .S RCMNUM=+$G(^RCY(344.5,RCTDA,0)),RCXMG=$P($G(^(0)),U,11) 76 .I $G(DUP) S RCNOUPD=$S(DUP>0:+DUP,1:RCXMG) 77 .S ^TMP($J,"RCDPEOB","HDR")=$G(^RCY(344.5,RCTDA,2,1,0)) 78 .I $P(^TMP($J,"RCDPEOB","HDR"),U)["XFR",'$P($G(^RCY(344.5,RCTDA,0)),U,14) D 79 ..D SENDACK^RCDPESR5(RCTDA,1) 80 ..S DR=".14////1",DIE="^RCY(344.5,",DA=RCTDA D ^DIE 81 ; 82 I RCFILE=4 D 83 .S RCGBL=$NA(^RCY(344.4,+RCTDA,1,+$P(RCTDA,";",2),1)) 84 .S RCMNUM=$P($G(^RCY(344.4,+RCTDA,0)),U,12),RCXMG=$P($G(^(0)),U,12) 85 .S ^TMP($J,"RCDPEOB","HDR")=$G(^RCY(344.4,+RCTDA,1,+$P(RCTDA,";",2),1,1,0)) 86 ; 87 S RCPAYER=$P($G(^TMP($J,"RCDPEOB","HDR")),U,6) 88 ; 89 ;srv dates 90 S RCSD=$NA(^TMP($J,"RCSRVDT")) K @RCSD 91 S RC=1,C5=0 92 F S RC=$O(@RCGBL@(RC)) Q:'RC S RC0=$G(^(RC,0)) D 93 .I RC0<5 Q 94 .I +RC0=5 S C5=RC Q 95 .I +RC0=40,$P(RC0,U,2)?1.7N,C5,'$D(@RCSD@(C5)) S @RCSD@(C5)=$P(RC0,U,19) ;serv date 96 ; 97 S RC=1,(RCCT,RCCT1,RCX,REFORM)=0,RCBILL="" 98 S RCERR1=$NA(^TMP("RCERR1",$J)) K @RCERR1 99 F S RC=$O(@RCGBL@(RC)) Q:'RC S RC0=$G(^(RC,0)) D 100 .I RCFILE=5,+RC0=1 D Q 101 ..S ^TMP($J,"RCDPEOB","CONTACT")=RC0 102 .; 103 .I RCFILE=5,+RC0=2 D Q 104 ..S RCX=RCX+1,^TMP($J,"RCDPEOB","ADJ",RCX)=RC0 105 .; 106 .I +RC0=5 S RCCT=RCCT+1,RCCT1=0 D 107 ..S REFORM=0 108 ..S Z=$$BILL^RCDPESR1($P(RC0,U,2),$G(@RCSD@(RC)),.RCIB) 109 ..I Z S RCBILL=$P($G(^PRCA(430,Z,0)),U) I RCBILL'="",RCBILL'=$P(RC0,U,2) S REFORM=1,$P(RC0,U,2)=RCBILL 110 ..S RCBILL=$P(RC0,U,2) 111 ..S Z=$S(Z>0:$S($G(RCIB):Z,1:-1),1:-1) 112 ..S ^TMP($J,"RCDP-EOB",RCCT,0)=Z_U_RCBILL_U_$G(@RCSD@(RC)) 113 ..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,5)=$P(RC0,U,3)_","_$P(RC0,U,4)_" "_$P(RC0,U,5) ;Save pt nm 114 ..I Z>0 S Q=+$P($G(^PRCA(430,Z,0)),U,9) I $P($G(^RCD(340,Q,0)),U)["DIC(36," S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,3)=+^RCD(340,Q,0) ;Save ins co 115 .; 116 .I +RC0>5,REFORM S $P(RC0,U,2)=RCBILL ; 117 .I +RC0=10 D ;Save amt pd/billed, rev flg 118 ..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,2)=$S(+$P(RC0,U,11):$J($P(RC0,U,11)/100,"",2),1:0),$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,6)=$J($P(RC0,U,11),"",2) 119 ..I $P(RC0,U,6)="Y"!($P(RC0,U,7)=22) S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,4)=1 120 .I RCBILL=$P(RC0,U,2) S RCCT1=RCCT1+1,^TMP($J,"RCDP-EOB",RCCT,RCCT1,0)=RC0 121 ; 122 S RCSTAR=$TR($J("",15)," ","*"),RCET=RCSTAR_"ERROR/WARNING EEOB DETAIL SEQ #" 123 S RCCT=0 F S RCCT=$O(^TMP($J,"RCDP-EOB",RCCT)) Q:'RCCT S RCIFN=+$G(^(RCCT,0)),RCBILL=$P($G(^(0)),U,2),^TMP($J,"RCDPEOB",RCCT)=$G(^TMP($J,"RCDP-EOB",RCCT,0)) D 124 .S RCEOB=-1,RCEOBD="" 125 .I $S(RCIFN>0:$P(^PRCA(430.3,+$P($G(^PRCA(430,+RCIFN,0)),U,8),0),U,3)'=102,RCIFN'>0&($G(DUP)'>0):1,1:0) D 126 ..S @RCERR1@(RCCT)=" ",@RCERR1@(RCCT,1)=RCET_RCCT_RCSTAR 127 ..S @RCERR1@(RCCT,2)="Bill "_RCBILL_" is"_$S(RCIFN>0:" not in an ACTIVE status in your A/R",1:"n't valid/wasn't found so its detail wasn't stored in IB") 128 ..S:RCFILE=5 @RCERR1@(RCCT,"*")=@RCERR1@(RCCT,2) 129 ..S @RCERR1@(RCCT,3)=" The reported amount paid on this bill was: "_$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,2) 130 ..I RCIFN'>0 D 131 ...S @RCERR1@(RCCT,4)=" If the bill is not for your site, it must be transferred to the" 132 ...S @RCERR1@(RCCT,5)=" correct site and manually adjusted in your AR." 133 ...S @RCERR1@(RCCT,6)=" You can perform this transfer using EDI Lockbox ERA/EEOB exception process." 134 ...S @RCERR1@(RCCT,7)=" " 135 ..D DISP1^RCDPESR5(RCCT,1) 136 ..S Q=0 F S Q=$O(^TMP($J,"RCDP-EOB",RCCT,Q)) Q:'Q S ^TMP($J,"RCDPEOB",RCCT,Q)=$G(^TMP($J,"RCDP-EOB",RCCT,Q,0)) 137 ..S ^TMP($J,"RCDPEOB",RCCT)=^TMP($J,"RCDP-EOB",RCCT,0) M ^TMP($J,"RCDPEOB",RCCT,"ERR")=@RCERR1@(RCCT) 138 ..I RCFILE=5 D ;Store err if trans-in failed 139 ...N RCE,RC,DIE,X,Y,DA,DR 140 ...S RCE(1)=$$FMTE^XLFDT($$NOW^XLFDT(),2)_" "_$G(@RCERR1@(RCCT,"*")) 141 ...S RCE(2)=" ",RCFILED=0 142 ...D WP^DIE(344.5,RCTDA_",",5,"A","RCE") 143 .I RCIFN>0 D 144 ..N RCDUPEOB,RCALLDUP 145 ..;Chk rec exists 146 ..S RCDUPEOB=0 147 ..S RCEOB=$$DUP^RCDPESR3(RCMNUM,RCIFN,$P($G(^TMP($J,"RCDPEOB",RCCT,"EOB")),U,2),$P($G(^TMP($J,"RCDPEOB",RCCT,"EOB")),U,6)) ;Same msg for update? 148 ..I RCEOB,$P(RCEOB,U,2) S RCEOB=0 ;If chksum exists, let below check it 149 ..S ^TMP($J,"RCDP-EOB",RCCT,.5,0)="835ERA" ;Needed - checksum 150 ..S RCALLDUP=$$DUP^IBCEOB("^TMP("_$J_",""RCDP-EOB"","_RCCT_")",RCIFN) 151 ..I $S(RCALLDUP:1,RCEOB:$G(DUP)'>0,1:0) D 152 ...S RCDUPEOB=1 153 ...D DUPREC^RCDPESR6(RCET,RCCT,RCSTAR,RCFILE,RCALLDUP,RCEOB,RCBILL,.RCDUPEOB) 154 ...S:RCALLDUP RCEOBD=RCALLDUP 155 ..;Add stub to 361.1 156 ..I 'RCDUPEOB S RCEOB=+$$ADD3611^IBCEOB(RCMNUM,"","",RCIFN,1,"^TMP("_$J_",""RCDP-EOB"","_RCCT_")") ;IA 4042 157 ..K ^TMP($J,"RCDP-EOB",RCCT,.5,0) 158 ..I RCEOB<0 D:$G(DUP)'>0 Q 159 ...S @RCERR1@(RCCT)=" ",^(RCCT,1)=RCET_RCCT_RCSTAR,RCFILED=0 160 ...S @RCERR1@(RCCT,2)="Error - EEOB detail not added to IB for bill "_RCBILL,$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)="" 161 ...S:RCFILE=5 @RCERR1@(RCCT,"*")=@RCERR1@(RCCT,2) 162 ...D DISP1^RCDPESR5(RCCT,1) 163 ...S Q=0 F S Q=$O(^TMP($J,"RCDP-EOB",RCCT,Q)) Q:'Q S ^TMP($J,"RCDPEOB",RCCT,Q)=$G(^TMP($J,"RCDP-EOB",RCCT,Q,0)) 164 ...S ^TMP($J,"RCDPEOB",RCCT)=^TMP($J,"RCDP-EOB",RCCT,0) M ^TMP($J,"RCDPEOB",RCCT,"ERR")=@RCERR1@(RCCT) 165 ..;Upd 361.1, needs ^TMP($J,"RCDPEOB","HDR" and $J,"RCDP-EOB" 166 ..I RCDUPEOB'<0 S RCNOUPD=0 D UPD3611^IBCEOB(RCEOB,RCCT,1) 167 ..;errors in ^TMP("RCDPERR-EOB",$J 168 ..I $O(^TMP("RCDPERR-EOB",$J,0)) D ERRUPD^IBCEOB(RCEOB,"RCDPERR-EOB") 169 ..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)=$S('$G(RCEOBD):RCEOB,1:RCEOBD) 170 .K ^TMP("RCDPERR-EOB",$J) 171 ; 172 I RCNOUPD D DUPERA^RCDPESR3($G(DUP),RCNOUPD) 173 I $O(@RCERR1@("")) D BULLS^RCDPESR3(RCFILE,RCTDA,$S(RCNOUPD:RCNOUPD,1:$G(DUP)),$G(RCXMG)) 174 K ^TMP("RCDPERR-EOB",$J),^TMP($J,"RCDP-EOB"),@RCERR1,@RCSD 175 D CLEAN^DILF 176 Q -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR3.m
r613 r623 1 RCDPESR3 2 ;;4.5;Accounts Receivable;**173,214,208,255**;Mar 20, 1995;Build 1 3 4 5 EFTIN(RCTXN,RCD,XMZ,RCGBL,RCEFLG) 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 EFTQ 61 62 63 64 ADDEFT(RCTXN,RCXMZ,RCGBL,RCERR) 65 66 67 68 69 70 71 72 73 74 I $E($P(RCTXN,U,6),1,3)'="469",$E($P(RCTXN,U,6),1,3)'="569",$E($P(RCTXN,U,6),1,3)'="HAC" D G ADDQ ; Invalid EFT deposit number75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 ADDQ 125 126 CHKSUM(RCTDA) 127 128 129 130 131 132 133 134 135 136 137 138 DISP(RCTIT,RCCT,RCDXM,RCXMZ) 139 140 141 142 143 144 145 146 147 148 149 150 151 152 DUP(RCM,RCIFN,RCAMT,RCAMT1) 153 154 155 156 157 158 159 160 161 162 163 164 165 166 DUPERA(DUP,RCNOUPD) 167 168 169 170 171 172 173 BULLS(RCFILE,RCTDA,DUP,RCXMSG) 174 175 176 177 178 ADJERR(RCERR) 179 180 181 182 1 RCDPESR3 ;ALB/TMK - Server auto-update utilities - EDI Lockbox ;06/06/02 2 ;;4.5;Accounts Receivable;**173,214,208**;Mar 20, 1995 3 Q 4 ; 5 EFTIN(RCTXN,RCD,XMZ,RCGBL,RCEFLG) ; Adds a new EFT record to AR file 344.3 6 ; from Lockbox EFT msg 7 ; RCTXN = the data on the header record of the message text 8 ; RCD = array containing formatted mail message header data 9 ; XMZ = the mail message number 10 ; RCGBL = the name of the array or global where the message is stored 11 ; RCEFLG = error flag returned if passed by reference 12 ; 13 N CT,RC,RC1,RCLAST,RCEFT,RCTDA,RCERR,RCTYP1,DA,DIK,RCZ,Z,Z0,DLAYGO 14 ; 15 ; Take data out of mail message 16 S (RCEFLG,RCLAST)=0,CT=0,RCTYP1="835EFT" 17 F X XMREC Q:XMER<0 D Q:RCLAST 18 . I +XMRG=99,$P(XMRG,U,2)="$" S RCLAST=1 Q 19 . S:XMRG'="" CT=CT+1,@RCGBL@(2,"D",CT)=XMRG 20 ; 21 I 'RCLAST,'$G(RCERR) K @RCGBL S RCERR=2 ;No $ as last character of msg 22 ; 23 I $G(RCERR)>0 D G EFTQ 24 . D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR) 25 . S RCEFLG=1 26 ; 27 ; Add top-level entry to file 344.3 28 S RCEFT=$$ADDEFT(RCTXN,XMZ,RCGBL,.RCERR) 29 ; 30 I $G(RCERR) D G EFTQ ; 'BAD' EFT's 31 . D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,.RCERR) 32 . S RCEFLG=1 33 ; 34 G:'RCEFT EFTQ 35 ; 36 ; Add the detail data to file 344.31 for this EFT record 37 S Z=0 F S Z=$O(^RCY(344.31,"B",RCEFT,Z)) Q:'Z S DA=Z,DIK="^RCY(344.31," D ^DIK ; Delete any detail data already there 38 ; 39 S (RC,RC1,RCZ)=0 40 F S RCZ=$O(@RCGBL@(2,"D",RCZ)) Q:'RCZ S Z0=$G(^(RCZ)) I Z0'="" D Q:$G(RCERR) 41 . I $P(Z0,U)="01" D ; Each payer's data 42 .. N DA,DIE,DR,X,Y,DO,DD,DIC 43 .. S X=RCEFT 44 .. S DIC("DR")=".11////0;.04////"_$P(Z0,U,2)_";.08////0"_$S($P(Z0,U,5)'="":";.02////"_$P(Z0,U,5),1:"")_$S($P(Z0,U,6)'="":";.03////"_$P(Z0,U,6),1:"")_";.07////"_$J(+$P(Z0,U,4)/100,"",2)_";.06////"_$S($P(Z0,U,8)'="":1,1:0) 45 .. S DIC("DR")=DIC("DR")_";.12///"_$$FDT^RCDPESR9($P(Z0,U,3))_";.13////"_DT_$S($P(Z0,U,7)'="":";.05////"_$P(Z0,U,7),1:"")_$S($P(Z0,U,9)'="":";.15////"_$P(Z0,U,9),1:"") 46 .. ; 47 .. I $P(Z0,U,8)'="" D ; tax id error 48 ... D TAXERR^RCDPESR1("EFT",$P(Z0,U,5)_" Payer ID: "_$P(RCTXN,U,6),$P(RCTXN,U,7),$P(RCTXN,U,8)) ; Send bad tax id bulletin 49 .. ; 50 .. S DIC(0)="L",DIC="^RCY(344.31,",DLAYGO=344.31 D FILE^DICN K DIC,DLAYGO,DO,DD 51 .. I Y'>0 D ; Error filing data 52 ... S DIK="^RCY(344.3,",DA=RCEFT D ^DIK 53 ... S Z=0 F S Z=$O(^RCY(344.31,"B",RCEFT,Z)) Q:'Z S DIK="^RCY(344.31,",DA=Z D ^DIK 54 ... S RCEFLG=1,RCERR=3 55 ... D ERRUPD^RCDPESR1(RCGBL,.RCD,RCTYP1,RCERR) 56 ; 57 I '$G(RCEFLG) D 58 . S DIE="^RCY(344.3,",DA=RCEFT,DR=".09////"_$$CHKSUM(RCEFT) D ^DIE 59 ; 60 EFTQ ; 61 D CLEAN^DILF 62 Q 63 ; 64 ADDEFT(RCTXN,RCXMZ,RCGBL,RCERR) ; File EFT TOTAL record in file 344.3 65 ; RCTXN = the data on the header record of the message text 66 ; RCXMZ = the mail message number 67 ; RCGBL = the name of the array or global where the message is stored 68 ; Function returns the ien of the total record found/added 69 ; and also returns RCERR if passed by reference 70 ; 71 N RCTDA,RCRCPT,RCDUP,RCHAC,Z,Z0 72 S (RCERR,RCTDA)="" 73 ; 74 I $E($P(RCTXN,U,6),1,3)'="469",$E($P(RCTXN,U,6),1,3)'="HAC" D G ADDQ ; Invalid EFT deposit number 75 . N RCDXM,RCCT 76 . S RCCT=0 77 . S RCCT=RCCT+1,RCDXM(RCCT)="This EFT has an invalid deposit number for EDI Lockbox and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" " 78 . S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:" 79 . D DISP("EDI LBOX INVALID EFT DEPOSIT #",RCCT,.RCDXM,RCXMZ) 80 ; 81 ; Make sure it's not already there or if so, it has no ptr to a deposit 82 ; or if a deposit exists, that the deposit does not yet have a receipt 83 S RCDUP=0,RCHAC=$E($P(RCTXN,U,6),1,3)="HAC" ; This is a HAC deposit 84 I $P(RCTXN,U,6)'="" D 85 . S Z=0 ; Lookup deposit by deposit # 86 . F S Z=$O(^RCY(344.3,"C",$P(RCTXN,U,6),Z)) Q:'Z S Z0=$G(^RCY(344.3,Z,0)) S:'$P(Z0,U,3) RCTDA=Z Q:RCTDA D Q 87 .. ; Deposit found - find receipt 88 .. I $O(^RCY(344,"AD",$P(Z0,U,3),0)) S RCDUP=Z Q 89 .. S RCTDA=Z 90 ; 91 I RCDUP D ; Send bulletin that duplicate EFT received 92 . N RCDXM,RCCT 93 . S RCCT=0 94 . S RCCT=RCCT+1,RCDXM(RCCT)="This EFT appears to be a duplicate transaction and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" " 95 . S RCCT=RCCT+1,RCDXM(RCCT)=" ",RCCT=RCCT+1,RCDXM(RCCT)="Here are the contents of this message:" 96 . D DISP("EDI LBOX DUP EFT DEPOSIT RECEIVED",RCCT,.RCDXM,RCXMZ) 97 ; 98 I 'RCDUP D ; Add or update the record 99 . N RCX,RCDTTM,DIE,DIC,DLAYGO,DD,DA,DO,DR,X,Y,%DT,DINUM 100 . ; 101 . S X=$$FDT^RCDPESR9($P(RCTXN,U,3))_"@"_$P(RCTXN,U,4) 102 . S %DT="XTS" D ^%DT S:Y>0 RCDTTM=Y 103 . ; 104 . S DIC("DR")="" 105 . S DIC("DR")=$S(RCDTTM'="":".02////"_RCDTTM,1:"") 106 . S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_".06////"_$P(RCTXN,U,6)_";.07///"_$$FDT^RCDPESR9($P(RCTXN,U,7)) 107 . S DIC("DR")=DIC("DR")_";.08////"_$$ZERO^RCDPESR9($P(RCTXN,U,8),1)_";.13////"_$$NOW^XLFDT()_";.05////"_RCXMZ_";.14////0;.12////0" 108 . ; 109 . I RCTDA D ; Overwrite the data already there 110 .. L +^RCY(344.3,RCTDA):1 I '$T S RCTDA=-1 Q 111 .. S DIE="^RCY(344.3,",DA=RCTDA,DR=DIC("DR") K DIC D ^DIE 112 .. L -^RCY(344.3,RCTDA) 113 . ; 114 . I 'RCTDA D 115 .. S RCX=+$O(^RCY(344.3," "),-1) 116 .. F RCX=RCX+1:1 I '$D(^RCY(344.3,RCX,0)) L +^RCY(344.3,RCX,0):1 I $T S X=RCX Q 117 .. S DIC(0)="L",DIC="^RCY(344.3,",DLAYGO=344.3,DINUM=RCX 118 .. D FILE^DICN K DO,DD,DLAYGO,DIC,DINUM 119 .. L -^RCY(344.3,RCX,0) 120 .. S RCTDA=$S(Y<0:"",1:+Y) 121 . ; 122 . I 'RCTDA S RCERR=3 ; Error in add of EFT record to file 344.3 123 ; 124 ADDQ Q $S(RCTDA>0:RCTDA,1:"") 125 ; 126 CHKSUM(RCTDA) ; Calc the checksum for EFT record stored in RCTDA in 344.3 127 ; 128 N RCDPCSUM,RCDPDATA,X,Y,Z,Z0 129 ; 130 S (RCDPCSUM,X)=0,Z0=$G(^RCY(344.3,RCTDA,0)) 131 ; Use pcs 1-8, leaving out piece 3 132 S RCDPDATA=$P(Z0,U,1,8),$P(RCDPDATA,U,3)="" 133 S X=RCDPCSUM_RCDPDATA X $S($G(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""") S RCDPCSUM=Y 134 ; Use detail iens and pieces 3,4,7 to complete the checksum 135 S Z=0 F S Z=$O(^RCY(344.31,"B",RCTDA,Z)) Q:'Z S Z0=$G(^RCY(344.31,Z,0)),RCDPDATA=Z_U_$P(Z0,U,3,4)_U_$P(Z0,U,7),X=RCDPCSUM_RCDPDATA X $S($G(^%ZOSF("LPC"))'="":^("LPC"),1:"S Y=""""") S RCDPCSUM=Y 136 Q RCDPCSUM 137 ; 138 DISP(RCTIT,RCCT,RCDXM,RCXMZ) ; Sends bulletin with formatted data from message 139 ; RCTIT = title of bulletin 140 ; RCCT = # of lines previously populated 141 ; RCXDM = array containing the text of the bulletin 142 N RC,Z 143 K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J) 144 S RC=1,^TMP("RCTEMP",$J,RC)=$G(^TMP("RCMSGH",$J,0)) 145 S Z=0 F S Z=$O(^TMP("RCMSG",$J,2,"D",Z)) Q:'Z S RC=RC+1,^TMP("RCTEMP",$J,RC)=$G(^TMP("RCMSG",$J,2,"D",Z)) 146 D DISP^RCDPESR8("^TMP(""RCTEMP"",$J)","^TMP(""RC1"",$J)",1,"^TMP(""RC"",$J)",75) 147 S Z=0 F S Z=$O(^TMP("RC",$J,Z)) Q:'Z S RCCT=RCCT+1,RCDXM(RCCT)=$G(^TMP("RC",$J,Z)) 148 D BULLEFT^RCDPESR0("",RCXMZ,RCTIT,.RCDXM) 149 K ^TMP("RC1",$J),^TMP("RC",$J),^TMP("RCTEMP",$J) 150 Q 151 ; 152 DUP(RCM,RCIFN,RCAMT,RCAMT1) ; EOB in mail message already stored in 361.1? 153 ; RCM = msg # EOB was received in 154 ; RCIFN = bill ien 155 ; RCAMT = amt pd 156 ; RCAMT1 = amt reported billed 157 ; Returns 0 if none found, entry #^message checksum on file if found 158 N Z,DUP,DUP1 159 S (DUP,DUP1,Z)=0 160 F S Z=$O(^IBM(361.1,"AC",RCM,Z)) Q:'Z I +$G(^IBM(361.1,Z,0))=RCIFN D Q:DUP 161 . I '$P($G(^IBM(361.1,Z,100)),U,5) S DUP1=Z Q ; Partially filed before 162 . I +$G(^IBM(361.1,Z,1))=+RCAMT,+$P($G(^IBM(361.1,1,Z,2)),U,4)=+RCAMT1 S DUP=Z_U_+$P($G(^IBM(361.1,Z,100)),U,5) Q 163 I 'DUP,DUP1 S DUP=DUP1_"^0" 164 Q DUP 165 ; 166 DUPERA(DUP,RCNOUPD) ; Msg for duplicate ERA 167 ; RCNOUPD = # of message with duplicate data 168 ; DUP = flag = -1 if duplicate message received in same mail msg # 169 K ^TMP("RCERR1",$J) 170 S ^TMP("RCERR1",$J,1)=$S(DUP>0:"This an exact duplicate of an ERA received previously in mail msg "_RCNOUPD,1:"This ERA message was already fully processed - message was ignored") 171 Q 172 ; 173 BULLS(RCFILE,RCTDA,DUP,RCXMSG) ; Error bulletins for ERA 174 I RCFILE=5 D BULL1^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",$S($G(DUP)>0:$G(DUP),1:"")) 175 I RCFILE=4 D BULL2^RCDPESR5(RCTDA,"^TMP(""RCERR1"",$J)",RCXMSG) 176 Q 177 ; 178 ADJERR(RCERR) ; Set up adj error text in RCERR(n) - pass by ref 179 ; Function returns # of lines for error text 180 S RCERR(1)="At least 1 adjustment transaction has been found on this ERA. Before the",RCERR(2)=" receipt for this ERA can be processed, the appropriate adjustments",RCERR(3)=" must be made using the EEOB Worklist",RCERR(4)=" " 181 Q 4 182 ; -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR6.m
r613 r623 1 RCDPESR6 ;ALB/TMK - Server auto-update file 344.4 - EDI Lockbox ;10/29/02 2 ;;4.5;Accounts Receivable;**173,214,208,230,252**;Mar 20, 1995;Build 63 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 UPD3444(RCRTOT) ; Add EOB detail to list in 344.41 for file 344.4 entry RCRTOT 6 ; If passed by reference, RCRTOT is returned = "" if errors 7 ; 8 N RC,RCCOM1,RCCOM2,RCCT,RC1,RC2,RCDPNM,RCEOB,RCNPI1,RCNPI2,DA,DR,DO,DD,DLAYGO,DIC,DIK,X,Y,Z 9 S RC=0 F S RC=$O(^TMP($J,"RCDPEOB",RC)) Q:'RC S RC1=$G(^(RC)),RC2=$G(^(RC,"EOB")),RCEOB=+RC2 D Q:'RCRTOT 10 . ; Upd 344.41 with reference to this record if it doesn't already exist 11 . I RCEOB>0 Q:$D(^RCY(344.4,RCRTOT,1,"AC",RCEOB,RC)) 12 . I RCEOB'>0,$S($P(RC1,U,2)'="":$D(^RCY(344.4,RCRTOT,1,"AD",$P(RC1,U,2),RC)),1:0) Q 13 . ; Disregard ECME reject related EEOBs 14 . I RCEOB'>0,'$P(RC2,U,2),$P(RC1,U,2)?1.7N,$$REJECT^IBNCPDPU($P(RC1,U,2),$P(RC1,U,3)) Q 15 . S DA(1)=RCRTOT,X=RC,DIC="^RCY(344.4,"_DA(1)_",1,",DIC(0)="L",DLAYGO=344.41 16 . S DIC("DR")=$S($G(RCEOB)>0:".02////"_RCEOB,1:".05////"_$P(RC1,U,2)_";.07////1") 17 . I $P(RC2,U,2)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".03///"_$P(RC2,U,2) ; amt 18 . I $P(RC2,U,3)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".04////"_$P(RC2,U,3) ; ins co 19 . I $P(RC2,U,4) S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".14////1" ; reversal 20 . I $P(RC2,U,5)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".15////^S X=$E($P(RC2,U,5),1,30)" ; Patient name 21 . ; Process Billing Prov NPI, Rendering/Servicing NPI & name 22 . S (RCCOM1,RCCOM2)="" 23 . S RCNPI1=$P(RC2,U,10),RCNPI2=$P(RC2,U,11) 24 . I RCNPI1'="",'$$CHKDGT^XUSNPI(RCNPI1) S RCCOM1="The Billing Provider NPI received on the 835 ("_$E(RCNPI1,1,10)_") is not a valid format." 25 . I RCNPI2'="",'$$CHKDGT^XUSNPI(RCNPI2) S RCCOM2="The "_$S($P(RC2,U,12)=1:"Rendering",1:"Servicing")_" NPI received on the 835 ("_$E(RCNPI2,1,10)_") is not a valid format." 26 . I RCCOM1="" S DIC("DR")=DIC("DR")_";.18////^S X=$P(RC2,U,10)" ;Billing Provider NPI 27 . I RCCOM2="" S DIC("DR")=DIC("DR")_";.19////^S X=$P(RC2,U,11)" ;Rendering Provider NPI 28 . S RCDPNM=$P(RC2,U,13) I $P(RC2,U,14)]"" S RCDPNM=RCDPNM_$S(RCDPNM]"":",",1:"")_$P(RC2,U,14) 29 . S DIC("DR")=DIC("DR")_";.2////^S X=$P(RC2,U,12);.21////^S X=RCDPNM" ; Entity Type Qualifier ^ Last name,First Name 30 . S DIC("DR")=DIC("DR")_";.22////^S X=RCCOM1;.23////^S X=RCCOM2" ;Comment on Billing provider^comment on rendering/servicing provider NPI 31 . D FILE^DICN K DO,DD,DLAYGO,DIC,DIK 32 . S RCCT=+Y 33 . I RCCT<0 D Q 34 .. S DA=RCRTOT,DIK="^RCY(344.4," D ^DIK 35 .. S RCRTOT=0 36 . ; If there is no IB EOB record, store the raw data in 344.411 37 . I RC1'>0!(RCEOB'>0) D 38 .. N RCDATA,RCC,RCDA 39 .. S RCC=2,RCDATA(1)=$G(^TMP($J,"RCDPEOB","HDR")) 40 .. S Z=0 F S Z=$O(^TMP($J,"RCDPEOB",RCCT,Z)) Q:'Z S RCC=RCC+1,RCDATA(RCC)=$G(^TMP($J,"RCDPEOB",RCCT,Z)) 41 .. S RCDA(1)=RCRTOT,RCDA=RCCT 42 .. D WP^DIE(344.41,$$IENS^DILF(.RCDA),1,"A","RCDATA") 43 Q 44 ; 45 ; 46 ERATOT(RCTDA,RCERR) ; File ERA TOTAL rec in 344.4 from entry RCTDA in 344.5 47 ; RCTDA = ien file 344.5 48 ; Returns: the ien file 344.4 49 ; RCERR if passed by reference, with error text 50 ; RCERR(1)=duplicated message 51 N RCTYPE,RCDA,RCMETH,RCTRACE,RCID,RCDT,RCAMT,RCDUP,RCZ,RCX,RCPAYER,DIE,DIK,DIC,DLAYGO,DD,DO,DR,DA,X,Y,Z0,Z1 52 S (RCERR,RCDA)="" 53 S RCZ=$G(^RCY(344.5,RCTDA,2,1,0)) 54 S RCTYPE=$P(RCZ,U),RCTRACE=$P(RCZ,U,8),RCID=$P(RCZ,U,7),RCPAYER=$P(RCZ,U,6),RCMETH=$P(RCZ,U,17) 55 ; Need header record as first entry in field 56 I RCTYPE'["835ERA" S RCERR="No header record found in message. An EEOB exception record was created" G ERATOTQ 57 ; 58 S RCDT=$$FMDT^RCDPESR1($P(RCZ,U,9)),RCAMT=$J(($P(RCZ,U,10)/100),0,2) 59 ;Elec ERA's must have a trace # and an ins co id 60 I RCTRACE=""!(RCID="") S RCERR="Trace # or ins ID missing on ERA transaction. An EEOB exception record was created." G ERATOTQ 61 ; Make sure it's not already there 62 S (RCDUP,Z1)=0 63 F S Z1=$O(^RCY(344.4,"ATRID",RCTRACE,RCID,Z1)) Q:'Z1 S Z0=$G(^RCY(344.4,Z1,0)) I $P(Z0,U,4)=RCDT,+$P(Z0,U,5)=+RCAMT S RCDUP=1 Q 64 ; 65 I RCDUP,$P(Z0,U,8) D G ERATOTQ ; Receipt already exists - no update 66 . S RCERR="This is a duplicate ERA and has already been posted",RCERR(1)=-2 67 I RCDUP S RCERR="DUP",RCERR(1)=$S($P(Z0,U,12)'=$P($G(^RCY(344.5,RCTDA,0)),U,11):$P(Z0,U,12),1:-1) G ERATOTQ 68 ; 69 S RCX=+$O(^RCY(344.4," "),-1) 70 S DIC(0)="L",DIC="^RCY(344.4,",DLAYGO=344.4 71 S DIC("DR")=".02////"_RCTRACE_";.03////"_RCID_";.04////"_RCDT_";.05////"_RCAMT_";.06////"_$P(RCZ,U,6)_";.09////0;.12////"_$P($G(^RCY(344.5,RCTDA,0)),U,11)_";.07////"_$$NOW^XLFDT()_";.1////1" 72 I RCMETH'="" S DIC("DR")=DIC("DR")_";.15////"_RCMETH 73 F RCX=RCX+1:1 L +^RCY(344.4,RCX,0):1 I $T,'$D(^RCY(344.4,RCX,0)) S X=RCX Q 74 D FILE^DICN K DO,DLAYGO,DD,DIC 75 L -^RCY(344.4,RCX,0) 76 S RCDA=$S(Y<0:"",1:+Y) 77 I 'RCDA D 78 . S RCERR="An error was encountered that prevented the adding of an ERA totals record. An EEOB exception record was created." 79 ; 80 ERATOTQ Q RCDA 81 ; 82 UPDCON(RCRTOT) ; Add contact information to file 344.4 for an ERA 83 N DIE,DA,DR,Z,Q,X,Y 84 S Z=$G(^TMP($J,"RCDPEOB","CONTACT")) 85 Q:$TR($P(Z,U,3,9),U)="" 86 S DA=RCRTOT,DIE="^RCY(344.4,",DR="" 87 F Q=3:1:9 S DR=DR_$S(DR'="":";3.0",1:"3.0")_(Q-2)_"///"_$S($P(Z,U,Q)="":"@",1:"/"_$P(Z,U,Q)) 88 D ^DIE 89 Q 90 ; 91 UPDADJ(RCRTOT) ; Add ERA level adj data to file 344.4 92 N Z,Z0,DA,DIC,DLAYGO,DR,X,Y,DO,DD 93 ; Remove any already there 94 S Z=0 F S Z=$O(^RCY(344.4,RCRTOT,2,Z)) Q:'Z S DA(1)=RCRTOT,DA=Z D ^DIK 95 ; 96 S Z=0 F S Z=$O(^TMP($J,"RCDPEOB","ADJ",Z)) Q:'Z S Z0=$G(^(Z)) D 97 . S DIC(0)="L",X=$P(Z0,U,3)_" ",DA(1)=RCRTOT,DIC="^RCY(344.4,"_DA(1)_",2,",DIC("DR")=$S($P(Z0,U,2)'="":".02////"_$P(Z0,U,2),1:"") 98 . S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_$S($P(Z0,U,4)'="":".03////"_$J(-$P(Z0,U,4)/100,"",2),1:"") 99 . S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_$S($P(Z0,U,5)'="":".04////"_$P(Z0,U,5),1:""),DLAYGO=344.42 100 . S:$O(^RCY(344.4,RCRTOT,2,"B",X,0)) X=""""_X_"""" 101 . D FILE^DICN K DIC,DO,DD 102 Q 103 ; 104 DUPREC(RCET,RCCT,RCSTAR,RCFILE,RCALLDUP,RCEOB,RCBILL,RCDUPEOB) ; Overflow from RCDPESR2 105 S ^TMP("RCERR1",$J,RCCT)=" ",^TMP("RCERR1",$J,RCCT,1)=RCET_RCCT_RCSTAR 106 S ^TMP("RCERR1",$J,RCCT,2)="(Warning): EEOB detail already filed for "_RCBILL_" - "_$S(RCALLDUP:"Duplicate not stored",1:"EEOB updated"),^TMP("RCERR1",$J,RCCT,3)=" " S:RCFILE=5 ^TMP("RCERR1",$J,RCCT,"*")=^TMP("RCERR1",$J,RCCT,2) 107 I RCALLDUP S RCEOB="",RCDUPEOB=-1 Q 108 S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)=RCEOB 109 Q 110 ; 1 RCDPESR6 ;ALB/TMK - Server auto-update file 344.4 - EDI Lockbox ;10/29/02 2 ;;4.5;Accounts Receivable;**173,214,208,230**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 UPD3444(RCRTOT) ; Add EOB detail to list in 344.41 for file 344.4 entry RCRTOT 6 ; If passed by reference, RCRTOT is returned = "" if errors 7 ; 8 N RC,RCCT,RC1,RC2,RCEOB,DA,DR,DO,DD,DLAYGO,DIC,DIK,X,Y,Z 9 S RC=0 F S RC=$O(^TMP($J,"RCDPEOB",RC)) Q:'RC S RC1=$G(^(RC)),RC2=$G(^(RC,"EOB")),RCEOB=+RC2 D Q:'RCRTOT 10 . ; Upd 344.41 with reference to this record if it doesn't already exist 11 . I RCEOB>0 Q:$D(^RCY(344.4,RCRTOT,1,"AC",RCEOB,RC)) 12 . I RCEOB'>0,$S($P(RC1,U,2)'="":$D(^RCY(344.4,RCRTOT,1,"AD",$P(RC1,U,2),RC)),1:0) Q 13 . ; Disregard ECME reject related EEOBs 14 . I RCEOB'>0,'$P(RC2,U,2),$P(RC1,U,2)?1.7N,$$REJECT^IBNCPDPU($P(RC1,U,2),$P(RC1,U,3)) Q 15 . S DA(1)=RCRTOT,X=RC,DIC="^RCY(344.4,"_DA(1)_",1,",DIC(0)="L",DLAYGO=344.41 16 . S DIC("DR")=$S($G(RCEOB)>0:".02////"_RCEOB,1:".05////"_$P(RC1,U,2)_";.07////1") 17 . I $P(RC2,U,2)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".03///"_$P(RC2,U,2) ; amt 18 . I $P(RC2,U,3)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".04////"_$P(RC2,U,3) ; ins co 19 . I $P(RC2,U,4) S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".14////1" ; reversal 20 . I $P(RC2,U,5)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".15////^S X=$E($P(RC2,U,5),1,30)" ; Patient name 21 . D FILE^DICN K DO,DD,DLAYGO,DIC,DIK 22 . S RCCT=+Y 23 . I RCCT<0 D Q 24 .. S DA=RCRTOT,DIK="^RCY(344.4," D ^DIK 25 .. S RCRTOT=0 26 . ; If there is no IB EOB record, store the raw data in 344.411 27 . I RC1'>0!(RCEOB'>0) D 28 .. N RCDATA,RCC,RCDA 29 .. S RCC=2,RCDATA(1)=$G(^TMP($J,"RCDPEOB","HDR")) 30 .. S Z=0 F S Z=$O(^TMP($J,"RCDPEOB",RCCT,Z)) Q:'Z S RCC=RCC+1,RCDATA(RCC)=$G(^TMP($J,"RCDPEOB",RCCT,Z)) 31 .. S RCDA(1)=RCRTOT,RCDA=RCCT 32 .. D WP^DIE(344.41,$$IENS^DILF(.RCDA),1,"A","RCDATA") 33 Q 34 ; 35 ; 36 ERATOT(RCTDA,RCERR) ; File ERA TOTAL rec in 344.4 from entry RCTDA in 344.5 37 ; RCTDA = ien file 344.5 38 ; Returns: the ien file 344.4 39 ; RCERR if passed by reference, with error text 40 ; RCERR(1)=duplicated message 41 N RCTYPE,RCDA,RCMETH,RCTRACE,RCID,RCDT,RCAMT,RCDUP,RCZ,RCX,RCPAYER,DIE,DIK,DIC,DLAYGO,DD,DO,DR,DA,X,Y,Z0,Z1 42 S (RCERR,RCDA)="" 43 S RCZ=$G(^RCY(344.5,RCTDA,2,1,0)) 44 S RCTYPE=$P(RCZ,U),RCTRACE=$P(RCZ,U,8),RCID=$P(RCZ,U,7),RCPAYER=$P(RCZ,U,6),RCMETH=$P(RCZ,U,17) 45 ; Need header record as first entry in field 46 I RCTYPE'["835ERA" S RCERR="No header record found in message. An EEOB exception record was created" G ERATOTQ 47 ; 48 S RCDT=$$FMDT^RCDPESR1($P(RCZ,U,9)),RCAMT=$J(($P(RCZ,U,10)/100),0,2) 49 ;Elec ERA's must have a trace # and an ins co id 50 I RCTRACE=""!(RCID="") S RCERR="Trace # or ins ID missing on ERA transaction. An EEOB exception record was created." G ERATOTQ 51 ; Make sure it's not already there 52 S (RCDUP,Z1)=0 53 F S Z1=$O(^RCY(344.4,"ATRID",RCTRACE,RCID,Z1)) Q:'Z1 S Z0=$G(^RCY(344.4,Z1,0)) I $P(Z0,U,4)=RCDT,+$P(Z0,U,5)=+RCAMT S RCDUP=1 Q 54 ; 55 I RCDUP,$P(Z0,U,8) D G ERATOTQ ; Receipt already exists - no update 56 . S RCERR="This is a duplicate ERA and has already been posted",RCERR(1)=-2 57 I RCDUP S RCERR="DUP",RCERR(1)=$S($P(Z0,U,12)'=$P($G(^RCY(344.5,RCTDA,0)),U,11):$P(Z0,U,12),1:-1) G ERATOTQ 58 ; 59 S RCX=+$O(^RCY(344.4," "),-1) 60 S DIC(0)="L",DIC="^RCY(344.4,",DLAYGO=344.4 61 S DIC("DR")=".02////"_RCTRACE_";.03////"_RCID_";.04////"_RCDT_";.05////"_RCAMT_";.06////"_$P(RCZ,U,6)_";.09////0;.12////"_$P($G(^RCY(344.5,RCTDA,0)),U,11)_";.07////"_$$NOW^XLFDT()_";.1////1" 62 I RCMETH'="" S DIC("DR")=DIC("DR")_";.15////"_RCMETH 63 F RCX=RCX+1:1 L +^RCY(344.4,RCX,0):1 I $T,'$D(^RCY(344.4,RCX,0)) S X=RCX Q 64 D FILE^DICN K DO,DLAYGO,DD,DIC 65 L -^RCY(344.4,RCX,0) 66 S RCDA=$S(Y<0:"",1:+Y) 67 I 'RCDA D 68 . S RCERR="An error was encountered that prevented the adding of an ERA totals record. An EEOB exception record was created." 69 ; 70 ERATOTQ Q RCDA 71 ; 72 UPDCON(RCRTOT) ; Add contact information to file 344.4 for an ERA 73 N DIE,DA,DR,Z,Q,X,Y 74 S Z=$G(^TMP($J,"RCDPEOB","CONTACT")) 75 Q:$TR($P(Z,U,3,9),U)="" 76 S DA=RCRTOT,DIE="^RCY(344.4,",DR="" 77 F Q=3:1:9 S DR=DR_$S(DR'="":";3.0",1:"3.0")_(Q-2)_"///"_$S($P(Z,U,Q)="":"@",1:"/"_$P(Z,U,Q)) 78 D ^DIE 79 Q 80 ; 81 UPDADJ(RCRTOT) ; Add ERA level adj data to file 344.4 82 N Z,Z0,DA,DIC,DLAYGO,DR,X,Y,DO,DD 83 ; Remove any already there 84 S Z=0 F S Z=$O(^RCY(344.4,RCRTOT,2,Z)) Q:'Z S DA(1)=RCRTOT,DA=Z D ^DIK 85 ; 86 S Z=0 F S Z=$O(^TMP($J,"RCDPEOB","ADJ",Z)) Q:'Z S Z0=$G(^(Z)) D 87 . S DIC(0)="L",X=$P(Z0,U,3)_" ",DA(1)=RCRTOT,DIC="^RCY(344.4,"_DA(1)_",2,",DIC("DR")=$S($P(Z0,U,2)'="":".02////"_$P(Z0,U,2),1:"") 88 . S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_$S($P(Z0,U,4)'="":".03////"_$J(-$P(Z0,U,4)/100,"",2),1:"") 89 . S DIC("DR")=DIC("DR")_$S(DIC("DR")'="":";",1:"")_$S($P(Z0,U,5)'="":".04////"_$P(Z0,U,5),1:""),DLAYGO=344.42 90 . S:$O(^RCY(344.4,RCRTOT,2,"B",X,0)) X=""""_X_"""" 91 . D FILE^DICN K DIC,DO,DD 92 Q 93 ; 94 DUPREC(RCET,RCCT,RCSTAR,RCFILE,RCALLDUP,RCEOB,RCBILL,RCDUPEOB) ; Overflow from RCDPESR2 95 S ^TMP("RCERR1",$J,RCCT)=" ",^TMP("RCERR1",$J,RCCT,1)=RCET_RCCT_RCSTAR 96 S ^TMP("RCERR1",$J,RCCT,2)="(Warning): EEOB detail already filed for "_RCBILL_" - "_$S(RCALLDUP:"Duplicate not stored",1:"EEOB updated"),^TMP("RCERR1",$J,RCCT,3)=" " S:RCFILE=5 ^TMP("RCERR1",$J,RCCT,"*")=^TMP("RCERR1",$J,RCCT,2) 97 I RCALLDUP S RCEOB="",RCDUPEOB=-1 Q 98 S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U)=RCEOB 99 Q 100 ; -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR9.m
r613 r623 1 RCDPESR9 ;ALB/TMK - ERA return file field captions ;09-SEP-2003 2 ;;4.5;Accounts Receivable;**173,252**;Mar 20, 1995;Build 63 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; Note: if the 835 flat file changes, make the corresponding changes 6 ; in this routine. 7 835 ;;HEADER DATA 8 ;;835^^Return Message ID^S Y=X_" (ERA HEADER DATA)" 9 ;;835^^X12/Proprietary flag^S Y=$S(X="X":"X12",1:X) 10 ;;835^^File Date^S Y=$$FDT^RCDPESR9(X) 11 ;;835^^File Time^S Y=$E(X,1,2)-$S($E(X,1,2)>12:12,1:0)_":"_$E(X,3,4)_$S($E(X,1,2)=24:" AM",$E(X,1,2)>11:" PM",1:" AM") 12 ;;835^1^MRA^S Y="" 13 ;;835^^Payer Name 14 ;;835^^Payer ID 15 ;;835^^Trace Number 16 ;;835^^Date Claims Paid^S Y=$$FDT^RCDPESR9(X) 17 ;;835^^Total ERA Amount^S Y=$$ZERO^RCDPESR9(X,1) 18 ;;835^^Erroneous Provider Tax ID 19 ;;835^^Tax ID correction Flag^S Y=$S(X="E":"CHANGED BY EPHRA",X="C":"DETERMINED FROM CLAIM DATA",X="":"NO CHANGE MADE",1:X) 20 ;;835^^Sequence Control # 21 ;;835^^Sequence # 22 ;;835^^Last Sequence # 23 ;;835^^Contact Information 24 ;;835^^Payment Method Code 25 ;;835^^Billing Provider NPI 26 ; 27 01 ;;PAYER CONTACT INFORMATION 28 ;;01^^ERA Contact Name 29 ;;01^^ERA Contact #1 30 ;;01^^ERA Contact #1 Type^S Y=$$EXTERNAL^DILFD(344.4,3.03,,X) 31 ;;01^^ERA Contact #2 32 ;;01^^ERA Contact #2 Type^S Y=$$EXTERNAL^DILFD(344.4,3.05,,X) 33 ;;01^^ERA Contact #3 34 ;;01^^ERA Contact #3 Type^S Y=$$EXTERNAL^DILFD(344.4,3.07,,X) 35 ; 36 02 ;;PAYER ADJUSTMENT RECORD 37 ;;02^^Line Type^S Y=X_" (ERA LEVEL PAYER ADJUSTMENT RECORD)" 38 ;;02^^X12 Adjustment Reason Code 39 ;;02^^Provider Adjustment Identifier 40 ;;02^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1) 41 ;;02^^X12 Reason Text 42 ; 43 05 ;;CLAIM PATIENT ID 44 ;;05^^Line Type^S Y=X_" (CLAIM LEVEL PATIENT ID DATA)" 45 ;;05^^Bill # 46 ;;05^^Patient Last Name 47 ;;05^^Patient First Name 48 ;;05^^Patient Middle Name 49 ;;05^^Patient ID # 50 ;;05^1^Record Contains Patient Name Change^S Y="" 51 ;;05^1^Record Contains Patient ID Change^S Y="" 52 ;;05^^Statement Start Date^S Y=$$FDT^RCDPESR9(X) 53 ;;05^^Statement End Date^S Y=$$FDT^RCDPESR9(X) 54 ; 55 10 ;;CLAIM STATUS DATA 56 ;;10^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM STATUS DATA)" 57 ;;10^^Bill # 58 ;;10^^Claim Processed^S Y=$$YN^RCDPESR9(X) 59 ;;10^^Claim Denied^S Y=$$YN^RCDPESR9(X) 60 ;;10^^Claim Pended^S Y=$$YN^RCDPESR9(X) 61 ;;10^^Claim Reversal^S Y=$$YN^RCDPESR9(X) 62 ;;10^^Claim Status Code 63 ;;10^1^Crossed Over Name^S Y="" 64 ;;10^1^Crossed Over ID^S Y="" 65 ;;10^^Submitted Charge^S Y=$$ZERO^RCDPESR9(X,1) 66 ;;10^^Amount Paid^S Y=$$ZERO^RCDPESR9(X,1) 67 ;;10^^ICN 68 ;;10^^DRG Code Used 69 ;;10^^DRG Weight Used^S Y=$J($$ZERO^RCDPESR9(X,1)/100,4) 70 ;;10^^Discharge Fraction^S Y=$$ZERO^RCDPESR9(X,1) 71 ;;10^^Rendering NPI 72 ;;10^^Entity Type Qualifier 73 ;;10^^Last Name 74 ;;10^^First Name 75 ; 76 15 ;;CLAIM STATUS DATA 77 ;;15^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM STATUS DATA (CONTINUED))" 78 ;;15^^Bill # 79 ;;15^^Covered Amount^S Y=$$ZERO^RCDPESR9(X,1) 80 ;;15^1^Discount Amount^S Y=$$ZERO^RCDPESR9(X,1,1) 81 ;;15^1^Day Limit Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 82 ;;15^1^Interest Amount^S Y=$$ZERO^RCDPESR9(X,1,1) 83 ;;15^1^Tax Amount^S Y=$$ZERO^RCDPESR9(X,1,1) 84 ;;15^1^Total Before Taxes Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 85 ;;15^^Patient Responsibility Amount^S Y=$$ZERO^RCDPESR9(X,1) 86 ;;15^1^Negative Reimbursement^S Y=$$ZERO^RCDPESR9(X,1,1) 87 ; 88 17 ;;CLAIM LEVEL PAYER CONTACT INFORMATION 89 ;;17^^Line Type^S Y=X_" (CLAIM LEVEL PAYER CONTACT INFO)" 90 ;;17^^Bill # 91 ;;17^^Contact Name 92 ;;17^^Contact #1 93 ;;17^^Contact #1 Type^S Y=$$EXTERNAL^DILFD(361.1,25.03,,X) 94 ;;17^^Contact #2 95 ;;17^^Contact #2 Type^S Y=$$EXTERNAL^DILFD(361.1,25.05,,X) 96 ;;17^^Contact #3 97 ;;17^^Contact #3 Type^S Y=$$EXTERNAL^DILFD(361.1,25.07,,X) 98 ; 99 20 ;;CLAIM LEVEL ADJUSTMENT DATA 100 ;;20^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM ADJUSTMENT DATA)" 101 ;;20^^Bill # 102 ;;20^^Adjustment Group Code 103 ;;20^^Adjustment Reason Code 104 ;;20^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1) 105 ;;20^^Quantity^S Y=$$ZERO^RCDPESR9(X) 106 ;;20^^Reason Code Text 107 ; 108 30 ;;CLAIM LEVEL MEDICARE INPT ADJUDICATION DATA 109 ;;30^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE INPATIENT ADJUDICATION DATA)" 110 ;;30^^Bill # 111 ;;30^^Covered Days/Visits^S Y=$$ZERO^RCDPESR9(X) 112 ;;30^1^Lifetime Reserve Days Count^S Y=$$ZERO^RCDPESR9(X,,1) 113 ;;30^1^Lifetime Psych Days Count^S Y=$$ZERO^RCDPESR9(X,,1) 114 ;;30^^Claim DRG Amt^S Y=$$ZERO^RCDPESR9(X,1) 115 ;;30^1^Claim Disproportionate Share Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 116 ;;30^1^Claim MSP Pass thru Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 117 ;;30^1^Claim PPS Capital Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 118 ;;30^1^PPS-Capital FSP DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 119 ;;30^1^PPS-Capital HSP DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 120 ;;30^1^PPS-Capital DSH DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 121 ;;30^1^Old Capital Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 122 ;;30^^Non-Covered Days^S Y=$$ZERO^RCDPESR9(X) 123 ; 124 35 ;;CLAIM LEVEL MEDICARE ADJUDICATION DATA 125 ;;35^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE ADJUDICATION DATA)" 126 ;;35^^Bill # 127 ;;35^1^PPS-Capital IME Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 128 ;;35^1^PPS-Operating Hosp Specific DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 129 ;;35^1^Cost Report Day Count^S Y=$$ZERO^RCDPESR9(X) 130 ;;35^1^PPS-Operating Fed Specific DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 131 ;;35^1^Claim PPS Capital Outlier Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 132 ;;35^1^Claim Indirect Teaching Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 133 ;;35^1^Non-payable Professional Component Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 134 ;;35^1^PPS-Capital Exception Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 135 ;;35^1^Outpatient Reimbursement %^S Y=$$ZERO^RCDPESR9(X) 136 ;;35^1^HCPCS Payable Amount^S Y=$$ZERO^RCDPESR9(X,1,1) 137 ;;35^1^ESRD Paid Amount^S Y=$$ZERO^RCDPESR9(X,1,1) 138 ;;35^1^Non-payable Professional Component^S Y=$$ZERO^RCDPESR9(X,1,1) 139 ; 140 37 ;;CLAIM LEVEL MEDICARE ADJUDICATION DATA REMARKS 141 ;;37^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE ADJUDICATION DATA REMARKS)" 142 ;;37^^Bill # 143 ;;37^^Type^S Y=$S(X="O":"MOA",X="I":"MIA",1:X) 144 ;;37^^Claim Payment Remark Code 145 ;;37^^Claim Payment Remark Code Message Text 146 ; 147 40 ;;SERVICE LINE DATA 148 ;;40^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA)" 149 ;;40^^Bill # 150 ;;40^^Procedure 151 ;;40^^Revenue Code 152 ;;40^^Modifier 1 153 ;;40^^Modifier 2 154 ;;40^^Modifier 3 155 ;;40^^Modifier 4 156 ;;40^^Description 157 ;;40^^Original Procedure 158 ;;40^^Original Modifier 1 159 ;;40^^Original Modifier 2 160 ;;40^^Original Modifier 3 161 ;;40^^Original Modifier 4 162 ;;40^^Original Charge^S Y=$$ZERO^RCDPESR9(X,1) 163 ;;40^^Original Units^S Y=$$ZERO^RCDPESR9(X,1) 164 ;;40^^Amount Paid^S Y=$$ZERO^RCDPESR9(X,1) 165 ;;40^^Covered Units^S Y=$$ZERO^RCDPESR9(X,1) 166 ;;40^^Service From Date^S Y=$$FDT^RCDPESR9(X) 167 ;;40^^Service To Date^S Y=$$FDT^RCDPESR9(X) 168 ;;40^^Procedure Type 169 ;;40^^Applies to Billing Line 170 ; 171 41 ;;SERVICE LINE DATA 172 ;;41^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA (CONTINUED))" 173 ;;41^^Bill # 174 ;;41^^Allowed Amount^S Y=$$ZERO^RCDPESR9(X,1) 175 ;;41^1^Per Diem Amount^S Y=$$ZERO^RCDPESR9(X,1,1) 176 ; 177 42 ; SERVICE LINE DATA 178 ;;42^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA (CONTINUED))" 179 ;;42^^Bill # 180 ;;42^^Line Item Remark Code 181 ;;42^^Line Item Remark Code Text 182 ; 183 45 ;;SERVICE LINE ADJUSTMENT DATA 184 ;;45^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE ADJUSTMENT DATA)" 185 ;;45^^Bill # 186 ;;45^^Adjustment Group Code 187 ;;45^^Adjustment Reason Code 188 ;;45^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1) 189 ;;45^^Quantity^S Y=$$ZERO^RCDPESR9(X) 190 ;;45^^Reason Code Text 191 ; 192 FDT(X) ; returns MM/DD/YYYY or MM/DD/YY from YYYYMMDD or YYMMDD in X 193 I $L(X)=8,X?8N S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4) 194 I $L(X)=6,X?6N S X=$E(X,3,4)_"/"_$E(X,5,6)_"/"_$E(X,1,2) 195 Q X 196 ; 197 ZERO(X,D,NULL) ; Returns numeric value of X without leading 0's 198 ; or null if no value wanted for 0 amount 199 ; D = 1 if dollar amt 200 N Z 201 I X["." S Z=$P(X,"."),X=+Z_"."_$P(X,".",2) 202 I X'["." D 203 . I $G(D) S X=+$E(X,1,$L(X)-2)_"."_$E(X,$L(X)-1,$L(X)) 204 . S X=$S('$G(D):+X,1:$J(X,"",2)) 205 Q $S(X:X,$G(NULL):"",1:X) 206 ; 207 YN(X) ; Returns YES for X="Y" and NO for X="N" 208 S X=$S(X="Y":"YES",X="N":"NO",1:X) 209 Q X 210 ; 1 RCDPESR9 ;ALB/TMK - ERA return file field captions ;09-SEP-2003 2 ;;4.5;Accounts Receivable;**173**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 ; Note: if the 835 flat file changes, make the corresponding changes 6 ; in this routine. 7 835 ;;HEADER DATA 8 ;;835^^Return Message ID^S Y=X_" (ERA HEADER DATA)" 9 ;;835^^X12/Proprietary flag^S Y=$S(X="X":"X12",1:X) 10 ;;835^^File Date^S Y=$$FDT^RCDPESR9(X) 11 ;;835^^File Time^S Y=$E(X,1,2)-$S($E(X,1,2)>12:12,1:0)_":"_$E(X,3,4)_$S($E(X,1,2)=24:" AM",$E(X,1,2)>11:" PM",1:" AM") 12 ;;835^1^MRA^S Y="" 13 ;;835^^Payer Name 14 ;;835^^Payer ID 15 ;;835^^Trace Number 16 ;;835^^Date Claims Paid^S Y=$$FDT^RCDPESR9(X) 17 ;;835^^Total ERA Amount^S Y=$$ZERO^RCDPESR9(X,1) 18 ;;835^^Erroneous Provider Tax ID 19 ;;835^^Tax ID correction Flag^S Y=$S(X="E":"CHANGED BY EPHRA",X="C":"DETERMINED FROM CLAIM DATA",X="":"NO CHANGE MADE",1:X) 20 ;;835^^Sequence Control # 21 ;;835^^Sequence # 22 ;;835^^Last Sequence # 23 ;;835^^Contact Information 24 ;;835^^Payment Method Code 25 ; 26 01 ;;PAYER CONTACT INFORMATION 27 ;;01^^ERA Contact Name 28 ;;01^^ERA Contact #1 29 ;;01^^ERA Contact #1 Type^S Y=$$EXTERNAL^DILFD(344.4,3.03,,X) 30 ;;01^^ERA Contact #2 31 ;;01^^ERA Contact #2 Type^S Y=$$EXTERNAL^DILFD(344.4,3.05,,X) 32 ;;01^^ERA Contact #3 33 ;;01^^ERA Contact #3 Type^S Y=$$EXTERNAL^DILFD(344.4,3.07,,X) 34 ; 35 02 ;;PAYER ADJUSTMENT RECORD 36 ;;02^^Line Type^S Y=X_" (ERA LEVEL PAYER ADJUSTMENT RECORD)" 37 ;;02^^X12 Adjustment Reason Code 38 ;;02^^Provider Adjustment Identifier 39 ;;02^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1) 40 ;;02^^X12 Reason Text 41 ; 42 05 ;;CLAIM PATIENT ID 43 ;;05^^Line Type^S Y=X_" (CLAIM LEVEL PATIENT ID DATA)" 44 ;;05^^Bill # 45 ;;05^^Patient Last Name 46 ;;05^^Patient First Name 47 ;;05^^Patient Middle Name 48 ;;05^^Patient ID # 49 ;;05^1^Record Contains Patient Name Change^S Y="" 50 ;;05^1^Record Contains Patient ID Change^S Y="" 51 ;;05^^Statement Start Date^S Y=$$FDT^RCDPESR9(X) 52 ;;05^^Statement End Date^S Y=$$FDT^RCDPESR9(X) 53 ; 54 10 ;;CLAIM STATUS DATA 55 ;;10^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM STATUS DATA)" 56 ;;10^^Bill # 57 ;;10^^Claim Processed^S Y=$$YN^RCDPESR9(X) 58 ;;10^^Claim Denied^S Y=$$YN^RCDPESR9(X) 59 ;;10^^Claim Pended^S Y=$$YN^RCDPESR9(X) 60 ;;10^^Claim Reversal^S Y=$$YN^RCDPESR9(X) 61 ;;10^^Claim Status Code 62 ;;10^1^Crossed Over Name^S Y="" 63 ;;10^1^Crossed Over ID^S Y="" 64 ;;10^^Submitted Charge^S Y=$$ZERO^RCDPESR9(X,1) 65 ;;10^^Amount Paid^S Y=$$ZERO^RCDPESR9(X,1) 66 ;;10^^ICN 67 ;;10^^DRG Code Used 68 ;;10^^DRG Weight Used^S Y=$J($$ZERO^RCDPESR9(X,1)/100,4) 69 ;;10^^Discharge Fraction^S Y=$$ZERO^RCDPESR9(X,1) 70 ; 71 15 ;;CLAIM STATUS DATA 72 ;;15^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM STATUS DATA (CONTINUED))" 73 ;;15^^Bill # 74 ;;15^^Covered Amount^S Y=$$ZERO^RCDPESR9(X,1) 75 ;;15^1^Discount Amount^S Y=$$ZERO^RCDPESR9(X,1,1) 76 ;;15^1^Day Limit Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 77 ;;15^1^Interest Amount^S Y=$$ZERO^RCDPESR9(X,1,1) 78 ;;15^1^Tax Amount^S Y=$$ZERO^RCDPESR9(X,1,1) 79 ;;15^1^Total Before Taxes Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 80 ;;15^^Patient Responsibility Amount^S Y=$$ZERO^RCDPESR9(X,1) 81 ;;15^1^Negative Reimbursement^S Y=$$ZERO^RCDPESR9(X,1,1) 82 ; 83 17 ;;CLAIM LEVEL PAYER CONTACT INFORMATION 84 ;;17^^Line Type^S Y=X_" (CLAIM LEVEL PAYER CONTACT INFO)" 85 ;;17^^Bill # 86 ;;17^^Contact Name 87 ;;17^^Contact #1 88 ;;17^^Contact #1 Type^S Y=$$EXTERNAL^DILFD(361.1,25.03,,X) 89 ;;17^^Contact #2 90 ;;17^^Contact #2 Type^S Y=$$EXTERNAL^DILFD(361.1,25.05,,X) 91 ;;17^^Contact #3 92 ;;17^^Contact #3 Type^S Y=$$EXTERNAL^DILFD(361.1,25.07,,X) 93 ; 94 20 ;;CLAIM LEVEL ADJUSTMENT DATA 95 ;;20^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM ADJUSTMENT DATA)" 96 ;;20^^Bill # 97 ;;20^^Adjustment Group Code 98 ;;20^^Adjustment Reason Code 99 ;;20^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1) 100 ;;20^^Quantity^S Y=$$ZERO^RCDPESR9(X) 101 ;;20^^Reason Code Text 102 ; 103 30 ;;CLAIM LEVEL MEDICARE INPT ADJUDICATION DATA 104 ;;30^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE INPATIENT ADJUDICATION DATA)" 105 ;;30^^Bill # 106 ;;30^^Covered Days/Visits^S Y=$$ZERO^RCDPESR9(X) 107 ;;30^1^Lifetime Reserve Days Count^S Y=$$ZERO^RCDPESR9(X,,1) 108 ;;30^1^Lifetime Psych Days Count^S Y=$$ZERO^RCDPESR9(X,,1) 109 ;;30^^Claim DRG Amt^S Y=$$ZERO^RCDPESR9(X,1) 110 ;;30^1^Claim Disproportionate Share Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 111 ;;30^1^Claim MSP Pass thru Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 112 ;;30^1^Claim PPS Capital Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 113 ;;30^1^PPS-Capital FSP DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 114 ;;30^1^PPS-Capital HSP DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 115 ;;30^1^PPS-Capital DSH DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 116 ;;30^1^Old Capital Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 117 ;;30^^Non-Covered Days^S Y=$$ZERO^RCDPESR9(X) 118 ; 119 35 ;;CLAIM LEVEL MEDICARE ADJUDICATION DATA 120 ;;35^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE ADJUDICATION DATA)" 121 ;;35^^Bill # 122 ;;35^1^PPS-Capital IME Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 123 ;;35^1^PPS-Operating Hosp Specific DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 124 ;;35^1^Cost Report Day Count^S Y=$$ZERO^RCDPESR9(X) 125 ;;35^1^PPS-Operating Fed Specific DRG Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 126 ;;35^1^Claim PPS Capital Outlier Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 127 ;;35^1^Claim Indirect Teaching Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 128 ;;35^1^Non-payable Professional Component Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 129 ;;35^1^PPS-Capital Exception Amt^S Y=$$ZERO^RCDPESR9(X,1,1) 130 ;;35^1^Outpatient Reimbursement %^S Y=$$ZERO^RCDPESR9(X) 131 ;;35^1^HCPCS Payable Amount^S Y=$$ZERO^RCDPESR9(X,1,1) 132 ;;35^1^ESRD Paid Amount^S Y=$$ZERO^RCDPESR9(X,1,1) 133 ;;35^1^Non-payable Professional Component^S Y=$$ZERO^RCDPESR9(X,1,1) 134 ; 135 37 ;;CLAIM LEVEL MEDICARE ADJUDICATION DATA REMARKS 136 ;;37^^Line Type^S Y=X_" (CLAIM LEVEL MEDICARE ADJUDICATION DATA REMARKS)" 137 ;;37^^Bill # 138 ;;37^^Type^S Y=$S(X="O":"MOA",X="I":"MIA",1:X) 139 ;;37^^Claim Payment Remark Code 140 ;;37^^Claim Payment Remark Code Message Text 141 ; 142 40 ;;SERVICE LINE DATA 143 ;;40^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA)" 144 ;;40^^Bill # 145 ;;40^^Procedure 146 ;;40^^Revenue Code 147 ;;40^^Modifier 1 148 ;;40^^Modifier 2 149 ;;40^^Modifier 3 150 ;;40^^Modifier 4 151 ;;40^^Description 152 ;;40^^Original Procedure 153 ;;40^^Original Modifier 1 154 ;;40^^Original Modifier 2 155 ;;40^^Original Modifier 3 156 ;;40^^Original Modifier 4 157 ;;40^^Original Charge^S Y=$$ZERO^RCDPESR9(X,1) 158 ;;40^^Original Units^S Y=$$ZERO^RCDPESR9(X,1) 159 ;;40^^Amount Paid^S Y=$$ZERO^RCDPESR9(X,1) 160 ;;40^^Covered Units^S Y=$$ZERO^RCDPESR9(X,1) 161 ;;40^^Service From Date^S Y=$$FDT^RCDPESR9(X) 162 ;;40^^Service To Date^S Y=$$FDT^RCDPESR9(X) 163 ;;40^^Procedure Type 164 ;;40^^Applies to Billing Line 165 ; 166 41 ;;SERVICE LINE DATA 167 ;;41^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA (CONTINUED))" 168 ;;41^^Bill # 169 ;;41^^Allowed Amount^S Y=$$ZERO^RCDPESR9(X,1) 170 ;;41^1^Per Diem Amount^S Y=$$ZERO^RCDPESR9(X,1,1) 171 ; 172 42 ; SERVICE LINE DATA 173 ;;42^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE DATA (CONTINUED))" 174 ;;42^^Bill # 175 ;;42^^Line Item Remark Code 176 ;;42^^Line Item Remark Code Text 177 ; 178 45 ;;SERVICE LINE ADJUSTMENT DATA 179 ;;45^^Line Type^S Y=X_" (CLAIM LEVEL SERVICE LINE ADJUSTMENT DATA)" 180 ;;45^^Bill # 181 ;;45^^Adjustment Group Code 182 ;;45^^Adjustment Reason Code 183 ;;45^^Adjustment Amount^S Y=$$ZERO^RCDPESR9(X,1) 184 ;;45^^Quantity^S Y=$$ZERO^RCDPESR9(X) 185 ;;45^^Reason Code Text 186 ; 187 FDT(X) ; returns MM/DD/YYYY or MM/DD/YY from YYYYMMDD or YYMMDD in X 188 I $L(X)=8,X?8N S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4) 189 I $L(X)=6,X?6N S X=$E(X,3,4)_"/"_$E(X,5,6)_"/"_$E(X,1,2) 190 Q X 191 ; 192 ZERO(X,D,NULL) ; Returns numeric value of X without leading 0's 193 ; or null if no value wanted for 0 amount 194 ; D = 1 if dollar amt 195 N Z 196 I X["." S Z=$P(X,"."),X=+Z_"."_$P(X,".",2) 197 I X'["." D 198 . I $G(D) S X=+$E(X,1,$L(X)-2)_"."_$E(X,$L(X)-1,$L(X)) 199 . S X=$S('$G(D):+X,1:$J(X,"",2)) 200 Q $S(X:X,$G(NULL):"",1:X) 201 ; 202 YN(X) ; Returns YES for X="Y" and NO for X="N" 203 S X=$S(X="Y":"YES",X="N":"NO",1:X) 204 Q X 205 ; -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEWL0.m
r613 r623 1 RCDPEWL0 ;ALB/TMK - ELECTRONIC EOB WORKLIST ACTIONS ;06 Jun 2007 11:50 AM 2 ;;4.5;Accounts Receivable;**173,208,252**;Mar 20, 1995;Build 63 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 Q 5 ; 6 PARAMS ; Select params for ERA list 7 ; Return ^TMP("RCERA_PARAMS",$J) array 8 N DIR,X,Y,RCDFR,RCDTO,RCPAYR,RCQUIT,DUOUT,DTOUT 9 K ^TMP("RCERA_PARAMS",$J) 10 S RCQUIT=0 11 W !!,"SELECT PARAMETERS FOR DISPLAYING THE LIST OF ERAs" 12 S DIR(0)="SA^U:UNPOSTED;P:POSTED;B:BOTH",DIR("B")="UNPOSTED",DIR("A")="ERA POSTING STATUS: " W ! D ^DIR K DIR 13 I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ 14 S ^TMP("RCERA_PARAMS",$J,"RCPOST")=Y 15 S DIR(0)="SA^N:NOT MATCHED;M:MATCHED;B:BOTH",DIR("B")="BOTH",DIR("A")="ERA-EFT MATCH STATUS: " W ! D ^DIR K DIR 16 I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ 17 S ^TMP("RCERA_PARAMS",$J,"RCMATCH")=Y 18 ; 19 DT1 S RCDTO=DT,RCDFR=0 20 S RCQUIT=0,DIR(0)="YA",DIR("A")="LIMIT THE SELECTION TO A DATE RANGE WHEN THE ERA WAS RECEIVED?: ",DIR("B")="NO" W ! D ^DIR K DIR 21 I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ 22 I Y=1 S RCQUIT=0 D I RCQUIT K ^TMP("RCERA_PARAMS",$J,"RCDT") G DT1 23 . S DIR(0)="DA",DIR("A")="EARLIEST DATE: " D ^DIR K DIR 24 . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q 25 . S RCDFR=Y 26 . S DIR(0)="DA^"_RCDFR_";"_DT,DIR("A")="LATEST DATE: " D ^DIR K DIR 27 . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q 28 . S RCDTO=Y 29 S ^TMP("RCERA_PARAMS",$J,"RCDT")=(RCDFR_U_RCDTO) 30 ; 31 PAYR S RCQUIT=0,DIR(0)="SA^A:ALL;R:RANGE",DIR("A")="(A)LL PAYERS, (R)ANGE OF PAYER NAMES: ",DIR("B")="ALL" W ! D ^DIR K DIR 32 I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ 33 S RCPAYR=Y,^TMP("RCERA_PARAMS",$J,"RCPAYR")=Y 34 I RCPAYR="A" G PARAMSQ 35 I RCPAYR="R" D I RCQUIT K ^TMP("RCERA_PARAMS",$J,"RCPAYR") G PAYR 36 . W !,"NAMES YOU SELECT HERE WILL BE THE PAYER NAMES FROM THE ERA, NOT THE INS FILE" 37 . S DIR("?")="ENTER A NAME BETWEEN 1 AND 30 CHARACTERS IN UPPERCASE" 38 . S DIR(0)="FA^1:30^K:X'?.U X",DIR("A")="START WITH PAYER NAME: " W ! D ^DIR K DIR 39 . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q 40 . S RCPAYR("FROM")=Y,$P(^TMP("RCERA_PARAMS",$J,"RCPAYR"),U,2)=Y 41 . S DIR("?")="ENTER A NAME BETWEEN 1 AND 30 CHARACTERS IN UPPERCASE" 42 . S DIR(0)="FA^1:30^K:X'?.U X",DIR("A")="GO TO PAYER NAME: ",DIR("B")=$E(RCPAYR("FROM"),1,27)_"ZZZ" W ! D ^DIR K DIR 43 . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q 44 . S $P(^TMP("RCERA_PARAMS",$J,"RCPAYR"),U,3)=Y 45 W ! 46 ; 47 PARAMSQ ; 48 D PARAMS^RCDPEWLD(.RCQUIT) 49 Q 50 ; 51 FILTER(Y) ; Returns 1 if record in entry Y in 344.4 passes 52 ; the edits for the worklist selection of ERAs 53 ; Parameters found in ^TMP("RCERA_PARAMS",$J) 54 N OK,RCPOST,RCMATCH,RCDFR,RCDTO,RCPAYFR,RCPAYTO,RCPAYR,RC0 55 S OK=1,RC0=$G(^RCY(344.4,Y,0)) 56 ; 57 S RCMATCH=$G(^TMP("RCERA_PARAMS",$J,"RCMATCH")),RCPOST=$G(^TMP("RCERA_PARAMS",$J,"RCPOST")) 58 S RCDFR=+$P($G(^TMP("RCERA_PARAMS",$J,"RCDT")),U),RCDTO=+$P($G(^TMP("RCERA_PARAMS",$J,"RCDT")),U,2) 59 S RCPAYR=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U),RCPAYFR=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U,2),RCPAYTO=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U,3) 60 ; 61 ; If receipt exists, scratchpad must exist 62 ;I $P(RC0,U,8),'$D(^RCY(344.49,+Y,0)) S OK=0 G FQ 63 ; Post status 64 I $S(RCPOST="B":0,RCPOST="U":$P(RC0,U,14),1:'$P(RC0,U,14)) S OK=0 G FQ 65 ; Match status 66 I $S(RCMATCH="B":0,RCMATCH="N":$P(RC0,U,9),1:'$P(RC0,U,9)) S OK=0 G FQ 67 ; dt rec'd range 68 I $S(RCDFR=0:0,1:$P(RC0,U,7)\1<RCDFR) S OK=0 G FQ 69 I $S(RCDTO=DT:0,1:$P(RC0,U,7)\1>RCDTO) S OK=0 G FQ 70 ; Payer name 71 I RCPAYR'="A" D G:'OK FQ 72 . N Q 73 . S Q=$$UPPER^RCDPEWL7($P(RC0,U,6)) 74 . I $S(Q=RCPAYFR:1,Q=RCPAYTO:1,Q]RCPAYFR:RCPAYTO]Q,1:0) Q 75 . S OK=0 76 FQ Q OK 77 ; 78 SPLIT ; Split line in ERA list 79 N RCLINE,RCZ,RCDA,Q,Q0,Z,Z0,DIR,X,Y,CT,L,L1,RCONE,RCQUIT 80 D FULL^VALM1 81 I $G(RCSCR("NOEDIT")) D NOEDIT^RCDPEWL G SPLITQ 82 W !!,"SELECT THE ENTRY THAT HAS A LINE YOU NEED TO SPLIT/EDIT",! 83 D SEL^RCDPEWL(.RCDA) 84 S Z=+$O(RCDA(0)) G:'$G(RCDA(Z)) SPLITQ 85 S RCLINE=+RCDA(Z),Z0=+$O(^TMP("RCDPE-EOB_WLDX",$J,Z_".999"),-1) 86 S RCZ=Z F S RCZ=$O(^TMP("RCDPE-EOB_WLDX",$J,RCZ)) Q:'RCZ!(RCZ\1'=Z) D 87 . S Q=$P($G(^TMP("RCDPE-EOB_WLDX",$J,RCZ)),U,2) 88 . Q:'Q 89 . S RCZ(RCZ)=Q 90 . S Q0=0 F S Q0=$O(^RCY(344.49,RCSCR,1,Q,1,Q0)) Q:'Q0 I "01"[$P($G(^(Q0,0)),U,2) K RCZ(RCZ) Q 91 I '$O(RCZ(0)) D G SPLITQ 92 . S DIR(0)="EA",DIR("A",1)="THIS ENTRY HAS NO LINES AVAILABLE TO EDIT/SPLIT",DIR("A")="PRESS RETURN TO CONTINUE " W ! D ^DIR K DIR 93 S RCQUIT=0 94 I $P($G(^RCY(344.49,RCSCR,1,RCLINE,0)),U,13) D G:RCQUIT SPLITQ 95 . S DIR("A",1)="WARNING! THIS LINE HAS ALREADY BEEN VERIFIED",DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE?: ",DIR(0)="YA",DIR("B")="NO" W ! D ^DIR K DIR 96 . I Y'=1 S RCQUIT=1 97 S CT=0,CT=CT+1,DIR("?",CT)="Enter the line # that you want to split or edit:",RCONE=1 98 S L=Z F S L=$O(RCZ(L)) Q:'L D 99 . S L1=+$G(^TMP("RCDPE-EOB_WLDX",$J,L)) 100 . S CT=CT+1 101 . S DIR("?",CT)=$G(^TMP("RCDPE-EOB_WL",$J,L1,0)),CT=CT+1,DIR("?",CT)=$G(^TMP("RCDPE-EOB_WL",$J,L1+1,0)) S RCONE(1)=$S(RCONE:L,1:"") S RCONE=0 102 S DIR("?")=" ",Y=-1 103 I $G(RCONE(1)) S Y=+RCONE(1) K DIR G:'Y SPLITQ 104 I '$G(RCONE(1)) D K DIR I $D(DTOUT)!$D(DUOUT)!(Y\1'=Z) G SPLITQ 105 . F S DIR(0)="NAO^"_(Z+.001)_":"_Z0_":3",DIR("A")="WHICH LINE OF ENTRY "_Z_" DO YOU WANT TO SPLIT/EDIT?: " S:$G(RCONE(1))'="" DIR("B")=RCONE(1) D ^DIR Q:'Y!$D(DUOUT)!$D(DTOUT) D Q:Y>0 106 .. I '$D(^TMP("RCDPE-EOB_WLDX",$J,Y)) W !!,"LINE "_Y_" DOES NOT EXIST - TRY AGAIN",! S Y=-1 Q 107 .. I '$D(RCZ(Y)) W !!,"LINE "_Y_" HAS BEEN USED IN A DISTRIBUTE ADJ ACTION AND CAN'T BE EDITED",! S Y=-1 Q 108 .. S Q=+$O(^RCY(344.49,RCSCR,1,"B",Y,0)) 109 ; 110 K ^TMP("RCDPE_SPLIT_REBLD",$J) 111 D SPLIT^RCDPEWL3(RCSCR,+Y) 112 I $G(^TMP("RCDPE_SPLIT_REBLD",$J)) K ^TMP("RCDPE_SPLIT_REBLD",$J) D BLD^RCDPEWL1($G(^TMP($J,"RC_SORTPARM"))) 113 ; 114 SPLITQ S VALMBCK="R" 115 Q 116 ; 117 PRTERA ; View/prt 118 N DIC,X,Y,RCSCR 119 S DIC="^RCY(344.4,",DIC(0)="AEMQ" D ^DIC 120 Q:Y'>0 121 S RCSCR=+Y 122 D PRERA1 123 Q 124 ; 125 PRERA ; RCSCR is assumed to be defined 126 D FULL^VALM1 ; Protocol entry 127 PRERA1 ; Option entry 128 N %ZIS,ZTRTN,ZTSAVE,ZTDESC,POP,DIR,X,Y,RCERADET 129 S DIR("?",1)="INCLUDING EXPANDED DETAIL WILL SIGNIFICANTLY INCREASE THE SIZE OF THIS REPORT",DIR("?",2)="IF YOU CHOOSE TO INCLUDE IT, ALL PAYMENT DETAILS FOR EACH EEOB WILL BE" 130 S DIR("?")="LISTED. IF YOU WANT JUST SUMMARY DATA FOR EACH EEOB, DO NOT INCLUDE IT." 131 S DIR(0)="YA",DIR("A")="DO YOU WANT TO INCLUDE EXPANDED EEOB DETAIL?: ",DIR("B")="NO" W ! D ^DIR K DIR 132 I $D(DUOUT)!$D(DTOUT) G PRERAQ 133 S RCERADET=+Y 134 S %ZIS="QM" D ^%ZIS G:POP PRERAQ 135 I $D(IO("Q")) D G PRERAQ 136 . S ZTRTN="VPERA^RCDPEWL0("_RCSCR_","_RCERADET_")",ZTDESC="AR - Print ERA From Worklist" 137 . D ^%ZTLOAD 138 . W !!,$S($D(ZTSK):"Your task # "_ZTSK_" has been queued.",1:"Unable to queue this job.") 139 . K ZTSK,IO("Q") D HOME^%ZIS 140 U IO 141 D VPERA(RCSCR,RCERADET) 142 Q 143 ; 144 VPERA(RCSCR,RCERADET) ; Queued entry 145 ; RCSCR = ien of entry in file 344.4 146 ; RCERADET = 1 if inclusion of all EOB details from file 361.1 is 147 ; desired, 0 if not 148 N Z,Z0,RCSTOP,RCZ,RCPG,RCDOT,RCDIQ,RCDIQ1,RCDIQ2,RCXM1,RC,RCSCR1,RC3611 149 K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT"),^TMP($J,"RC_SUMALL") 150 S (RCSTOP,RCPG)=0,RCDOT="",$P(RCDOT,".",79)="" 151 D GETS^DIQ(344.4,RCSCR_",","*","IEN","RCDIQ") 152 D TXT0^RCDPEX31(RCSCR,.RCDIQ,.RCXM1,.RC) ; Get top level 0-node captioned flds 153 I $O(^RCY(344.4,RCSCR,2,0)) S RC=RC+1,RCXM1(RC)=" **ERA LEVEL ADJUSTMENTS**" 154 S RCSCR1=0 F S RCSCR1=$O(^RCY(344.4,RCSCR,2,RCSCR1)) Q:'RCSCR1 D 155 . K RCDIQ2 156 . D GETS^DIQ(344.42,RCSCR1_","_RCSCR_",","*","IEN","RCDIQ2") 157 . D TXT2^RCDPEX31(RCSCR,RCSCR1,.RCDIQ2,.RCXM1,.RC) ; Get top level ERA adjs 158 S RCSCR1=0 F S RCSCR1=$O(^RCY(344.4,RCSCR,1,RCSCR1)) Q:'RCSCR1 D 159 . K RCDIQ1 160 . D GETS^DIQ(344.41,RCSCR1_","_RCSCR_",","*","IEN","RCDIQ1") 161 . D TXT00^RCDPEX31(RCSCR,RCSCR1,.RCDIQ1,.RCXM1,.RC) 162 . S RC=RC+1,RCXM1(RC-1)=$E("PATIENT: "_$$PNM4^RCDPEWL1(RCSCR,RCSCR1)_$J("",41),1,41)_"CLAIM #: "_$$BILLREF^RCDPESR0(RCSCR,RCSCR1),RCXM1(RC)=" " 163 . D PROV^RCDPEWLD(RCSCR,RCSCR1,.RCXM1,.RC) 164 . S RC3611=$P($G(^RCY(344.4,RCSCR,1,RCSCR1,0)),U,2) 165 . I RCERADET D 166 .. I 'RC3611 D Q 167 ... D DISP^RCDPESR0("^RCY(344.4,"_RCSCR_",1,"_RCSCR1_",1)","^TMP($J,""RC_SUMRAW"")",1,"^TMP($J,""RC_SUMOUT"")",75,1) 168 ..; 169 .. E D ; Detail record is in 361.1 170 ... K ^TMP("PRCA_EOB",$J) 171 ... D GETEOB^IBCECSA6(RC3611,2) 172 ... I $O(^IBM(361.1,RC3611,"ERR",0)) D GETERR^RCDPEDS(RC3611,+$O(^TMP("PRCA_EOB",$J,RC3611," "),-1)) ; get filing errors 173 ... S Z=0 F S Z=$O(^TMP("PRCA_EOB",$J,RC3611,Z)) Q:'Z S RC=RC+1,^TMP($J,"RC_SUMOUT",RC)=$G(^TMP("PRCA_EOB",$J,RC3611,Z)) 174 ... S RC=RC+2,^TMP($J,"RC_SUMOUT",RC-1)=" ",^TMP($J,"RC_SUMOUT",RC)=" " 175 ... K ^TMP("PRCA_EOB",$J) 176 . I $D(RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2)) D 177 .. S RC=RC+1,RCXM1(RC)=" **EXCEPTION RESOLUTION LOG DATA**" 178 .. S Z=0 F S Z=$O(RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2,Z)) Q:'Z S RC=RC+1,RCXM1(RC)=RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2,Z) 179 . S RC=RC+1,RCXM1(RC)=" " 180 . S Z0=+$O(^TMP($J,"RC_SUMALL"," "),-1) 181 . S Z=0 F S Z=$O(RCXM1(Z)) Q:'Z S Z0=Z0+1,^TMP($J,"RC_SUMALL",Z0)=RCXM1(Z) 182 . K RCXM1 S RC=0 183 . S Z=0 F S Z=$O(^TMP($J,"RC_SUMOUT",Z)) Q:'Z S Z0=Z0+1,^TMP($J,"RC_SUMALL",Z0)=$G(^TMP($J,"RC_SUMOUT",Z)) 184 S RCSTOP=0,Z="" 185 F S Z=$O(^TMP($J,"RC_SUMALL",Z)) Q:'Z D Q:RCSTOP 186 . I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPG) W !!,"***TASK STOPPED BY USER***" Q 187 . I 'RCPG!(($Y+5)>IOSL) D I RCSTOP Q 188 .. D:RCPG ASK(.RCSTOP) I RCSTOP Q 189 .. D HDR(.RCPG) 190 . W !,$G(^TMP($J,"RC_SUMALL",Z)) 191 ; 192 I 'RCSTOP,RCPG D ASK(.RCSTOP) 193 ; 194 I $D(ZTQUEUED) S ZTREQ="@" 195 I '$D(ZTQUEUED) D ^%ZISC 196 ; 197 PRERAQ K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT"),^TMP($J,"SUMALL") 198 S VALMBCK="R" 199 Q 200 ; 201 HDR(RCPG) ;Report hdr 202 ; RCPG = last page # 203 I RCPG!($E(IOST,1,2)="C-") W @IOF,*13 204 S RCPG=$G(RCPG)+1 205 W !,?5,"EDI LOCKBOX WORKLIST - ERA DETAIL",?55,$$FMTE^XLFDT(DT,2),?70,"Page: ",RCPG,!,$TR($J("",IOM)," ","=") 206 Q 207 ; 208 ASK(RCSTOP) ; 209 I $E(IOST,1,2)'["C-" Q 210 N DIR,DIROUT,DIRUT,DTOUT,DUOUT 211 S DIR(0)="E" W ! D ^DIR 212 I ($D(DIRUT))!($D(DUOUT)) S RCSTOP=1 Q 213 Q 214 ; 1 RCDPEWL0 ;ALB/TMK - ELECTRONIC EOB WORKLIST ACTIONS ;26-NOV-02 2 ;;4.5;Accounts Receivable;**173,208**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 Q 5 ; 6 PARAMS ; Select params for ERA list 7 ; Return ^TMP("RCERA_PARAMS",$J) array 8 N DIR,X,Y,RCDFR,RCDTO,RCPAYR,RCQUIT 9 K ^TMP("RCERA_PARAMS",$J) 10 S RCQUIT=0 11 W !!,"SELECT PARAMETERS FOR DISPLAYING THE LIST OF ERAs" 12 S DIR(0)="SA^U:UNPOSTED;P:POSTED;B:BOTH",DIR("B")="UNPOSTED",DIR("A")="ERA POSTING STATUS: " W ! D ^DIR K DIR 13 I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ 14 S ^TMP("RCERA_PARAMS",$J,"RCPOST")=Y 15 S DIR(0)="SA^N:NOT MATCHED;M:MATCHED;B:BOTH",DIR("B")="BOTH",DIR("A")="ERA-EFT MATCH STATUS: " W ! D ^DIR K DIR 16 I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ 17 S ^TMP("RCERA_PARAMS",$J,"RCMATCH")=Y 18 ; 19 DT1 S RCDTO=DT,RCDFR=0 20 S RCQUIT=0,DIR(0)="YA",DIR("A")="LIMIT THE SELECTION TO A DATE RANGE WHEN THE ERA WAS RECEIVED?: ",DIR("B")="NO" W ! D ^DIR K DIR 21 I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ 22 I Y=1 S RCQUIT=0 D I RCQUIT K ^TMP("RCERA_PARAMS",$J,"RCDT") G DT1 23 . S DIR(0)="DA",DIR("A")="EARLIEST DATE: " D ^DIR K DIR 24 . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q 25 . S RCDFR=Y 26 . S DIR(0)="DA^"_RCDFR_";"_DT,DIR("A")="LATEST DATE: " D ^DIR K DIR 27 . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q 28 . S RCDTO=Y 29 S ^TMP("RCERA_PARAMS",$J,"RCDT")=(RCDFR_U_RCDTO) 30 ; 31 PAYR S RCQUIT=0,DIR(0)="SA^A:ALL;R:RANGE",DIR("A")="(A)LL PAYERS, (R)ANGE OF PAYER NAMES: ",DIR("B")="ALL" W ! D ^DIR K DIR 32 I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 G PARAMSQ 33 S RCPAYR=Y,^TMP("RCERA_PARAMS",$J,"RCPAYR")=Y 34 I RCPAYR="A" G PARAMSQ 35 I RCPAYR="R" D I RCQUIT K ^TMP("RCERA_PARAMS",$J,"RCPAYR") G PAYR 36 . W !,"NAMES YOU SELECT HERE WILL BE THE PAYER NAMES FROM THE ERA, NOT THE INS FILE" 37 . S DIR("?")="ENTER A NAME BETWEEN 1 AND 30 CHARACTERS IN UPPERCASE" 38 . S DIR(0)="FA^1:30^K:X'?.U X",DIR("A")="START WITH PAYER NAME: " W ! D ^DIR K DIR 39 . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q 40 . S RCPAYR("FROM")=Y,$P(^TMP("RCERA_PARAMS",$J,"RCPAYR"),U,2)=Y 41 . S DIR("?")="ENTER A NAME BETWEEN 1 AND 30 CHARACTERS IN UPPERCASE" 42 . S DIR(0)="FA^1:30^K:X'?.U X",DIR("A")="GO TO PAYER NAME: ",DIR("B")=$E(RCPAYR("FROM"),1,27)_"ZZZ" W ! D ^DIR K DIR 43 . I $D(DTOUT)!$D(DUOUT) S RCQUIT=1 Q 44 . S $P(^TMP("RCERA_PARAMS",$J,"RCPAYR"),U,3)=Y 45 W ! 46 ; 47 PARAMSQ I $G(RCQUIT) K ^TMP("RCERA_PARAMS",$J) 48 Q 49 ; 50 FILTER(Y) ; Returns 1 if record in entry Y in 344.4 passes 51 ; the edits for the worklist selection of ERAs 52 ; Parameters found in ^TMP("RCERA_PARAMS",$J) 53 N OK,RCPOST,RCMATCH,RCDFR,RCDTO,RCPAYFR,RCPAYTO,RCPAYR,RC0 54 S OK=1,RC0=$G(^RCY(344.4,Y,0)) 55 ; 56 S RCMATCH=$G(^TMP("RCERA_PARAMS",$J,"RCMATCH")),RCPOST=$G(^TMP("RCERA_PARAMS",$J,"RCPOST")) 57 S RCDFR=+$P($G(^TMP("RCERA_PARAMS",$J,"RCDT")),U),RCDTO=+$P($G(^TMP("RCERA_PARAMS",$J,"RCDT")),U,2) 58 S RCPAYR=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U),RCPAYFR=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U,2),RCPAYTO=$P($G(^TMP("RCERA_PARAMS",$J,"RCPAYR")),U,3) 59 ; 60 ; If receipt exists, scratchpad must exist 61 ;I $P(RC0,U,8),'$D(^RCY(344.49,+Y,0)) S OK=0 G FQ 62 ; Post status 63 I $S(RCPOST="B":0,RCPOST="U":$P(RC0,U,14),1:'$P(RC0,U,14)) S OK=0 G FQ 64 ; Match status 65 I $S(RCMATCH="B":0,RCMATCH="N":$P(RC0,U,9),1:'$P(RC0,U,9)) S OK=0 G FQ 66 ; dt rec'd range 67 I $S(RCDFR=0:0,1:$P(RC0,U,7)\1<RCDFR) S OK=0 G FQ 68 I $S(RCDTO=DT:0,1:$P(RC0,U,7)\1>RCDTO) S OK=0 G FQ 69 ; Payer name 70 I RCPAYR'="A" D G:'OK FQ 71 . N Q 72 . S Q=$$UPPER^RCDPEWL7($P(RC0,U,6)) 73 . I $S(Q=RCPAYFR:1,Q=RCPAYTO:1,Q]RCPAYFR:RCPAYTO]Q,1:0) Q 74 . S OK=0 75 FQ Q OK 76 ; 77 SPLIT ; Split line in ERA list 78 N RCLINE,RCZ,RCDA,Q,Q0,Z,Z0,DIR,X,Y,CT,L,L1,RCONE,RCQUIT 79 D FULL^VALM1 80 I $G(RCSCR("NOEDIT")) D NOEDIT^RCDPEWL G SPLITQ 81 W !!,"SELECT THE ENTRY THAT HAS A LINE YOU NEED TO SPLIT/EDIT",! 82 D SEL^RCDPEWL(.RCDA) 83 S Z=+$O(RCDA(0)) G:'$G(RCDA(Z)) SPLITQ 84 S RCLINE=+RCDA(Z),Z0=+$O(^TMP("RCDPE-EOB_WLDX",$J,Z_".999"),-1) 85 S RCZ=Z F S RCZ=$O(^TMP("RCDPE-EOB_WLDX",$J,RCZ)) Q:'RCZ!(RCZ\1'=Z) D 86 . S Q=$P($G(^TMP("RCDPE-EOB_WLDX",$J,RCZ)),U,2) 87 . Q:'Q 88 . S RCZ(RCZ)=Q 89 . S Q0=0 F S Q0=$O(^RCY(344.49,RCSCR,1,Q,1,Q0)) Q:'Q0 I "01"[$P($G(^(Q0,0)),U,2) K RCZ(RCZ) Q 90 I '$O(RCZ(0)) D G SPLITQ 91 . S DIR(0)="EA",DIR("A",1)="THIS ENTRY HAS NO LINES AVAILABLE TO EDIT/SPLIT",DIR("A")="PRESS RETURN TO CONTINUE " W ! D ^DIR K DIR 92 S RCQUIT=0 93 I $P($G(^RCY(344.49,RCSCR,1,RCLINE,0)),U,13) D G:RCQUIT SPLITQ 94 . S DIR("A",1)="WARNING! THIS LINE HAS ALREADY BEEN VERIFIED",DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE?: ",DIR(0)="YA",DIR("B")="NO" W ! D ^DIR K DIR 95 . I Y'=1 S RCQUIT=1 96 S CT=0,CT=CT+1,DIR("?",CT)="Enter the line # that you want to split or edit:",RCONE=1 97 S L=Z F S L=$O(RCZ(L)) Q:'L D 98 . S L1=+$G(^TMP("RCDPE-EOB_WLDX",$J,L)) 99 . S CT=CT+1 100 . S DIR("?",CT)=$G(^TMP("RCDPE-EOB_WL",$J,L1,0)),CT=CT+1,DIR("?",CT)=$G(^TMP("RCDPE-EOB_WL",$J,L1+1,0)) S RCONE(1)=$S(RCONE:L,1:"") S RCONE=0 101 S DIR("?")=" ",Y=-1 102 I $G(RCONE(1)) S Y=+RCONE(1) K DIR G:'Y SPLITQ 103 I '$G(RCONE(1)) D K DIR I $D(DTOUT)!$D(DUOUT)!(Y\1'=Z) G SPLITQ 104 . F S DIR(0)="NAO^"_(Z+.001)_":"_Z0_":3",DIR("A")="WHICH LINE OF ENTRY "_Z_" DO YOU WANT TO SPLIT/EDIT?: " S:$G(RCONE(1))'="" DIR("B")=RCONE(1) D ^DIR Q:'Y!$D(DUOUT)!$D(DTOUT) D Q:Y>0 105 .. I '$D(^TMP("RCDPE-EOB_WLDX",$J,Y)) W !!,"LINE "_Y_" DOES NOT EXIST - TRY AGAIN",! S Y=-1 Q 106 .. I '$D(RCZ(Y)) W !!,"LINE "_Y_" HAS BEEN USED IN A DISTRIBUTE ADJ ACTION AND CAN'T BE EDITED",! S Y=-1 Q 107 .. S Q=+$O(^RCY(344.49,RCSCR,1,"B",Y,0)) 108 ; 109 K ^TMP("RCDPE_SPLIT_REBLD",$J) 110 D SPLIT^RCDPEWL3(RCSCR,+Y) 111 I $G(^TMP("RCDPE_SPLIT_REBLD",$J)) K ^TMP("RCDPE_SPLIT_REBLD",$J) D BLD^RCDPEWL1($G(^TMP($J,"RC_SORTPARM"))) 112 ; 113 SPLITQ S VALMBCK="R" 114 Q 115 ; 116 PRTERA ; View/prt 117 N DIC,X,Y,RCSCR 118 S DIC="^RCY(344.4,",DIC(0)="AEMQ" D ^DIC 119 Q:Y'>0 120 S RCSCR=+Y 121 D PRERA1 122 Q 123 ; 124 PRERA ; RCSCR is assumed to be defined 125 D FULL^VALM1 ; Protocol entry 126 PRERA1 ; Option entry 127 N %ZIS,ZTRTN,ZTSAVE,ZTDESC,POP,DIR,X,Y,RCERADET 128 S DIR("?",1)="INCLUDING EXPANDED DETAIL WILL SIGNIFICANTLY INCREASE THE SIZE OF THIS REPORT",DIR("?",2)="IF YOU CHOOSE TO INCLUDE IT, ALL PAYMENT DETAILS FOR EACH EEOB WILL BE" 129 S DIR("?")="LISTED. IF YOU WANT JUST SUMMARY DATA FOR EACH EEOB, DO NOT INCLUDE IT." 130 S DIR(0)="YA",DIR("A")="DO YOU WANT TO INCLUDE EXPANDED EEOB DETAIL?: ",DIR("B")="NO" W ! D ^DIR K DIR 131 I $D(DUOUT)!$D(DTOUT) G PRERAQ 132 S RCERADET=+Y 133 S %ZIS="QM" D ^%ZIS G:POP PRERAQ 134 I $D(IO("Q")) D G PRERAQ 135 . S ZTRTN="VPERA^RCDPEWL0("_RCSCR_","_RCERADET_")",ZTDESC="AR - Print ERA From Worklist" 136 . D ^%ZTLOAD 137 . W !!,$S($D(ZTSK):"Your task # "_ZTSK_" has been queued.",1:"Unable to queue this job.") 138 . K ZTSK,IO("Q") D HOME^%ZIS 139 U IO 140 D VPERA(RCSCR,RCERADET) 141 Q 142 ; 143 VPERA(RCSCR,RCERADET) ; Queued entry 144 ; RCSCR = ien of entry in file 344.4 145 ; RCERADET = 1 if inclusion of all EOB details from file 361.1 is 146 ; desired, 0 if not 147 N Z,Z0,RCSTOP,RCZ,RCPG,RCDOT,RCDIQ,RCDIQ1,RCDIQ2,RCXM1,RC,RCSCR1,RC3611 148 K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT"),^TMP($J,"RC_SUMALL") 149 S (RCSTOP,RCPG)=0,RCDOT="",$P(RCDOT,".",79)="" 150 D GETS^DIQ(344.4,RCSCR_",","*","IEN","RCDIQ") 151 D TXT0^RCDPEX31(RCSCR,.RCDIQ,.RCXM1,.RC) ; Get top level 0-node captioned flds 152 I $O(^RCY(344.4,RCSCR,2,0)) S RC=RC+1,RCXM1(RC)=" **ERA LEVEL ADJUSTMENTS**" 153 S RCSCR1=0 F S RCSCR1=$O(^RCY(344.4,RCSCR,2,RCSCR1)) Q:'RCSCR1 D 154 . K RCDIQ2 155 . D GETS^DIQ(344.42,RCSCR1_","_RCSCR_",","*","IEN","RCDIQ2") 156 . D TXT2^RCDPEX31(RCSCR,RCSCR1,.RCDIQ2,.RCXM1,.RC) ; Get top level ERA adjs 157 S RCSCR1=0 F S RCSCR1=$O(^RCY(344.4,RCSCR,1,RCSCR1)) Q:'RCSCR1 D 158 . K RCDIQ1 159 . D GETS^DIQ(344.41,RCSCR1_","_RCSCR_",","*","IEN","RCDIQ1") 160 . D TXT00^RCDPEX31(RCSCR,RCSCR1,.RCDIQ1,.RCXM1,.RC) 161 . S RC=RC+1,RCXM1(RC-1)=$E("PATIENT: "_$$PNM4^RCDPEWL1(RCSCR,RCSCR1)_$J("",41),1,41)_"CLAIM #: "_$$BILLREF^RCDPESR0(RCSCR,RCSCR1),RCXM1(RC)=" " 162 . S RC3611=$P($G(^RCY(344.4,RCSCR,1,RCSCR1,0)),U,2) 163 . I RCERADET D ; Include formatted txt from 361.1 or 344.411 164 .. I 'RC3611 D Q ; Formatted raw data 165 ... D DISP^RCDPESR0("^RCY(344.4,"_RCSCR_",1,"_RCSCR1_",1)","^TMP($J,""RC_SUMRAW"")",1,"^TMP($J,""RC_SUMOUT"")",75,1) 166 ..; 167 .. E D ; Detail record is in 361.1 168 ... K ^TMP("PRCA_EOB",$J) 169 ... D GETEOB^IBCECSA6(RC3611,2) 170 ... I $O(^IBM(361.1,RC3611,"ERR",0)) D GETERR^RCDPEDS(RC3611,+$O(^TMP("PRCA_EOB",$J,RC3611," "),-1)) ; get filing errors 171 ... S Z=0 F S Z=$O(^TMP("PRCA_EOB",$J,RC3611,Z)) Q:'Z S RC=RC+1,^TMP($J,"RC_SUMOUT",RC)=$G(^TMP("PRCA_EOB",$J,RC3611,Z)) 172 ... S RC=RC+2,^TMP($J,"RC_SUMOUT",RC-1)=" ",^TMP($J,"RC_SUMOUT",RC)=" " 173 ... K ^TMP("PRCA_EOB",$J) 174 . I $D(RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2)) D 175 .. S RC=RC+1,RCXM1(RC)=" **EXCEPTION RESOLUTION LOG DATA**" 176 .. S Z=0 F S Z=$O(RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2,Z)) Q:'Z S RC=RC+1,RCXM1(RC)=RCDIQ1(344.41,RCSCR1_","_RCSCR_",",2,Z) 177 . S RC=RC+1,RCXM1(RC)=" " 178 . S Z0=+$O(^TMP($J,"RC_SUMALL"," "),-1) 179 . S Z=0 F S Z=$O(RCXM1(Z)) Q:'Z S Z0=Z0+1,^TMP($J,"RC_SUMALL",Z0)=RCXM1(Z) 180 . K RCXM1 S RC=0 181 . S Z=0 F S Z=$O(^TMP($J,"RC_SUMOUT",Z)) Q:'Z S Z0=Z0+1,^TMP($J,"RC_SUMALL",Z0)=$G(^TMP($J,"RC_SUMOUT",Z)) 182 S RCSTOP=0,Z="" 183 F S Z=$O(^TMP($J,"RC_SUMALL",Z)) Q:'Z D Q:RCSTOP 184 . I $D(ZTQUEUED),$$S^%ZTLOAD S (RCSTOP,ZTSTOP)=1 K ZTREQ I +$G(RCPG) W !!,"***TASK STOPPED BY USER***" Q 185 . I 'RCPG!(($Y+5)>IOSL) D I RCSTOP Q 186 .. D:RCPG ASK(.RCSTOP) I RCSTOP Q 187 .. D HDR(.RCPG) 188 . W !,$G(^TMP($J,"RC_SUMALL",Z)) 189 ; 190 I 'RCSTOP,RCPG D ASK(.RCSTOP) 191 ; 192 I $D(ZTQUEUED) S ZTREQ="@" 193 I '$D(ZTQUEUED) D ^%ZISC 194 ; 195 PRERAQ K ^TMP($J,"RC_SUMRAW"),^TMP($J,"RC_SUMOUT"),^TMP($J,"SUMALL") 196 S VALMBCK="R" 197 Q 198 ; 199 HDR(RCPG) ;Report hdr 200 ; RCPG = last page # 201 I RCPG!($E(IOST,1,2)="C-") W @IOF,*13 202 S RCPG=$G(RCPG)+1 203 W !,?5,"EDI LOCKBOX WORKLIST - ERA DETAIL",?55,$$FMTE^XLFDT(DT,2),?70,"Page: ",RCPG,!,$TR($J("",IOM)," ","=") 204 Q 205 ; 206 ASK(RCSTOP) ; 207 I $E(IOST,1,2)'["C-" Q 208 N DIR,DIROUT,DIRUT,DTOUT,DUOUT 209 S DIR(0)="E" W ! D ^DIR 210 I ($D(DIRUT))!($D(DUOUT)) S RCSTOP=1 Q 211 Q 212 ; -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEX32.m
r613 r623 1 RCDPEX32 2 ;;4.5;Accounts Receivable;**173,249**;Mar 20, 1995;Build 2 3 4 5 EDITNUM 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 . S RCEOB=$$DUP^IBCEOB("^TMP("_$J_",""RCDP-EOB"",1)",RCBILL) ; IA 404251 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 EDITNQ 84 85 86 87 88 CHGED(DA,RCEOB,RCSAVE) 89 90 91 92 93 94 95 1 RCDPEX32 ;ALB/TMK - ELECTRONIC EOB EXCEPTION PROCESSING - FILE 344.4 ;10-OCT-02 2 ;;4.5;Accounts Receivable;**173**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 EDITNUM ; Edit invalid claim # to valid, refile EOB 6 N RC,RC0,RCDA,RCXDA,RCXDA1,RCSAVE,RCEOB,RCWARN,Q,Q0,DA,DR,DIE,DIC,DIR,X,Y,RCBILL,RCCHG 7 D FULL^VALM1 8 D SEL^RCDPEX3(.RCDA) 9 G:'$O(RCDA(0)) EDITNQ 10 ; 11 S RC=0 F S RC=$O(RCDA(RC)) Q:'RC D L -^RCY(344.4,RCXDA1,1,RCXDA,0) 12 . S RCXDA1=+RCDA(RC),RCXDA=+$P(RCDA(RC),U,2),RCSAVE="" 13 . I '$$LOCK^RCDPEX31(RCXDA1,RCXDA,1) D Q 14 .. S DIR(0)="EA",DIR("A",1)="**Selection #"_RC_" is being edited by another user - ... please try again later",DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR 15 . S RC0=$G(^RCY(344.4,RCXDA1,1,RCXDA,0)) 16 . I $P(RC0,U,5)="" D Q 17 .. S DIR(0)="EA",DIR("A",1)="The claim for selection #"_RC_" can't be edited as the bill # is not invalid",DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR 18 . I $P(RC0,U,9) D Q 19 .. S DIR(0)="EA",DIR("A",1)="The claim for selection #"_RC_" can't be edited as the claim has already",DIR("A")="been transferred to another site - PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR 20 . ; 21 . I $D(^RCY(344.49,RCXDA1)) D 22 .. N X 23 .. S X=$G(^RCY(344,+$P($G(^RCY(344.49,RCXDA1,0)),U,2),0)) 24 .. W !!,*7,"Warning: EEOB Worklist entry #"_RCXDA1_$S($P(X,U)'="":" and receipt "_$P(X,U),1:"")_" exist for this EEOB" 25 .. I X="" W !,"You should refresh the worklist entry to include the new claim #",!," before creating the receipt",! 26 . I $P($G(^RCY(344.4,RCXDA1,0)),U,8) D 27 .. W !,"Since the receipt for this EEOB ("_$P($G(^RCY(344,+$P($G(^RCY(344.4,RCXDA1,0)),U,8),0)),U)_") already exists" 28 .. I '$P($G(^RCY(344,+$P($G(^RCY(344.4,RCXDA1,0)),U,8),0)),U,14) W !," and is closed, you will need to use link payment to apply the payment",!," to the correct account",! Q 29 .. W !," you should edit the receipt and change the claim # so it posts to the",!," correct account",! 30 . ; 31 . I $P(RC0,U,17)="" S RCSAVE=$P(RC0,U,5) 32 . W !,"Selection #: "_RC_$J("",5)_$P(RC0,U,5) 33 . S DIC("A")="Select A/R Bill this EEOB is actually paying on: ",DIC="^PRCA(430,",DIC(0)="AEMQ",DIC("S")="I $D(^DGCR(399,+Y,0))" W ! D ^DIC K DIC 34 . Q:Y'>0 35 . S RCBILL=+Y,RCBILL(1)=$P($G(^PRCA(430,RCBILL,0)),U),RCWARN=0 36 . I $P($G(^RCY(344.4,RCXDA1,0)),U,14) S RCWARN=RCWARN+1,DIR("A",RCWARN+1)=$J("",4)_"THE RECEIPT FOR THIS EEOB HAS ALREADY BEEN POSTED." 37 . I $P($G(^PRCA(430.3,+$P($G(^PRCA(430,RCBILL,0)),U,8),0)),U,3)'=102 S RCWARN=RCWARN+1,DIR("A",RCWARN+1)=$J("",4)_"THIS IS NOT AN ACTIVE ACCOUNTS RECEIVABLE." 38 . I RCWARN D I Y'=1 Q 39 .. S DIR("A",1)="** WARNING"_$S(RCWARN>1:"S",1:"")_":" 40 .. S DIR("A",RCWARN+1)=" " 41 .. S DIR(0)="YA",DIR("A")="ARE YOU SURE YOU WANT TO FILE THIS EEOB FOR CLAIM #: "_RCBILL(1)_"?: ",DIR("B")="NO" W ! D ^DIR K DIR 42 .. ; 43 . ; File EOB for new claim # 44 . K ^TMP($J,"RCDP-EOB"),^TMP($J,"RCDPEOB","HDR") 45 . S Q=0 F S Q=$O(^RCY(344.4,RCXDA1,1,RCXDA,1,Q)) Q:'Q S Q0=$G(^(Q,0)) D 46 .. I $P(Q0,U)["835ERA" S ^TMP($J,"RCDPEOB","HDR")=Q0 47 .. I $P(Q0,U,2)=$P(RC0,U,5) S $P(Q0,U,2)=RCBILL(1) 48 .. S ^TMP($J,"RCDP-EOB",1,Q,0)=Q0 49 . S ^TMP($J,"RCDP-EOB",1,.5,0)="835ERA" 50 . S RCEOB=$$DUP^IBCEOB(RCBILL,"^TMP("_$J_",""RCDP-EOB"",1)") ; IA 4042 51 . K ^TMP($J,"RCDP-EOB",1,.5,0) 52 . I RCEOB D Q 53 .. N RCWHY S RCWHY(1)="EEOB already found on file while trying to change claim # and filing into IB" 54 .. D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY) 55 .. S RCCHG=1,DA(1)=RCXDA1,DA=RCXDA D CHGED(.DA,RCEOB,RCSAVE) 56 .. S DIR(0)="YA",DIR("A",1)="EEOB detail is already on file for "_RCBILL(1)_" - Exception removed",DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR 57 . ; 58 . ; Add stub rec to 361.1 if not there 59 . S RCEOB=+$$ADD3611^IBCEOB(+$P($G(^RCY(344.4,RCXDA1,0)),U,12),"","",RCBILL,1,"^TMP("_$J_",""RCDP-EOB"",1)") ; IA 4042 60 . ; 61 . I RCEOB<0 D Q 62 .. N RCWHY S RCWHY(1)="Error encountered trying to change claim # and file into IB" 63 .. D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY) 64 .. S DIR("A")="EA",DIR("A",1)="Error - EEOB detail not added to IB for bill "_RCBILL(1),DIR("A")="PRESS RETURN TO CONTINUE" D ^DIR K DIR 65 . ; 66 . ; Update EOB in file 361.1 67 . ; Call needs ^TMP arrays: $J,"RCDPEOB","HDR" and $J,"RCDP-EOB" 68 . D UPD3611^IBCEOB(RCEOB,1,1) ; IA 4042 69 . ; errors in ^TMP("RCDPERR-EOB",$J 70 . I $O(^TMP("RCDPERR-EOB",$J,0)) D 71 .. D ERRUPD^IBCEOB(RCEOB,"RCDPERR-EOB") ; Adds error msgs to IB file 361.1 ; IA 4042 72 . ; 73 . S RCCHG=1 74 . N RCWHY S RCWHY(1)="EEOB claim # changed and filed into IB under new claim #" 75 . D STORACT^RCDPEX31(RCXDA1,RCXDA,.RCWHY) 76 . S DA(1)=RCXDA1,DA=RCXDA 77 . D CHGED(.DA,RCEOB,RCSAVE) 78 . S DIE="^RCY(344.4,"_DA(1)_",1,",DR="1///@" D ^DIE 79 . S DIR("A",1)="EEOB Filed. Its detail may be viewed using Third Party Joint Inquiry",DIR("A")="PRESS RETURN TO CONTINUE ",DIR(0)="EA" 80 . W ! D ^DIR K DIR 81 . S VALMBG=1 82 ; 83 EDITNQ I $G(RCCHG) D BLD^RCDPEX2 84 K ^TMP($J,"RCDP-EOB"),^TMP($J,"RCDPEOB","HDR"),^TMP("RCDPERR-EOB",$J) 85 S VALMBCK="R" 86 Q 87 ; 88 CHGED(DA,RCEOB,RCSAVE) ; Change bad bill # to good one for EOB 89 ; DA = DA and DA(1) to use for DIE call 90 ; RCEOB = the ien of the entry in file 361.1 91 ; RCSAVE = the free text of the original bill # 92 N DIE,DR,X,Y 93 S DIE="^RCY(344.4,"_DA(1)_",1,",DR=".05///@;.02////"_RCEOB_";.13////1"_$S(RCSAVE'="":";.17////"_RCSAVE,1:"")_";.07///@" D ^DIE 94 Q 95 ; -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPUDEP.m
r613 r623 1 RCDPUDEP ;WISC/RFJ-deposit utilities ;29/MAY/2008 2 ;;4.5;Accounts Receivable;**114,173,257**;Mar 20, 1995;Build 3 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 Q 5 ; 6 ; 7 ADDDEPT(DEPOSIT,DEPDATE) ; if the deposit is not entered, add it 8 ; 9 ; if deposit date is missing, do not add the deposit 10 I 'DEPDATE Q 0 11 ; 12 ; already in file, deposit number and deposit date match 13 N DA,RCDPFLAG 14 S DA=0 F S DA=$O(^RCY(344.1,"B",DEPOSIT,DA)) Q:'DA I $P($G(^RCY(344.1,DA,0)),"^",3)=DEPDATE S RCDPFLAG=1 Q 15 I $G(RCDPFLAG) Q DA 16 ; 17 ; add it 18 N %,%DT,D0,DA,DD,DI,DIC,DIE,DLAYGO,DO,DQ,DR,X,Y 19 S DIC="^RCY(344.1,",DIC(0)="L",DLAYGO=344.1 20 ; .03 = deposit date .06 = opened by 21 ; .07 = date/time opened .12 = status (set to 1:open) 22 S DIC("DR")=".03////"_DEPDATE_";.06////"_DUZ_";.07///NOW;.12////1;" 23 S X=DEPOSIT 24 D FILE^DICN 25 I Y>0 Q +Y 26 Q 0 27 ; 28 ; 29 SELDEPT(ADDNEW) ; select a deposit 30 ; if $g(addnew) allow adding a new deposit 31 ; returns -1 for timeout or ^, 0 for no selection, or ien of deposit 32 N %,%T,%Y,C,D0,DA,DIC,DIE,DLAYGO,DQ,DR,DTOUT,DUOUT,RCDEFLUP,X,Y 33 S DIC="^RCY(344.1,",DIC(0)="QEAM",DIC("A")="Select DEPOSIT: " 34 S DIC("W")="D DICW^RCDPUDEP" 35 ; use special lookup on input 36 S RCDEFLUP=1 37 I $G(ADDNEW) S DIC(0)="QEALM",DLAYGO=344.1,DIC("DR")=".03///TODAY;.06////"_DUZ_";.07///NOW;.12////1;" 38 D ^DIC 39 I Y<0,'$G(DUOUT),'$G(DTOUT) S Y=0 40 Q +Y 41 ; 42 ; 43 DICW ; write identifier code for receipt lookup 44 N DATA 45 S DATA=$G(^RCY(344.1,Y,0)) I DATA="" Q 46 ; opened by 47 W ?13,"by: ",$E($P($G(^VA(200,+$P(DATA,"^",6),0)),"^"),1,15) 48 ; date opened 49 I '$P(DATA,"^",7) S $P(DATA,"^",7)="???????" 50 W ?35," on: ",$E($P(DATA,"^",7),4,5),"/",$E($P(DATA,"^",7),6,7),"/",$E($P(DATA,"^",7),2,3) 51 ; total dollars 52 W ?50," amt: $",$J($P(DATA,"^",4),9,2) 53 ; status 54 W ?69," ",$P("N/A^OPEN^DEPOSITED^CONFIRMED^PROCESSED^VOID","^",+$P(DATA,"^",12)+1) 55 Q 56 ; 57 ; 58 LOOKUP ; special lookup on deposits, called from ^dd(344.1,.01,7.5) 59 ; if rcdeflup flag not set, do not use special lookup 60 I '$D(RCDEFLUP) Q 61 ; 1:OPEN;3:CONFIRMED 62 ; user entered O.? for lookup on open deposits 63 I X["O."!(X["o.") S DIC("S")="I $P(^(0),U,12)=1" S X="?" Q 64 ; user entered C.? for lookup on confirmed deposits 65 I X["C."!(X["c.") S DIC("S")="I $P(^(0),U,12)=3" S X="?" Q 66 ; deposit ticket # manually added is for electronic ticket only 67 I $G(DIC(0))["L",$$AUTODEP(X) D EN^DDIOL(" ** Deposit #'s starting with "_$E(X,1,3)_" can only be used by automatic deposits",,"!") S X="" Q 68 ; Do not allow for 7-, 8-, or 9-digit electronic ticket to be added. 69 I $G(DIC(0))["L",'$D(^RCY(344.1,"B",X)),$L(X)>6,$L(X)<10 D EN^DDIOL(" ** Deposit # of "_$L(X)_" digits not allowed. "_$S($L(X)=9:"9 digits limited to automatic deposits.",1:""),,"!") S X="" Q 70 K DIC("S") 71 Q 72 ; 73 ; 74 EDITDEP(DA,ASKDATE) ; edit the deposit 75 ; if $g(askdate) ask only the deposit date 76 N %,D,D0,DI,DIC,DIE,DQ,DR,J,X,Y 77 S (DIC,DIE)="^RCY(344.1,",DR="" 78 ; deposit date(.03), do not allow edit if closed or either lockbox 79 I $$CHECKDEP^RCDPDPLU(DA) S DR=".03BANK DEPOSIT DATE//TODAY;" 80 ; bank(.13) 81 S DR=DR_".13//"_$P($G(^RC(342.1,+$O(^RC(342.1,"AC",9,0)),0)),"^")_";" 82 ; bank trace(.05) 83 S DR=DR_".05;" 84 ; agency title(.17) 85 S DR=DR_".17//"_$P($G(^RC(342.1,+$O(^RC(342.1,"AC",10,0)),0)),"^")_";" 86 ; agency location code(.14), comments(1) 87 S DR=DR_".14//"_$P(^RC(342,1,0),"^",7)_";1;" 88 ; 89 ; only ask deposit date 90 I $G(ASKDATE) S DR=".03BANK DEPOSIT DATE//TODAY;" 91 D ^DIE 92 Q 93 ; 94 ; 95 CONFIRM(DA) ; confirm the deposit 96 N %DT,D,D0,DI,DIC,DIE,DQ,DR,X,Y 97 S (DIC,DIE)="^RCY(344.1," 98 S DR=".04///"_$$TOTAL(DA)_";.12////3;.1////"_DUZ_";.11///NOW;" 99 D ^DIE 100 Q 101 ; 102 ; 103 TOTAL(RCDEPTDA) ; compute total dollars for all receipts on the deposit 104 N RCRECTDA,RCTRANDA,TOTAL 105 S RCRECTDA=0 106 F S RCRECTDA=$O(^RCY(344,"AD",RCDEPTDA,RCRECTDA)) Q:'RCRECTDA D 107 . S RCTRANDA=0 108 . F S RCTRANDA=$O(^RCY(344,RCRECTDA,1,RCTRANDA)) Q:'RCTRANDA D 109 . . S TOTAL=$G(TOTAL)+$P($G(^RCY(344,RCRECTDA,1,RCTRANDA,0)),"^",4) 110 Q +$G(TOTAL) 111 ; 112 AUTODEP(X) ; Function returns 1 if the deposit ticket # in X is in the auto 113 ; deposit number space 269xxx, 369xxx, 469xxx, 569xxx, or 669xxx 114 ; and hasn't been previously entered via lockbox interface. 115 ; 116 N Y 117 S Y=0 118 I $L(X)=6,$E(X,2,3)="69","23456"[$E(X),'$D(^RCY(344.1,"B",X)) S Y=1 119 Q Y 120 ; 1 RCDPUDEP ;WISC/RFJ-deposit utilities ;1 Jun 99 2 ;;4.5;Accounts Receivable;**114,173**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 Q 5 ; 6 ; 7 ADDDEPT(DEPOSIT,DEPDATE) ; if the deposit is not entered, add it 8 ; 9 ; if deposit date is missing, do not add the deposit 10 I 'DEPDATE Q 0 11 ; 12 ; already in file, deposit number and deposit date match 13 N DA,RCDPFLAG 14 S DA=0 F S DA=$O(^RCY(344.1,"B",DEPOSIT,DA)) Q:'DA I $P($G(^RCY(344.1,DA,0)),"^",3)=DEPDATE S RCDPFLAG=1 Q 15 I $G(RCDPFLAG) Q DA 16 ; 17 ; add it 18 N %,%DT,D0,DA,DD,DI,DIC,DIE,DLAYGO,DO,DQ,DR,X,Y 19 S DIC="^RCY(344.1,",DIC(0)="L",DLAYGO=344.1 20 ; .03 = deposit date .06 = opened by 21 ; .07 = date/time opened .12 = status (set to 1:open) 22 S DIC("DR")=".03////"_DEPDATE_";.06////"_DUZ_";.07///NOW;.12////1;" 23 S X=DEPOSIT 24 D FILE^DICN 25 I Y>0 Q +Y 26 Q 0 27 ; 28 ; 29 SELDEPT(ADDNEW) ; select a deposit 30 ; if $g(addnew) allow adding a new deposit 31 ; returns -1 for timeout or ^, 0 for no selection, or ien of deposit 32 N %,%T,%Y,C,D0,DA,DIC,DIE,DLAYGO,DQ,DR,DTOUT,DUOUT,RCDEFLUP,X,Y 33 S DIC="^RCY(344.1,",DIC(0)="QEAM",DIC("A")="Select DEPOSIT: " 34 S DIC("W")="D DICW^RCDPUDEP" 35 ; use special lookup on input 36 S RCDEFLUP=1 37 I $G(ADDNEW) S DIC(0)="QEALM",DLAYGO=344.1,DIC("DR")=".03///TODAY;.06////"_DUZ_";.07///NOW;.12////1;" 38 D ^DIC 39 I Y<0,'$G(DUOUT),'$G(DTOUT) S Y=0 40 Q +Y 41 ; 42 ; 43 DICW ; write identifier code for receipt lookup 44 N DATA 45 S DATA=$G(^RCY(344.1,Y,0)) I DATA="" Q 46 ; opened by 47 W ?13,"by: ",$E($P($G(^VA(200,+$P(DATA,"^",6),0)),"^"),1,15) 48 ; date opened 49 I '$P(DATA,"^",7) S $P(DATA,"^",7)="???????" 50 W ?35," on: ",$E($P(DATA,"^",7),4,5),"/",$E($P(DATA,"^",7),6,7),"/",$E($P(DATA,"^",7),2,3) 51 ; total dollars 52 W ?50," amt: $",$J($P(DATA,"^",4),9,2) 53 ; status 54 W ?69," ",$P("N/A^OPEN^DEPOSITED^CONFIRMED^PROCESSED^VOID","^",+$P(DATA,"^",12)+1) 55 Q 56 ; 57 ; 58 LOOKUP ; special lookup on deposits, called from ^dd(344.1,.01,7.5) 59 ; if rcdeflup flag not set, do not use special lookup 60 I '$D(RCDEFLUP) Q 61 ; 1:OPEN;3:CONFIRMED 62 ; user entered O.? for lookup on open deposits 63 I X["O."!(X["o.") S DIC("S")="I $P(^(0),U,12)=1" S X="?" Q 64 ; user entered C.? for lookup on confirmed deposits 65 I X["C."!(X["c.") S DIC("S")="I $P(^(0),U,12)=3" S X="?" Q 66 ; deposit ticket # manually entered is for electronic ticket only 67 I $G(DIC(0))["L",$$AUTODEP(X) D EN^DDIOL(" ** Deposit #'s starting with "_$E(X,1,3)_" can only be used by automatic deposits",,"!") S X="" 68 K DIC("S") 69 Q 70 ; 71 ; 72 EDITDEP(DA,ASKDATE) ; edit the deposit 73 ; if $g(askdate) ask only the deposit date 74 N %,D,D0,DI,DIC,DIE,DQ,DR,J,X,Y 75 S (DIC,DIE)="^RCY(344.1,",DR="" 76 ; deposit date(.03), do not allow edit if closed or either lockbox 77 I $$CHECKDEP^RCDPDPLU(DA) S DR=".03BANK DEPOSIT DATE//TODAY;" 78 ; bank(.13) 79 S DR=DR_".13//"_$P($G(^RC(342.1,+$O(^RC(342.1,"AC",9,0)),0)),"^")_";" 80 ; bank trace(.05) 81 S DR=DR_".05;" 82 ; agency title(.17) 83 S DR=DR_".17//"_$P($G(^RC(342.1,+$O(^RC(342.1,"AC",10,0)),0)),"^")_";" 84 ; agency location code(.14), comments(1) 85 S DR=DR_".14//"_$P(^RC(342,1,0),"^",7)_";1;" 86 ; 87 ; only ask deposit date 88 I $G(ASKDATE) S DR=".03BANK DEPOSIT DATE//TODAY;" 89 D ^DIE 90 Q 91 ; 92 ; 93 CONFIRM(DA) ; confirm the deposit 94 N %DT,D,D0,DI,DIC,DIE,DQ,DR,X,Y 95 S (DIC,DIE)="^RCY(344.1," 96 S DR=".04///"_$$TOTAL(DA)_";.12////3;.1////"_DUZ_";.11///NOW;" 97 D ^DIE 98 Q 99 ; 100 ; 101 TOTAL(RCDEPTDA) ; compute total dollars for all receipts on the deposit 102 N RCRECTDA,RCTRANDA,TOTAL 103 S RCRECTDA=0 104 F S RCRECTDA=$O(^RCY(344,"AD",RCDEPTDA,RCRECTDA)) Q:'RCRECTDA D 105 . S RCTRANDA=0 106 . F S RCTRANDA=$O(^RCY(344,RCRECTDA,1,RCTRANDA)) Q:'RCTRANDA D 107 . . S TOTAL=$G(TOTAL)+$P($G(^RCY(344,RCRECTDA,1,RCTRANDA,0)),"^",4) 108 Q +$G(TOTAL) 109 ; 110 AUTODEP(X) ; Function returns 1 if the deposit ticket # in X is in the auto 111 ; deposit number space 269xxx, 369xxx, 469xxx, 569xxx 112 N Y 113 S Y=0 114 I $L(X)=6,$E(X,2,3)="69","2345"[$E(X),'$D(^RCY(344.1,"B",X)) S Y=1 115 Q Y 116 ; -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCFMOBR.m
r613 r623 1 RCFMOBR ;WASH-ISC@ALTOONA,PA/RWT-BILL RECONCILIATIONS LIST ;11/20/96 2:30 PM 2 V ;;4.5;Accounts Receivable;**2,20,40,53,249**;Mar 20, 1995;Build 2 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 EN ;Creates report from OBR data in file 423.6 5 ; 6 ; OBR Data Structure used by this routine 7 ; ^TMP("OBR",$J,SITE,"NOT IN AR")=NextRec^TotalItems^TotalFMSAmt 8 ; ^TMP("OBR",$J,SITE,"NOT IN FMS")=NextRec^TotalItems^TotalARAmt 9 ; ^TMP("OBR",$J,SITE,"DISCREPANCY")=NextRec^TotalItems^TotalFMSAmt^TotalARAmt 10 ; ^TMP("OBR",$J,"BN",BILLNUMBER)=[423.6 rec] <-- x-ref of FMS Bills 11 ; ^TMP("OBR",$J,"REPORT","1")="LINE 1" 12 ; ^TMP("OBR",$J","REPORT,"2")="LINE 2" 13 ; 14 ; Descriptions of modules: 15 ; PROCFMS - loop through FMS bills (^PRCF(423.6)) updating 16 ; global ^TMP("OBR",$J,"BN") while also checking 17 ; for invalid AR bills 18 ; PROCAR - loop through all Active AR Bills comparing amounts 19 ; and looking for Detail bills not found in FMS 20 ; BUILDRPT - Prepares report in global ^TMP("OBR",$J,"REPORT") 21 ; 22 N X,Y,OBR,A0,ERR 23 K ^TMP("OBR",$J) 24 ; 25 I $G(PRCADA) D PROCESS(PRCADA) G Q1 26 S OBR="OBR-",ERR=-1 27 F S OBR=$O(^PRCF(423.6,"B",OBR)) Q:OBR=""!(OBR'["OBR-") D 28 .I $O(^PRCF(423.6,"B",OBR))'["OBR-" D Q 29 ..S A0=$O(^PRCF(423.6,"B",OBR,0)) 30 ..S ERR=0 D PROCESS(A0) 31 I ERR D PROCESS(ERR) 32 Q1 K ^TMP("OBR",$J) 33 Q 34 PROCESS(A0) N X,X1,X2,Y,SN,PARENT,XMTEXT,XMSUB,XMSENDER,XMDUZ,ERR,DATE,FMSDATE 35 S ERR=0 D 36 .I '$D(^PRCF(423.6,A0,0)) S ERR=-1 Q 37 .I $E(^PRCF(423.6,A0,0),1,3)'["OBR" S ERR=-1 Q 38 .S X=$P(^PRCF(423.6,A0,0),"-",2) 39 .S X=$E(X,5,6)_"-"_$E(X,7,8)_"-"_$E(X,1,4) D ^%DT ;Y is defined 40 .S PARENT=$P($P(^PRCF(423.6,A0,0),"-",5),U) 41 .; 42 .D PROCFMS^RCFMOBR1(A0) 43 .D PROCAR^RCFMOBR1(A0) 44 .D BUILDRPT^RCFMOBR2(PARENT) 45 ; 46 I '$D(PARENT) S PARENT=$$SITE^RCMSITE 47 S PARENT=$P(^DIC(4,+$O(^DIC(4,"D",PARENT,0)),0),U) 48 ; 49 I '$D(Y) S Y=DT ;Y may be defined from %DT call above 50 S X1=Y,X2=($E(Y,6,7)+1)*-1 D C^%DTC,YX^%DTC 51 S FMSDATE=$P(Y,"@"),FMSDATE=$E(FMSDATE,1,4)_$E(FMSDATE,9,12) 52 D NOW^%DTC S DATE=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3) 53 ; - Transmits report via e-mail to FMS mail group 54 S XMSUB="FMS "_FMSDATE_" RECONCILIATION ("_DATE_") " 55 S XMSUB=XMSUB_PARENT 56 I ERR D 57 .S ^TMP("OBR",$J,"REPORT",1)="Date of Report: "_DATE 58 .S ^TMP("OBR",$J,"REPORT",2)="NOTE: This report compares your current A/R records with data received from" 59 .S ^TMP("OBR",$J,"REPORT",3)=" FMS on the last day of the previous accounting period." 60 .S ^TMP("OBR",$J,"REPORT",4)="" 61 .S ^TMP("OBR",$J,"REPORT",5)="No FMS data exists to reconcile!" 62 S XMTEXT="^TMP(""OBR"",$J,""REPORT""," 63 S XMDUZ="Accounts Receivable Package",XMY("G.FMS")="",XMY(DUZ)="" D ^XMD 64 Q 65 EN2 ;Entry point from Regenerate Prior Month OBRs option 66 N DIR,PRCADA,Y 67 W !!,"This option will transmit the OBR report(s) to you and members" 68 W !,"of the G.FMS mail group." 69 W !!,"NOTE: Depending on the number of active AR bills in your system," 70 W !," this may take awhile to run.",! 71 S DIR(0)="YO",DIR("A")="Are you sure you want to do this",DIR("B")="NO" 72 D ^DIR Q:Y'=1 S ZTRTN="EN^RCFMOBR",ZTDESC="Prior Month OBRs" 73 S ZTIO="" D ^%ZTLOAD Q 74 ; 75 EN3 ;Deletes OBRs over 60 days old 76 N A0,A1,A2,DA,DIK,X,X1,X2 77 S A0="OBR-" F S A0=$O(^PRCF(423.6,"B",A0)) Q:A0=""!(A0'["OBR-") S A1=$E($P(A0,"-",2),1,8),A2=0 F S A2=$O(^PRCF(423.6,"B",A0,A2)) Q:+A2=0 D 78 .S X1=DT,X2=$$RCDT(A1) D ^%DTC I X>60 S DIK="^PRCF(423.6,",DA=A2 D ^DIK 79 Q 80 RCDT(A1) ;Convert yyyymmdd to FM date 81 N X,Y 82 S X=A1,X=$E(X,5,6)_" "_$E(X,7,8)_", "_$E(X,1,4) 83 D ^%DT 84 Q Y 85 PURGE ;purge unprocessed document file 86 N DIR,Y,X,X1,X2,RCDT 87 S DIR("A")="How many days worth of DATA do you want to retain" 88 S DIR(0)="N",DIR("?")="This is the number of days entries will remain in the file." 89 D ^DIR 90 I +Y<0!(Y="")!($E(Y,1)="^") G POUT 91 S X1=DT,X2=-(+Y) D C^%DTC S RCDT=X 92 S ZTRTN="QPURGE^RCFMOBR",ZTSAVE("RCDT")="",ZTDESC="Purge unprocessed document list",ZTIO="" D ^%ZTLOAD 93 POUT K DIRUT,DIROUT,DTOUT,DUOUT Q 94 ; 95 QPURGE N DA,DIK 96 S DIK="^RC(347," 97 Q:'$D(^RC(347)) 98 S DA=0 F S DA=$O(^RC(347,DA)) Q:'DA I $P(^(DA,0),U,5)<RCDT D ^DIK 99 K RCDT 100 Q 1 RCFMOBR ;WASH-ISC@ALTOONA,PA/RWT-BILL RECONCILIATIONS LIST ;11/20/96 2:30 PM 2 V ;;4.5;Accounts Receivable;**2,20,40,53**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 EN ;Creates report from OBR data in file 423.6 5 ; 6 ; OBR Data Structure used by this routine 7 ; ^TMP("OBR",$J,SITE,"NOT IN AR")=NextRec^TotalItems^TotalFMSAmt 8 ; ^TMP("OBR",$J,SITE,"NOT IN FMS")=NextRec^TotalItems^TotalARAmt 9 ; ^TMP("OBR",$J,SITE,"DISCREPANCY")=NextRec^TotalItems^TotalFMSAmt^TotalARAmt 10 ; ^TMP("OBR",$J,"BN",BILLNUMBER)=[423.6 rec] <-- x-ref of FMS Bills 11 ; ^TMP("OBR",$J,"REPORT","1")="LINE 1" 12 ; ^TMP("OBR",$J","REPORT,"2")="LINE 2" 13 ; 14 ; Descriptions of modules: 15 ; PROCFMS - loop through FMS bills (^PRCF(423.6)) updating 16 ; global ^TMP("OBR",$J,"BN") while also checking 17 ; for invalid AR bills 18 ; PROCAR - loop through all Active AR Bills comparing amounts 19 ; and looking for Detail bills not found in FMS 20 ; BUILDRPT - Prepares report in global ^TMP("OBR",$J,"REPORT") 21 ; 22 N X,Y,OBR,A0,ERR 23 K ^TMP("OBR",$J) 24 ; 25 I $G(PRCADA) D PROCESS(PRCADA) G Q1 26 S OBR="OBR-",ERR=-1 27 F S OBR=$O(^PRCF(423.6,"B",OBR)) Q:OBR=""!(OBR'["OBR-") D 28 .I $O(^PRCF(423.6,"B",OBR))'["OBR-" D Q 29 ..S A0=$O(^PRCF(423.6,"B",OBR,0)) 30 ..S ERR=0 D PROCESS(A0) 31 I ERR D PROCESS(ERR) 32 Q1 K ^TMP("OBR",$J) 33 Q 34 PROCESS(A0) N X,X1,X2,Y,SN,PARENT,XMTEXT,XMSUB,XMSENDER,XMDUZ,ERR,DATE,FMSDATE 35 S ERR=0 D 36 .I '$D(^PRCF(423.6,A0,0)) S ERR=-1 Q 37 .I $E(^PRCF(423.6,A0,0),1,3)'["OBR" S ERR=-1 Q 38 .S X=$P(^PRCF(423.6,A0,0),"-",2) 39 .S X=$E(X,5,6)_"-"_$E(X,7,8)_"-"_$E(X,1,4) D ^%DT ;Y is defined 40 .S PARENT=$P($P(^PRCF(423.6,A0,0),"-",5),U) 41 .; 42 .D PROCFMS^RCFMOBR1(A0) 43 .D PROCAR^RCFMOBR1(A0) 44 .D BUILDRPT^RCFMOBR2(PARENT) 45 ; 46 I '$D(PARENT) S PARENT=$$SITE^RCMSITE 47 S PARENT=$P(^DIC(4,+$O(^DIC(4,"D",PARENT,0)),0),U) 48 ; 49 I '$D(Y) S Y=DT ;Y may be defined from %DT call above 50 S X1=Y,X2=($E(Y,6,7)+1)*-1 D C^%DTC,YX^%DTC 51 S FMSDATE=$P(Y,"@"),FMSDATE=$E(FMSDATE,1,4)_$E(FMSDATE,9,12) 52 D NOW^%DTC S DATE=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3) 53 ; - Transmits report via e-mail to FMS mail group 54 S XMSUB="FMS "_FMSDATE_" RECONCILIATION ("_DATE_") " 55 S XMSUB=XMSUB_PARENT 56 I ERR D 57 .S ^TMP("OBR",$J,"REPORT",1)="Date of Report: "_DATE 58 .S ^TMP("OBR",$J,"REPORT",2)="NOTE: This report compares your current A/R records with data received from" 59 .S ^TMP("OBR",$J,"REPORT",3)=" FMS on the last day of the previous accounting period." 60 .S ^TMP("OBR",$J,"REPORT",4)="" 61 .S ^TMP("OBR",$J,"REPORT",5)="No FMS data exists to reconcile!" 62 S XMTEXT="^TMP(""OBR"",$J,""REPORT""," 63 S XMDUZ="Accounts Receivable Package",XMY("G.FMS")="",XMY(DUZ)="" D ^XMD 64 Q 65 EN2 ;Entry point from Regenerate Prior Month OBRs option 66 N DIR,PRCADA,Y 67 W !!,"This option will transmit the OBR report(s) to you and members" 68 W !,"of the G.FMS mail group." 69 W !!,"NOTE: Depending on the number of active AR bills in your system," 70 W !," this may take awhile to run.",! 71 S DIR(0)="YO",DIR("A")="Are you sure you want to do this",DIR("B")="NO" 72 D ^DIR Q:Y'=1 S ZTRTN="EN^RCFMOBR",ZTDESC="Prior Month OBRs" 73 S ZTIO="" D ^%ZTLOAD Q 74 ; 75 EN3 ;Deletes OBRs over 60 days old 76 N A0,A1,A2,DA,DIK,X,X1,X2 77 S A0="OBR-" F S A0=$O(^PRCF(423.6,"B",A0)) Q:A0=""!(A0'["OBR-") S A1=2_$E($P(A0,"-",2),3,8),A2=0 F S A2=$O(^PRCF(423.6,"B",A0,A2)) Q:+A2=0 D 78 .S X1=DT,X2=A1 D ^%DTC I X>60 S DIK="^PRCF(423.6,",DA=A2 D ^DIK 79 Q 80 PURGE ;purge unprocessed document file 81 N DIR,Y,X,X1,X2,RCDT 82 S DIR("A")="How many days worth of DATA do you want to retain" 83 S DIR(0)="N",DIR("?")="This is the number of days entries will remain in the file." 84 D ^DIR 85 I +Y<0!(Y="")!($E(Y,1)="^") G POUT 86 S X1=DT,X2=-(+Y) D C^%DTC S RCDT=X 87 S ZTRTN="QPURGE^RCFMOBR",ZTSAVE("RCDT")="",ZTDESC="Purge unprocessed document list",ZTIO="" D ^%ZTLOAD 88 POUT K DIRUT,DIROUT,DTOUT,DUOUT Q 89 ; 90 QPURGE N DA,DIK 91 S DIK="^RC(347," 92 Q:'$D(^RC(347)) 93 S DA=0 F S DA=$O(^RC(347,DA)) Q:'DA I $P(^(DA,0),U,5)<RCDT D ^DIK 94 K RCDT 95 Q -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCMSITE.m
r613 r623 1 RCMSITE ;ALB/RRG - EDIT SITE PARAMETERS ;03/12/02 2 V ;;4.5;Accounts Receivable;**173,236,253**;Mar 20, 1995;Build 9 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 BEG ;Start editing site paramters 5 N DIC,DLAYGO,X,Y,DIE,DA,DR 6 S DIC="^RC(342,",DIC(0)="QEAML",DLAYGO=342 D ^DIC I Y>0 S DA=+Y,DR=.01,DIE="^RC(342," D ^DIE 7 Q 8 ALC ;Edit ALC parameter 9 NEW DIC,DR,DA,Y 10 S DIE="^RC(342,",DA=1,DR=".07;31" D ^DIE 11 Q 12 IRS ;Edit IRS OFFSET site parameters 13 NEW DIE,DR,DA,Y 14 I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q 15 S DA=1,DR="[RCMS IRS]",DIE="^RC(342," D ^DIE 16 Q Q 17 STAT ;Edit NOTIFICATION site parameters 18 NEW DIE,DR,DA,Y 19 I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q1 20 S DA=1,DR="[RCMS NOTIFICATION]",DIE="^RC(342," D ^DIE 21 Q1 Q 22 GRP ;Edit AR Group Parameters 23 NEW DIE,DR,DA,Y 24 F W ! S DIC(0)="QEAML",DIC="^RC(342.1,",DLAYGO=342.1 D ^DIC K DIC G:Y<0 Q3 S DA=+Y,DIE="^RC(342.1,",DR=$P($G(^RC(342.2,+$P(^RC(342.1,+Y,0),"^",2),1)),"^") I DR]"" D ^DIE 25 Q3 Q 26 DEA ;Deactive an AR group 27 NEW DIE,DIC,DA,DR,Y,GRP 28 S DIC="^RC(342.1,",DIC(0)="QEAM",DIC("S")="I $P(^(0),""^"",2)'=7" D ^DIC Q:Y<0 S GRP=+Y 29 W ! S DIR("A")="Are you sure you want to Deactive Group '"_$P(^RC(342.1,GRP,0),"^")_"'",DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR 30 I 'Y W !!,"*** NO ACTION TAKEN ***" Q 31 I Y S DIE="^RC(342.1,",DA=GRP,DR=".02////^S X=7" D ^DIE W !!,"*** Group Deactivated ***" 32 Q 33 SITE() ;Return site number 34 Q +$G(^DIC(4,+$P($G(^RC(342,1,0)),"^"),99)) 35 INT ;Print Inter/Admin/Pen effective report 36 NEW DIC,BY,FR,TO,FLDS,L 37 S DIC="^RC(342,",BY=.01,(FR,TO)="",FLDS="[RCMS INT/ADM/PEN]",L=0 D EN1^DIP 38 Q 39 UPINT ;Update Rate site parameters 40 NEW DIE,DR,DA,Y,IOP 41 S IOP=ION D INT 42 I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q4 43 F W ! S DA=1,DR="[RCMS RATES]",DIE="^RC(342," D ^DIE Q:$D(Y) 44 Q4 Q 45 ; 46 EDILOCK ;Update EDI Lockbox site parameters 47 N DIE,DR,DA,Y 48 I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q5 49 S DA=1,DR="[RCMS EDI LOCKBOX]",DIE="^RC(342," D ^DIE 50 Q5 Q 51 ; 52 EDITRDDT ;Update # OF DAYS FOR RD ELIG CHG RPT site parameter 53 ;This is the number of days for the Rated Disability Eligibility 54 ;Change Report to be used when the report is scheduled to be run 55 ;on a recurring basis. (Added for Hold Debt to DMC Project) 56 N DIE,DR,DA,Y 57 I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q6 58 S DA=1,DR="8.01",DIE="^RC(342," D ^DIE 59 Q6 Q 60 ; 61 GETRDDAY() ;Return # OF DAYS FOR RD ELIG CHG RPT site parameter 62 Q $$GET1^DIQ(342,1_",",8.01) 63 ; 64 EDITRDAY ;Update NUMBER OF DAYS FOR DMC REPORTS site parameter. 65 ;This is the number of days in the past bills for episodes 66 ;of care will be included for the following reports when scheduled by 67 ;IRM to be run on a recurring basis: 68 ; DMC Debt Validity Report 69 ; DMC Debt Validity Management Report 70 ; Rated Disability Eligibility Change Report 71 ;The minimum value for this field is 365 days (1 year) and the maximum 72 ;value is 3650 days (10 years). If no value is added in this field the 73 ;report will default to 365 days. (Added for Hold Debt to DMC Project) 74 N DIE,DR,DA,Y 75 I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q7 76 S DA=1,DR="8.02",DIE="^RC(342," D ^DIE 77 Q7 Q 78 ; 79 GETRDAY() ;Return NUMBER OF DAYS FOR DMC REPORTS site parameter 80 Q $$GET1^DIQ(342,1_",",8.02) 81 ; 1 RCMSITE ;ALB/RRG - EDIT SITE PARAMETERS ;03/12/02 2 V ;;4.5;Accounts Receivable;**173,236**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 BEG ;Start editing site paramters 5 N DIC,DLAYGO,X,Y,DIE,DA,DR 6 S DIC="^RC(342,",DIC(0)="QEAML",DLAYGO=342 D ^DIC I Y>0 S DA=+Y,DR=.01,DIE="^RC(342," D ^DIE 7 Q 8 ALC ;Edit ALC parameter 9 NEW DIC,DR,DA,Y 10 S DIE="^RC(342,",DA=1,DR=".07;31" D ^DIE 11 Q 12 IRS ;Edit IRS OFFSET site parameters 13 NEW DIE,DR,DA,Y 14 I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q 15 S DA=1,DR="[RCMS IRS]",DIE="^RC(342," D ^DIE 16 Q Q 17 STAT ;Edit NOTIFICATION site parameters 18 NEW DIE,DR,DA,Y 19 I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q1 20 S DA=1,DR="[RCMS NOTIFICATION]",DIE="^RC(342," D ^DIE 21 Q1 Q 22 GRP ;Edit AR Group Parameters 23 NEW DIE,DR,DA,Y 24 F W ! S DIC(0)="QEAML",DIC="^RC(342.1,",DLAYGO=342.1 D ^DIC K DIC G:Y<0 Q3 S DA=+Y,DIE="^RC(342.1,",DR=$P($G(^RC(342.2,+$P(^RC(342.1,+Y,0),"^",2),1)),"^") I DR]"" D ^DIE 25 Q3 Q 26 DEA ;Deactive an AR group 27 NEW DIE,DIC,DA,DR,Y,GRP 28 S DIC="^RC(342.1,",DIC(0)="QEAM",DIC("S")="I $P(^(0),""^"",2)'=7" D ^DIC Q:Y<0 S GRP=+Y 29 W ! S DIR("A")="Are you sure you want to Deactive Group '"_$P(^RC(342.1,GRP,0),"^")_"'",DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR 30 I 'Y W !!,"*** NO ACTION TAKEN ***" Q 31 I Y S DIE="^RC(342.1,",DA=GRP,DR=".02////^S X=7" D ^DIE W !!,"*** Group Deactivated ***" 32 Q 33 SITE() ;Return site number 34 Q +$G(^DIC(4,+$P($G(^RC(342,1,0)),"^"),99)) 35 INT ;Print Inter/Admin/Pen effective report 36 NEW DIC,BY,FR,TO,FLDS,L 37 S DIC="^RC(342,",BY=.01,(FR,TO)="",FLDS="[RCMS INT/ADM/PEN]",L=0 D EN1^DIP 38 Q 39 UPINT ;Update Rate site parameters 40 NEW DIE,DR,DA,Y,IOP 41 S IOP=ION D INT 42 I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q4 43 F W ! S DA=1,DR="[RCMS RATES]",DIE="^RC(342," D ^DIE Q:$D(Y) 44 Q4 Q 45 ; 46 EDILOCK ;Update EDI Lockbox site parameters 47 N DIE,DR,DA,Y 48 I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q5 49 S DA=1,DR="[RCMS EDI LOCKBOX]",DIE="^RC(342," D ^DIE 50 Q5 Q 51 ; -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRCXM1.m
r613 r623 1 RCRCXM1 2 V ;;4.5;Accounts Receivable;**63,122,189,249**;Mar 20, 1995;Build 23 4 5 6 7 IBS 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 S ^TMP("RCRCVL",$J,"XM",PRCABN,4,1)="INS^"_$P($G(RCIB("PIN")),U,1)_U_$G(RCIB("PIN","MMA"))_U_$P($G(RCIB("PIN")),U,2,4)43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 IBSQ 66 67 1 RCRCXM1 ;ALB/CMS - AR/RC ORIGINAL TRANSMISSION SET ;09/08/97 2 V ;;4.5;Accounts Receivable;**63,122,189**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 Q 6 ; 7 IBS ;Set the IB Bill Information data line from RCRCVXM 8 ;Return: ^TMP("RCRCVL",$J,"XM") 9 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,1,1)="BN1^BILL#^CAT.ABB^STATUS.ABB^CURRENT BALANCE^BILL TYPE^FORM TYPE^BILL DATE FROM^BILL DATE TO" 10 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,1,2)="BN2^TOTAL BILL CHARGES^OFFSET AMT^OFFSET DESC.^DATE FIRST PRINTED^TAX ID^REFERRAL REASON CODE^REFERRAL COMMENT" 11 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,2,1)="BINS^NAME OF INSURED^SUBSCRIBER ID#^RELATIONSHIP TO INSURED^CONDITION RELATED TO^" 12 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,3,1)="PAT^PAT NAME^SSN^DOB^SEX^SENSITIVE RECORD Y/N^ADD1^ADD2^ADD3^CITY^STATE^ZIP" 13 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,4,1)="INS^INSURER NAME^ADD1^ADD2^ADD3^CITY^STATE^ZIP^PHONE^PROVIDER ID#^GROUP NAME^GROUP #" 14 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,5,1)="INSUP^DEBTNAME^DEBT ADD1^DEBT ADD2^DEBT ADD3^CITY^STATE^ZIP^PHONE 15 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,6,1)="OPV^1^OPV DATE1" 16 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,6,2)="OPV^2^OPV DATE2" 17 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,7,1)="DXS^1^DIAGNOSIS CODE^DESCRIPTION" 18 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,7,2)="DXS^2^DIAGNOSIS CODE^DESCRIPTION" 19 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,8,1)="RVC^1^REVENUE CODE^DESCRIPTION^RATE^UNITS^TOTAL CHARGES" 20 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,8,2)="RVC^2^REVENUE CODE^DESCRIPTION^RATE^UNITS^TOTAL CHARGES" 21 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,9,1)="PRC^1^PROCEDURE CODE^PROCEDURE DATE^PLACE OF SERVICE CODE^PLACE OF SERVICE^TYPE OF SERVICE CODE^TYPE OF SERVICE" 22 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,9,2)="PRC^2^PROCEDURE CODE^PROCEDURE DATE^PLACE OF SERVICE CODE^PLACE OF SERVICE^TYPE OF SERVICE CODE^TYPE OF SERVICE" 23 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,10,1)="RXF^1^RX #^REFILL DATE^DRUG^NAME^DAYS SUPPLY^QUANTITY^NDC NUMBER" 24 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,10,2)="RXF^2^RX #^REFILL DATE^DRUG^NAME^DAYS SUPPLY^QUANTITY^NDC NUMBER" 25 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,11,1)="PRD^1^PROSTHETIC DEVICE NAME^DELIVERY DATE" 26 ;S ^TMP("RCRCVL",$J,"XM",PRCABN,11,2)="PRD^2^PROSTHETIC DEVICE NAME^DELIVERY DATE" 27 ; 28 N RCDR,RCI,RCIB,RCUNK S RCIB="" 29 D BILL^IBRFN3(PRCABN,.RCIB) 30 S RCUNK="UNK" 31 I RCIB=0 S RCA(PRCABN,RCY)="No IB Bill/Claim Information" G IBSQ 32 ; - allow sites to refer bill but not electronically 33 I $P($G(RCCAT(+$G(PRCA("CAT")))),U,1)'=1 S ^TMP("RCRCVL",$J,"XM",PRCABN,0)=RCY G IBSQ 34 ; - set XM primary bill information 35 S RCCNT=RCCNT+1 36 S ^TMP("RCRCVL",$J,"XM",PRCABN,0)=RCY 37 S RCDR="BN1^"_$G(PRCA("BNAME"),RCUNK)_U_$P($G(PRCA("CAT")),U,3)_U_$P($G(PRCA("STATUS")),U,3)_U_+$P($$BILL^RCJIBFN2(PRCABN),U,3)_U_$G(RCIB("TOC"))_U_$G(RCIB("TCF"))_U_$G(RCIB("STF"))_U_$G(RCIB("STT")) 38 S ^TMP("RCRCVL",$J,"XM",PRCABN,1,1)=RCDR S RCDR="" 39 S ^TMP("RCRCVL",$J,"XM",PRCABN,1,2)="BN2^"_$G(RCIB("TCG"))_U_$G(RCIB("DFP"))_U_$G(RCIB("TAX"))_U_$G(PRCA("REF REASON")) 40 S ^TMP("RCRCVL",$J,"XM",PRCABN,2,1)="BINS^"_$P($G(RCIB("PIN")),U,5)_U_$P($G(RCIB("PIN")),U,6)_U_$P($G(RCIB("PIN")),U,7)_U_$S($G(RCIB("CRE"))]"":RCIB("CRE"),$G(RCIB("CRA"))]"":RCIB("CRA"),$G(RCIB("CRO"))]"":RCIB("CRO"),1:"") 41 S ^TMP("RCRCVL",$J,"XM",PRCABN,3,1)="PAT^"_$E($G(VADM(1),RCUNK),1,30)_U_$P($G(VADM(2)),U,1)_U_$P($G(VADM(3)),U,1)_U_$P($G(VADM(5)),U)_U_$G(RCIB("SR"))_U_$G(VAPA(1))_U_$G(VAPA(2))_U_$G(VAPA(3))_U_$G(VAPA(4))_U_$P($G(VAPA(5)),U,2)_U_+$G(VAPA(6)) 42 S ^TMP("RCRCVL",$J,"XM",PRCABN,4,1)="INS^"_$P($G(RCIB("PIN")),U,1)_U_$G(RCIB("PIN","MMA"))_U_$P($G(RCIB("PIN")),2,4) 43 ; 44 ; - set multiples if defined 45 I $O(RCIB("OPV",0)) S RCI=0 F S RCI=$O(RCIB("OPV",RCI)) Q:'RCI D 46 .S ^TMP("RCRCVL",$J,"XM",PRCABN,6,RCI)="OPV^"_RCI_U_RCIB("OPV",RCI) 47 I $O(RCIB("DXS",0)) S RCI=0 F S RCI=$O(RCIB("DXS",RCI)) Q:'RCI D 48 .S ^TMP("RCRCVL",$J,"XM",PRCABN,7,RCI)="DXS^"_RCI_U_RCIB("DXS",RCI) 49 I $O(RCIB("RVC",0)) S RCI=0 F S RCI=$O(RCIB("RCV",RCI)) Q:'RCI D 50 .S ^TMP("RCRCVL",$J,"XM",PRCABN,8,RCI)="RVC^"_RCI_U_RCIB("RCV",RCI) 51 I $O(RCIB("PRC",0)) S RCI=0 F S RCI=$O(RCIB("PRC",RCI)) Q:'RCI D 52 .S ^TMP("RCRCVL",$J,"XM",PRCABN,9,RCI)="PRC^"_RCI_U_RCIB("PRC",RCI) 53 I $O(RCIB("RXF",0)) S RCI=0 F S RCI=$O(RCIB("RXF",RCI)) Q:'RCI D 54 .S ^TMP("RCRCVL",$J,"XM",PRCABN,10,RCI)="RXF^"_RCI_U_RCIB("RXF",RCI) 55 I $O(RCIB("PDR",0)) S RCI=0 F S RCI=$O(RCIB("PDR",RCI)) Q:'RCI D 56 .S ^TMP("RCRCVL",$J,"XM",PRCABN,11,RCI)="PDR^"_RCI_U_RCIB("PDR",RCI) 57 ; 58 ; - set Current Debtor Name and Address if different 59 S RCI="" 60 I $G(PRCA("DEBTNM"))'=$P($G(RCIB("PIN")),U,1) S RCI=1 61 I 'RCI,$G(PRCA("DEBTAD1"))'=$P($G(RCIB("PIN","MMA")),U,1) S RCI=1 62 I 'RCI,$P($G(PRCA("DEBTADD")),U,7)'=$P($G(PRCA("PIN","MMA")),U,7) 63 I RCI S ^TMP("RCRCVL",$J,"XM",PRCABN,5,1)="INSUP^"_$E($G(PRCA("DEBTNM")),1,30)_U_$G(PRCA("DEBTAD1"))_U_$G(PRCA("DEBTAD2"))_U_$G(PRCA("DEBTAD3"))_U_$G(PRCA("DEBTCT"))_U_$G(PRCA("DEBTST"))_U_$G(PRCA("DEBTZIP"))_U_$P($G(PRCA("DEBTADD")),U,7) 64 ; 65 IBSQ K DFN,PRCA,RCCAT,VA,VADM,VAPA 66 Q 67 ;RCRCXM1 -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC.m
r613 r623 1 RCXVDC ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03 2 ;;4.5;Accounts Receivable;**201,228,256**;Mar 20, 1995;Build 6 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 Q 6 EN ; Entry Point 7 NEW RCXVD0,RCXVEVDT,RCXVBCN 8 NEW RCXVI,RCXVCP,RCXVPC,RCXVPFDT,RCXVPTDT 9 NEW RCXVBLNA,RCXVBLNB,RCXVICN 10 I DFN="" S DFN=$P($G(^PRCA(430,RCXVBLN,0)),U,7) ; 11 K ^TMP($J) 12 D D430^RCXVDC1 13 I DFN'="" D D2^RCXVDC2 14 D D399^RCXVDC3 15 D D399PC^RCXVDC4 16 D D350^RCXVDC5 17 D D3625^RCXVDC7 18 I RCXVRT="D"!(RCXVRT="C")!(RCXVRT="E") D D433^RCXVDC6 19 I RCXVRT="H" D D433B^RCXVDC6 20 ; 21 FILE ; 22 W "REC:"_RCXVBLNA,! 23 W "430:"_$G(^TMP($J,RCXVBLN,"1-430A"))_RCXVU 24 W $G(^TMP($J,RCXVBLN,"1-430B"))_RCXVU 25 W $G(^TMP($J,RCXVBLN,"1-430C")) 26 W ! 27 I DFN'="" W "2:"_$G(^TMP($J,RCXVBLN,"2-2A"))_RCXVU_$G(^TMP($J,RCXVBLN,"2-2B")),! 28 I $G(^TMP($J,RCXVBLN,"3-399A"))'="" W "399:"_^TMP($J,RCXVBLN,"3-399A")_RCXVU_^TMP($J,RCXVBLN,"3-399B")_RCXVU_^TMP($J,RCXVBLN,"3-399C")_RCXVU_^TMP($J,RCXVBLN,"3-399D"),! 29 S RCXVPC=0 30 F S RCXVPC=$O(^TMP($J,RCXVBLN,"4-399A",RCXVPC)) Q:'RCXVPC D 31 . I $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC))'="" D 32 .. W "399.0304:" 33 .. W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC)) 34 .. W RCXVU 35 .. F RCXVCP=1:1 Q:('$D(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))) D 36 ... I RCXVCP>1 W "~" 37 ... W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP)) 38 ... Q 39 .. W ! 40 . I $G(^TMP($J,RCXVBLN,"4-399B",RCXVPC))'="" W "399.042:"_$G(^TMP($J,RCXVBLN,"4-399B",RCXVPC)),! 41 . Q 42 S RCXVI="" 43 F S RCXVI=$O(^TMP($J,RCXVBLN,"5-350A",RCXVI)) Q:RCXVI="" D 44 . W "350:"_^TMP($J,RCXVBLN,"5-350A",RCXVI),! 45 S RCXVI="" 46 F S RCXVI=$O(^TMP($J,RCXVBLN,"7-362.5A",RCXVI)) Q:RCXVI="" D 47 . W "362.5:"_^TMP($J,RCXVBLN,"7-362.5A",RCXVI),! 48 ; LOOP THRU ^TMP($J,RCXVBLN,"6-433A",RCXVI) 49 S RCXVI="" 50 F S RCXVI=$O(^TMP($J,RCXVBLN,"6-433A",RCXVI)) Q:RCXVI="" D 51 . W "433:"_$G(^TMP($J,RCXVBLN,"6-433A",RCXVI)),! 52 . Q 53 Q 1 RCXVDC ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03 2 ;;4.5;Accounts Receivable;**201,228**;Mar 20, 1995 3 ; 4 Q 5 EN ; Entry Point 6 NEW RCXVD0,RCXVEVDT,RCXVBCN 7 NEW RCXVI,RCXVCP,RCXVPC,RCXVPFDT,RCXVPTDT 8 NEW RCXVBLNA,RCXVBLNB,RCXVICN 9 I DFN="" S DFN=$P($G(^PRCA(430,RCXVBLN,0)),U,7) ; 10 K ^TMP($J) 11 D D430^RCXVDC1 12 I DFN'="" D D2^RCXVDC2 13 D D399^RCXVDC3 14 D D399PC^RCXVDC4 15 D D350^RCXVDC5 16 D D3625^RCXVDC7 17 I RCXVRT="D"!(RCXVRT="C")!(RCXVRT="E") D D433^RCXVDC6 18 I RCXVRT="H" D D433B^RCXVDC6 19 ; 20 FILE ; 21 W "REC:"_RCXVBLNA,! 22 W "430:"_$G(^TMP($J,RCXVBLN,"1-430A"))_RCXVU 23 W $G(^TMP($J,RCXVBLN,"1-430B"))_RCXVU 24 W $G(^TMP($J,RCXVBLN,"1-430C")) 25 W ! 26 I DFN'="" W "2:"_$G(^TMP($J,RCXVBLN,"2-2A"))_RCXVU_$G(^TMP($J,RCXVBLN,"2-2B")),! 27 I $G(^TMP($J,RCXVBLN,"3-399A"))'="" W "399:"_^TMP($J,RCXVBLN,"3-399A")_RCXVU_^TMP($J,RCXVBLN,"3-399B")_RCXVU_^TMP($J,RCXVBLN,"3-399C")_RCXVU_^TMP($J,RCXVBLN,"3-399D"),! 28 S RCXVPC=0 29 F S RCXVPC=$O(^TMP($J,RCXVBLN,"4-399A",RCXVPC)) Q:'RCXVPC D 30 . W "399.0304:" 31 . W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC)) 32 . W RCXVU 33 . F RCXVCP=1:1 Q:('$D(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))) D 34 . . I RCXVCP>1 W "~" 35 . . W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP)) 36 . . Q 37 . W ! 38 . I $D(^TMP($J,RCXVBLN,"4-399B",RCXVPC)) W "399.042:"_$G(^TMP($J,RCXVBLN,"4-399B",RCXVPC)),! 39 . Q 40 S RCXVI="" 41 F S RCXVI=$O(^TMP($J,RCXVBLN,"5-350A",RCXVI)) Q:RCXVI="" D 42 . W "350:"_^TMP($J,RCXVBLN,"5-350A",RCXVI),! 43 S RCXVI="" 44 F S RCXVI=$O(^TMP($J,RCXVBLN,"7-362.5A",RCXVI)) Q:RCXVI="" D 45 . W "362.5:"_^TMP($J,RCXVBLN,"7-362.5A",RCXVI),! 46 ; LOOP THRU ^TMP($J,RCXVBLN,"6-433A",RCXVI) 47 S RCXVI="" 48 F S RCXVI=$O(^TMP($J,RCXVBLN,"6-433A",RCXVI)) Q:RCXVI="" D 49 . W "433:"_$G(^TMP($J,RCXVBLN,"6-433A",RCXVI)),! 50 . Q 51 Q -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC4.m
r613 r623 1 RCXVDC4 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03 2 ;;4.5;Accounts Receivable;**201,227,228,248,251,256**;Mar 20, 1995;Build 6 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; Procedures 6 Q 7 D399PC ; 8 I RCXVD0="" Q 9 N RCXVD,RCXVDA,RCXVB,RCXVPC,RCXVP1,RCXVP2,RCXVP3,RCXVMULT 10 N RCXVDT3,RCXVCP,RCXVPCDT,RCXVPS1,RCXVPS2,RCXVPS,RCXVPSER,RCXVNPI,RCXVCNT,RCXVMH 11 ;RCXVPC=PROC. CODE IEN, RCXVCP=CPT CODE IEN 12 ; LOOP THRU PROC. 13 S RCXVMH="",(RCXVPC,RCXVCNT)=0 14 F S RCXVPC=$O(^DGCR(399,RCXVD0,"CP",RCXVPC)) Q:'RCXVPC D D399PCA 15 S RCXVPC=0 16 F S RCXVPC=$O(^DGCR(399,RCXVD0,"RC",RCXVPC)) Q:'RCXVPC D D39942 17 Q 18 D399PCA ; 19 S RCXVD=$G(^DGCR(399,RCXVD0,"CP",RCXVPC,0)) Q:RCXVD="" 20 S RCXVP1=$P(RCXVD,U,1),RCXVVP="",RCXVVP1="" 21 I RCXVP1'="" S RCXVVP="^"_$P(RCXVP1,";",2)_$P(RCXVP1,";",1)_",0)" 22 I RCXVVP'="" S RCXVVP1=$P($G(@RCXVVP),U,1) I RCXVVP1="" D 23 . NEW CT 24 . S CT=$G(^TMP("RCXVBREC",$J,0))+1,^TMP("RCXVBREC",$J,0)=CT 25 . S ^TMP("RCXVBREC",$J,CT,0)="Bill # "_$P($G(^DGCR(399,RCXVD0,0)),"^",1)_" has a bad CPT code at IEN # "_RCXVPC_" check ^DGCR(399,"_RCXVD0_",""CP"","_RCXVPC_",0)" 26 S RCXVDA=RCXVBLNA_RCXVU_RCXVVP1 ; PROC. 27 S RCXVDT=$P(RCXVD,U,2) 28 S RCXVPCDT=$E($$HLDATE^HLFNC(RCXVDT),1,8) 29 S RCXVDA=RCXVDA_RCXVU_RCXVPCDT ; DT 30 S RCXVP1=$P(RCXVD,U,11),RCXVP2="" 31 I RCXVP1'="" S RCXVP1=$P($G(^IBA(362.3,RCXVP1,0)),U,1) 32 I RCXVP1'="" S RCXVP2=$P($G(^ICD9(RCXVP1,0)),U,1) 33 S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSOC DXN (1) 34 S RCXVP1=$P(RCXVD,U,7),RCXVP2="" 35 I RCXVP1'="" S RCXVP2=$P($G(^SC(RCXVP1,0)),U,1) 36 S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSC. CLNC (P) 37 S RCXVP1=$P(RCXVD,U,18),(RCXVP2,RCXVPS,RCXVPSER,RCXVNPI)="" 38 I RCXVP1'="" S RCXVP2=$$GET1^DIQ(200,RCXVP1_",",.01,"E"),RCXVNPI=$P($$NPI^XUSNPI("Individual_ID",RCXVP1),RCXVU,1) S:+RCXVNPI<1 RCXVNPI="" D 39 . S RCXVPS=$$GET^XUA4A72(RCXVP1,RCXVDT) 40 . S RCXVPS=$P(RCXVPS,U,3) 41 . S RCXVPSER=$$GET1^DIQ(200,RCXVP1_",",29,"E") 42 . Q 43 ;provider^provider npi^specialty^service/section 44 S RCXVDA=RCXVDA_RCXVU_RCXVP2_RCXVU_RCXVNPI_RCXVU_RCXVPS_RCXVU_RCXVPSER 45 S RCXVCNT=RCXVCNT+1,^TMP($J,RCXVBLN,"4-399A",RCXVCNT)=RCXVDA 46 ; LOOP THRU CPT 47 S RCXVCP=0,RCXVMULT=0 48 F S RCXVCP=$O(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP)) Q:'RCXVCP D 49 . Q:'($D(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0))) 50 . ; ^DGCR(399,D0,CP,D1,MOD,D2,0)= (#.01) CPT MODIFIER SEQUENCE [1N] 51 . ; (#.02) CPT ==>MODIFIER [2P:81.3] 52 . S RCXVP1=$P($G(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0)),U,2) 53 . Q:RCXVP1="" 54 . S RCXVMULT=RCXVMULT+1 55 . S RCXVP2=$P($G(^DIC(81.3,RCXVP1,0)),U,1) 56 . S ^TMP($J,RCXVBLN,"4-399A",RCXVCNT,RCXVMULT)=RCXVP2 57 . Q 58 ; 59 ; *256 - loop through 399.042 to find CPT procedure 60 MATCH N RCXVCPT1,RCXVFND,X 61 S RCXVCPT1=$P(RCXVD,";",1) ;proc 62 S (RCXVFND,RCXVCP)=0 63 F S RCXVCP=$O(^DGCR(399,RCXVD0,"RC",RCXVCP)) Q:'RCXVCP!RCXVFND D 64 . Q:$F(RCXVMH,";"_RCXVCP) ;quit if CPT proc match 65 . S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVCP,0)) 66 . Q:RCXVD1="" 67 . S X=$P(RCXVD1,U,6) ;CPT proc 68 . I RCXVCPT1'="",X'="",RCXVCPT1=X D 69 .. S RCXVFND=1 70 .. S X=$P(RCXVD1,U) 71 .. S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code 72 .. S X=$P(RCXVD1,U,6) 73 .. S RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(81,X_",",.01,"E") ; Procedures [P] 74 .. S RCXVDB=RCXVDB_RCXVU_RCXVPCDT ; PROC. DT 75 .. S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges 76 .. S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB 77 .. S RCXVMH=RCXVMH_";"_RCXVCP 78 I 'RCXVFND S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)="" 79 Q 80 ; 81 D39942 ; charge 82 N X 83 Q:$F(RCXVMH,";"_RCXVPC) 84 S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVPC,0)) 85 Q:RCXVD1="" 86 S X=$P(RCXVD1,U) 87 S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code 88 S RCXVDB=RCXVDB_RCXVU_"" ;No CPT proc 89 S RCXVDB=RCXVDB_RCXVU_"" ; No proc dt 90 S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges 91 S RCXVCNT=RCXVCNT+1 92 S ^TMP($J,RCXVBLN,"4-399A",RCXVCNT)="" 93 S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB 94 Q 95 ; 1 RCXVDC4 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03 2 ;;4.5;Accounts Receivable;**201,227,228,248,251**;Mar 20, 1995;Build 21 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ; Procedures 6 Q 7 D399PC ; 8 I RCXVD0="" Q 9 N RCXVD,RCXVDA,RCXVB,RCXVPC,RCXVP1,RCXVP2,RCXVP3,RCXVMULT 10 N RCXVDT3,RCXVCP,RCXVPCDT,RCXVPS1,RCXVPS2,RCXVPS,RCXVPSER,RCXVNPI 11 ;RCXVPC=PROC. CODE IEN, RCXVCP=CPT CODE IEN 12 ; LOOP THRU PROC. 13 S RCXVPC=0 14 F S RCXVPC=$O(^DGCR(399,RCXVD0,"CP",RCXVPC)) Q:'RCXVPC D D399PCA 15 Q 16 D399PCA ; 17 S RCXVD=$G(^DGCR(399,RCXVD0,"CP",RCXVPC,0)) Q:RCXVD="" 18 S RCXVP1=$P(RCXVD,U,1),RCXVVP="",RCXVVP1="" 19 I RCXVP1'="" S RCXVVP="^"_$P(RCXVP1,";",2)_$P(RCXVP1,";",1)_",0)" 20 I RCXVVP'="" S RCXVVP1=$P($G(@RCXVVP),U,1) I RCXVVP1="" D 21 . NEW CT 22 . S CT=$G(^TMP("RCXVBREC",$J,0))+1,^TMP("RCXVBREC",$J,0)=CT 23 . S ^TMP("RCXVBREC",$J,CT,0)="Bill # "_$P($G(^DGCR(399,RCXVD0,0)),"^",1)_" has a bad CPT code at IEN # "_RCXVPC_" check ^DGCR(399,"_RCXVD0_",""CP"","_RCXVPC_",0)" 24 S RCXVDA=RCXVBLNA_RCXVU_RCXVVP1 ; PROC. 25 S RCXVDT=$P(RCXVD,U,2) 26 S RCXVPCDT=$E($$HLDATE^HLFNC(RCXVDT),1,8) 27 S RCXVDA=RCXVDA_RCXVU_RCXVPCDT ; DT 28 S RCXVP1=$P(RCXVD,U,11),RCXVP2="" 29 I RCXVP1'="" S RCXVP1=$P($G(^IBA(362.3,RCXVP1,0)),U,1) 30 I RCXVP1'="" S RCXVP2=$P($G(^ICD9(RCXVP1,0)),U,1) 31 S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSOC DXN (1) 32 S RCXVP1=$P(RCXVD,U,7),RCXVP2="" 33 I RCXVP1'="" S RCXVP2=$P($G(^SC(RCXVP1,0)),U,1) 34 S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; ASSC. CLNC (P) 35 S RCXVP1=$P(RCXVD,U,18),(RCXVP2,RCXVPS,RCXVPSER,RCXVNPI)="" 36 I RCXVP1'="" S RCXVP2=$$GET1^DIQ(200,RCXVP1_",",.01,"E"),RCXVNPI=$P($$NPI^XUSNPI("Individual_ID",RCXVP1),RCXVU,1) S:+RCXVNPI<1 RCXVNPI="" D 37 . S RCXVPS=$$GET^XUA4A72(RCXVP1,RCXVDT) 38 . S RCXVPS=$P(RCXVPS,U,3) 39 . S RCXVPSER=$$GET1^DIQ(200,RCXVP1_",",29,"E") 40 . Q 41 ;provider^provider npi^specialty^service/section 42 S RCXVDA=RCXVDA_RCXVU_RCXVP2_RCXVU_RCXVNPI_RCXVU_RCXVPS_RCXVU_RCXVPSER 43 S ^TMP($J,RCXVBLN,"4-399A",RCXVPC)=RCXVDA 44 ; LOOP THRU CPT 45 S RCXVCP=0,RCXVMULT=0 46 F S RCXVCP=$O(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP)) Q:'RCXVCP D 47 . Q:'($D(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0))) 48 . ; ^DGCR(399,D0,CP,D1,MOD,D2,0)= (#.01) CPT MODIFIER SEQUENCE [1N] 49 . ; (#.02) CPT ==>MODIFIER [2P:81.3] 50 . S RCXVP1=$P($G(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP,0)),U,2) 51 . Q:RCXVP1="" 52 . S RCXVMULT=RCXVMULT+1 53 . S RCXVP2=$P($G(^DIC(81.3,RCXVP1,0)),U,1) 54 . S ^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVMULT)=RCXVP2 55 . Q 56 D39942 ; CHARGES FROM 399.042 57 ; LOOP THRU 399.042 58 N X 59 S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVPC,0)) 60 I RCXVD1="" Q 61 S X=$P(RCXVD1,U) 62 S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code 63 S X=$P(RCXVD1,U,6) 64 S RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(81,X_",",.01,"E") ; Procedures [P] 65 S RCXVDB=RCXVDB_RCXVU_RCXVPCDT ; PROC. DT 66 S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges 67 S ^TMP($J,RCXVBLN,"4-399B",RCXVPC)=RCXVDB 68 Q 69 ; -
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVFTP.m
r613 r623 1 RCXVFTP 2 ;;4.5;Accounts Receivable;**201,256**;Mar 20, 1995;Build 6 3 4 5 6 7 EN(FILE,DIREC) 8 9 10 11 12 13 SYS 14 15 16 17 18 19 20 21 22 23 24 25 26 ARC 27 28 29 30 31 32 33 34 . S RCXVUSR="cbotest1"35 36 37 38 39 40 41 42 43 44 45 46 47 48 FCK 49 50 FQT 51 52 53 54 55 56 57 58 1 RCXVFTP ;DAOU/ALA-FTP AR Data Extract Batch Files ;08-SEP-03 2 ;;4.5;Accounts Receivable;**201**;Mar 20, 1995 3 ; 4 ;**Program Description** 5 ; This code will ftp a batch file 6 ; 7 EN(FILE,DIREC) ; 8 ; Input Parameter 9 ; FILE = Filename 10 ; DIREC = Directory 11 S RCXVPTH=$S($G(DIREC)'="":DIREC,1:RCXVDIR) 12 ; 13 SYS ; Get system type 14 S RCXVSYS=$$VERSION^%ZOSV(1) 15 I RCXVSYS["DSM" S RCXVSYS="VMS",RCXVSYT="DSM" 16 I RCXVSYS["MSM" D 17 . I RCXVSYS["NT"!(RCXVSYS["PC") S RCXVSYS="MSM",RCXVSYT="MSM" Q 18 . E S RCXVSYS="UNIX",RCXVSYT="MSM" 19 I RCXVSYS["Cache" D 20 . I RCXVSYS["VMS" S RCXVSYS="VMS",RCXVSYT="CACHE" Q 21 . S RCXVSYS="CACHE",RCXVSYT="CACHE" 22 ; 23 I RCXVSYS="VMS" S RCXVNME=FILE_";1" 24 I RCXVSYS'="VMS" S RCXVNME=FILE 25 ; 26 ARC ; Directly FTP to the Boston Allocation Resource Center 27 I $$GET1^DIQ(342,"1,",20.06,"I")="P" D 28 . S RCXVIP="MORPHEUS.ARC.MED.VA.GOV" 29 . S RCXVUSR="mccf" 30 . S RCXVPAS="1qaz2wsx" 31 ; 32 I $$GET1^DIQ(342,"1,",20.06,"I")'="P" D 33 . S RCXVIP="MORPHEUS.ARC.MED.VA.GOV" 34 . S RCXVUSR="cbotest" 35 . S RCXVPAS="1qaz2wsx" 36 ; 37 I RCXVSYS="VMS" D ^RCXVFTV 38 I RCXVSYS'="VMS" D ^RCXVFTC 39 ; 40 S RCXVARRY(RCXVTXT)="",RCXVARRY(RCXVBAT)="",RCXVARRY(RCXVNME)="" 41 S Y=$$DEL^%ZISH(RCXVPTH,$NA(RCXVARRY)) 42 K RCXVARRY,%ZISHF,%ZISHO,%ZISUB,DIREC,FILE,I,RCXCT,RCXI,RCXOKAY,RCXVBAT 43 K RCXVFTP,RCXVHNDL,RCXVIP,RCXVNME,RCXVOUT,RCXVPAS,RCXVPTH,RCXVSCR,XMY 44 K RCXVSYS,RCXVSYT,RCXVTXT,RCXVUSR,RCXVVMS,CNT,QER,QFL,RCXMGRP,XMSUB 45 K VALMSG,RCXVROOT 46 Q 47 ; 48 FCK ; Check that file is ready to read 49 S QFL=0,CNT=0,QER=0 50 FQT I QFL Q 51 D OPEN^%ZISH(RCXVHNDL,RCXVPTH,RCXVSCR,"R") 52 I POP D G FQT 53 . HANG 5 54 . S CNT=CNT+1 55 . I CNT>10 S QFL=1,QER=1 D CLOSE^%ZISH(RCXVHNDL) 56 S QFL=1 D CLOSE^%ZISH(RCXVHNDL) 57 G FQT 58 ;
Note:
See TracChangeset
for help on using the changeset viewer.
