123 lines
7.1 KiB
Mathematica
123 lines
7.1 KiB
Mathematica
RCDPEWL4 ;ALB/TMK - ELECTRONIC EOB WORKLIST ACTIONS ;24-FEB-03
|
|
;;4.5;Accounts Receivable;**173,208**;Mar 20, 1995
|
|
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
; RCSCR variable must be defined for this routine
|
|
Q
|
|
;
|
|
DISTADJ(RCFR,RCTO,RCAMT,RCCOM) ; Action that distributes an adjustment amount
|
|
; against another line item's payment
|
|
; Assumes RCSCR = ien of the entry in file 344.49
|
|
; RCFR = ien of entry in 344.491 that has a negative net
|
|
; RCTO = ien of entry in 344.491 that will be decremented
|
|
; RCAMT = the amount being adjusted (positive #)
|
|
; RCCOM = the comment to place on the decrease adjustment
|
|
;
|
|
N RCFRX,RCREF,RCFR0,RCFR1,RCFR10,RCTO0,RCTO1,RCTO10,RCY,DIK,DA,DR,DIC,X,Y,DLAYGO,DD,DO,DIE,DIR
|
|
I $G(^TMP("RCBATCH_SELECTED",$J)) D NOBATCH^RCDPEWL Q
|
|
S RCFR0=$G(^RCY(344.49,RCSCR,1,RCFR,0)),RCTO0=$G(^RCY(344.49,RCSCR,1,RCTO,0)),RCFRX=+$O(^RCY(344.49,RCSCR,1,"B",RCFR0\1,0)),RCFRX=$G(^RCY(344.49,RCSCR,1,RCFRX,0))
|
|
S RCREF=$P($P(RCFRX,U,2),"**ADJ",2),RCREF=$S(RCREF="":"",RCREF=0:$P(RCFRX,U,9),1:$P($G(^RCY(344.4,RCSCR,2,+RCREF,0)),U))
|
|
S RCFR1=+$O(^RCY(344.49,RCSCR,1,"B",RCFR0\1,0)),RCTO1=+$O(^RCY(344.49,RCSCR,1,"B",RCTO0\1,0))
|
|
S RCFR10=$G(^RCY(344.49,RCSCR,1,RCFR1,0)),RCTO10=$G(^RCY(344.49,RCSCR,1,RCTO1,0))
|
|
S RCFR0=$G(^RCY(344.49,RCSCR,1,RCFR,0)),RCTO0=$G(^RCY(344.49,RCSCR,1,RCTO,0))
|
|
S DA(2)=RCSCR,DA(1)=RCFR
|
|
S DIC("DR")=".02////1;.03////"_RCAMT_";.04////"_$S($P(RCTO0,U,2)'="":$P(RCTO0,U,2),RCREF'="":RCREF,1:"UNKNOWN")
|
|
S DIC("DR")=DIC("DR")_";.05////0;.06////0;.09////RETRACTED FUNDS DEDUCTED FROM OTHER PAYMENT ON THIS ERA",DIC="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,"
|
|
S DLAYGO=344.4911,DIC(0)="L",X=+$O(^RCY(344.49,RCSCR,1,RCFR,1,"B",""),-1)+1
|
|
D FILE^DICN K DIC,DD,DO,DLAYGO
|
|
S RCY=+Y
|
|
I RCY'>0 D Q
|
|
. S DIR(0)="EA",DIR("A",1)="PROBLEM ADDING ADJUSTMENT - NO DISTRIBUTION PERFORMED",DIR("A")="PRESS RETURN TO CONTINUE " D ^DIR K DIR
|
|
;
|
|
S DA(2)=RCSCR,DA(1)=RCTO
|
|
S DIC("DR")=".02////0;.03////"_$J(-RCAMT,"",2)
|
|
S DIC("DR")=DIC("DR")_";.04////"_$S($P(RCFR0,U,2)'="":$P(RCFR0,U,2),RCREF'="":RCREF,1:"UNKNOWN")_";.05////"_$S($P($G(^RCY(344.49,RCSCR,1,RCTO1,0)),U,2)'["**ADJ":"1;.08////0",1:0)_";.06////0"_$S(RCCOM'="":";.09////"_RCCOM,1:"")
|
|
S DIC="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,"
|
|
S DLAYGO=344.4911,DIC(0)="L",X=+$O(^RCY(344.49,RCSCR,1,RCTO,1,"B",""),-1)+1
|
|
D FILE^DICN K DIC,DD,DO,DLAYGO
|
|
S RCY=+Y
|
|
;
|
|
I RCY'>0 D Q
|
|
. N DA
|
|
. S DA(2)=RCSCR,DA(1)=RCFR,DA=RCY,DIK="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1," D ^DIK
|
|
. S DIR(0)="EA",DIR("A",1)="PROBLEM ADDING ADJUSTMENT - NO DISTRIBUTION PERFORMED",DIR("A")="PRESS RETURN TO CONTINUE " D ^DIR K DIR
|
|
;
|
|
S DA(1)=RCSCR,DA=RCFR,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".06////"_$J($P(RCFR0,U,6)+RCAMT,"",2)_";.08////"_$J($P(RCFR0,U,8)+RCAMT,"",2) D ^DIE
|
|
S DA=RCFR1,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".06////"_$J($P(RCFR10,U,6)+RCAMT,"",2) D ^DIE
|
|
S DA(1)=RCSCR,DA=RCTO,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".06////"_$J($P(RCTO0,U,6)-RCAMT,"",2)_";.03////"_$J($P(RCTO0,U,3)-RCAMT,"",2)_";.08////"_$J($P(RCTO0,U,8)-RCAMT,"",2) D ^DIE
|
|
S DA(1)=RCSCR,DA=RCTO1,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".06////"_$J($P(RCTO10,U,6)-RCAMT,"",2)_";.03////"_$J($P(RCTO10,U,3)-RCAMT,"",2)_";.08////"_$J($P(RCTO10,U,8)-RCAMT,"",2) D ^DIE
|
|
D BLD^RCDPEWL1($G(^TMP($J,"RC_SORTPARM")))
|
|
Q
|
|
;
|
|
NEWREC ; Create a new receipt from scratch pad entry
|
|
N Z,Z0,RCOK,RCRECTDA,RCSTOP,DIR,X,Y,RECTDA,CT,DIE,DA,DR,RCER,RCPAYTY,RCHAC,RCDEP,DIC
|
|
D FULL^VALM1
|
|
I $G(RCSCR("NOEDIT"))=2 D NOTAV^RCDPEWL2 G NEWRECQ
|
|
S (RCSTOP,RCOK)=0,VALMBCK="R"
|
|
S RECTDA=$P($G(^RCY(344.49,RCSCR,0)),U,2)
|
|
I 'RECTDA S RECTDA=$P($G(^RCY(344.4,RCSCR,0)),U,8)
|
|
I RECTDA D G NEWRECQ
|
|
. S DIR(0)="EA",DIR("A",1)="THIS ERA ALREADY HAS A RECEIPT - "_$P($G(^RCY(344,+$P($G(^RCY(344.49,RCSCR,0)),U,2),0)),U)_" - NO RECEIPT CREATED",DIR("A")="PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR
|
|
S DIR("A",1)="THIS ACTION WILL CREATE THE RECEIPT FOR THIS ERA. ONCE THE RECEIPT IS",DIR("A",2)=" CREATED HERE, NO MORE AUTOMATIC ADJUSTMENTS MAY BE MADE FOR THIS ERA.",DIR("A",3)=" "
|
|
S DIR("A")="ARE YOU SURE YOU ARE READY TO CREATE THIS RECEIPT?: ",DIR("B")="NO",DIR(0)="YA"
|
|
W ! D ^DIR K DIR W !
|
|
I Y'=1 S DIR(0)="EA",DIR("A")="NO RECEIPT CREATED - PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR G NEWRECQ
|
|
I $$HASADJ^RCDPEWL8(RCSCR,.RCOK) D G NEWRECQ
|
|
. S DIR(0)="EA",DIR("A",1)="AT LEAST ONE LINE ITEM WAS FOUND WITH A NEGATIVE PAYMENT AMOUNT",DIR("A")="NO RECEIPT CAN BE CREATED - PRESS RETURN TO CONTINUE " D ^DIR K DIR S RCSTOP=1
|
|
I 'RCOK S DIR(0)="EA",DIR("A")="NO RECEIPT CAN BE CREATED - NO POSTABLE LINE ITEMS WERE FOUND" W ! D ^DIR K DIR G NEWRECQ
|
|
;
|
|
S RCHAC=$$HACERA^RCDPEU(RCSCR)
|
|
S RCPAYTY=$S(RCHAC:8,$P($G(^RCY(344.4,+RCSCR,0)),U,13)="":14,1:4)
|
|
S RCDEP=""
|
|
I RCPAYTY=4 D
|
|
. N RCOK1
|
|
. F D Q:RCOK1
|
|
.. S RCOK1=1
|
|
.. S DIC="^RCY(344.1,",DIC("S")="I $P(^(0),U,12)=1",DIC(0)="AEMQ" D ^DIC
|
|
.. Q:Y'>0
|
|
.. S RCDEP=+Y
|
|
.. I RCDEP,$$TOOOLD^RCDPEWLA(RCDEP) S RCOK1=0,RCDEP=""
|
|
S RECTDA=$$BLDRCPT^RCDPUREC(DT,+RCDEP_$S(RCPAYTY=4:"ERACHK",1:""),+$O(^RC(341.1,"AC",+RCPAYTY,0))) ; Note:ERA with paper check is type 4, but receipt needs to start with an 'E'
|
|
I 'RECTDA W ! S DIR(0)="EA",DIR("A",1)="A PROBLEM WAS ENCOUNTERED ADDING THE RECEIPT - NO RECEIPT ADDED",DIR("A")="PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR G NEWRECQ
|
|
;
|
|
D RCPTDET^RCDPEM(RCSCR,RECTDA,.RCER)
|
|
;
|
|
S DIE="^RCY(344.49,",DA=RCSCR,DR=".02////"_RECTDA D ^DIE
|
|
S DIE="^RCY(344.4,",DA=RCSCR,DR=".08////"_RECTDA D ^DIE
|
|
S Z=+$O(^RCY(344.31,"AERA",RCSCR,0))
|
|
S DIE="^RCY(344,",DA=RECTDA,DR=".18////"_RCSCR_$S(Z:";.17////"_Z,1:"")_$S(RCPAYTY=4:";.06////"_RCDEP,1:"")_$S($P($G(^RCY(344.31,Z,0)),U,15)'="":";.16////"_$P(^RCY(344.31,Z,0),U,15),1:"") D ^DIE
|
|
;
|
|
I $O(RCER(0)) D
|
|
. S CT=1,DIR(0)="EA",DIR("A",1)="THE FOLLOWING PROBLEMS OCCURRED WHILE ADDING THE RECEIPT: "
|
|
. S Z=0 F S Z=$O(RCER(Z)) Q:'Z S CT=CT+1,DIR("A",CT)=RCER(Z)
|
|
. S DIR("A")="PRESS RETURN TO CONTINUE "
|
|
. W ! D ^DIR K DIR
|
|
;
|
|
S DIR(0)="YA",DIR("A")="DO YOU WANT TO GO TO RECEIPT PROCESSING NOW? ",DIR("A",1)=" ",DIR("A",2)="RECEIPT "_$P($G(^RCY(344,+RECTDA,0)),U)_" HAS BEEN CREATED FOR THIS ERA",DIR("B")="YES" W ! D ^DIR K DIR
|
|
I Y=1 S RCRECTDA=RECTDA D EN^VALM("RCDP RECEIPT PROFILE")
|
|
S RCSCR=0
|
|
S VALMBCK="Q"
|
|
;
|
|
NEWRECQ Q
|
|
;
|
|
VRECPT ; Preview receipt lines
|
|
N RCZ,RCOK,Z,Z0,DIR,X,Y
|
|
D FULL^VALM1
|
|
S VALMBCK="R"
|
|
I $G(^TMP("RCBATCH_SELECTED",$J)) D NOBATCH^RCDPEWL Q
|
|
I $O(^RCY(344.49,RCSCR,3,0)) D Q:'RCOK
|
|
. S RCOK=1
|
|
. S Z=0 F S Z=$O(^RCY(344.49,RCSCR,3,Z)) Q:'Z I '$P($G(^(Z,0)),U,3) S RCOK=0 Q
|
|
. I 'RCOK S DIR(0)="EA",DIR("A",1)="A RECEIPT CANNOT BE PREVIEWED UNTIL ALL BATCHES FOR THIS ERA ARE MARKED AS",DIR("A",2)="'READY TO POST'",DIR("A")="PRESS RETURN TO CONTINUE " W ! D ^DIR K DIR
|
|
;
|
|
S Z=0 F S Z=$O(^RCY(344.49,RCSCR,1,Z)) Q:'Z I $P(Z,".",2) S Z0=$G(^(Z,0)) I $P(Z0,U,6)<0 S RCZ($P(Z0,U))=$P(Z0,U,2)_U_$P(Z0,U,6)
|
|
I $O(RCZ(""))'="" D
|
|
. W !,"THE FOLLOWING LINES HAVE A NET PAYMENT LESS THAN 0. THESE LINES MUST HAVE",!,"THIS NEGATIVE AMOUNT DISTRIBUTED TO OTHER LINE(S) IN THE ERA BEFORE A",!,"RECEIPT CAN BE CREATED."
|
|
. S Z="" F S Z=$O(RCZ(Z)) Q:Z="" W !,$J("",5)_$J(Z,10)_" "_$E($P(RCZ(Z),U)_$J("",15),1,15)_" "_$J(+$P(RCZ(Z),U,2),"",2)
|
|
. W !
|
|
. S DIR(0)="E" D ^DIR K DIR
|
|
;
|
|
D EN^VALM("RCDPE EOB RECEIPT PREVIEW")
|
|
S VALMBCK=$S('$G(RCSCR):"Q",1:"R")
|
|
Q
|
|
;
|