source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAV2.m@ 1556

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

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1FBAAV2 ;AISC/GRR-ELECTRONICALLY TRANSMIT PHARMACY PAYMENTS ;11 Apr 2006 2:52 PM
2 ;;3.5;FEE BASIS;**3,89,98**;JAN 30, 1995;Build 54
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4DETP ; ENTRY FROM FBAAV0
5 S FBTXT=0
6 D CKB5V^FBAAV01 I $G(FBERR) K FBERR Q
7 F K=0:0 S K=$O(^FBAA(162.1,"AE",J,K)) Q:K'>0 F L=0:0 S L=$O(^FBAA(162.1,"AE",J,K,L)) Q:L'>0 S Y(0)=$G(^FBAA(162.1,K,"RX",L,0)),Y(2)=$G(^(2)),Y=$G(^FBAA(162.1,K,0)) I Y(0)]"",Y]"",+$P(Y(0),U,16) D
8 .N FBPICN,FBY
9 .S FBPICN=K_U_L
10 .S FBY=$S($P(Y,U,12):$P(Y,U,12),1:$P(Y,U,2))_U_+$P(Y(2),U,9)
11 .I 'FBTXT S FBTXT=1 D NEWMSG^FBAAV01,STORE^FBAAV01,UPD^FBAAV0
12 .D GOTP
13 D:FBTXT XMIT^FBAAV01
14 Q
15 ;
16GOTP ; process a B5 line item
17 N DFN,FBADJ,FBADJA1,FBADJA2,FBADJR1,FBADJR2,FBIENS,FBPNAMX,FBVY0,FBX,FBNPI
18 ;
19 S FBIENS=$P(FBPICN,U,2)_","_$P(FBPICN,U,1)_","
20 S FBPAYT=$P(Y(0),"^",20),FBPAYT=$S(FBPAYT]"":FBPAYT,1:"V")
21 S FBINVN=$P(Y,"^"),FBINVN=$E("000000000",$L(FBINVN)+1,9)_FBINVN
22 S FBDIN=$$AUSDT^FBAAV3($P(Y,"^",2))
23 ;
24 S FBVFN=$P(Y,"^",4)
25 S FBNPI=$$EN^FBNPILK(FBVFN)
26 S FBVY0=$G(^FBAAV(FBVFN,0)) ; vendor 0 node
27 S FBVID=$P(FBVY0,U,2),FBVID=$E(FBVID,1,9)_$E(PAD,$L(FBVID)+1,9)
28 S FBCSN=$S($P(FBVY0,U,2)]"":$P(FBVY0,U,10),1:"")
29 S FBCSN=$E("0000",$L(FBCSN)+1,4)_FBCSN
30 I FBPAYT="R" S FBVID=$E(PAD,1,9),FBCSN=$E(PAD,1,4)
31 K FBVY0
32 ;
33 S FBRX=$P(Y(0),"^",1),FBRX=$E("00000000",$L(FBRX)+1,8)_FBRX
34 I '$L($G(FBAASN)) D STATION^FBAAUTL
35 S FBPSA=$$PSA^FBAAV5(+$P(Y(2),U,5),+FBAASN) I $L(+FBPSA)'=3 S FBPSA=999
36 S FBTD=$$AUSDT^FBAAV3($P(Y(0),"^",3))
37 S FBSUSP=$P(Y(0),"^",8),FBSUSP=$S(FBSUSP="":" ",$D(^FBAA(161.27,+FBSUSP,0)):$P(^(0),"^"),1:" ")
38 S FBAC=$$AUSAMT^FBAAV3($P(Y(0),"^",4),8)
39 S FBAP=$$AUSAMT^FBAAV3($P(Y(0),"^",16),8)
40 I FBAC=FBAP S FBAP=" "
41 S DFN=$P(Y(0),"^",5)
42 Q:'DFN
43 Q:'$D(^DPT(DFN,0))
44 ; Note: Prior to the following line Y(0) = the 0 node of subfile 161.11
45 ; After the line Y(0) will be the 0 node of file #2
46 S VAPA("P")="",Y(0)=^DPT(DFN,0) D PAT^FBAAUTL2,ADD^VADPT
47 S FBPNAMX=$$HL7NAME^FBAAV4(DFN)
48 S FBST=$S($P(VAPA(5),"^")="":" ",$D(^DIC(5,$P(VAPA(5),"^"),0)):$P(^(0),"^",2),1:" ")
49 S:$L(FBST)'=2 FBST=$E(PAD,$L(FBST)+1,2)_FBST
50 S FBCTY=$S($P(VAPA(7),"^")="":" ",FBST=" ":" ",$D(^DIC(5,$P(VAPA(5),"^"),1,$P(VAPA(7),"^"),0)):$P(^(0),"^",3),1:" ")
51 I $L(FBCTY)'=3 S FBCTY=$E("000",$L(FBCTY)+1,3)_FBCTY
52 S FBZIP=$S('+$G(VAPA(11)):VAPA(6),+VAPA(11):$P(VAPA(11),U),1:VAPA(6)),FBZIP=$TR(FBZIP,"-","")_$E("000000000",$L(FBZIP)+1,9)
53 ;
54 ; get and format adjustment reason codes and amounts (if any)
55 D LOADADJ^FBRXFA(FBIENS,.FBADJ)
56 S FBX=$$ADJL^FBUTL2(.FBADJ)
57 S FBADJR1=$$RJ^XLFSTR($P(FBX,U,1),5," ")
58 S FBADJA1=$$AUSAMT^FBAAV3($P(FBX,U,3),9,1)
59 S FBADJR2=$$RJ^XLFSTR($P(FBX,U,4),5," ")
60 S FBADJA2=$$AUSAMT^FBAAV3($P(FBX,U,6),9,1)
61 K FBADJ,FBX
62 ;
63 S FBSTR=5_FBAASN_FBSSN_FBPAYT_FBPNAMX_FBVID_FBCSN_FBAC_FBAP_FBAAON_FBSUSP_FBTD_FBRX_FBDIN_FBINVN_FBST_FBCTY_FBZIP_$E(FBPSA,1,3)
64 S FBSTR=FBSTR_$P(FBY,U,2)_$E(PAD,1,8)_$$PADZ^FBAAV01(FBPICN,30)_$$AUSDT^FBAAV3(+FBY)
65 S FBSTR=FBSTR_FBADJR1_FBADJR2_FBADJA1_FBADJA2_FBNPI_"$"
66 D STORE^FBAAV01
67 Q
Note: See TracBrowser for help on using the repository browser.