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

FBCHEP1.m

Go to the documentation of this file. 
  1. FBCHEP1 ;AISC/DMK - EDIT PAYMENT FOR CONTRACT HOSPITAL ;10/01/14
  1.  ;;3.5;FEE BASIS;**38,61,122,133,108,124,132,139,123,154**;JAN 30, 1995;Build 12
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1. EDIT ;ENTRY POINT TO EDIT PAYMENT
  1.  N LASTDX,LASTPROC
  1.  S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP
  1. BT W ! S DIC="^FBAA(161.7,",DIC(0)="AEQMZ",DIC("S")="I $P(^(0),U,3)=""B9""&($P(^(0),U,15)=""Y"")",DIC("S")=$S($D(^XUSEC("FBAA LEVEL 2",DUZ)):DIC("S"),1:DIC("S")_"&($P(^(0),U,5)=DUZ)") D ^DIC
  1.  G END:X=""!(X="^"),BT:Y<0 S FBN=+Y,FBN(0)=Y(0)
  1.  S FBEXMPT=$P(FBN(0),"^",18)
  1.  S FBSTAT=^FBAA(161.7,FBN,"ST"),FBBAMT=$S($P(FBN(0),"^",9)="":0,1:$P(FBN(0),"^",9))
  1.  I FBSTAT="C"&('$D(^XUSEC("FBAA LEVEL 2",DUZ))) W !!,*7,?3,"You must Reopen the batch prior to editing the invoice.",! G END
  1.  I FBSTAT="S"!(FBSTAT="P")!(FBSTAT="R")&('$D(^XUSEC("FBAA LEVEL 2",DUZ))) W !!,*7,?3,"You must be a holder of the FBAA LEVEL 2 security key",!,?3,"to edit this invoice.",! G END
  1.  I FBSTAT="T"!(FBSTAT="F")!(FBSTAT="V") W !!,?3,"Batch has already been sent to Austin for payment.",! G END
  1. INV W ! S DIC="^FBAAI(",DIC(0)="AEQZ",DIC("S")="I $P(^(0),U,17)=FBN" D ^DIC K DIC("S") G BT:X=""!(X="^"),INV:Y<0 S FBI=+Y
  1.  ;
  1.  ; enforce separation of duties
  1.  S FBDFN=$P($G(^FBAAI(FBI,0)),U,4)
  1.  S FB7078I=$P($G(^FBAAI(FBI,0)),U,5)
  1.  S FTP=$S(FB7078I]"":$O(^FBAAA("AG",FB7078I,FBDFN,0)),1:"")
  1.  I '$$UOKPAY^FBUTL9(FBDFN,FTP) D  Q
  1.  . W !!,"You cannot process a payment associated with authorization ",FBDFN,"-",FTP
  1.  . W !,"due to separation of duties."
  1.  ;
  1.  ;
  1.  ; FB*3.5*123 - edit inpatient invoice - check for IPAC data for Federal Vendors
  1.  I '$$IPACEDIT^FBAAPET1(162.5,FBI,.FBIA,.FBDODINV) G INV
  1.  ;
  1.  S FBK=$S($P(^FBAAI(FBI,0),"^",9)="":0,1:$P(^(0),"^",9))
  1.  S FBLISTC="",FBAAI=FBI W @IOF D START^FBCHDI2 S FBI=FBAAI I $P(^FBAAI(FBI,0),"^",9)="" S FBPRICE=""
  1.  ; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
  1.  D
  1.  . N FBY
  1.  . S FBY=$G(^FBAAI(FBI,0))
  1.  . S FB1725=$S($P(FBY,U,5)["FB583":+$P($G(^FB583(+$P(FBY,U,5),0)),U,28),1:0)
  1.  ; get values of FPPS Claim ID and Line Item
  1.  S FBFPPSC=$P($G(^FBAAI(FBI,3)),U)
  1.  S FBFPPSL=$P($G(^FBAAI(FBI,3)),U,2)
  1.  ; load current adjustment data
  1.  D LOADADJ^FBCHFA(FBI_",",.FBADJ)
  1.  ; save adjustment data prior to edit session in sorted list
  1.  S FBADJL(0)=$$ADJL^FBUTL2(.FBADJ) ; sorted list of original adjustments
  1.  ; load current remittance remark data
  1.  D LOADRR^FBCHFR(FBI_",",.FBRRMK)
  1.  ; load Item level Rendering provider data
  1.  D LOADRP^FBUTL8(FBI_",",.FBPROV) ;FB*3.5*122
  1.  ; save remittance remarks prior to edit session in sorted list
  1.  S FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK)
  1.  S LASTDX=$$LAST(FBI,"DX"),LASTPROC=$$LAST(FBI,"PROC")
  1.  S (DIE,DIC)="^FBAAI(",DIC(0)="AEQM",DA=FBI,DR="[FBCH EDIT PAYMENT]" W !
  1.  D
  1.  . N ICDVDT,DFN,FB583,FBAAMM1,FBAAPTC,FBCNTRA,FBCNTRP,FBV,FBVEN,FTP
  1.  . S ICDVDT=$$FRDTINV^FBCSV1(DA) ;date for files 80 and 80.1 identifier
  1.  . ;get variables for call to PPT^FBAACO1
  1.  . S FBAAMM1=$P($G(^FBAAI(DA,2)),U,3)
  1.  . S FBCNTRP=$P($G(^FBAAI(DA,5)),U,8)
  1.  . S FBV=$P($G(^FBAAI(DA,0)),U,3)
  1.  . S DFN=$P($G(^FBAAI(DA,0)),U,4)
  1.  . S FBAAPTC=$P($G(^FBAAI(DA,0)),U,13)
  1.  . S X=$P($G(^FBAAI(DA,0)),U,5)
  1.  . S:X[";FB583(" FB583=+X
  1.  . S FTP=$S(X]"":+$O(^FBAAA("AG",X,DFN,0)),1:"")
  1.  . S FBVEN=$S(FTP:$P($G(^FBAAA(DFN,1,FTP,0)),U,4),1:"")
  1.  . S FBCNTRA=$S(FTP:$P($G(^FBAAA(DFN,1,FTP,0)),U,22),1:"")
  1.  . D ^DIE
  1.  ; if adjustment data changed then file
  1.  I $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0) D FILEADJ^FBCHFA(FBI_",",.FBADJ)
  1.  ; if remit remark data changed then file
  1.  I $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0) D FILERR^FBCHFR(FBI_",",.FBRRMK)
  1.  ; remove any gaps in codes
  1.  D RMVGAP(FBI,1)
  1.  ; if line item rendering providers exist then file FB*3.5*133
  1.  I $D(FBPROV) D FILERP^FBUTL8(FBI_",",.FBPROV)
  1.  K FBAAMM,FBAAMM1
  1.  S FBNK=$P(^FBAAI(FBI,0),"^",9)
  1.  I FBNK-FBK S $P(^FBAA(161.7,FBN,0),"^",9)=FBBAMT+(FBNK-FBK)
  1. END K DA,DFN,DIC,DIE,DR,FBAAOUT,FBDX,FBI,FBIN,FBLISTC,FBN,FBPROC,FBSTAT,FBVEN,FBVID,J,K,L,POP,Q,VA,VADM,X,FBIFN,Y,FBPRICE,FBK,FBNK,FB583,FBAAPN,FBASSOC,FBDEL,FBLOC,DAT
  1.  K CNT,D0,FB7078,FBAABDT,FBAAEDT,FBASSOC,FBAUT,FBLOC,FBPROG,FBPSA,FBPT,FBRR,FBTT,FBTYPE,FBXX,FTP,PI,PTYPE,T,Z,ZZ,F,FBPOV,I,TA,VAL,DUOUT,FBVET,FBBAMT,FBAAI,FBEXMPT,FB1725,FBPAMT
  1.  K FBFPPSC,FBFPPSL,FBADJ,FBADJD,FBRRMK,FBRRMKD,FBIA,FBDODINV
  1.  K FB7078I,FBDFN
  1.  D END^FBCHDI
  1.  Q
  1.  ;
  1. BADDATE(INVRCVDT,TEMPDA) ;Compare edited Invoice Received Date to Treatment Date, reject if before. Called from [FBCH EDIT PAYMENT] template. 
  1.  I INVRCVDT="" Q 0 ;Inv Date not changed, no check necessary
  1.  N TDAT,SHODAT S TDAT=$$GET1^DIQ(162.5,TEMPDA_",",6,"I") I TDAT]"" S SHODAT="TO"
  1.  I TDAT="" S TDAT=$$GET1^DIQ(162.5,TEMPDA_",",5,"I"),SHODAT="FROM"
  1.  I INVRCVDT<TDAT D  Q 1 ;Reject entered date
  1.  .N SHOTDAT S SHOTDAT=$E(TDAT,4,5)_"/"_$E(TDAT,6,7)_"/"_$E(TDAT,2,3) ;Convert TDAT into display format for error message.
  1.  .N MSG1,MSG2 S MSG1="*** Invoice Received Date cannot be before",MSG2=" Treatment "_SHODAT_" Date ("_SHOTDAT_") !!!"
  1.  .W !!?5,*7,MSG1,!?8,MSG2
  1.  Q 0 ;Date entered is OK
  1.  ;
  1. LAST(FBDA,FBNODE) ; Returns number (0-25) of last code in node for invoice
  1.  D RMVGAP(FBDA,0)  ;Insure that gaps were not created outside normal processes
  1.  N FBI,FBRET,FBX
  1.  S FBRET=0
  1.  I FBDA,"^DX^PROC^"[(U_FBNODE_U) D
  1.  . S FBX=$G(^FBAAI(FBDA,FBNODE))
  1.  . F FBI=25:-1:1 I $P(FBX,"^",FBI)'="" S FBRET=FBI Q
  1.  Q FBRET
  1.  ;
  1. RMVGAP(FBDA,FBWRT) ;  Remove gaps in ICD diagnosis and procedure codes
  1.  ; input
  1.  ;   FBDA  IEN of invoice
  1.  ;   FBWRT (optional) =1 if messages can be written to the screen
  1.  ; remove any gaps
  1.  N DXFLD,FBDX,FBFDA,FBI,FBMOVED,FBN,FBPOA,FBPROC,POAFLD,PROCFLD
  1.  D FLDLIST ; get list of field numbers
  1.  ; check diagnosis and POA codes
  1.  S FBDX=$G(^FBAAI(FBDA,"DX"))
  1.  S FBPOA=$G(^FBAAI(FBDA,"POA"))
  1.  S FBMOVED=0
  1.  S FBN=0
  1.  F FBI=1:1:25 D
  1.  . ; JAS - 03/05/14 - Patch 139 (ICD-10 Project) - Modified next line to also quit if 0
  1.  . Q:(($P(FBDX,U,FBI)="")!($P(FBDX,U,FBI)=0))
  1.  . S FBN=FBN+1 ; increment number of diagnosis codes
  1.  . Q:FBI=FBN  ; no gap
  1.  . ; move diagnosis and POA from slot FBI to slot FBN
  1.  . S FBMOVED=1 ; set flag for message
  1.  . K FBFDA
  1.  . S FBFDA(162.5,FBDA_",",$P(DXFLD,U,FBN))=$P(FBDX,U,FBI)
  1.  . S FBFDA(162.5,FBDA_",",$P(POAFLD,U,FBN))=$P(FBPOA,U,FBI)
  1.  . S FBFDA(162.5,FBDA_",",$P(DXFLD,U,FBI))="@"
  1.  . S FBFDA(162.5,FBDA_",",$P(POAFLD,U,FBI))="@"
  1.  . D FILE^DIE("","FBFDA") D:$G(FBWRT) MSG^DIALOG()
  1.  . S $P(FBDX,U,FBN)=$P(FBDX,U,FBI)
  1.  . S $P(FBPOA,U,FBN)=$P(FBPOA,U,FBI)
  1.  . S $P(FBDX,U,FBI)=""
  1.  . S $P(FBPOA,U,FBI)=""
  1.  I $G(FBWRT),FBMOVED W !,"Diagnosis codes were moved to remove gaps"
  1.  ;
  1.  S FBPROC=$G(^FBAAI(FBDA,"PROC"))
  1.  S FBMOVED=0
  1.  S FBN=0
  1.  F FBI=1:1:25 D
  1.  . ; JAS - 03/05/14 - Patch 139 (ICD-10 Project) - Modified next line to also quit if 0
  1.  . Q:(($P(FBPROC,U,FBI)="")!($P(FBPROC,U,FBI)=0))
  1.  . S FBN=FBN+1 ; increment number of procedure codes
  1.  . Q:FBI=FBN  ; no gap
  1.  . ; move procedure from slot FBI to slot FBN
  1.  . S FBMOVED=1
  1.  . K FBFDA
  1.  . S FBFDA(162.5,FBDA_",",$P(PROCFLD,U,FBN))=$P(FBPROC,U,FBI)
  1.  . S FBFDA(162.5,FBDA_",",$P(PROCFLD,U,FBI))="@"
  1.  . D FILE^DIE("","FBFDA") D:$G(FBWRT) MSG^DIALOG()
  1.  . S $P(FBPROC,U,FBN)=$P(FBPROC,U,FBI)
  1.  . S $P(FBPROC,U,FBI)=""
  1.  I $G(FBWRT),FBMOVED W !,"Procedure codes were moved to remove gaps"
  1.  Q
  1.  ;
  1. FLDLIST ; Provide list of fields for diagnosis, POA, and procedures
  1.  S DXFLD="30^31^32^33^34^35^35.1^35.2^35.3^35.4^35.5^35.6^35.7^35.8^35.9^36^36.1^36.2^36.3^36.4^36.5^36.6^36.7^36.8^36.9"
  1.  S POAFLD="30.02^31.02^32.02^33.02^34.02^35.02^35.12^35.22^35.32^35.42^35.52^35.62^35.72^35.82^35.92^36.02^36.12^36.22^36.32^36.42^36.52^36.62^36.72^26.82^36.92"
  1.  S PROCFLD="40^41^42^43^44^44.06^44.07^44.08^44.09^44.1^44.11^44.12^44.13^44.14^44.15^44.16^44.17^44.18^44.19^44.2^44.21^44.22^44.23^44.24^44.25"
  1.  Q
  1.  ;
  1. GETIPAC(FBDA,FBVEN,FBIA,FBDODINV) ; Get vendor/IPAC data for Inpatient (FB*3.5*123)
  1.  ; All parameters required and assumed to exist
  1.  ; Called by $$IPACEDIT^FBAAPET1
  1.  N GX5
  1.  S FBVEN=+$P($G(^FBAAI(FBDA,0)),U,3)    ; vendor ien
  1.  S GX5=$G(^FBAAI(FBDA,5))
  1.  S FBIA=+$P(GX5,U,10)                   ; ipac agreement ien
  1.  S FBDODINV=$P(GX5,U,7)                 ; ipac DoD invoice#
  1.  Q
  1.  ;
  1. DELIPAC(FBDA) ; Delete all IPAC data on file for Inpatient (FB*3.5*123)
  1.  ; Called by $$IPACEDIT^FBAAPET1
  1.  N DIE,DA,DR,DIC
  1.  S DIE=162.5,DA=FBDA,DR="86///@;87///@" D ^DIE
  1.  Q
  1.  ;