source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEWL4.m@ 861

Last change on this file since 861 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 7.1 KB
RevLine 
[613]1RCDPEWL4 ;ALB/TMK - ELECTRONIC EOB WORKLIST ACTIONS ;24-FEB-03
2 ;;4.5;Accounts Receivable;**173,208**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ; RCSCR variable must be defined for this routine
5 Q
6 ;
7DISTADJ(RCFR,RCTO,RCAMT,RCCOM) ; Action that distributes an adjustment amount
8 ; against another line item's payment
9 ; Assumes RCSCR = ien of the entry in file 344.49
10 ; RCFR = ien of entry in 344.491 that has a negative net
11 ; RCTO = ien of entry in 344.491 that will be decremented
12 ; RCAMT = the amount being adjusted (positive #)
13 ; RCCOM = the comment to place on the decrease adjustment
14 ;
15 N RCFRX,RCREF,RCFR0,RCFR1,RCFR10,RCTO0,RCTO1,RCTO10,RCY,DIK,DA,DR,DIC,X,Y,DLAYGO,DD,DO,DIE,DIR
16 I $G(^TMP("RCBATCH_SELECTED",$J)) D NOBATCH^RCDPEWL Q
17 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))
18 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))
19 S RCFR1=+$O(^RCY(344.49,RCSCR,1,"B",RCFR0\1,0)),RCTO1=+$O(^RCY(344.49,RCSCR,1,"B",RCTO0\1,0))
20 S RCFR10=$G(^RCY(344.49,RCSCR,1,RCFR1,0)),RCTO10=$G(^RCY(344.49,RCSCR,1,RCTO1,0))
21 S RCFR0=$G(^RCY(344.49,RCSCR,1,RCFR,0)),RCTO0=$G(^RCY(344.49,RCSCR,1,RCTO,0))
22 S DA(2)=RCSCR,DA(1)=RCFR
23 S DIC("DR")=".02////1;.03////"_RCAMT_";.04////"_$S($P(RCTO0,U,2)'="":$P(RCTO0,U,2),RCREF'="":RCREF,1:"UNKNOWN")
24 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,"
25 S DLAYGO=344.4911,DIC(0)="L",X=+$O(^RCY(344.49,RCSCR,1,RCFR,1,"B",""),-1)+1
26 D FILE^DICN K DIC,DD,DO,DLAYGO
27 S RCY=+Y
28 I RCY'>0 D Q
29 . S DIR(0)="EA",DIR("A",1)="PROBLEM ADDING ADJUSTMENT - NO DISTRIBUTION PERFORMED",DIR("A")="PRESS RETURN TO CONTINUE " D ^DIR K DIR
30 ;
31 S DA(2)=RCSCR,DA(1)=RCTO
32 S DIC("DR")=".02////0;.03////"_$J(-RCAMT,"",2)
33 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:"")
34 S DIC="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,"
35 S DLAYGO=344.4911,DIC(0)="L",X=+$O(^RCY(344.49,RCSCR,1,RCTO,1,"B",""),-1)+1
36 D FILE^DICN K DIC,DD,DO,DLAYGO
37 S RCY=+Y
38 ;
39 I RCY'>0 D Q
40 . N DA
41 . S DA(2)=RCSCR,DA(1)=RCFR,DA=RCY,DIK="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1," D ^DIK
42 . S DIR(0)="EA",DIR("A",1)="PROBLEM ADDING ADJUSTMENT - NO DISTRIBUTION PERFORMED",DIR("A")="PRESS RETURN TO CONTINUE " D ^DIR K DIR
43 ;
44 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
45 S DA=RCFR1,DIE="^RCY(344.49,"_DA(1)_",1,",DR=".06////"_$J($P(RCFR10,U,6)+RCAMT,"",2) D ^DIE
46 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
47 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
48 D BLD^RCDPEWL1($G(^TMP($J,"RC_SORTPARM")))
49 Q
50 ;
51NEWREC ; Create a new receipt from scratch pad entry
52 N Z,Z0,RCOK,RCRECTDA,RCSTOP,DIR,X,Y,RECTDA,CT,DIE,DA,DR,RCER,RCPAYTY,RCHAC,RCDEP,DIC
53 D FULL^VALM1
54 I $G(RCSCR("NOEDIT"))=2 D NOTAV^RCDPEWL2 G NEWRECQ
55 S (RCSTOP,RCOK)=0,VALMBCK="R"
56 S RECTDA=$P($G(^RCY(344.49,RCSCR,0)),U,2)
57 I 'RECTDA S RECTDA=$P($G(^RCY(344.4,RCSCR,0)),U,8)
58 I RECTDA D G NEWRECQ
59 . 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
60 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)=" "
61 S DIR("A")="ARE YOU SURE YOU ARE READY TO CREATE THIS RECEIPT?: ",DIR("B")="NO",DIR(0)="YA"
62 W ! D ^DIR K DIR W !
63 I Y'=1 S DIR(0)="EA",DIR("A")="NO RECEIPT CREATED - PRESS RETURN TO CONTINUE" W ! D ^DIR K DIR G NEWRECQ
64 I $$HASADJ^RCDPEWL8(RCSCR,.RCOK) D G NEWRECQ
65 . 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
66 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
67 ;
68 S RCHAC=$$HACERA^RCDPEU(RCSCR)
69 S RCPAYTY=$S(RCHAC:8,$P($G(^RCY(344.4,+RCSCR,0)),U,13)="":14,1:4)
70 S RCDEP=""
71 I RCPAYTY=4 D
72 . N RCOK1
73 . F D Q:RCOK1
74 .. S RCOK1=1
75 .. S DIC="^RCY(344.1,",DIC("S")="I $P(^(0),U,12)=1",DIC(0)="AEMQ" D ^DIC
76 .. Q:Y'>0
77 .. S RCDEP=+Y
78 .. I RCDEP,$$TOOOLD^RCDPEWLA(RCDEP) S RCOK1=0,RCDEP=""
79 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'
80 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
81 ;
82 D RCPTDET^RCDPEM(RCSCR,RECTDA,.RCER)
83 ;
84 S DIE="^RCY(344.49,",DA=RCSCR,DR=".02////"_RECTDA D ^DIE
85 S DIE="^RCY(344.4,",DA=RCSCR,DR=".08////"_RECTDA D ^DIE
86 S Z=+$O(^RCY(344.31,"AERA",RCSCR,0))
87 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
88 ;
89 I $O(RCER(0)) D
90 . S CT=1,DIR(0)="EA",DIR("A",1)="THE FOLLOWING PROBLEMS OCCURRED WHILE ADDING THE RECEIPT: "
91 . S Z=0 F S Z=$O(RCER(Z)) Q:'Z S CT=CT+1,DIR("A",CT)=RCER(Z)
92 . S DIR("A")="PRESS RETURN TO CONTINUE "
93 . W ! D ^DIR K DIR
94 ;
95 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
96 I Y=1 S RCRECTDA=RECTDA D EN^VALM("RCDP RECEIPT PROFILE")
97 S RCSCR=0
98 S VALMBCK="Q"
99 ;
100NEWRECQ Q
101 ;
102VRECPT ; Preview receipt lines
103 N RCZ,RCOK,Z,Z0,DIR,X,Y
104 D FULL^VALM1
105 S VALMBCK="R"
106 I $G(^TMP("RCBATCH_SELECTED",$J)) D NOBATCH^RCDPEWL Q
107 I $O(^RCY(344.49,RCSCR,3,0)) D Q:'RCOK
108 . S RCOK=1
109 . 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
110 . 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
111 ;
112 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)
113 I $O(RCZ(""))'="" D
114 . 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."
115 . 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)
116 . W !
117 . S DIR(0)="E" D ^DIR K DIR
118 ;
119 D EN^VALM("RCDPE EOB RECEIPT PREVIEW")
120 S VALMBCK=$S('$G(RCSCR):"Q",1:"R")
121 Q
122 ;
Note: See TracBrowser for help on using the repository browser.