FBPRICE1 ;AISC/DMK,WOIFO/SAB - GENERIC PRICER INTERFACE CON'T ;9/14/2009
;;3.5;FEE BASIS;**56,55,77,108,139**;JAN 30, 1995;Build 127
;;Per VA Directive 6402, this routine should not be modified.
;
N FBCDCNT,FBCNT,FBI,FBLNCNT,FBRT,FBTL,FBVAL,XICDVDT,FBISYS
S XICDVDT=FBCSVDT ; date for file 80 and 80.1 identifier logic
S FBCNT=0 ; count of codes
N EDATE,DP,DA S EDATE=XICDVDT,DP=0,DA=0 ; FB*3.5*139 JLG ICD-10 remediation
S FBISYS=10 S:XICDVDT<$$IMPDATE^FBCSV1("10D") FBISYS=9 ; FB*3.5*139 JLG ICD-10 remediation
;
ICD ;ask Dx
W !
S FBQUIT=0
F I=1:1:25 D Q:((FBISYS=9)&(X=""))!(FBQUIT)!($D(DTOUT))!($D(DUOUT))
. I FBISYS=9 D Q:X=""!($D(DTOUT))!($D(DUOUT))
. . S DIR(0)="PO^80:EIQMZ" ;3/28/13 S DIR(0)="PO^80:EQMZ"
. . ;JAS - 04/09/13 - Patch 139 - Added next line for screening
. . S DIR("S")="I $$CHKVERS^FBICD9(+Y,FBCSVDT)"
. . F D ^DIR Q:X=""!($D(DTOUT))!($D(DUOUT)) S FBVAL=+Y,FBRT=$$CHKICD9^FBCSV1(FBVAL,FBCSVDT) I FBRT]"" S FBDX(I)=FBVAL,FBCNT=FBCNT+1 Q
. . K DIR
. . Q:'$G(FBDX(I))
. . D POA Q:$D(DTOUT)!$D(DUOUT)
. I FBISYS=10 D
. . S FBY=$$ICD10 S X=1
. . I FBY=-3 S DTOUT=-1 Q ; -3 means ^ entered by user
. . I FBY>0 S FBDX(I)=FBY,FBCNT=FBCNT+1 D POA S X=1 Q
. . S FBQUIT=-1 Q
I $D(DTOUT)!($D(DUOUT)) G END^FBPRICE
I (FBISYS=9)&('$G(FBDX(1))) W !,*7,"Must enter at least a primary diagnosis.",! G ICD
K DIR,I
;
ADMITDX ;ask admitting diagnosis for ICD-9
I FBISYS=10 G ADMITDX0
I FBISYS=9 D
. ;JAS - 04/10/13 - Patch 139 - Altered DIR read for ICD versioning
. W ! S DIR(0)="PO^80:EIQMZ",DIR("A")="Admitting Diagnosis"
. S DIR("S")="I $$CHKVERS^FBICD9(+Y,FBCSVDT)"
. ;END 139
. D ^DIR K DIR
. Q:$D(DIRUT)
. S FBVAL=+Y
. S FBRT=$$CHKICD9^FBCSV1(FBVAL,FBCSVDT)
;JAS - 09/18/13 - PATCH 139 - Modified code to force entry of required Admitting dx field.
I $D(DIRUT) W !,"This is a required response." G ADMITDX
I FBRT="" G ADMITDX
S FBADMTDX=FBVAL
S FBCNT=FBCNT+1
;
ADMITDX0 ; ask admitting diagnosis for ICD-10 ; FB*3.5*139 JLG ICD-10 remediation
I FBISYS=10 D
. W ! S FBRT=$$ASKICD10^FBASF("Admitting Diagnosis","","Y")
. I FBRT'>0 W !,"This is a required response."
G END^FBPRICE:$D(DIRUT)
I (FBISYS=10)&(FBRT'>0) G ADMITDX0
I (FBISYS=10) S FBADMTDX=FBRT S FBCNT=FBCNT+1
;
PROC ;ask procedure codes
W !
;JAS - 04/10/13 - Patch 139 - Changed from DIR read to new utility to allow for proper code-set versioning and additional inactive code checks
F I=1:1:25 D Q:X=""!($D(DUOUT))!($D(DTOUT))
. F S Y=$$ENICD9^FBICDP(FBCSVDT,"Select ICD OPERATION/PROCEDURE") Q:X=""!($D(DUOUT))!($D(DTOUT))!(+Y'>0) S FBVAL=+Y,FBPRC(I)=FBVAL,FBCNT=FBCNT+1 Q
;END 139
I $D(DTOUT)!($D(DUOUT)) G END^FBPRICE
K DIR,I
;
W ! S DIR(0)="162.5,6.6",DIR("A")="Billed Charges"
D ^DIR K DIR G END^FBPRICE:$D(DIRUT)
S FBBILL=$FN(Y,"",2),FBBILL=$TR(FBBILL,".")
S FBBILL=$E("000000000",$L(FBBILL)+1,9)_FBBILL
;
S DIR(0)="162.5,6.6",DIR("A")="Amount Claimed"
D ^DIR K DIR G END^FBPRICE:$D(DIRUT)
S FBCLAIM=$FN(Y,"",2),FBCLAIM=$TR(FBCLAIM,".")
S FBCLAIM=$E("000000000",$L(FBCLAIM)+1,9)_FBCLAIM
;
S FBOBL="000000"
;
STRING ;set-up message text for pricer
W ! D WAIT^DICD
D ADDRESS^FBAAV01 Q:$G(VATERR) K VAT
S FBTL=(FBCNT-1)\13+2 ; total number of lines needed
S FBFLAG=1 D NEWMSG^FBAAV01
S FBRESUB=2 ; 2 identifies the message as generic pricer
S FBLNCNT=0 ; init invoice line counter
D NEWLN^FBAAV6
S FBSTR=FBSTR_FBTL_FBLNAM_FBFI_FBMI_FBSEX_FBDOB_FBLOS
S FBSTR=FBSTR_FBDISP_FBBILL_FBCLAIM_FBAUTH_FBPAYT_FBOBL_"Y"
S FBSTR=FBSTR_FBVID_FBMED_$E(PAD,1,29)_FBTDT_FBSTABR_" "
D STORE^FBAAV01
;
D NEWLN^FBAAV6
S FBCDCNT=1 ; count of codes in the line (=1 for admit dx)
S FBSTR=FBSTR_$$DX^FBAAV6(FBADMTDX,FBCSVDT,"")
; loop thru Dx
F FBI=1:1:25 Q:'$G(FBDX(FBI)) D
. S FBCDCNT=FBCDCNT+1
. I FBCDCNT=14 D
. . D STORE^FBAAV01
. . D NEWLN^FBAAV6
. . S FBCDCNT=1
. S FBSTR=FBSTR_$$DX^FBAAV6(FBDX(FBI),FBCSVDT,FBPOA(FBI))
; loop thru proc
F FBI=1:1:25 Q:'$G(FBPRC(FBI)) D
. S FBCDCNT=FBCDCNT+1
. I FBCDCNT=14 D
. . D STORE^FBAAV01
. . D NEWLN^FBAAV6
. . S FBCDCNT=1
. S FBSTR=FBSTR_$$PROC^FBAAV6(FBPRC(FBI),FBCSVDT)
; pad remainder of last line with spaces and save it
S FBSTR=$$LJ^XLFSTR(FBSTR,131," ")
D STORE^FBAAV01
;
D XMIT^FBAAV01 K FBFLAG
W !,"Case sent to pricer.",!
Q
;
POA ; ask POA
N DIR,Y
S DIR(0)="P^161.94:EQM" D ^DIR K DIR Q:$D(DTOUT)!$D(DUOUT)
S FBPOA(I)=+Y
Q
ICD10() ;FB*3.5*139 JLG ICD-10 remediation
N FBY,FBQUIT
ASK10 ;FB*3.5*139 JLG ICD-10 remediation
S FBY=$$ASKICD10^FBASF("Select ICD DIAGNOSIS","","Y")
Q:(FBY>0)!(FBY=-3) FBY
I (I>1)&(FBY'>0) S FBQUIT=-1 Q ""
I '$G(FBDX(1)) W !,*7,"Must enter at least a primary diagnosis.",! G ASK10
G ASK10
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPRICE1 4792 printed Nov 22, 2024@17:09:57 Page 2
FBPRICE1 ;AISC/DMK,WOIFO/SAB - GENERIC PRICER INTERFACE CON'T ;9/14/2009
+1 ;;3.5;FEE BASIS;**56,55,77,108,139**;JAN 30, 1995;Build 127
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 NEW FBCDCNT,FBCNT,FBI,FBLNCNT,FBRT,FBTL,FBVAL,XICDVDT,FBISYS
+5 ; date for file 80 and 80.1 identifier logic
SET XICDVDT=FBCSVDT
+6 ; count of codes
SET FBCNT=0
+7 ; FB*3.5*139 JLG ICD-10 remediation
NEW EDATE,DP,DA
SET EDATE=XICDVDT
SET DP=0
SET DA=0
+8 ; FB*3.5*139 JLG ICD-10 remediation
SET FBISYS=10
if XICDVDT<$$IMPDATE^FBCSV1("10D")
SET FBISYS=9
+9 ;
ICD ;ask Dx
+1 WRITE !
+2 SET FBQUIT=0
+3 FOR I=1:1:25
Begin DoDot:1
+4 IF FBISYS=9
Begin DoDot:2
+5 ;3/28/13 S DIR(0)="PO^80:EQMZ"
SET DIR(0)="PO^80:EIQMZ"
+6 ;JAS - 04/09/13 - Patch 139 - Added next line for screening
+7 SET DIR("S")="I $$CHKVERS^FBICD9(+Y,FBCSVDT)"
+8 FOR
DO ^DIR
if X=""!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
SET FBVAL=+Y
SET FBRT=$$CHKICD9^FBCSV1(FBVAL,FBCSVDT)
IF FBRT]""
SET FBDX(I)=FBVAL
SET FBCNT=FBCNT+1
QUIT
+9 KILL DIR
+10 if '$GET(FBDX(I))
QUIT
+11 DO POA
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
End DoDot:2
if X=""!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+12 IF FBISYS=10
Begin DoDot:2
+13 SET FBY=$$ICD10
SET X=1
+14 ; -3 means ^ entered by user
IF FBY=-3
SET DTOUT=-1
QUIT
+15 IF FBY>0
SET FBDX(I)=FBY
SET FBCNT=FBCNT+1
DO POA
SET X=1
QUIT
+16 SET FBQUIT=-1
QUIT
End DoDot:2
End DoDot:1
if ((FBISYS=9)&(X=""))!(FBQUIT)!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+17 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO END^FBPRICE
+18 IF (FBISYS=9)&('$GET(FBDX(1)))
WRITE !,*7,"Must enter at least a primary diagnosis.",!
GOTO ICD
+19 KILL DIR,I
+20 ;
ADMITDX ;ask admitting diagnosis for ICD-9
+1 IF FBISYS=10
GOTO ADMITDX0
+2 IF FBISYS=9
Begin DoDot:1
+3 ;JAS - 04/10/13 - Patch 139 - Altered DIR read for ICD versioning
+4 WRITE !
SET DIR(0)="PO^80:EIQMZ"
SET DIR("A")="Admitting Diagnosis"
+5 SET DIR("S")="I $$CHKVERS^FBICD9(+Y,FBCSVDT)"
+6 ;END 139
+7 DO ^DIR
KILL DIR
+8 if $DATA(DIRUT)
QUIT
+9 SET FBVAL=+Y
+10 SET FBRT=$$CHKICD9^FBCSV1(FBVAL,FBCSVDT)
End DoDot:1
+11 ;JAS - 09/18/13 - PATCH 139 - Modified code to force entry of required Admitting dx field.
+12 IF $DATA(DIRUT)
WRITE !,"This is a required response."
GOTO ADMITDX
+13 IF FBRT=""
GOTO ADMITDX
+14 SET FBADMTDX=FBVAL
+15 SET FBCNT=FBCNT+1
+16 ;
ADMITDX0 ; ask admitting diagnosis for ICD-10 ; FB*3.5*139 JLG ICD-10 remediation
+1 IF FBISYS=10
Begin DoDot:1
+2 WRITE !
SET FBRT=$$ASKICD10^FBASF("Admitting Diagnosis","","Y")
+3 IF FBRT'>0
WRITE !,"This is a required response."
End DoDot:1
+4 if $DATA(DIRUT)
GOTO END^FBPRICE
+5 IF (FBISYS=10)&(FBRT'>0)
GOTO ADMITDX0
+6 IF (FBISYS=10)
SET FBADMTDX=FBRT
SET FBCNT=FBCNT+1
+7 ;
PROC ;ask procedure codes
+1 WRITE !
+2 ;JAS - 04/10/13 - Patch 139 - Changed from DIR read to new utility to allow for proper code-set versioning and additional inactive code checks
+3 FOR I=1:1:25
Begin DoDot:1
+4 FOR
SET Y=$$ENICD9^FBICDP(FBCSVDT,"Select ICD OPERATION/PROCEDURE")
if X=""!($DATA(DUOUT))!($DATA(DTOUT))!(+Y'>0)
QUIT
SET FBVAL=+Y
SET FBPRC(I)=FBVAL
SET FBCNT=FBCNT+1
QUIT
End DoDot:1
if X=""!($DATA(DUOUT))!($DATA(DTOUT))
QUIT
+5 ;END 139
+6 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO END^FBPRICE
+7 KILL DIR,I
+8 ;
+9 WRITE !
SET DIR(0)="162.5,6.6"
SET DIR("A")="Billed Charges"
+10 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END^FBPRICE
+11 SET FBBILL=$FNUMBER(Y,"",2)
SET FBBILL=$TRANSLATE(FBBILL,".")
+12 SET FBBILL=$EXTRACT("000000000",$LENGTH(FBBILL)+1,9)_FBBILL
+13 ;
+14 SET DIR(0)="162.5,6.6"
SET DIR("A")="Amount Claimed"
+15 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END^FBPRICE
+16 SET FBCLAIM=$FNUMBER(Y,"",2)
SET FBCLAIM=$TRANSLATE(FBCLAIM,".")
+17 SET FBCLAIM=$EXTRACT("000000000",$LENGTH(FBCLAIM)+1,9)_FBCLAIM
+18 ;
+19 SET FBOBL="000000"
+20 ;
STRING ;set-up message text for pricer
+1 WRITE !
DO WAIT^DICD
+2 DO ADDRESS^FBAAV01
if $GET(VATERR)
QUIT
KILL VAT
+3 ; total number of lines needed
SET FBTL=(FBCNT-1)\13+2
+4 SET FBFLAG=1
DO NEWMSG^FBAAV01
+5 ; 2 identifies the message as generic pricer
SET FBRESUB=2
+6 ; init invoice line counter
SET FBLNCNT=0
+7 DO NEWLN^FBAAV6
+8 SET FBSTR=FBSTR_FBTL_FBLNAM_FBFI_FBMI_FBSEX_FBDOB_FBLOS
+9 SET FBSTR=FBSTR_FBDISP_FBBILL_FBCLAIM_FBAUTH_FBPAYT_FBOBL_"Y"
+10 SET FBSTR=FBSTR_FBVID_FBMED_$EXTRACT(PAD,1,29)_FBTDT_FBSTABR_" "
+11 DO STORE^FBAAV01
+12 ;
+13 DO NEWLN^FBAAV6
+14 ; count of codes in the line (=1 for admit dx)
SET FBCDCNT=1
+15 SET FBSTR=FBSTR_$$DX^FBAAV6(FBADMTDX,FBCSVDT,"")
+16 ; loop thru Dx
+17 FOR FBI=1:1:25
if '$GET(FBDX(FBI))
QUIT
Begin DoDot:1
+18 SET FBCDCNT=FBCDCNT+1
+19 IF FBCDCNT=14
Begin DoDot:2
+20 DO STORE^FBAAV01
+21 DO NEWLN^FBAAV6
+22 SET FBCDCNT=1
End DoDot:2
+23 SET FBSTR=FBSTR_$$DX^FBAAV6(FBDX(FBI),FBCSVDT,FBPOA(FBI))
End DoDot:1
+24 ; loop thru proc
+25 FOR FBI=1:1:25
if '$GET(FBPRC(FBI))
QUIT
Begin DoDot:1
+26 SET FBCDCNT=FBCDCNT+1
+27 IF FBCDCNT=14
Begin DoDot:2
+28 DO STORE^FBAAV01
+29 DO NEWLN^FBAAV6
+30 SET FBCDCNT=1
End DoDot:2
+31 SET FBSTR=FBSTR_$$PROC^FBAAV6(FBPRC(FBI),FBCSVDT)
End DoDot:1
+32 ; pad remainder of last line with spaces and save it
+33 SET FBSTR=$$LJ^XLFSTR(FBSTR,131," ")
+34 DO STORE^FBAAV01
+35 ;
+36 DO XMIT^FBAAV01
KILL FBFLAG
+37 WRITE !,"Case sent to pricer.",!
+38 QUIT
+39 ;
POA ; ask POA
+1 NEW DIR,Y
+2 SET DIR(0)="P^161.94:EQM"
DO ^DIR
KILL DIR
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+3 SET FBPOA(I)=+Y
+4 QUIT
ICD10() ;FB*3.5*139 JLG ICD-10 remediation
+1 NEW FBY,FBQUIT
ASK10 ;FB*3.5*139 JLG ICD-10 remediation
+1 SET FBY=$$ASKICD10^FBASF("Select ICD DIAGNOSIS","","Y")
+2 if (FBY>0)!(FBY=-3)
QUIT FBY
+3 IF (I>1)&(FBY'>0)
SET FBQUIT=-1
QUIT ""
+4 IF '$GET(FBDX(1))
WRITE !,*7,"Must enter at least a primary diagnosis.",!
GOTO ASK10
+5 GOTO ASK10
