source: FOIAVistA/trunk/r/FEE_BASIS-FB/FBAAV6.m

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