Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FBPRICE1

FBPRICE1.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  N FBCDCNT,FBCNT,FBI,FBLNCNT,FBRT,FBTL,FBVAL,XICDVDT,FBISYS
  1.  S XICDVDT=FBCSVDT ; date for file 80 and 80.1 identifier logic
  1.  S FBCNT=0 ; count of codes
  1.  N EDATE,DP,DA S EDATE=XICDVDT,DP=0,DA=0 ; FB*3.5*139 JLG ICD-10 remediation
  1.  S FBISYS=10 S:XICDVDT<$$IMPDATE^FBCSV1("10D") FBISYS=9 ; FB*3.5*139 JLG ICD-10 remediation
  1.  ;
  1. ICD ;ask Dx
  1.  W !
  1.  S FBQUIT=0
  1.  F I=1:1:25 D  Q:((FBISYS=9)&(X=""))!(FBQUIT)!($D(DTOUT))!($D(DUOUT))
  1.  . I FBISYS=9 D  Q:X=""!($D(DTOUT))!($D(DUOUT))
  1.  . . S DIR(0)="PO^80:EIQMZ" ;3/28/13 S DIR(0)="PO^80:EQMZ"
  1.  . . ;JAS - 04/09/13 - Patch 139 - Added next line for screening
  1.  . . S DIR("S")="I $$CHKVERS^FBICD9(+Y,FBCSVDT)"
  1.  . . 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
  1.  . . K DIR
  1.  . . Q:'$G(FBDX(I))
  1.  . . D POA Q:$D(DTOUT)!$D(DUOUT)
  1.  . I FBISYS=10 D
  1.  . . S FBY=$$ICD10 S X=1
  1.  . . I FBY=-3 S DTOUT=-1 Q  ; -3 means ^ entered by user
  1.  . . I FBY>0 S FBDX(I)=FBY,FBCNT=FBCNT+1 D POA S X=1 Q
  1.  . . S FBQUIT=-1 Q
  1.  I $D(DTOUT)!($D(DUOUT)) G END^FBPRICE
  1.  I (FBISYS=9)&('$G(FBDX(1))) W !,*7,"Must enter at least a primary diagnosis.",! G ICD
  1.  K DIR,I
  1.  ; 
  1. ADMITDX ;ask admitting diagnosis for ICD-9
  1.  I FBISYS=10 G ADMITDX0
  1.  I FBISYS=9 D
  1.  . ;JAS - 04/10/13 - Patch 139 - Altered DIR read for ICD versioning
  1.  . W ! S DIR(0)="PO^80:EIQMZ",DIR("A")="Admitting Diagnosis"
  1.  . S DIR("S")="I $$CHKVERS^FBICD9(+Y,FBCSVDT)"
  1.  . ;END 139
  1.  . D ^DIR K DIR
  1.  . Q:$D(DIRUT)
  1.  . S FBVAL=+Y
  1.  . S FBRT=$$CHKICD9^FBCSV1(FBVAL,FBCSVDT)
  1.  ;JAS - 09/18/13 - PATCH 139 - Modified code to force entry of required Admitting dx field.
  1.  I $D(DIRUT) W !,"This is a required response." G ADMITDX
  1.  I FBRT="" G ADMITDX
  1.  S FBADMTDX=FBVAL
  1.  S FBCNT=FBCNT+1
  1.  ;
  1. ADMITDX0 ; ask admitting diagnosis for ICD-10  ; FB*3.5*139 JLG ICD-10 remediation
  1.  I FBISYS=10 D
  1.  . W ! S FBRT=$$ASKICD10^FBASF("Admitting Diagnosis","","Y")
  1.  . I FBRT'>0 W !,"This is a required response."
  1.  G END^FBPRICE:$D(DIRUT)
  1.  I (FBISYS=10)&(FBRT'>0) G ADMITDX0
  1.  I (FBISYS=10) S FBADMTDX=FBRT S FBCNT=FBCNT+1
  1.  ;
  1. PROC ;ask procedure codes
  1.  W !
  1.  ;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
  1.  F I=1:1:25 D  Q:X=""!($D(DUOUT))!($D(DTOUT))
  1.  . 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
  1.  ;END 139
  1.  I $D(DTOUT)!($D(DUOUT)) G END^FBPRICE
  1.  K DIR,I
  1.  ;
  1.  W ! S DIR(0)="162.5,6.6",DIR("A")="Billed Charges"
  1.  D ^DIR K DIR G END^FBPRICE:$D(DIRUT)
  1.  S FBBILL=$FN(Y,"",2),FBBILL=$TR(FBBILL,".")
  1.  S FBBILL=$E("000000000",$L(FBBILL)+1,9)_FBBILL
  1.  ;
  1.  S DIR(0)="162.5,6.6",DIR("A")="Amount Claimed"
  1.  D ^DIR K DIR G END^FBPRICE:$D(DIRUT)
  1.  S FBCLAIM=$FN(Y,"",2),FBCLAIM=$TR(FBCLAIM,".")
  1.  S FBCLAIM=$E("000000000",$L(FBCLAIM)+1,9)_FBCLAIM
  1.  ;
  1.  S FBOBL="000000"
  1.  ;
  1. STRING ;set-up message text for pricer
  1.  W ! D WAIT^DICD
  1.  D ADDRESS^FBAAV01 Q:$G(VATERR)  K VAT
  1.  S FBTL=(FBCNT-1)\13+2 ; total number of lines needed
  1.  S FBFLAG=1 D NEWMSG^FBAAV01
  1.  S FBRESUB=2 ; 2 identifies the message as generic pricer
  1.  S FBLNCNT=0 ; init invoice line counter
  1.  D NEWLN^FBAAV6
  1.  S FBSTR=FBSTR_FBTL_FBLNAM_FBFI_FBMI_FBSEX_FBDOB_FBLOS
  1.  S FBSTR=FBSTR_FBDISP_FBBILL_FBCLAIM_FBAUTH_FBPAYT_FBOBL_"Y"
  1.  S FBSTR=FBSTR_FBVID_FBMED_$E(PAD,1,29)_FBTDT_FBSTABR_"  "
  1.  D STORE^FBAAV01
  1.  ;
  1.  D NEWLN^FBAAV6
  1.  S FBCDCNT=1 ; count of codes in the line (=1 for admit dx)
  1.  S FBSTR=FBSTR_$$DX^FBAAV6(FBADMTDX,FBCSVDT,"")
  1.  ; loop thru Dx
  1.  F FBI=1:1:25 Q:'$G(FBDX(FBI))  D
  1.  . S FBCDCNT=FBCDCNT+1
  1.  . I FBCDCNT=14 D
  1.  . . D STORE^FBAAV01
  1.  . . D NEWLN^FBAAV6
  1.  . . S FBCDCNT=1
  1.  . S FBSTR=FBSTR_$$DX^FBAAV6(FBDX(FBI),FBCSVDT,FBPOA(FBI))
  1.  ; loop thru proc
  1.  F FBI=1:1:25 Q:'$G(FBPRC(FBI))  D
  1.  . S FBCDCNT=FBCDCNT+1
  1.  . I FBCDCNT=14 D
  1.  . . D STORE^FBAAV01
  1.  . . D NEWLN^FBAAV6
  1.  . . S FBCDCNT=1
  1.  . S FBSTR=FBSTR_$$PROC^FBAAV6(FBPRC(FBI),FBCSVDT)
  1.  ; pad remainder of last line with spaces and save it
  1.  S FBSTR=$$LJ^XLFSTR(FBSTR,131," ")
  1.  D STORE^FBAAV01
  1.  ;
  1.  D XMIT^FBAAV01 K FBFLAG
  1.  W !,"Case sent to pricer.",!
  1.  Q
  1.  ; 
  1. POA ; ask POA
  1.  N DIR,Y
  1.  S DIR(0)="P^161.94:EQM" D ^DIR K DIR Q:$D(DTOUT)!$D(DUOUT)
  1.  S FBPOA(I)=+Y
  1.  Q
  1. ICD10() ;FB*3.5*139 JLG ICD-10 remediation
  1.  N FBY,FBQUIT
  1. ASK10 ;FB*3.5*139 JLG ICD-10 remediation 
  1.  S FBY=$$ASKICD10^FBASF("Select ICD DIAGNOSIS","","Y")
  1.  Q:(FBY>0)!(FBY=-3) FBY
  1.  I (I>1)&(FBY'>0) S FBQUIT=-1 Q ""
  1.  I '$G(FBDX(1)) W !,*7,"Must enter at least a primary diagnosis.",! G ASK10
  1.  G ASK10