FBAAV6 ;AISC/GRR-CREATE TRANSACTIONS TO SEND TO PRICER SYSTEM ;4/28/93 10:59 ;;3.5;FEE BASIS;**55**;JAN 30, 1995 ;;Per VHA Directive 10-93-142, this routine should not be modified. S FBFLAG=1,FBTXT=0 S FBSTAT="P",FBJ=J D UPDT^FBAAUTL2 S J=FBJ F K=0:0 S K=$O(^FBAAI("AC",J,K)) Q:K'>0 S Y(0)=$G(^FBAAI(K,0)) I Y(0)]"" D .N FBDTSR1 S FBDTSR1=$P($G(Y(0)),"^",6) .I 'FBTXT S FBTXT=1 D NEWMSG^FBAAV01 .D GOT D:FBTXT XMIT^FBAAV01 K FBFLAG Q GOT S FBPAYT=$P(Y(0),"^",13),FBPAYT=$S(FBPAYT]"":$S(FBPAYT="R":"P",1:FBPAYT),1:"V"),FBVID=$P(Y(0),"^",3),FBVEN=FBVID I FBVID]"" S FBVID=$S($D(^FBAAV(FBVID,0)):$P(^(0),"^",17),1:$E(PAD,1,6)) S:FBVID']"" FBVID=$E(PAD,1,6) S FB7078=$P(Y(0),"^",5) I FB7078]"" D .I FB7078["FB7078(",$D(^FB7078(+FB7078,0)) S FBFNY=^FB7078(+FB7078,0),FBFDT=$S($P(FBFNY,"^",15):$P(FBFNY,"^",15),1:$P(FBFNY,"^",4)),FBTDT=$S($P(FBFNY,"^",16):$P(FBFNY,"^",16),1:$P(FBFNY,"^",5)) .I FB7078["FB583(",$D(^FB583(+FB7078,0)) S FBFNY=^FB583(+FB7078,0),FBFDT=$S($P(FBFNY,"^",5)]"":$P(FBFNY,"^",5),1:$P(FBFNY,"^",13)),FBTDT=$S($P(FBFNY,"^",6)]"":$P(FBFNY,"^",6),1:$P(FBFNY,"^",14)) S X1=FBTDT,X2=FBFDT D ^%DTC S FBLOS=$S(X<1:1,1:X),FBFDT=$E(FBFDT,4,7)_($E(FBFDT,1,3)+1700) S FBTDT=$E(FBTDT,4,7)_($E(FBTDT,1,3)+1700),FBLOS=$E("000",$L(FBLOS)+1,3)_FBLOS,FBRESUB=+$P(Y(0),"^",25) S FBDISP=$P(Y(0),"^",21) I FBDISP]"" S FBDISP=$S($D(^FBAA(162.6,FBDISP,0)):$P(^(0),"^",2),1:"00") S FBDISP=$E("00",$L(FBDISP)+1,2)_FBDISP,FBBILL=$P(Y(0),"^",22)+.00001,FBBILL=$P(FBBILL,".",1)_$E($P(FBBILL,".",2),1,2),FBBILL=$E("00000000",$L(FBBILL)+1,8)_FBBILL S FBCLAIM=$P(Y(0),"^",8)+.00001,FBCLAIM=$P(FBCLAIM,".",1)_$E($P(FBCLAIM,".",2),1,2),FBCLAIM=$E("00000000",$L(FBCLAIM)+1,8)_FBCLAIM S FBSTAT=$S(FBVEN']"":"",$D(^FBAAV(FBVEN,0)):$P(^(0),"^",5),1:"") S FBSTABR=$S(FBSTAT']"":" ",$D(^DIC(5,FBSTAT,0)):$P(^(0),"^",2),1:" "),FBSTABR=$E(" ",$L(FBSTABR)+1,2)_FBSTABR,FBAUTH="" I FB7078]"" S FBAUTH=$S(FB7078["FB583(":" ",$D(^FB7078(+FB7078,0)):$P(^(0),"^",6),1:" ") S FBAUTH=$$AUTH(FBAUTH) S DFN=+$P(Y(0),"^",4),FBMED=$P(Y(0),"^",23),FBMED=$S(FBMED="":"N",1:FBMED),Y(0)=$G(^DPT(DFN,0)) D PAT^FBAAUTL2 S FBLNAM=$E(FBFLNAM,1,12),FBSSN=$E(FBSSN,10)_$E(FBSSN,1,9)_" " K FBDX,FBPRC F I=1:1:5 S (FBDX(I),FBPRC(I))=" " I '$D(^FBAAI(K,"DX")) G OVR S Y("DX")=^("DX") F M=1:1:5 Q:$P(Y("DX"),"^",M)="" S FBDX(M)=$$EV^FBCSV1($$ICD9^FBCSV1($P(Y("DX"),"^",M),$G(FBDTSR1)),FBDX(M)),FBDX(M)=$S(FBDX(M)'[".":FBDX(M),1:$P(FBDX(M),".",1)_$P(FBDX(M),".",2)),FBDX(M)=FBDX(M)_$E(PAD,$L(FBDX(M))+1,7) OVR I '$D(^FBAAI(K,"PROC")) G OVR2 S Y("PROC")=^("PROC") F M=1:1:3 Q:$P(Y("PROC"),"^",M)="" S FBPRC(M)=$$EV^FBCSV1($$ICD0^FBCSV1($P(Y("PROC"),"^",M),$G(FBDTSR1)),FBPRC(M)) D MORE OVR2 S FBPART1=FBSSN_FBFDT_FBAASN S FBSTR=FBPART1_FBRESUB_"1"_FBLNAM_FBFI_FBMI_FBSEX_FBDOB_FBLOS_FBDISP_FBBILL_FBCLAIM_FBAUTH_FBPAYT_FBAACP_FBAAON_"Y" D STORE S FBSTR=FBPART1_FBRESUB_"2"_FBVID_FBMED_$E(PAD,1,29)_FBTDT_FBSTABR_FBDX(1) D STORE S FBSTR=FBPART1_FBRESUB_"3"_FBDX(2)_FBDX(3)_FBDX(4)_FBDX(5)_FBPRC(1)_FBPRC(2)_FBPRC(3)_" " D STORE Q STORE D STORE^FBAAV01 ;S FBLN=FBLN+1,^XMB(3.9,FBXMZ,2,FBLN,0)=FBSTR ;,^TMP($J,"FBPRICER",FBCN3,1,FBCN4,0)=FBSTR Q MORE S FBPRC(M)=$S(FBPRC(M)'[".":FBPRC(M),1:$P(FBPRC(M),".",1)_$P(FBPRC(M),".",2)),FBPRC(M)=FBPRC(M)_$E(PAD,$L(FBPRC(M))+1,7) Q AUTH(X) ;Function call to provide the Admitting Regulation. ;X is equal to the internal entry number of the VA Admitting Reg file ;User is returned with an alpha dependent on the Admitting Reg chosen N CFR,FBCFR S CFR=$P($G(^DIC(43.4,+X,0)),"^",3) I '$G(CFR) Q "A" S FBCFR=$S(CFR="17.50b(a)(1)(i)":"A",CFR="17.50b(a)(1)(iii)":"B",CFR="17.50b(a)(1)(iv)":"C",CFR="17.50b(a)(3)":"H",CFR="17.50b(a)(4)":"D",CFR="17.50b(a)(5)":"E",CFR="17.50b(a)(6)":"F",CFR="17.50b(a)(8)":"G",1:"") I FBCFR="" S FBCFR=$S(CFR="17.50b(a)(9)":"I",CFR="17.80(a)(i)":"L",CFR="17.80(a)(iii)":"J",1:"A") Q FBCFR