47 lines
3.8 KiB
Mathematica
47 lines
3.8 KiB
Mathematica
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
|