source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPRPL4.m@ 1608

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

initial load of WorldVistAEHR
File size: 4.8 KB
Line 
1RCDPRPL4 ;WISC/RFJ-receipt profile listmanager options ;1 Apr 01
2 ;;4.5;Accounts Receivable;**169,172,173**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ; this routine contains the entry points for receipt management
7 ;
8 ;
9ONLINE ; allow the supervisor to mark the CR document as input on line
10 D FULL^VALM1
11 S VALMBCK="R"
12 ;
13 ; get fms document and status
14 N %,FMSDOC,GECSDATA
15 S FMSDOC=$$FMSSTAT^RCDPUREC(RCRECTDA)
16 ;
17 W !!,"This option will allow you to mark a rejected Cash Receipt document as"
18 W !,"entered on line. This will prevent the document from being listed on"
19 W !,"the nightly mailman message used to help manage the receipts and deposits."
20 ;
21 W !!,"FMS Cash Receipt Document: ",$P(FMSDOC,"^"),?48,"Status: ",$P(FMSDOC,"^",2)
22 ;
23 I '$D(^XUSEC("PRCAY PAYMENT SUP",DUZ)) W !!,"You are not an owner of the supervisor PRCAY PAYMENT SUP security key." D QUIT Q
24 ;
25 ; cr accepted
26 I $E($P(FMSDOC,"^",2))="A" W !!,"You CANNOT mark the Cash Receipt document as entered on line.",!,"The CR document is ACCEPTED ??" D QUIT Q
27 ;
28 ; not been transmitted for 2 days
29 I $E($P(FMSDOC,"^",2))="T",$$FMDIFF^XLFDT(DT,$P(^RCY(344,RCRECTDA,0),"^",8))'>2 W !!,"You CANNOT mark the Cash Receipt document as entered on line.",!,"The CR document has NOT been TRANSMITTED for 2 days ??" D QUIT Q
30 ;
31 ; cr queued for transmission
32 I $E($P(FMSDOC,"^",2))="Q"!($E($P(FMSDOC,"^",2))="M") W !!,"You CANNOT mark the Cash Receipt document as entered on line.",!,"The CR document is waiting to be TRANSMITTED ??" D QUIT Q
33 ;
34 ; check to see if already marked as entered on line
35 I $E($P(FMSDOC,"^",2))="O" D Q
36 . I $$ASKSTAT("REMOVE")'=1 Q
37 . W !,"... removing CR status as entered on line ..."
38 . ; remove the status on field 201
39 . D EDITREC^RCDPUREC(RCRECTDA,"201////0;")
40 . ; show the new status
41 . S FMSDOC=$$FMSSTAT^RCDPUREC(RCRECTDA)
42 . W !!,"FMS Cash Receipt Document: ",$P(FMSDOC,"^"),?48,"Status: ",$P(FMSDOC,"^",2)
43 . D QUIT
44 ;
45 ; ask to change the status to entered on line
46 I $$ASKSTAT("ENTER")'=1 D QUIT Q
47 ;
48 ; change the status to entered on line
49 W !,"... changing status to entered on line ..."
50 W !,"... changing the generic code sheet stack file status to ACCEPTED ..."
51 ;
52 ; set the status to entered on line in field 201
53 D EDITREC^RCDPUREC(RCRECTDA,"201////1;")
54 ;
55 ; set the generic code sheet status as accepted
56 ; get the document ien
57 D DATA^GECSSGET($P(FMSDOC,"^"))
58 I $G(GECSDATA) D SETSTAT^GECSSTAA(GECSDATA,"A")
59 ;
60 ; show the new status
61 S FMSDOC=$$FMSSTAT^RCDPUREC(RCRECTDA)
62 W !!,"FMS Cash Receipt Document: ",$P(FMSDOC,"^"),?48,"Status: ",$P(FMSDOC,"^",2)
63 ;
64QUIT ; pause and rebuild the header
65 W !!,"press RETURN to continue: "
66 R %:DTIME
67 D HDR^RCDPRPLM
68 Q
69 ;
70 ;
71ASKSTAT(ACTION) ; ask if its okay to remove or change the entered online status
72 ; 1 is yes, otherwise no
73 N DIR,DIQ2,DTOUT,DUOUT,X,Y
74 S DIR(0)="YO",DIR("B")="NO"
75 S DIR("A",1)=" Do you want to "_ACTION_" the status showing the Cash Receipt"
76 S DIR("A")=" document was entered ON LINE"
77 D ^DIR
78 I $G(DTOUT)!($G(DUOUT)) S Y=-1
79 Q Y
80 ;
81ERAWL(RCSCR) ; Generate automatic dec adj from ERA Worklist in RCSCR
82 ; RCADJ returned = 1 if passed by reference and adjustment successful
83 ; returned = 2 if passed by ref and adjustments aborted
84 ; returned = -1 if error
85 ; returned = 0 if no WL adjustments found
86 N RCZ,RCZ0,Z00,V00,RCCOM,RC1,RCADJ,RCOK
87 S RC1=1,RCZ=0,RCADJ=0
88 F S RCZ=$O(^RCY(344.49,RCSCR,1,RCZ)) Q:'RCZ!(RCADJ=2) S V00=$G(^(RCZ,0)),RCZ0=0 F S RCZ0=$O(^RCY(344.49,RCSCR,1,RCZ,1,RCZ0)) Q:'RCZ0!(RCADJ=2) S Z00=$G(^(RCZ0,0)) Q:"12"'[+$P(Z00,U,5) D
89 . S RCCOM(1)=$P(Z00,U,9)
90 . I RC1,$P(Z00,U,5)=1 D Q:RCADJ=2
91 .. S RC1=0
92 .. S DIR(0)="YA",DIR("B")="YES",DIR("A",1)="Generating automatic decrease adjustments from EDI Lbox Worklist ...",DIR("A")="ARE YOU SURE YOU WANT TO CONTINUE?: "
93 .. D ^DIR K DIR
94 .. I Y'=1 S RCADJ=2
95 . I $P(Z00,U,8)=1 D Q ; previously done
96 .. I $P(Z00,U,5)=1 W !," Automatic decrease adj from ERA Worklist for bill #"_$P($G(^PRCA(430,+$P(V00,U,7),0)),U),!," for amount of "_$J(+$P(Z00,U,3),"",2)_" was previously completed" S RCADJ=1
97 . I $P(Z00,U,5)=1 D Q ; Decrease adj
98 .. I '$$INCDEC^RCBEUTR1($P(V00,U,7),$P(Z00,U,3),.RCCOM) D
99 ... W !," Could not perform automatic decrease adj from ERA Worklist for ",!," bill # "_$P($G(^PRCA(430,+$P(V00,U,7),0)),U)_" for amount of "_$J(+$P(Z00,U,3),"",2)
100 ... S RCADJ=-1
101 .. E D ; success
102 ... D UPD(RCSCR,RCZ,RCZ0)
103 ... S RCADJ=1
104 ... W !," EDI Lbox Worklist automatic dec adjustment made to "_$P($G(^PRCA(430,+$P(V00,U,7),0)),U)_": "_$J(+$P(Z00,U,3),"",2)
105 . I $P(Z00,U,5)=2 D Q ; Bill comment
106 .. D ADDCOMM^RCBEUTRA($P(V00,U,7),.RCCOM),UPD(RCSCR,RCZ,RCZ0)
107 ;
108 Q $G(RCADJ)
109 ;
110UPD(RCSCR,Z,Z0) ; Mark as complete so it doesn't get done twice
111 N DA,DIE,DR
112 S DA(2)=RCSCR,DA(1)=Z,DA=Z0
113 S DIE="^RCY(344.49,"_DA(2)_",1,"_DA(1)_",1,",DR=".08////1" D ^DIE
114 Q
115 ;
Note: See TracBrowser for help on using the repository browser.