- 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 Mar 13, 2025@21:01:43 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
