source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBPAID1.m@ 1698

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

initial load of WorldVistAEHR
File size: 3.5 KB
RevLine 
[613]1FBPAID1 ;AISC - SERVER ROUTINE TO UPDATE PAYMENTS CON'T ;10/17/2000
2 ;;3.5;FEE BASIS;**19**;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4PARSE ;set-up variables for payment record called from FBPAID
5 ; FBPROG = 3 for Outpatient (file 162)
6 ; = T for Travel (file 162)
7 ; = 5 for Pharmacy (file 162.1)
8 ; = 9 for Inpatient (file 162.5)
9 ; = $E(XMRG,7) fee program and effected file
10 ; FBACT = $E(XMRG,8) type of activity
11 ; FBIEN(x)=$E(XMRG,9,38) IEN for payment record to update
12 ; FBCKNUM= $E(XMRG,39,46) check number
13 ; FBCKDT = $E(XMRG,47,52) check date
14 ; FBINAMT= $E(XMRG,53,60) interest amount
15 ; FBXDT = $E(XMRG,61,66) cancel date
16 ; FBRCOD = $E(XMRG,67) reason code
17 ; FBXCOD = $E(XMRG,68) cancel code
18 ; FBDAMT = $E(XMRG,69,76) disbursed amount
19 ; FBAMT = Amount paid out of payment record
20 Q:$G(FBERR)
21 S FBPROG=$E(XMRG,7) I $S(FBPROG=3:0,FBPROG=5:0,FBPROG=9:0,FBPROG="T":0,1:1) S FBERR=1 Q
22 S FBACT=$E(XMRG,8) I $S(FBACT="C":0,FBACT="B":0,FBACT="X":0,1:1) S FBERR=1 Q
23 S FBIEN=$E(XMRG,9,38) D Q:$G(FBERR)
24 . I FBPROG=3 D Q:$G(FBERR)
25 ..S FBIEN(3)=+$P(FBIEN,U),FBIEN(2)=+$P(FBIEN,U,2),FBIEN(1)=+$P(FBIEN,U,3),FBIEN=+$P(FBIEN,U,4)
26 ..I '$D(^FBAAC(FBIEN(3),1,FBIEN(2),1,FBIEN(1),1,FBIEN,0)) D CHKMOVE
27 ..I '$D(^FBAAC(FBIEN(3),1,FBIEN(2),1,FBIEN(1),1,FBIEN,0)) S FBERR=1,^TMP("FBERR",$J,3,I)=""
28 . ;
29 . I FBPROG=5 D Q:$G(FBERR)
30 ..S FBIEN(1)=+$P(FBIEN,U),FBIEN=+$P(FBIEN,U,2)
31 ..I '$D(^FBAA(162.1,FBIEN(1),"RX",FBIEN,0)) S FBERR=1,^TMP("FBERR",$J,3,I)=""
32 . ;
33 . I FBPROG=9 D Q:$G(FBERR)
34 ..S FBIEN=+FBIEN I '$D(^FBAAI(FBIEN,0)) S FBERR=1,^TMP("FBERR",$J,3,I)=""
35 . ;
36 . I FBPROG="T" D Q:$G(FBERR)
37 ..S FBIEN(1)=+$P(FBIEN,U),FBIEN=+$P(FBIEN,U,2)
38 ..I '$D(^FBAAC(FBIEN(1),3,FBIEN,0)) D CHKMOVE
39 ..I '$D(^FBAAC(FBIEN(1),3,FBIEN,0)) S FBERR=1,^TMP("FBERR",$J,3,I)=""
40 S FBCKNUM=$$EXTRL^FBMRASVR($E(XMRG,39,46),1),FBCKDT=$$DATE^FBPAID1($E(XMRG,47,52))
41 S FBINAMT=$S(+$E(XMRG,53,60):+$E(XMRG,53,58)_"."_$E(XMRG,59,60),1:0)
42 S FBINAMT=$S(FBINAMT=0:0,$P(FBINAMT,".",2)'>0:$P(FBINAMT,"."),1:+FBINAMT)
43 S FBXDT=$$DATE^FBPAID1($E(XMRG,61,66))
44 S FBRCOD=$E(XMRG,67),FBXCOD=$E(XMRG,68)
45 S FBRCOD=$O(^FB(162.95,"C",FBRCOD,0))
46 S FBDAMT=$S(+$E(XMRG,69,76):+$E(XMRG,69,74)_"."_$E(XMRG,75,76),1:0)
47 S FBDAMT=$S(FBDAMT=0:0,$P(FBDAMT,".",2)'>0:$P(FBDAMT,"."),1:+FBDAMT)
48 Q
49 ;
50BUL ;create server bulletin message
51 S ^TMP("FBPAID",$J,0)=FBMCNT
52 Q
53DATE(X) ;pass in 'X'=date in yymmdd format and return date in
54 ;fileman format.
55 N Y I '$G(X) Q ""
56 S %DT="",X=$E(X,3,7)_$E(X,1,2) D ^%DT K %DT
57 Q $S(Y=-1:"",1:Y)
58CHKMOVE ;check if payment moved
59 ; input
60 ; FBPROG - fee program
61 ; FBIEN - ien of payment (from austin)
62 ; FBIEN() - ien(s) of higher level entries (1 for next higher, etc.)
63 ; output
64 ; FBIEN may be changed
65 ; FBIEN() may be changed
66 N FBDA,FBFILE,FBNIENS,FBOIENS
67 S FBFILE=$S(FBPROG=3:162.03,FBPROG="T":162.04,1:"")
68 Q:FBFILE=""
69 I FBPROG=3 D
70 . S FBOIENS=FBIEN_","_FBIEN(1)_","_FBIEN(2)_","_FBIEN(3)_","
71 . S FBDA=$O(^FBAA(161.45,"C",FBFILE,FBOIENS,0))
72 . Q:'FBDA ; not moved
73 . S FBNIENS=$P($G(^FBAA(161.45,FBDA,0)),U,3)
74 . Q:FBNIENS="" ; don't know new iens
75 . S FBIEN=$P(FBNIENS,",",1)
76 . S FBIEN(1)=$P(FBNIENS,",",2)
77 . S FBIEN(2)=$P(FBNIENS,",",3)
78 . S FBIEN(3)=$P(FBNIENS,",",4)
79 I FBPROG="T" D
80 . S FBOIENS=FBIEN_","_FBIEN(1)_","
81 . S FBDA=$O(^FBAA(161.45,"C",FBFILE,FBOIENS,0))
82 . Q:'FBDA ; not moved
83 . S FBNIENS=$P($G(^FBAA(161.45,FBDA,0)),U,3)
84 . Q:FBNIENS="" ; don't known new iens
85 . S FBIEN=$P(FBNIENS,",",1)
86 . S FBIEN(1)=$P(FBNIENS,",",2)
87 Q
Note: See TracBrowser for help on using the repository browser.