FBAAV6 ;AISC/GRR,WOIFO/SAB - CREATE TRANSACTIONS TO SEND TO PRICER ;9/14/2009
;;3.5;FEE BASIS;**55,108**;JAN 30, 1995;Build 115
;;Per VHA Directive 2004-038, 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)),Y(5)=$G(^FBAAI(K,5)) I Y(0)]"" D
.I 'FBTXT S FBTXT=1 D NEWMSG^FBAAV01
.D GOT
D:FBTXT XMIT^FBAAV01 K FBFLAG Q
;
GOT N FBCDCNT,FBCSVDT,FBI,FBLNCNT,FBTL
S FBCSVDT=$$FRDTINV^FBCSV1(K) ; code set version date
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:+FBLOS>999 FBLOS="***"
;S:$L(FBLOS)>3 FBLOS="***" ; >999 not supported, *** to cause reject
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("000000000",$L(FBBILL)+1,9)_FBBILL
S FBCLAIM=$P(Y(0),"^",8)+.00001,FBCLAIM=$P(FBCLAIM,".",1)_$E($P(FBCLAIM,".",2),1,2),FBCLAIM=$E("000000000",$L(FBCLAIM)+1,9)_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 $L(FBSTABR)>2 S FBSTABR="**" ; ** to cause reject of invalid state
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)_" "
;
S FBLNCNT=0 ; init invoice line counter
D NEWLN
; compute total lines needed (2-5)
S FBTL=($$LAST^FBCHEP1(K,"DX")+$$LAST^FBCHEP1(K,"PROC"))\13+2
; add rest of data for line 1
S FBSTR=FBSTR_FBTL_FBLNAM_FBFI_FBMI_FBSEX_FBDOB_FBLOS
S FBSTR=FBSTR_FBDISP_FBBILL_FBCLAIM_FBAUTH_FBPAYT_FBAACP_FBAAON_"Y"
S FBSTR=FBSTR_FBVID_FBMED_$E(PAD,1,29)_FBTDT_FBSTABR_" "
D STORE
;
S FBYDX=$G(^FBAAI(K,"DX"))
S FBYPOA=$G(^FBAAI(K,"POA"))
D NEWLN
; admitting Dx
S FBADMTDX=$P($G(^FBAAI(K,5)),"^",9)
; NVH Pricer requested sending primary Dx if admit Dx not known
I 'FBADMTDX S FBADMTDX=$P(FBYDX,"^")
S FBCDCNT=1 ; count of codes for line
S FBSTR=FBSTR_$$DX(FBADMTDX,FBCSVDT,"")
;
; loop thru Dx
F FBI=1:1:25 Q:$P(FBYDX,"^",FBI)="" D
. S FBCDCNT=FBCDCNT+1
. I FBCDCNT=14 D
. . D STORE
. . D NEWLN
. . S FBCDCNT=1
. S FBSTR=FBSTR_$$DX($P(FBYDX,"^",FBI),FBCSVDT,$P(FBYPOA,"^",FBI))
K FBADMTDX,FBYDX,FBYPOA
;
; loop thru Proc
S FBYPROC=$G(^FBAAI(K,"PROC"))
F FBI=1:1:25 Q:$P(FBYPROC,"^",FBI)="" D
. S FBCDCNT=FBCDCNT+1
. I FBCDCNT=14 D
. . D STORE
. . D NEWLN
. . S FBCDCNT=1
. S FBSTR=FBSTR_$$PROC($P(FBYPROC,"^",FBI),FBCSVDT)
K FBYPROC
;
; pad remainder of the invoice last line with spaces
S FBSTR=$$LJ^XLFSTR(FBSTR,131," ")
D STORE
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
;
NEWLN ; New Line
S FBLNCNT=FBLNCNT+1 ; increment invoice line count
S FBSTR=FBSSN_FBFDT_FBAASN_FBRESUB_FBLNCNT ; data at start of each line
Q
;
STORE D STORE^FBAAV01
Q
;
DX(FBDX,FBDATE,FBPOA) ; format diagnosis & POA for NVH Pricer
; Input
; FBDX = pointer to file 80 (ICD diagnosis)
; FBDATE = fileman date
; FBPOA = (optional) poiner to file 161.94 (present on admission)
; Returns formatted string of 8 characters
N FBRET,FBX,FBX2
S FBRET=" "
I FBDX D
. S FBX=$$ICD9^FBCSV1(FBDX,FBDATE)
. S:FBX["." FBX=$P(FBX,".",1)_$P(FBX,".",2)
. Q:FBX=""
. S FBX=FBX_$E(" ",$L(FBX)+1,7)
. S FBX2=$S($G(FBPOA):$P($G(^FB(161.94,FBPOA,0)),"^"),1:"")
. S:FBX2="" FBX2=" "
. S FBRET=FBX_FBX2
Q FBRET
;
PROC(FBPROC,FBDATE) ; format procedure for NVH Pricer
; Input
; FBPROC = pointer to file 80.1 (ICD operation/procedure)
; FBDATE = fileman date
; Returns formatted string of 8 characters
N FBRET,FBX
S FBRET=" "
I FBPROC D
. S FBX=$$ICD0^FBCSV1(FBPROC,FBDATE)
. S:FBX["." FBX=$P(FBX,".",1)_$P(FBX,".",2)
. Q:FBX=""
. S FBX=FBX_$E(" ",$L(FBX)+1,7)
. S FBRET=FBX_"*"
Q FBRET
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAV6 5546 printed Oct 16, 2024@17:57:51 Page 2
FBAAV6 ;AISC/GRR,WOIFO/SAB - CREATE TRANSACTIONS TO SEND TO PRICER ;9/14/2009
+1 ;;3.5;FEE BASIS;**55,108**;JAN 30, 1995;Build 115
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 SET FBFLAG=1
SET FBTXT=0
+4 SET FBSTAT="P"
SET FBJ=J
DO UPDT^FBAAUTL2
SET J=FBJ
FOR K=0:0
SET K=$ORDER(^FBAAI("AC",J,K))
if K'>0
QUIT
SET Y(0)=$GET(^FBAAI(K,0))
SET Y(5)=$GET(^FBAAI(K,5))
IF Y(0)]""
Begin DoDot:1
+5 IF 'FBTXT
SET FBTXT=1
DO NEWMSG^FBAAV01
+6 DO GOT
End DoDot:1
+7 if FBTXT
DO XMIT^FBAAV01
KILL FBFLAG
QUIT
+8 ;
GOT NEW FBCDCNT,FBCSVDT,FBI,FBLNCNT,FBTL
+1 ; code set version date
SET FBCSVDT=$$FRDTINV^FBCSV1(K)
+2 SET FBPAYT=$PIECE(Y(0),"^",13)
SET FBPAYT=$SELECT(FBPAYT]"":$SELECT(FBPAYT="R":"P",1:FBPAYT),1:"V")
SET FBVID=$PIECE(Y(0),"^",3)
SET FBVEN=FBVID
IF FBVID]""
SET FBVID=$SELECT($DATA(^FBAAV(FBVID,0)):$PIECE(^(0),"^",17),1:$EXTRACT(PAD,1,6))
+3 if FBVID']""
SET FBVID=$EXTRACT(PAD,1,6)
+4 SET FB7078=$PIECE(Y(0),"^",5)
IF FB7078]""
Begin DoDot:1
+5 IF FB7078["FB7078("
IF $DATA(^FB7078(+FB7078,0))
SET FBFNY=^FB7078(+FB7078,0)
SET FBFDT=$SELECT($PIECE(FBFNY,"^",15):$PIECE(FBFNY,"^",15),1:$PIECE(FBFNY,"^",4))
SET FBTDT=$SELECT($PIECE(FBFNY,"^",16):$PIECE(FBFNY,"^",16),1:$PIECE(FBFNY,"^",5))
+6 IF FB7078["FB583("
IF $DATA(^FB583(+FB7078,0))
SET FBFNY=^FB583(+FB7078,0)
SET FBFDT=$SELECT($PIECE(FBFNY,"^",5)]"":$PIECE(FBFNY,"^",5),1:$PIECE(FBFNY,"^",13))
SET FBTDT=$SELECT($PIECE(FBFNY,"^",6)]"":$PIECE(FBFNY,"^",6),1:$PIECE(FBFNY,"^",14))
End DoDot:1
+7 SET X1=FBTDT
SET X2=FBFDT
DO ^%DTC
SET FBLOS=$SELECT(X<1:1,1:X)
SET FBFDT=$EXTRACT(FBFDT,4,7)_($EXTRACT(FBFDT,1,3)+1700)
+8 SET FBTDT=$EXTRACT(FBTDT,4,7)_($EXTRACT(FBTDT,1,3)+1700)
SET FBLOS=$EXTRACT("000",$LENGTH(FBLOS)+1,3)_FBLOS
SET FBRESUB=+$PIECE(Y(0),"^",25)
+9 if +FBLOS>999
SET FBLOS="***"
+10 ;S:$L(FBLOS)>3 FBLOS="***" ; >999 not supported, *** to cause reject
+11 SET FBDISP=$PIECE(Y(0),"^",21)
IF FBDISP]""
SET FBDISP=$SELECT($DATA(^FBAA(162.6,FBDISP,0)):$PIECE(^(0),"^",2),1:"00")
+12 SET FBDISP=$EXTRACT("00",$LENGTH(FBDISP)+1,2)_FBDISP
SET FBBILL=$PIECE(Y(0),"^",22)+.00001
SET FBBILL=$PIECE(FBBILL,".",1)_$EXTRACT($PIECE(FBBILL,".",2),1,2)
SET FBBILL=$EXTRACT("000000000",$LENGTH(FBBILL)+1,9)_FBBILL
+13 SET FBCLAIM=$PIECE(Y(0),"^",8)+.00001
SET FBCLAIM=$PIECE(FBCLAIM,".",1)_$EXTRACT($PIECE(FBCLAIM,".",2),1,2)
SET FBCLAIM=$EXTRACT("000000000",$LENGTH(FBCLAIM)+1,9)_FBCLAIM
+14 SET FBSTAT=$SELECT(FBVEN']"":"",$DATA(^FBAAV(FBVEN,0)):$PIECE(^(0),"^",5),1:"")
+15 SET FBSTABR=$SELECT(FBSTAT']"":" ",$DATA(^DIC(5,FBSTAT,0)):$PIECE(^(0),"^",2),1:" ")
SET FBSTABR=$EXTRACT(" ",$LENGTH(FBSTABR)+1,2)_FBSTABR
SET FBAUTH=""
+16 ; ** to cause reject of invalid state
IF $LENGTH(FBSTABR)>2
SET FBSTABR="**"
+17 IF FB7078]""
SET FBAUTH=$SELECT(FB7078["FB583(":" ",$DATA(^FB7078(+FB7078,0)):$PIECE(^(0),"^",6),1:" ")
+18 SET FBAUTH=$$AUTH(FBAUTH)
+19 SET DFN=+$PIECE(Y(0),"^",4)
SET FBMED=$PIECE(Y(0),"^",23)
SET FBMED=$SELECT(FBMED="":"N",1:FBMED)
SET Y(0)=$GET(^DPT(DFN,0))
DO PAT^FBAAUTL2
SET FBLNAM=$EXTRACT(FBFLNAM,1,12)
SET FBSSN=$EXTRACT(FBSSN,10)_$EXTRACT(FBSSN,1,9)_" "
+20 ;
+21 ; init invoice line counter
SET FBLNCNT=0
+22 DO NEWLN
+23 ; compute total lines needed (2-5)
+24 SET FBTL=($$LAST^FBCHEP1(K,"DX")+$$LAST^FBCHEP1(K,"PROC"))\13+2
+25 ; add rest of data for line 1
+26 SET FBSTR=FBSTR_FBTL_FBLNAM_FBFI_FBMI_FBSEX_FBDOB_FBLOS
+27 SET FBSTR=FBSTR_FBDISP_FBBILL_FBCLAIM_FBAUTH_FBPAYT_FBAACP_FBAAON_"Y"
+28 SET FBSTR=FBSTR_FBVID_FBMED_$EXTRACT(PAD,1,29)_FBTDT_FBSTABR_" "
+29 DO STORE
+30 ;
+31 SET FBYDX=$GET(^FBAAI(K,"DX"))
+32 SET FBYPOA=$GET(^FBAAI(K,"POA"))
+33 DO NEWLN
+34 ; admitting Dx
+35 SET FBADMTDX=$PIECE($GET(^FBAAI(K,5)),"^",9)
+36 ; NVH Pricer requested sending primary Dx if admit Dx not known
+37 IF 'FBADMTDX
SET FBADMTDX=$PIECE(FBYDX,"^")
+38 ; count of codes for line
SET FBCDCNT=1
+39 SET FBSTR=FBSTR_$$DX(FBADMTDX,FBCSVDT,"")
+40 ;
+41 ; loop thru Dx
+42 FOR FBI=1:1:25
if $PIECE(FBYDX,"^",FBI)=""
QUIT
Begin DoDot:1
+43 SET FBCDCNT=FBCDCNT+1
+44 IF FBCDCNT=14
Begin DoDot:2
+45 DO STORE
+46 DO NEWLN
+47 SET FBCDCNT=1
End DoDot:2
+48 SET FBSTR=FBSTR_$$DX($PIECE(FBYDX,"^",FBI),FBCSVDT,$PIECE(FBYPOA,"^",FBI))
End DoDot:1
+49 KILL FBADMTDX,FBYDX,FBYPOA
+50 ;
+51 ; loop thru Proc
+52 SET FBYPROC=$GET(^FBAAI(K,"PROC"))
+53 FOR FBI=1:1:25
if $PIECE(FBYPROC,"^",FBI)=""
QUIT
Begin DoDot:1
+54 SET FBCDCNT=FBCDCNT+1
+55 IF FBCDCNT=14
Begin DoDot:2
+56 DO STORE
+57 DO NEWLN
+58 SET FBCDCNT=1
End DoDot:2
+59 SET FBSTR=FBSTR_$$PROC($PIECE(FBYPROC,"^",FBI),FBCSVDT)
End DoDot:1
+60 KILL FBYPROC
+61 ;
+62 ; pad remainder of the invoice last line with spaces
+63 SET FBSTR=$$LJ^XLFSTR(FBSTR,131," ")
+64 DO STORE
+65 QUIT
+66 ;
AUTH(X) ;Function call to provide the Admitting Regulation.
+1 ;X is equal to the internal entry number of the VA Admitting Reg file
+2 ;User is returned with an alpha dependent on the Admitting Reg chosen
+3 NEW CFR,FBCFR
+4 SET CFR=$PIECE($GET(^DIC(43.4,+X,0)),"^",3)
IF '$GET(CFR)
QUIT "A"
+5 SET FBCFR=$SELECT(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:"")
+6 IF FBCFR=""
SET FBCFR=$SELECT(CFR="17.50b(a)(9)":"I",CFR="17.80(a)(i)":"L",CFR="17.80(a)(iii)":"J",1:"A")
+7 QUIT FBCFR
+8 ;
NEWLN ; New Line
+1 ; increment invoice line count
SET FBLNCNT=FBLNCNT+1
+2 ; data at start of each line
SET FBSTR=FBSSN_FBFDT_FBAASN_FBRESUB_FBLNCNT
+3 QUIT
+4 ;
STORE DO STORE^FBAAV01
+1 QUIT
+2 ;
DX(FBDX,FBDATE,FBPOA) ; format diagnosis & POA for NVH Pricer
+1 ; Input
+2 ; FBDX = pointer to file 80 (ICD diagnosis)
+3 ; FBDATE = fileman date
+4 ; FBPOA = (optional) poiner to file 161.94 (present on admission)
+5 ; Returns formatted string of 8 characters
+6 NEW FBRET,FBX,FBX2
+7 SET FBRET=" "
+8 IF FBDX
Begin DoDot:1
+9 SET FBX=$$ICD9^FBCSV1(FBDX,FBDATE)
+10 if FBX["."
SET FBX=$PIECE(FBX,".",1)_$PIECE(FBX,".",2)
+11 if FBX=""
QUIT
+12 SET FBX=FBX_$EXTRACT(" ",$LENGTH(FBX)+1,7)
+13 SET FBX2=$SELECT($GET(FBPOA):$PIECE($GET(^FB(161.94,FBPOA,0)),"^"),1:"")
+14 if FBX2=""
SET FBX2=" "
+15 SET FBRET=FBX_FBX2
End DoDot:1
+16 QUIT FBRET
+17 ;
PROC(FBPROC,FBDATE) ; format procedure for NVH Pricer
+1 ; Input
+2 ; FBPROC = pointer to file 80.1 (ICD operation/procedure)
+3 ; FBDATE = fileman date
+4 ; Returns formatted string of 8 characters
+5 NEW FBRET,FBX
+6 SET FBRET=" "
+7 IF FBPROC
Begin DoDot:1
+8 SET FBX=$$ICD0^FBCSV1(FBPROC,FBDATE)
+9 if FBX["."
SET FBX=$PIECE(FBX,".",1)_$PIECE(FBX,".",2)
+10 if FBX=""
QUIT
+11 SET FBX=FBX_$EXTRACT(" ",$LENGTH(FBX)+1,7)
+12 SET FBRET=FBX_"*"
End DoDot:1
+13 QUIT FBRET
