68 lines
3.0 KiB
Mathematica
68 lines
3.0 KiB
Mathematica
FBAAV2 ;AISC/GRR-ELECTRONICALLY TRANSMIT PHARMACY PAYMENTS ;11 Apr 2006 2:52 PM
|
|
;;3.5;FEE BASIS;**3,89,98**;JAN 30, 1995;Build 54
|
|
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
DETP ; ENTRY FROM FBAAV0
|
|
S FBTXT=0
|
|
D CKB5V^FBAAV01 I $G(FBERR) K FBERR Q
|
|
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
|
|
.N FBPICN,FBY
|
|
.S FBPICN=K_U_L
|
|
.S FBY=$S($P(Y,U,12):$P(Y,U,12),1:$P(Y,U,2))_U_+$P(Y(2),U,9)
|
|
.I 'FBTXT S FBTXT=1 D NEWMSG^FBAAV01,STORE^FBAAV01,UPD^FBAAV0
|
|
.D GOTP
|
|
D:FBTXT XMIT^FBAAV01
|
|
Q
|
|
;
|
|
GOTP ; process a B5 line item
|
|
N DFN,FBADJ,FBADJA1,FBADJA2,FBADJR1,FBADJR2,FBIENS,FBPNAMX,FBVY0,FBX,FBNPI
|
|
;
|
|
S FBIENS=$P(FBPICN,U,2)_","_$P(FBPICN,U,1)_","
|
|
S FBPAYT=$P(Y(0),"^",20),FBPAYT=$S(FBPAYT]"":FBPAYT,1:"V")
|
|
S FBINVN=$P(Y,"^"),FBINVN=$E("000000000",$L(FBINVN)+1,9)_FBINVN
|
|
S FBDIN=$$AUSDT^FBAAV3($P(Y,"^",2))
|
|
;
|
|
S FBVFN=$P(Y,"^",4)
|
|
S FBNPI=$$EN^FBNPILK(FBVFN)
|
|
S FBVY0=$G(^FBAAV(FBVFN,0)) ; vendor 0 node
|
|
S FBVID=$P(FBVY0,U,2),FBVID=$E(FBVID,1,9)_$E(PAD,$L(FBVID)+1,9)
|
|
S FBCSN=$S($P(FBVY0,U,2)]"":$P(FBVY0,U,10),1:"")
|
|
S FBCSN=$E("0000",$L(FBCSN)+1,4)_FBCSN
|
|
I FBPAYT="R" S FBVID=$E(PAD,1,9),FBCSN=$E(PAD,1,4)
|
|
K FBVY0
|
|
;
|
|
S FBRX=$P(Y(0),"^",1),FBRX=$E("00000000",$L(FBRX)+1,8)_FBRX
|
|
I '$L($G(FBAASN)) D STATION^FBAAUTL
|
|
S FBPSA=$$PSA^FBAAV5(+$P(Y(2),U,5),+FBAASN) I $L(+FBPSA)'=3 S FBPSA=999
|
|
S FBTD=$$AUSDT^FBAAV3($P(Y(0),"^",3))
|
|
S FBSUSP=$P(Y(0),"^",8),FBSUSP=$S(FBSUSP="":" ",$D(^FBAA(161.27,+FBSUSP,0)):$P(^(0),"^"),1:" ")
|
|
S FBAC=$$AUSAMT^FBAAV3($P(Y(0),"^",4),8)
|
|
S FBAP=$$AUSAMT^FBAAV3($P(Y(0),"^",16),8)
|
|
I FBAC=FBAP S FBAP=" "
|
|
S DFN=$P(Y(0),"^",5)
|
|
Q:'DFN
|
|
Q:'$D(^DPT(DFN,0))
|
|
; Note: Prior to the following line Y(0) = the 0 node of subfile 161.11
|
|
; After the line Y(0) will be the 0 node of file #2
|
|
S VAPA("P")="",Y(0)=^DPT(DFN,0) D PAT^FBAAUTL2,ADD^VADPT
|
|
S FBPNAMX=$$HL7NAME^FBAAV4(DFN)
|
|
S FBST=$S($P(VAPA(5),"^")="":" ",$D(^DIC(5,$P(VAPA(5),"^"),0)):$P(^(0),"^",2),1:" ")
|
|
S:$L(FBST)'=2 FBST=$E(PAD,$L(FBST)+1,2)_FBST
|
|
S FBCTY=$S($P(VAPA(7),"^")="":" ",FBST=" ":" ",$D(^DIC(5,$P(VAPA(5),"^"),1,$P(VAPA(7),"^"),0)):$P(^(0),"^",3),1:" ")
|
|
I $L(FBCTY)'=3 S FBCTY=$E("000",$L(FBCTY)+1,3)_FBCTY
|
|
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)
|
|
;
|
|
; get and format adjustment reason codes and amounts (if any)
|
|
D LOADADJ^FBRXFA(FBIENS,.FBADJ)
|
|
S FBX=$$ADJL^FBUTL2(.FBADJ)
|
|
S FBADJR1=$$RJ^XLFSTR($P(FBX,U,1),5," ")
|
|
S FBADJA1=$$AUSAMT^FBAAV3($P(FBX,U,3),9,1)
|
|
S FBADJR2=$$RJ^XLFSTR($P(FBX,U,4),5," ")
|
|
S FBADJA2=$$AUSAMT^FBAAV3($P(FBX,U,6),9,1)
|
|
K FBADJ,FBX
|
|
;
|
|
S FBSTR=5_FBAASN_FBSSN_FBPAYT_FBPNAMX_FBVID_FBCSN_FBAC_FBAP_FBAAON_FBSUSP_FBTD_FBRX_FBDIN_FBINVN_FBST_FBCTY_FBZIP_$E(FBPSA,1,3)
|
|
S FBSTR=FBSTR_$P(FBY,U,2)_$E(PAD,1,8)_$$PADZ^FBAAV01(FBPICN,30)_$$AUSDT^FBAAV3(+FBY)
|
|
S FBSTR=FBSTR_FBADJR1_FBADJR2_FBADJA1_FBADJA2_FBNPI_"$"
|
|
D STORE^FBAAV01
|
|
Q
|