FBCHEP1 ;AISC/DMK - EDIT PAYMENT FOR CONTRACT HOSPITAL ;10/01/14
;;3.5;FEE BASIS;**38,61,122,133,108,124,132,139,123,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
EDIT ;ENTRY POINT TO EDIT PAYMENT
N LASTDX,LASTPROC
S IOP=$S($D(ION):ION,1:"HOME") D ^%ZIS K IOP
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
G END:X=""!(X="^"),BT:Y<0 S FBN=+Y,FBN(0)=Y(0)
S FBEXMPT=$P(FBN(0),"^",18)
S FBSTAT=^FBAA(161.7,FBN,"ST"),FBBAMT=$S($P(FBN(0),"^",9)="":0,1:$P(FBN(0),"^",9))
I FBSTAT="C"&('$D(^XUSEC("FBAA LEVEL 2",DUZ))) W !!,*7,?3,"You must Reopen the batch prior to editing the invoice.",! G END
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
I FBSTAT="T"!(FBSTAT="F")!(FBSTAT="V") W !!,?3,"Batch has already been sent to Austin for payment.",! G END
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
;
; enforce separation of duties
S FBDFN=$P($G(^FBAAI(FBI,0)),U,4)
S FB7078I=$P($G(^FBAAI(FBI,0)),U,5)
S FTP=$S(FB7078I]"":$O(^FBAAA("AG",FB7078I,FBDFN,0)),1:"")
I '$$UOKPAY^FBUTL9(FBDFN,FTP) D Q
. W !!,"You cannot process a payment associated with authorization ",FBDFN,"-",FTP
. W !,"due to separation of duties."
;
;
; FB*3.5*123 - edit inpatient invoice - check for IPAC data for Federal Vendors
I '$$IPACEDIT^FBAAPET1(162.5,FBI,.FBIA,.FBDODINV) G INV
;
S FBK=$S($P(^FBAAI(FBI,0),"^",9)="":0,1:$P(^(0),"^",9))
S FBLISTC="",FBAAI=FBI W @IOF D START^FBCHDI2 S FBI=FBAAI I $P(^FBAAI(FBI,0),"^",9)="" S FBPRICE=""
; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
D
. N FBY
. S FBY=$G(^FBAAI(FBI,0))
. S FB1725=$S($P(FBY,U,5)["FB583":+$P($G(^FB583(+$P(FBY,U,5),0)),U,28),1:0)
; get values of FPPS Claim ID and Line Item
S FBFPPSC=$P($G(^FBAAI(FBI,3)),U)
S FBFPPSL=$P($G(^FBAAI(FBI,3)),U,2)
; load current adjustment data
D LOADADJ^FBCHFA(FBI_",",.FBADJ)
; save adjustment data prior to edit session in sorted list
S FBADJL(0)=$$ADJL^FBUTL2(.FBADJ) ; sorted list of original adjustments
; load current remittance remark data
D LOADRR^FBCHFR(FBI_",",.FBRRMK)
; load Item level Rendering provider data
D LOADRP^FBUTL8(FBI_",",.FBPROV) ;FB*3.5*122
; save remittance remarks prior to edit session in sorted list
S FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK)
S LASTDX=$$LAST(FBI,"DX"),LASTPROC=$$LAST(FBI,"PROC")
S (DIE,DIC)="^FBAAI(",DIC(0)="AEQM",DA=FBI,DR="[FBCH EDIT PAYMENT]" W !
D
. N ICDVDT,DFN,FB583,FBAAMM1,FBAAPTC,FBCNTRA,FBCNTRP,FBV,FBVEN,FTP
. S ICDVDT=$$FRDTINV^FBCSV1(DA) ;date for files 80 and 80.1 identifier
. ;get variables for call to PPT^FBAACO1
. S FBAAMM1=$P($G(^FBAAI(DA,2)),U,3)
. S FBCNTRP=$P($G(^FBAAI(DA,5)),U,8)
. S FBV=$P($G(^FBAAI(DA,0)),U,3)
. S DFN=$P($G(^FBAAI(DA,0)),U,4)
. S FBAAPTC=$P($G(^FBAAI(DA,0)),U,13)
. S X=$P($G(^FBAAI(DA,0)),U,5)
. S:X[";FB583(" FB583=+X
. S FTP=$S(X]"":+$O(^FBAAA("AG",X,DFN,0)),1:"")
. S FBVEN=$S(FTP:$P($G(^FBAAA(DFN,1,FTP,0)),U,4),1:"")
. S FBCNTRA=$S(FTP:$P($G(^FBAAA(DFN,1,FTP,0)),U,22),1:"")
. D ^DIE
; if adjustment data changed then file
I $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0) D FILEADJ^FBCHFA(FBI_",",.FBADJ)
; if remit remark data changed then file
I $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0) D FILERR^FBCHFR(FBI_",",.FBRRMK)
; remove any gaps in codes
D RMVGAP(FBI,1)
; if line item rendering providers exist then file FB*3.5*133
I $D(FBPROV) D FILERP^FBUTL8(FBI_",",.FBPROV)
K FBAAMM,FBAAMM1
S FBNK=$P(^FBAAI(FBI,0),"^",9)
I FBNK-FBK S $P(^FBAA(161.7,FBN,0),"^",9)=FBBAMT+(FBNK-FBK)
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
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
K FBFPPSC,FBFPPSL,FBADJ,FBADJD,FBRRMK,FBRRMKD,FBIA,FBDODINV
K FB7078I,FBDFN
D END^FBCHDI
Q
;
BADDATE(INVRCVDT,TEMPDA) ;Compare edited Invoice Received Date to Treatment Date, reject if before. Called from [FBCH EDIT PAYMENT] template.
I INVRCVDT="" Q 0 ;Inv Date not changed, no check necessary
N TDAT,SHODAT S TDAT=$$GET1^DIQ(162.5,TEMPDA_",",6,"I") I TDAT]"" S SHODAT="TO"
I TDAT="" S TDAT=$$GET1^DIQ(162.5,TEMPDA_",",5,"I"),SHODAT="FROM"
I INVRCVDT<TDAT D Q 1 ;Reject entered date
.N SHOTDAT S SHOTDAT=$E(TDAT,4,5)_"/"_$E(TDAT,6,7)_"/"_$E(TDAT,2,3) ;Convert TDAT into display format for error message.
.N MSG1,MSG2 S MSG1="*** Invoice Received Date cannot be before",MSG2=" Treatment "_SHODAT_" Date ("_SHOTDAT_") !!!"
.W !!?5,*7,MSG1,!?8,MSG2
Q 0 ;Date entered is OK
;
LAST(FBDA,FBNODE) ; Returns number (0-25) of last code in node for invoice
D RMVGAP(FBDA,0) ;Insure that gaps were not created outside normal processes
N FBI,FBRET,FBX
S FBRET=0
I FBDA,"^DX^PROC^"[(U_FBNODE_U) D
. S FBX=$G(^FBAAI(FBDA,FBNODE))
. F FBI=25:-1:1 I $P(FBX,"^",FBI)'="" S FBRET=FBI Q
Q FBRET
;
RMVGAP(FBDA,FBWRT) ; Remove gaps in ICD diagnosis and procedure codes
; input
; FBDA IEN of invoice
; FBWRT (optional) =1 if messages can be written to the screen
; remove any gaps
N DXFLD,FBDX,FBFDA,FBI,FBMOVED,FBN,FBPOA,FBPROC,POAFLD,PROCFLD
D FLDLIST ; get list of field numbers
; check diagnosis and POA codes
S FBDX=$G(^FBAAI(FBDA,"DX"))
S FBPOA=$G(^FBAAI(FBDA,"POA"))
S FBMOVED=0
S FBN=0
F FBI=1:1:25 D
. ; JAS - 03/05/14 - Patch 139 (ICD-10 Project) - Modified next line to also quit if 0
. Q:(($P(FBDX,U,FBI)="")!($P(FBDX,U,FBI)=0))
. S FBN=FBN+1 ; increment number of diagnosis codes
. Q:FBI=FBN ; no gap
. ; move diagnosis and POA from slot FBI to slot FBN
. S FBMOVED=1 ; set flag for message
. K FBFDA
. S FBFDA(162.5,FBDA_",",$P(DXFLD,U,FBN))=$P(FBDX,U,FBI)
. S FBFDA(162.5,FBDA_",",$P(POAFLD,U,FBN))=$P(FBPOA,U,FBI)
. S FBFDA(162.5,FBDA_",",$P(DXFLD,U,FBI))="@"
. S FBFDA(162.5,FBDA_",",$P(POAFLD,U,FBI))="@"
. D FILE^DIE("","FBFDA") D:$G(FBWRT) MSG^DIALOG()
. S $P(FBDX,U,FBN)=$P(FBDX,U,FBI)
. S $P(FBPOA,U,FBN)=$P(FBPOA,U,FBI)
. S $P(FBDX,U,FBI)=""
. S $P(FBPOA,U,FBI)=""
I $G(FBWRT),FBMOVED W !,"Diagnosis codes were moved to remove gaps"
;
S FBPROC=$G(^FBAAI(FBDA,"PROC"))
S FBMOVED=0
S FBN=0
F FBI=1:1:25 D
. ; JAS - 03/05/14 - Patch 139 (ICD-10 Project) - Modified next line to also quit if 0
. Q:(($P(FBPROC,U,FBI)="")!($P(FBPROC,U,FBI)=0))
. S FBN=FBN+1 ; increment number of procedure codes
. Q:FBI=FBN ; no gap
. ; move procedure from slot FBI to slot FBN
. S FBMOVED=1
. K FBFDA
. S FBFDA(162.5,FBDA_",",$P(PROCFLD,U,FBN))=$P(FBPROC,U,FBI)
. S FBFDA(162.5,FBDA_",",$P(PROCFLD,U,FBI))="@"
. D FILE^DIE("","FBFDA") D:$G(FBWRT) MSG^DIALOG()
. S $P(FBPROC,U,FBN)=$P(FBPROC,U,FBI)
. S $P(FBPROC,U,FBI)=""
I $G(FBWRT),FBMOVED W !,"Procedure codes were moved to remove gaps"
Q
;
FLDLIST ; Provide list of fields for diagnosis, POA, and procedures
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"
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"
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"
Q
;
GETIPAC(FBDA,FBVEN,FBIA,FBDODINV) ; Get vendor/IPAC data for Inpatient (FB*3.5*123)
; All parameters required and assumed to exist
; Called by $$IPACEDIT^FBAAPET1
N GX5
S FBVEN=+$P($G(^FBAAI(FBDA,0)),U,3) ; vendor ien
S GX5=$G(^FBAAI(FBDA,5))
S FBIA=+$P(GX5,U,10) ; ipac agreement ien
S FBDODINV=$P(GX5,U,7) ; ipac DoD invoice#
Q
;
DELIPAC(FBDA) ; Delete all IPAC data on file for Inpatient (FB*3.5*123)
; Called by $$IPACEDIT^FBAAPET1
N DIE,DA,DR,DIC
S DIE=162.5,DA=FBDA,DR="86///@;87///@" D ^DIE
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHEP1 8331 printed Sep 23, 2025@19:33:46 Page 2
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
+2 ;;Per VA Directive 6402, this routine should not be modified.
EDIT ;ENTRY POINT TO EDIT PAYMENT
+1 NEW LASTDX,LASTPROC
+2 SET IOP=$SELECT($DATA(ION):ION,1:"HOME")
DO ^%ZIS
KILL IOP
BT WRITE !
SET DIC="^FBAA(161.7,"
SET DIC(0)="AEQMZ"
SET DIC("S")="I $P(^(0),U,3)=""B9""&($P(^(0),U,15)=""Y"")"
SET DIC("S")=$SELECT($DATA(^XUSEC("FBAA LEVEL 2",DUZ)):DIC("S"),1:DIC("S")_"&($P(^(0),U,5)=DUZ)")
DO ^DIC
+1 if X=""!(X="^")
GOTO END
if Y<0
GOTO BT
SET FBN=+Y
SET FBN(0)=Y(0)
+2 SET FBEXMPT=$PIECE(FBN(0),"^",18)
+3 SET FBSTAT=^FBAA(161.7,FBN,"ST")
SET FBBAMT=$SELECT($PIECE(FBN(0),"^",9)="":0,1:$PIECE(FBN(0),"^",9))
+4 IF FBSTAT="C"&('$DATA(^XUSEC("FBAA LEVEL 2",DUZ)))
WRITE !!,*7,?3,"You must Reopen the batch prior to editing the invoice.",!
GOTO END
+5 IF FBSTAT="S"!(FBSTAT="P")!(FBSTAT="R")&('$DATA(^XUSEC("FBAA LEVEL 2",DUZ)))
WRITE !!,*7,?3,"You must be a holder of the FBAA LEVEL 2 security key",!,?3,"to edit this invoice.",!
GOTO END
+6 IF FBSTAT="T"!(FBSTAT="F")!(FBSTAT="V")
WRITE !!,?3,"Batch has already been sent to Austin for payment.",!
GOTO END
INV WRITE !
SET DIC="^FBAAI("
SET DIC(0)="AEQZ"
SET DIC("S")="I $P(^(0),U,17)=FBN"
DO ^DIC
KILL DIC("S")
if X=""!(X="^")
GOTO BT
if Y<0
GOTO INV
SET FBI=+Y
+1 ;
+2 ; enforce separation of duties
+3 SET FBDFN=$PIECE($GET(^FBAAI(FBI,0)),U,4)
+4 SET FB7078I=$PIECE($GET(^FBAAI(FBI,0)),U,5)
+5 SET FTP=$SELECT(FB7078I]"":$ORDER(^FBAAA("AG",FB7078I,FBDFN,0)),1:"")
+6 IF '$$UOKPAY^FBUTL9(FBDFN,FTP)
Begin DoDot:1
+7 WRITE !!,"You cannot process a payment associated with authorization ",FBDFN,"-",FTP
+8 WRITE !,"due to separation of duties."
End DoDot:1
QUIT
+9 ;
+10 ;
+11 ; FB*3.5*123 - edit inpatient invoice - check for IPAC data for Federal Vendors
+12 IF '$$IPACEDIT^FBAAPET1(162.5,FBI,.FBIA,.FBDODINV)
GOTO INV
+13 ;
+14 SET FBK=$SELECT($PIECE(^FBAAI(FBI,0),"^",9)="":0,1:$PIECE(^(0),"^",9))
+15 SET FBLISTC=""
SET FBAAI=FBI
WRITE @IOF
DO START^FBCHDI2
SET FBI=FBAAI
IF $PIECE(^FBAAI(FBI,0),"^",9)=""
SET FBPRICE=""
+16 ; set FB1725 flag = true if payment for a 38 U.S.C. 1725 claim
+17 Begin DoDot:1
+18 NEW FBY
+19 SET FBY=$GET(^FBAAI(FBI,0))
+20 SET FB1725=$SELECT($PIECE(FBY,U,5)["FB583":+$PIECE($GET(^FB583(+$PIECE(FBY,U,5),0)),U,28),1:0)
End DoDot:1
+21 ; get values of FPPS Claim ID and Line Item
+22 SET FBFPPSC=$PIECE($GET(^FBAAI(FBI,3)),U)
+23 SET FBFPPSL=$PIECE($GET(^FBAAI(FBI,3)),U,2)
+24 ; load current adjustment data
+25 DO LOADADJ^FBCHFA(FBI_",",.FBADJ)
+26 ; save adjustment data prior to edit session in sorted list
+27 ; sorted list of original adjustments
SET FBADJL(0)=$$ADJL^FBUTL2(.FBADJ)
+28 ; load current remittance remark data
+29 DO LOADRR^FBCHFR(FBI_",",.FBRRMK)
+30 ; load Item level Rendering provider data
+31 ;FB*3.5*122
DO LOADRP^FBUTL8(FBI_",",.FBPROV)
+32 ; save remittance remarks prior to edit session in sorted list
+33 SET FBRRMKL(0)=$$RRL^FBUTL4(.FBRRMK)
+34 SET LASTDX=$$LAST(FBI,"DX")
SET LASTPROC=$$LAST(FBI,"PROC")
+35 SET (DIE,DIC)="^FBAAI("
SET DIC(0)="AEQM"
SET DA=FBI
SET DR="[FBCH EDIT PAYMENT]"
WRITE !
+36 Begin DoDot:1
+37 NEW ICDVDT,DFN,FB583,FBAAMM1,FBAAPTC,FBCNTRA,FBCNTRP,FBV,FBVEN,FTP
+38 ;date for files 80 and 80.1 identifier
SET ICDVDT=$$FRDTINV^FBCSV1(DA)
+39 ;get variables for call to PPT^FBAACO1
+40 SET FBAAMM1=$PIECE($GET(^FBAAI(DA,2)),U,3)
+41 SET FBCNTRP=$PIECE($GET(^FBAAI(DA,5)),U,8)
+42 SET FBV=$PIECE($GET(^FBAAI(DA,0)),U,3)
+43 SET DFN=$PIECE($GET(^FBAAI(DA,0)),U,4)
+44 SET FBAAPTC=$PIECE($GET(^FBAAI(DA,0)),U,13)
+45 SET X=$PIECE($GET(^FBAAI(DA,0)),U,5)
+46 if X[";FB583("
SET FB583=+X
+47 SET FTP=$SELECT(X]"":+$ORDER(^FBAAA("AG",X,DFN,0)),1:"")
+48 SET FBVEN=$SELECT(FTP:$PIECE($GET(^FBAAA(DFN,1,FTP,0)),U,4),1:"")
+49 SET FBCNTRA=$SELECT(FTP:$PIECE($GET(^FBAAA(DFN,1,FTP,0)),U,22),1:"")
+50 DO ^DIE
End DoDot:1
+51 ; if adjustment data changed then file
+52 IF $$ADJL^FBUTL2(.FBADJ)'=FBADJL(0)
DO FILEADJ^FBCHFA(FBI_",",.FBADJ)
+53 ; if remit remark data changed then file
+54 IF $$RRL^FBUTL4(.FBRRMK)'=FBRRMKL(0)
DO FILERR^FBCHFR(FBI_",",.FBRRMK)
+55 ; remove any gaps in codes
+56 DO RMVGAP(FBI,1)
+57 ; if line item rendering providers exist then file FB*3.5*133
+58 IF $DATA(FBPROV)
DO FILERP^FBUTL8(FBI_",",.FBPROV)
+59 KILL FBAAMM,FBAAMM1
+60 SET FBNK=$PIECE(^FBAAI(FBI,0),"^",9)
+61 IF FBNK-FBK
SET $PIECE(^FBAA(161.7,FBN,0),"^",9)=FBBAMT+(FBNK-FBK)
END KILL 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 KILL 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
+2 KILL FBFPPSC,FBFPPSL,FBADJ,FBADJD,FBRRMK,FBRRMKD,FBIA,FBDODINV
+3 KILL FB7078I,FBDFN
+4 DO END^FBCHDI
+5 QUIT
+6 ;
BADDATE(INVRCVDT,TEMPDA) ;Compare edited Invoice Received Date to Treatment Date, reject if before. Called from [FBCH EDIT PAYMENT] template.
+1 ;Inv Date not changed, no check necessary
IF INVRCVDT=""
QUIT 0
+2 NEW TDAT,SHODAT
SET TDAT=$$GET1^DIQ(162.5,TEMPDA_",",6,"I")
IF TDAT]""
SET SHODAT="TO"
+3 IF TDAT=""
SET TDAT=$$GET1^DIQ(162.5,TEMPDA_",",5,"I")
SET SHODAT="FROM"
+4 ;Reject entered date
IF INVRCVDT<TDAT
Begin DoDot:1
+5 ;Convert TDAT into display format for error message.
NEW SHOTDAT
SET SHOTDAT=$EXTRACT(TDAT,4,5)_"/"_$EXTRACT(TDAT,6,7)_"/"_$EXTRACT(TDAT,2,3)
+6 NEW MSG1,MSG2
SET MSG1="*** Invoice Received Date cannot be before"
SET MSG2=" Treatment "_SHODAT_" Date ("_SHOTDAT_") !!!"
+7 WRITE !!?5,*7,MSG1,!?8,MSG2
End DoDot:1
QUIT 1
+8 ;Date entered is OK
QUIT 0
+9 ;
LAST(FBDA,FBNODE) ; Returns number (0-25) of last code in node for invoice
+1 ;Insure that gaps were not created outside normal processes
DO RMVGAP(FBDA,0)
+2 NEW FBI,FBRET,FBX
+3 SET FBRET=0
+4 IF FBDA
IF "^DX^PROC^"[(U_FBNODE_U)
Begin DoDot:1
+5 SET FBX=$GET(^FBAAI(FBDA,FBNODE))
+6 FOR FBI=25:-1:1
IF $PIECE(FBX,"^",FBI)'=""
SET FBRET=FBI
QUIT
End DoDot:1
+7 QUIT FBRET
+8 ;
RMVGAP(FBDA,FBWRT) ; Remove gaps in ICD diagnosis and procedure codes
+1 ; input
+2 ; FBDA IEN of invoice
+3 ; FBWRT (optional) =1 if messages can be written to the screen
+4 ; remove any gaps
+5 NEW DXFLD,FBDX,FBFDA,FBI,FBMOVED,FBN,FBPOA,FBPROC,POAFLD,PROCFLD
+6 ; get list of field numbers
DO FLDLIST
+7 ; check diagnosis and POA codes
+8 SET FBDX=$GET(^FBAAI(FBDA,"DX"))
+9 SET FBPOA=$GET(^FBAAI(FBDA,"POA"))
+10 SET FBMOVED=0
+11 SET FBN=0
+12 FOR FBI=1:1:25
Begin DoDot:1
+13 ; JAS - 03/05/14 - Patch 139 (ICD-10 Project) - Modified next line to also quit if 0
+14 if (($PIECE(FBDX,U,FBI)="")!($PIECE(FBDX,U,FBI)=0))
QUIT
+15 ; increment number of diagnosis codes
SET FBN=FBN+1
+16 ; no gap
if FBI=FBN
QUIT
+17 ; move diagnosis and POA from slot FBI to slot FBN
+18 ; set flag for message
SET FBMOVED=1
+19 KILL FBFDA
+20 SET FBFDA(162.5,FBDA_",",$PIECE(DXFLD,U,FBN))=$PIECE(FBDX,U,FBI)
+21 SET FBFDA(162.5,FBDA_",",$PIECE(POAFLD,U,FBN))=$PIECE(FBPOA,U,FBI)
+22 SET FBFDA(162.5,FBDA_",",$PIECE(DXFLD,U,FBI))="@"
+23 SET FBFDA(162.5,FBDA_",",$PIECE(POAFLD,U,FBI))="@"
+24 DO FILE^DIE("","FBFDA")
if $GET(FBWRT)
DO MSG^DIALOG()
+25 SET $PIECE(FBDX,U,FBN)=$PIECE(FBDX,U,FBI)
+26 SET $PIECE(FBPOA,U,FBN)=$PIECE(FBPOA,U,FBI)
+27 SET $PIECE(FBDX,U,FBI)=""
+28 SET $PIECE(FBPOA,U,FBI)=""
End DoDot:1
+29 IF $GET(FBWRT)
IF FBMOVED
WRITE !,"Diagnosis codes were moved to remove gaps"
+30 ;
+31 SET FBPROC=$GET(^FBAAI(FBDA,"PROC"))
+32 SET FBMOVED=0
+33 SET FBN=0
+34 FOR FBI=1:1:25
Begin DoDot:1
+35 ; JAS - 03/05/14 - Patch 139 (ICD-10 Project) - Modified next line to also quit if 0
+36 if (($PIECE(FBPROC,U,FBI)="")!($PIECE(FBPROC,U,FBI)=0))
QUIT
+37 ; increment number of procedure codes
SET FBN=FBN+1
+38 ; no gap
if FBI=FBN
QUIT
+39 ; move procedure from slot FBI to slot FBN
+40 SET FBMOVED=1
+41 KILL FBFDA
+42 SET FBFDA(162.5,FBDA_",",$PIECE(PROCFLD,U,FBN))=$PIECE(FBPROC,U,FBI)
+43 SET FBFDA(162.5,FBDA_",",$PIECE(PROCFLD,U,FBI))="@"
+44 DO FILE^DIE("","FBFDA")
if $GET(FBWRT)
DO MSG^DIALOG()
+45 SET $PIECE(FBPROC,U,FBN)=$PIECE(FBPROC,U,FBI)
+46 SET $PIECE(FBPROC,U,FBI)=""
End DoDot:1
+47 IF $GET(FBWRT)
IF FBMOVED
WRITE !,"Procedure codes were moved to remove gaps"
+48 QUIT
+49 ;
FLDLIST ; Provide list of fields for diagnosis, POA, and procedures
+1 SET 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"
+2 SET 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"
+3 SET 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"
+4 QUIT
+5 ;
GETIPAC(FBDA,FBVEN,FBIA,FBDODINV) ; Get vendor/IPAC data for Inpatient (FB*3.5*123)
+1 ; All parameters required and assumed to exist
+2 ; Called by $$IPACEDIT^FBAAPET1
+3 NEW GX5
+4 ; vendor ien
SET FBVEN=+$PIECE($GET(^FBAAI(FBDA,0)),U,3)
+5 SET GX5=$GET(^FBAAI(FBDA,5))
+6 ; ipac agreement ien
SET FBIA=+$PIECE(GX5,U,10)
+7 ; ipac DoD invoice#
SET FBDODINV=$PIECE(GX5,U,7)
+8 QUIT
+9 ;
DELIPAC(FBDA) ; Delete all IPAC data on file for Inpatient (FB*3.5*123)
+1 ; Called by $$IPACEDIT^FBAAPET1
+2 NEW DIE,DA,DR,DIC
+3 SET DIE=162.5
SET DA=FBDA
SET DR="86///@;87///@"
DO ^DIE
+4 QUIT
+5 ;
