source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAV6.m@ 975

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

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1FBAAV6 ;AISC/GRR-CREATE TRANSACTIONS TO SEND TO PRICER SYSTEM ;4/28/93 10:59
2 ;;3.5;FEE BASIS;**55**;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 S FBFLAG=1,FBTXT=0
5 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
6 .N FBDTSR1 S FBDTSR1=$P($G(Y(0)),"^",6)
7 .I 'FBTXT S FBTXT=1 D NEWMSG^FBAAV01
8 .D GOT
9 D:FBTXT XMIT^FBAAV01 K FBFLAG Q
10GOT 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))
11 S:FBVID']"" FBVID=$E(PAD,1,6)
12 S FB7078=$P(Y(0),"^",5) I FB7078]"" D
13 .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))
14 .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))
15 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)
16 S FBTDT=$E(FBTDT,4,7)_($E(FBTDT,1,3)+1700),FBLOS=$E("000",$L(FBLOS)+1,3)_FBLOS,FBRESUB=+$P(Y(0),"^",25)
17 S FBDISP=$P(Y(0),"^",21) I FBDISP]"" S FBDISP=$S($D(^FBAA(162.6,FBDISP,0)):$P(^(0),"^",2),1:"00")
18 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
19 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
20 S FBSTAT=$S(FBVEN']"":"",$D(^FBAAV(FBVEN,0)):$P(^(0),"^",5),1:"")
21 S FBSTABR=$S(FBSTAT']"":" ",$D(^DIC(5,FBSTAT,0)):$P(^(0),"^",2),1:" "),FBSTABR=$E(" ",$L(FBSTABR)+1,2)_FBSTABR,FBAUTH=""
22 I FB7078]"" S FBAUTH=$S(FB7078["FB583(":" ",$D(^FB7078(+FB7078,0)):$P(^(0),"^",6),1:" ")
23 S FBAUTH=$$AUTH(FBAUTH)
24 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)_" "
25 K FBDX,FBPRC F I=1:1:5 S (FBDX(I),FBPRC(I))=" "
26 I '$D(^FBAAI(K,"DX")) G OVR
27 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)
28OVR I '$D(^FBAAI(K,"PROC")) G OVR2
29 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
30OVR2 S FBPART1=FBSSN_FBFDT_FBAASN
31 S FBSTR=FBPART1_FBRESUB_"1"_FBLNAM_FBFI_FBMI_FBSEX_FBDOB_FBLOS_FBDISP_FBBILL_FBCLAIM_FBAUTH_FBPAYT_FBAACP_FBAAON_"Y" D STORE
32 S FBSTR=FBPART1_FBRESUB_"2"_FBVID_FBMED_$E(PAD,1,29)_FBTDT_FBSTABR_FBDX(1) D STORE
33 S FBSTR=FBPART1_FBRESUB_"3"_FBDX(2)_FBDX(3)_FBDX(4)_FBDX(5)_FBPRC(1)_FBPRC(2)_FBPRC(3)_" " D STORE
34 Q
35STORE D STORE^FBAAV01 ;S FBLN=FBLN+1,^XMB(3.9,FBXMZ,2,FBLN,0)=FBSTR ;,^TMP($J,"FBPRICER",FBCN3,1,FBCN4,0)=FBSTR
36 Q
37MORE 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)
38 Q
39AUTH(X) ;Function call to provide the Admitting Regulation.
40 ;X is equal to the internal entry number of the VA Admitting Reg file
41 ;User is returned with an alpha dependent on the Admitting Reg chosen
42 N CFR,FBCFR
43 S CFR=$P($G(^DIC(43.4,+X,0)),"^",3) I '$G(CFR) Q "A"
44 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:"")
45 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")
46 Q FBCFR
Note: See TracBrowser for help on using the repository browser.