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